diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,21 @@ # Changelog +This is release chronology, not current interface authority. The package +[README](./README.md), Cabal manifest, and linked focused guides own the live +surface. + `moonlight-triangulation` follows the [Haskell Package Versioning Policy](https://pvp.haskell.org). The serialization format carries its own version tag, independent of the package version; any change to it is recorded here explicitly. + +## 1.4.0.2 - 2026-08-28 + +* Consolidate usage guidance behind one operation index and exact set-operation + type contract. Focused guides now uniquely own publication schedules, + examples, comparisons, exhibits, and foreign-consumer details instead of + repeating them across the package overview. ## 1.4.0.1 - 2026-08-24 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2026 agent, Blue Rose +Copyright (c) 2026 Blue Rose Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,323 +14,62 @@ regions and labelled overlay, intrinsic valuations, polygonal Minkowski morphology, the Voronoi dual, natural-neighbour interpolation, Ruppert refinement, walk point location, convex hull, exact Shewchuk predicates, -incremental insertion and removal, and versioned binary serialization. +and versioned binary serialization. ## Persistence rose -![Animated Moonlight persistence rose: exact Delaunay alpha filtration, persistent homology, Voronoi dual, and natural-neighbour field](./docs/social/moonlight-triangulation-persistence-rose.gif) - -[Open the animation directly.](./docs/social/moonlight-triangulation-persistence-rose.gif) -· [Open the static vector poster.](./docs/moonlight-triangulation-persistence-rose.svg) -· [Browse the exhibit files.](./docs/README.md) - -This is computed, not ornament. A deterministic 169-site cover becomes one -Delaunay mesh, one exact 626-value alpha filtration, and one Homology reduction. -The poster state has `β₁ = 7`; seven bounded components recovered -independently by face descent and boundary gluing agree with that persistent -Betti number. The colour field is 447 fallback-free Sibson natural-neighbour -queries, the fine cyan geometry is the finite Voronoi dual, and the flower -silhouette is seven exact Minkowski-offset petals glued by labelled planar -overlay. - -On GHC 9.14, the package-owned generator reproduces the poster, the exact alpha -eclipse, or the canonical 65-frame seamless SVG sweep: - -```console -cabal run moonlight-triangulation-persistence-rose -- poster persistence-rose.svg -cabal run moonlight-triangulation-persistence-rose -- eclipse alpha-eclipse.svg -cabal run moonlight-triangulation-persistence-rose -- frames 65 persistence-rose-frames -``` - -The retained GIF is the 960×540, 8 fps projection of those 65 source frames. -Its exact encoding boundary is deliberately outside geometry and Homology: -rasterize the SVG section, encode it, then let the exhibit owner stamp the GIF -with the deterministic source-frame fingerprint it computed itself. - -```console -mkdir -p persistence-rose-png -sips -s format png persistence-rose-frames/frame-*.svg --out persistence-rose-png -ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \ - -vf "scale=960:-2:flags=lanczos,palettegen=max_colors=96:stats_mode=diff" \ - -y persistence-rose-palette.png -ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \ - -i persistence-rose-palette.png \ - -lavfi "[0:v]scale=960:-2:flags=lanczos[x];[x][1:v]paletteuse=dither=bayer:bayer_scale=4:diff_mode=rectangle" \ - -loop 0 -y persistence-rose-raw.gif -cabal run moonlight-triangulation-persistence-rose -- \ - stamp-gif persistence-rose-raw.gif docs/social/moonlight-triangulation-persistence-rose.gif -cabal run moonlight-triangulation-persistence-rose -- verify-artifacts . -``` +![Animated Moonlight persistence rose: exact Delaunay alpha filtration, persistent homology, Voronoi dual, and natural-neighbour field](./docs/persistence-rose/moonlight-triangulation-persistence-rose.gif) -`verify-artifacts` compares both retained SVGs byte-for-byte with their pure -renderers, checks the GIF dimensions, timing, and image-frame inventory, and requires -the GIF's embedded source fingerprint to equal the freshly rendered canonical -frame section. A plausible binary can no longer wander in wearing a nice hat. +[Open the animation directly.](./docs/persistence-rose/moonlight-triangulation-persistence-rose.gif) +· [Open the static vector poster.](./docs/persistence-rose/moonlight-triangulation-persistence-rose.svg) +· [Read the exhibit guide.](./docs/persistence-rose/README.md) ## Operations -| Operation | Role | What it returns | -| --- | --- | --- | -| `union` | join | A valid Delaunay representative of both site sets; overlapping annotations glue through `JoinSemilattice`. | -| `unions` | balanced fold | The same join over a list, associated for the tournament rather than the left. | -| `siteRelation` | support order | Exact equality, proper-subset, disjointness or partial-overlap classification. | -| `intersection` | geometry-only meet | The sites both meshes hold. | -| `intersectionWith` | annotated meet | Shared sites with a left-then-right annotation combiner. | -| `difference` | relative complement | The left's sites and annotations, less the right's support. | -| `symmetricDifference` | exclusive or | The sites and annotations carried by exactly one mesh. | -| `canonicalize` | physical normal form | Construction-independent dense numbering, derived explicitly when required. | -| `refine` | quality | Steiner insertion, composed *after* any of the above — never a second kind of mesh. | -| `constrainedDelaunay` | boundary | Sites plus segments, after which interiority is computable. | -| `overlayLayers` | exact common refinement | One provenance-bearing arrangement whose bounded cells carry both source labels. | -| `overlayClosedUnion` / `overlayClosedIntersection` / `overlayRegularizedDifference` | planar Boolean selection | A closed exact cell set retaining point- and edge-only results; difference is regularized from selected faces. | -| `overlaySelectedRegion` | polygon publication | Selected bounded faces with internal arrangement edges dissolved through the existing boundary walker. | -| `cellValuations` / `regionValuations` | intrinsic measurement | Exact Euler characteristic and rational area plus symbolic radical length with certified bounds. | -| `minkowskiSum` | polygonal convolution | Exact convex or general polygonal Minkowski addition, with work recorded in a receipt. | -| `erodeBy` / `openWith` / `closeWith` | regularized morphology | Full-dimensional polygonal erosion and its opening/closing compositions for an origin-anchored convex kernel. | -| `fromExactCellSet` | topology interpretation | An opaque `DCELComplex` view of the already-admitted cell inventory; no mesh copy or second validation authority. | -| `alphaFiltration` | exact scale geometry | One handle-indexed birth section for every resident vertex, edge, and bounded face of a Delaunay triangulation. | -| `filteredAlphaComplex` | persistent topology | The same resident cells and exact births lowered into Homology's checked filtered chain complex. | - -### Choose the operation - -| What you need | Use | Do not substitute | -| --- | --- | --- | -| Build a geometry-only mesh from coordinates | `delaunayGeometry` | Do not manufacture unit annotations and erase them afterward. | -| Build from separate coordinates and annotations | `delaunayFromCoordinates` | Do not fabricate a `HasPosition` instance for an annotation that does not own geometry. | -| Combine two unconstrained meshes | `union` | Do not concatenate vertices and rebuild manually; `union` owns overlap annotations and the measured schedule. | -| Combine many unconstrained meshes | `unions` | Do not left-fold `union`; `unions` owns balanced association. | -| Classify coordinate support without constructing a mesh | `siteRelation` | Do not compare vertex counts or resident `Eq`; neither answers support order. | -| Keep coordinates present in both geometry-only meshes | `intersection` | Use `intersectionWith` instead when annotations must survive or be recomputed. | -| Keep shared coordinates and choose their annotation | `intersectionWith combine` | For a left annotation-preserving mask, use `intersectionWith const left mask`. | -| Remove a coordinate mask from a mesh | `difference source mask` | Do not remove by stale `VertexId`; removal compacts arenas while coordinates remain stable. | -| Keep coordinates present in exactly one mesh | `symmetricDifference` | Do not spell it as two differences plus `union`; the direct operation owns the persistent toggle schedule. | -| Build the first constrained mesh | `constrainedDelaunay` | Do not build unconstrained and treat a rendered outline as topology. | -| Canonically combine arbitrary constrained meshes | `unionConstrainedWith` or geometry-only `unionConstrained` | Do not use unconstrained `union`; constrained union owns complete conflict witnesses and constraint recovery. | -| Join two strictly x-separated constrained meshes | `joinSeparatedConstrained` | Separation means annotations are copied, never combined; use the general constrained union when separation is not proved. | -| Append one constrained section to an authoritative constrained base | `extendConstrainedWith` | Do not use symmetric constrained union when base identity and already-solved constraints must remain resident. | -| Insert one site persistently | `BulkLoad.insert` or `BulkLoad.insertAt` | Do not open a manual transaction; the singleton entry owns the dense/copy-on-write crossover. | -| Insert a vector of sites | `BulkLoad.insertMany` | Do not fold singleton insertion; one batch thaws and publishes once. | -| Compose insertions and removals | one `Session.withSession` | Do not publish every intermediate mesh. Use coordinate-keyed removal after the first compaction. | -| Refine the whole mesh | `refine` | Do not manufacture a domain witness merely to reach the local API. | -| Refine a proved face section without changing protected faces | `refineWithinDomain` | Supply its exact permitted faces; the immutable interface is derived once by the domain owner and returned as receipt evidence. | -| Partition bounded faces by any caller-owned label | `faceComponents mesh labelFace` | Do not rebuild adjacency outside the DCEL or collapse disconnected regions sharing a label. | -| Recover one component's polygonal boundary | `componentBoundary mesh component` | Do not emit one polygon per triangle; outer and hole loops have canonical winding and exact collinear simplification. | -| Combine two labelled polygon layers | `overlayLayers left right` | Do not run separate clipping engines for union, intersection, and difference; select cells from the one common refinement. | -| Preserve a point- or edge-only Boolean result | `overlayClosedUnion`, `overlayClosedIntersection`, or `overlayRegularizedDifference` | Do not publish immediately as `PlanarRegion`; that carrier is deliberately full-dimensional. | -| Publish a selected polygonal region | `overlaySelectedRegion predicate overlay` | Do not collect arrangement cells independently; selection must precede boundary descent so internal seams disappear. | -| Measure a closed exact selection or region | `cellValuations` or `regionValuations` | Do not coerce irrational perimeter to an allegedly exact `Double`; inspect its radical expression and certified interval. | -| Expand a polygon by another polygon | `minkowskiSum` or `polygonOffset` | Do not add resident mesh vertices pairwise and rebuild; morphology acts on the represented continuum. | -| Erode, open, or close a polygonal region | `erodeBy`, `openWith`, or `closeWith` | Do not infer a hidden universe or invent lower-dimensional polygons; the result is regularized to representable 2D area. | -| Render only Delaunay faces below one alpha threshold | `alphaShapeContainsFace threshold mesh` | This constant-work-per-face projection deliberately does not build the full filtration. | -| Ask topology questions across many radii | `alphaFiltration mesh`, then `filteredAlphaComplex` and `mod2PersistentPairs` | Do not rebuild disc unions, triangulations, or homology independently at every radius. | -| 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.4 && < 1.5, - 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. - -### Exact alpha filtration and persistent topology - -![Alpha eclipse: a fixed Delaunay site set closes one hole and later fills it across exact critical radii](./docs/moonlight-triangulation-alpha-eclipse.svg) - -[Open the full-size alpha eclipse.](./docs/moonlight-triangulation-alpha-eclipse.svg) - -The eclipse uses the package's canonical four-site square witness and isolates -its one finite `H₁` interval. The four sites, five resident Delaunay edges, and -two resident faces remain fixed: the four hull edges close one hole at exact -`α² = 1`; the resident diagonal and both resident faces enter at exact -`α² = 2`, making that cycle a boundary. Only the alpha sublevel changes. Every -visible cell is projected from the resident DCEL, and the `β₁ = 0 → 1 → 0` -profile comes from Moonlight Homology rather than a hand-authored diagram. - -The full alpha path is a different observation of the same resident Delaunay -DCEL. `alphaFiltration` computes exact squared-radius births once: vertices at -zero, Gabriel edges at one quarter of their squared length, other edges at their -least incident-face witness, and faces at their circumradius squared. -`filteredAlphaComplex` lowers that section to the one Homology persistence -owner. `AlphaBirth` is an opaque reduced rational; equality and ordering never -round through `Double`. - -This is the planar alpha-complex shortcut to the Cech filtration: the Delaunay -subcomplex has the same homotopy type as the corresponding union of discs, but -has only the resident planar cells. One reduction therefore yields the barcode -for every critical radius. `persistentBettiAtCriticalValues` sweeps all of -those sublevels through dense complex-relative ranks without rebuilding -geometry, reducing another boundary matrix, or rescanning the barcode per -radius. - -The minimal component path names only Delaunay construction, the DCEL alpha -owner, the opt-in lowering component, and Homology. A consumer already using -the broad `moonlight-triangulation` facade may substitute it for `build` and -`dcel` below. - -```cabal -build-depends: - moonlight-triangulation:build >= 1.4 && < 1.5, - moonlight-triangulation:dcel >= 1.4 && < 1.5, - moonlight-triangulation:cell-complex >= 1.4 && < 1.5, - moonlight-homology >= 0.1 && < 0.2 -``` - -```haskell -import Data.Foldable (traverse_) -import qualified Data.Vector as Vector -import Moonlight.Homology.Persistence - ( filteredCriticalValues - , mod2PersistentPairs - , persistentBettiAtCriticalValues - ) -import Moonlight.Triangulation.Alpha (alphaFiltration) -import Moonlight.Triangulation.BulkLoad (delaunayGeometry) -import Moonlight.Triangulation.CellComplex (filteredAlphaComplex) -import Moonlight.Triangulation.Types (Point (..)) - -main :: IO () -main = do - mesh <- requireRight (delaunayGeometry (Vector.fromList [Point (-1) (-1), Point 1 (-1), Point 1 1, Point (-1) 1])) - filtration <- requireRight (alphaFiltration mesh) - filtered <- requireRight (filteredAlphaComplex filtration) - pairs <- requireRight (mod2PersistentPairs filtered) - profiles <- requireRight (persistentBettiAtCriticalValues filtered pairs) - traverse_ print (zip (filteredCriticalValues filtered) profiles) - -requireRight :: Show failure => Either failure value -> IO value -requireRight = either (fail . show) pure -``` +| Operation | Use when | Inputs | Result | +| --- | --- | --- | --- | +| `delaunayGeometry` | Coordinates own the input | `Vector Point` | Geometry-only mesh / `BuildError` | +| `delaunayFromCoordinates` | Payloads have a separate plane | Defaults, points, payloads, duplicate policy | `BuildResult` / `BuildError` | +| `siteRelation` | Supports need exact classification | Two meshes | `SiteRelation` | +| `union` / `unions` | Unconstrained supports must join | Two meshes / mesh list | Union mesh / `BuildError` | +| `intersection` / `intersectionWith` | Shared support is required | Two meshes; optional payload combiner | Common-site mesh / `BuildError` | +| `difference` / `symmetricDifference` | Left-only / exclusive support is required | Source and mask / two meshes | Result mesh / `BuildError` | +| `constrainedDelaunay` | Segments author topology | Defaults, positioned vertices, index pairs | `BuildResult` / `CdtError` | +| `unionConstrained` / `unionConstrainedWith` | Arbitrary constrained meshes must join | Two meshes; optional payload combiner | Constrained mesh / `ConstrainedUnionError` | +| `extendConstrainedWith` | One constrained mesh owns identity | Combiner, base, extension | `ConstrainedExtensionResult` / `ConstrainedUnionError` | +| `joinSeparatedConstrained` | Inputs are strictly x-separated | Face predicate, refinement parameters, two meshes | `ConstrainedSeamResult` / `ConstrainedUnionError` | +| `refine` | Quality applies globally | Vertex constructor, parameters, mesh | `RefinementResult` / `BuildError` | +| `refineWithinDomain` | Quality applies to admitted faces | Vertex constructor, parameters, face set, mesh | `RefinementDomainResult` / `BuildError` | +| `faceComponents` | Bounded faces must descend by label | Mesh, `FaceId -> label` | `[(label, FaceComponent)]` | +| `componentBoundary` | One component must publish as loops | Mesh, `FaceComponent` | `RegionBoundary` / `BoundaryObstruction` | +| `overlayLayers` | Layers need one exact arrangement | Two `PlanarLayer`s | `OverlayResult` / `OverlayError` | +| `overlayClosedUnion` / `overlayClosedIntersection` / `overlayRegularizedDifference` | Boolean output may retain lower cells | Two label predicates, `OverlayResult` | `ExactCellSet` / `OverlaySelectionError` | +| `overlaySelectedRegion` | Selected faces must publish as polygons | Label-pair predicate, `OverlayResult` | `PlanarRegion` / `RegionPublicationError` | +| `cellValuations` / `regionValuations` | Intrinsic measures are required | `ExactCellSet` / `PlanarRegion` | `PlanarValuations` / `ValuationError` | +| `minkowskiSum` / `polygonOffset` | Regions must add / expand | Two regions / element and region | Region plus receipt / `MinkowskiError` | +| `erodeBy` / `openWith` / `closeWith` | Regularized morphology is required | Structuring element, region | Region plus receipt / `MinkowskiError` | +| `alphaShapeContainsFace` | One face at one radius is enough | `RadiusSquared`, mesh, `FaceId` | `Bool` | +| `alphaFiltration` | Every critical radius matters | Delaunay mesh | `AlphaFiltration` / `AlphaFiltrationError` | +| `fromExactCellSet` | Exact cells need a generic complex view | `ExactCellSet` | `DCELComplex` | +| `filteredAlphaComplex` | Alpha births must enter persistence | `AlphaFiltration` | Filtered chain complex / `DCELError` | +| `canonicalize` | Numbering must ignore construction history | Mesh with unit edge/face payloads | Canonical mesh / `BuildError` | -The focused `moonlight-triangulation-alpha-bench` measures exact preparation, -one persistence reduction plus all critical-radius queries, and repeated -threshold homology as separate lanes over the same prebuilt Delaunay mesh. +[Interpret cell sets as incidence categories.](docs/category-observatory/README.md#cell-complex-and-category-interpretation) +· [Compute persistent alpha topology.](docs/persistence-rose/README.md#exact-alpha-filtration-and-persistent-topology) ## Foreign bindings -The `moonlight-triangulation-c` foreign-library component exposes opaque -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. - -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. - -### Persistent publication schedules - -The algebraic result is independent of the execution schedule. These are the -currently measured publication choices; `canonicalize` remains the explicit -global observation when construction-independent numbering is required. - -| Operation context | Publication schedule | -| --- | --- | -| `siteRelation left right` | Index the smaller support in one transient exact open-addressed section, scan the other operand, then discard the index; no support maps or published cache state. | -| `difference mesh empty`, `symmetricDifference mesh empty`, `symmetricDifference empty mesh` | Return the surviving representative verbatim. | -| `difference left right` with `size right <= (size left - size right) / 128` | Remove the right support through one local copy-on-write session; return `left` verbatim when the supports are disjoint. Larger masks rebuild. | -| Geometry-only `intersection left right` | Return an existing operand for equality or subset, return the empty mesh for disjoint supports, and locally remove the smaller complement when it is at most `overlap / 128`. Other partial overlaps rebuild. | -| `intersectionWith` | Rebuild, because the annotation combiner may rewrite every surviving payload even when topology changes locally. | -| `symmetricDifference left right` with `small <= (large - small) / 128` | Toggle the smaller operand through one local session. Comparable operands and small-output, large-input cases rebuild. | -| Comparable `symmetricDifference left right` | Partition through one transient exact index and a matched bitset, then rebuild only the exclusive output section. | -| `BulkLoad.insert` / `BulkLoad.insertAt` | Dense publication below 10,000 resident sites; copy-on-write publication at 10,000 and above. A sequence still belongs in one `Session`. | -| `extendConstrainedWith` | Copy-on-write only for a base of at least 200,000 sites, at most 128 incoming sites, exactly one incoming segment, and a pre-thaw corridor with no resident intersection. Every unmeasured or resident-corridor case stays dense. | -| `refineWithinDomain` | Dense publication. The local transaction candidate preserved semantics but did not improve wall time, so it was removed. | - -### Overall Moonlight–Spade comparison - -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. - -| 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/moonlight-triangulation-1.4.0.1/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. +The C ABI and its Python, TypeScript, and Rust consumers are documented in the +[foreign-bindings guide](ffi/bindings/README.md). It owns construction, ABI +versioning, lifecycle, obstruction semantics, and consumer examples. -Spade exposes no public triangulation set algebra corresponding to these -operations. Their independently witnessed Moonlight publication costs are: +## Algebraic contract -| Operation | Workload | Moonlight | -| --- | ---: | ---: | -| `siteRelation` | 1m sites vs 995k retained | **96.759 ms** | -| `intersection` | retain 995k / 1m sites | **109.513 ms** | -| `symmetricDifference` | publish the 5k-site exclusive result | **119.298 ms** | -| `difference` | remove 5k / 1m sites | **129.820 ms** | -| `union` | add 5k / 5m sites | **130.295 ms** | +`union` is idempotent; commutativity and associativity hold after +`canonicalize`. Structural `Eq` is resident equality; use `siteRelation` for +support comparison. -These are raw publication measurements. `canonicalize` remains a separate, -explicit observation when construction-independent numbering is required. +### Set-operation types ```haskell union :: JoinSemilattice annotation @@ -369,401 +108,46 @@ -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) ``` -## Constraints - -* No `Semigroup`, no `Monoid`, no `<>`. A join the finite arena cannot - represent is a `Left`; a partial class instance would lie about totality. -* `union` and `unions` glue overlapping annotations through - `JoinSemilattice`. `intersectionWith` supplies the corresponding explicit - overlap combiner. `difference` preserves the left annotation and - `symmetricDifference` preserves the annotation of whichever exclusive site - survives. Plain `intersection` remains the geometry-only specialization. - Annotation-preserving restriction is derived rather than stored as a second - operator: `intersectionWith const left mask`. -* `refine` composes after an operation. It is not a mode, a flag, or a second - triangulation type. -* Mutation lives in `ST` behind `Moonlight.Triangulation.Internal.Mutable` and - never escapes. -* `serialize` is absent from the facade by design; import - `Moonlight.Triangulation.Serialization` to reach it. Its canonical decoder - requires both a `DecodingBudget` and explicit `TrustedPayloadDecoders`; wire - format 6 validates one structural count prefix before decoding defaults, - payloads, or allocating a section, and preserves the vertex payload plane's - optional fill. The budget covers the input envelope and every module-owned - container. `trustedBinaryPayloadDecoders` records the separate caller - decision that the selected executable `Binary` decoders have an acceptable - internal resource policy. Version 5 is intentionally unsupported. -* Resident triangulation coordinates are binary64. Exact planar-region APIs use - normalized rational `ExactPoint`s; an admitted `OverlayResult` seals those - authoritative coordinates beside one certified binary64 DCEL projection. - `vertexPoints` and `innerFaceVertexTriples` still project the resident DCEL - directly; callers do not reconstruct a sibling mesh DTO. -* One half-edge mesh underneath. `Cdt` is a mode index on it, not a second - structure. - -The Haskell facade 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. +[Publication schedules and scale behavior.](docs/mesh-publication.md) ## Use -A triangulation is a value of its site set: construction returns `Either` with -typed obstructions, `union` returns the same typed refusal when the finite arena -cannot represent its result, and mesh quality is a -composition over the result rather than a second operation. This program -compiles against the facade alone; `fromList` is `GHC.Exts`, so nothing beyond -`base` and `moonlight-triangulation` is in scope. - -```haskell -module Main where - -import GHC.Exts (fromList) -import Moonlight.Triangulation - -main :: IO () -main = do - let build :: [(Double, Double)] -> IO (DelaunayTriangulation ()) - build coords = - either (fail . show) pure (delaunayGeometry (fromList [Point x y | (x, y) <- coords])) - a <- build [(x, y) | x <- [0 .. 9], y <- [0 .. 9]] - b <- build [(x + 6, y) | x <- [0 .. 9], y <- [0 .. 9]] - - -- valid Delaunay representative of the union of sites - joined <- either (fail . show) pure (union a b) - - -- meet and differences return typed obstructions, never partial results - met <- either (fail . show) pure (intersection a b) - - -- mesh quality is a composition, not a second operation - parameters <- either (fail . show) pure (withMinimumAngle 14 defaultRefinementParameters) - result <- either (fail . show) pure (refine (const ()) parameters joined) - let healed = refinedTriangulation result - - print (numVertices joined, numVertices met, numVertices healed, refinementComplete result) -``` - -Output: `(160,40,160,True)` — the union carries 160 sites, the meet 40, and -refinement inserts nothing because every triangle already clears the 14° bar; -`refinementComplete` states that sufficiency. Where operands leave concavities, -the same composition places Steiner sites exactly at the slivers it dissolves. - -`delaunayGeometry` constructs the unit-annotated carrier directly. Payloads can -instead enter with their coordinates through `delaunay`, or independently -through `delaunayFromCoordinates`; annotation-preserving restriction is -available through `intersectionWith`, `difference`, and `symmetricDifference`. Constraints enter through -`constrainedDelaunay`; bulk incremental work names the machine-room module -directly (`Moonlight.Triangulation.BulkLoad` for `insertMany`, -`Moonlight.Triangulation.Session` for the owned editing transaction — -`withSession`: thaw once, insert and remove freely, publish once). - -### Interior without hull-fill - -A point set has no boundary, so `delaunay` necessarily meshes the convex hull: -concavities and holes are spanned by faces that belong to the hull, not to any -intended region. The region becomes real the moment its boundary is authored: -`constrainedDelaunay` takes the sites plus constraint segments as input-index -pairs, and interiority is then computable — `facesAtEvenBarrierDepth` runs a -0–1 BFS from the outer face and returns every face at even barrier depth, -which is exactly the outside (depth 0) plus anything nested behind a second -loop. The interior is the complement. `refine` consumes the same parity -through `refineExcludeOuterFaces`, so Steiner sites respect the boundary too. - -```haskell -module Main where - -import GHC.Exts (fromList) -import Moonlight.Triangulation - -ring :: Double -> Int -> [(Double, Double)] -ring radius n = - [ (radius * cos t, radius * sin t) - | k <- [0 .. n - 1] - , let t = 2 * pi * fromIntegral k / fromIntegral n - ] - -main :: IO () -main = do - let outer = ring 4 32 - inner = ring 2 16 - middle = ring 3 24 - pts = fromList [Point x y | (x, y) <- outer <> inner <> middle] - loop base count = [(base + k, base + (k + 1) `mod` count) | k <- [0 .. count - 1]] - constraints = fromList (loop 0 32 <> loop 32 16) - annulus <- case constrainedDelaunay unitElementDefaults pts constraints of - Left err -> fail (show err) - Right result -> pure (buildTriangulation result) - let outside = - [ fromIntegral raw :: Int - | FaceId raw <- facesAtEvenBarrierDepth annulus (isConstraintEdge annulus) - ] - interior = - [ FaceId (fromIntegral k) - | k <- [0 .. numFaces annulus - 1] - , not (k `elem` outside) - ] - print (numFaces annulus, length interior) -``` - -Output: `(111,97)` — the annulus band is the 97 interior faces; the 14 -excluded faces are the hole's hull-fill and the outer region. Rendering the -interior list draws the ring with a genuine void: no crop, no edge-length -heuristic, the engine's own verdict. `faceVertices` walks each interior face -for display, and a nested loop flips parity again, so islands inside holes -come back automatically. - -### Deriving the boundary - -When no boundary is known, classify the Delaunay faces and let the DCEL descend -them. `faceComponents` evaluates the caller's label once per bounded face and -keeps disconnected regions distinct even when their labels compare equal. -`componentBoundary` then returns one counter-clockwise outer loop and clockwise -hole loops, dropping a boundary vertex only when the library's exact -orientation predicate proves it collinear and the point lies on the closed -neighbour segment. A point pinch is a typed `BoundaryPinch`, never an invented -polygon. - -For alpha-shape work the supplied label is simply -`alphaShapeContainsFace threshold mesh`. `mkRadiusSquared` admits the -finite non-negative threshold and exact dyadic comparison makes membership -closed at equality. This is the face, or 2-simplex, filtration; it does not manufacture a second mesh or -pretend to own palette, colour-space, or rendering policy. - -```haskell -module Main where - -import GHC.Exts (fromList) -import Moonlight.Triangulation - -ring :: Double -> Int -> [(Double, Double)] -ring radius n = - [ (radius * cos t, radius * sin t) - | k <- [0 .. n - 1] - , let t = 2 * pi * fromIntegral k / fromIntegral n - ] - -main :: IO () -main = do - let pts = ring 4 32 <> ring 2 16 <> ring 3 24 - mesh <- - either - (fail . show) - pure - (delaunayGeometry (fromList [Point x y | (x, y) <- pts])) - threshold <- either (fail . show) pure (mkRadiusSquared 0.4) - let components = faceComponents mesh (alphaShapeContainsFace threshold mesh) - kept = [(label, component) | (label, component) <- components, label] - boundaries <- - traverse - (either (fail . show) pure . componentBoundary mesh . snd) - kept - print - [ ( length (boundaryLoopVertices (regionBoundaryOuterLoop boundary)) - , length (regionBoundaryHoleLoops boundary) - ) - | boundary <- boundaries - ] -``` - -The numeric threshold remains application policy; the circumradius calculation, -face adjacency, loop extraction, winding, holes, and exact simplification do -not. The derived boundary walks through data sites, so it is as jagged as the -sampling; an authored boundary stays smooth at any pitch and wins where the -generator is known. - -### Exact overlay, valuations, and morphology - -Author polygonal regions with rational coordinates, refine labelled layers -once, and select every Boolean from that common arrangement. Closed selection -retains zero- and one-dimensional intersections; polygon publication dissolves -all arrangement edges internal to the selected faces. - -Valuations read either carrier. Euler characteristic and area remain exact, -while Euclidean length is a normalized radical expression with certified -binary64 bounds. Minkowski addition, offset, erosion, opening, and closing then -compose over the same admitted `PlanarRegion`. - -```haskell -module Main where - -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map -import Moonlight.Triangulation - -admit :: Show obstruction => Either obstruction value -> IO value -admit = either (fail . show) pure - -rectangleLoop :: Integer -> Integer -> Integer -> Integer -> IO ExactLoop -rectangleLoop minimumX minimumY maximumX maximumY = - admit - ( exactLoop - ( exactPoint (fromInteger minimumX) (fromInteger minimumY) - :| [ exactPoint (fromInteger maximumX) (fromInteger minimumY) - , exactPoint (fromInteger maximumX) (fromInteger maximumY) - , exactPoint (fromInteger minimumX) (fromInteger maximumY) - ] - ) - ) - -rectangleRegion :: Integer -> Integer -> Integer -> Integer -> IO PlanarRegion -rectangleRegion minimumX minimumY maximumX maximumY = do - outer <- rectangleLoop minimumX minimumY maximumX maximumY - component <- admit (polygonComponent outer []) - admit (planarRegion [component]) - -insideLayer :: PlanarRegion -> IO (PlanarLayer Bool) -insideLayer region = admit (planarLayer False (Map.singleton True region)) - -cellSummary :: ExactCellSet -> IO (Int, Integer, Integer, CertifiedInterval) -cellSummary cells = do - values <- admit (cellValuations cells) - perimeter <- admit (cellSetPerimeter cells) - let area = exactAreaValue (valuationArea values) - pure - ( eulerCharacteristicValue (valuationEuler values) - , exactRationalNumerator area - , exactRationalDenominator area - , exactLengthBounds perimeter - ) - -regionArea :: PlanarRegion -> IO (Integer, Integer) -regionArea region = do - values <- admit (regionValuations region) - let area = exactAreaValue (valuationArea values) - pure (exactRationalNumerator area, exactRationalDenominator area) - -main :: IO () -main = do - left <- rectangleRegion 0 0 4 4 - right <- rectangleRegion 2 1 6 3 - leftLayer <- insideLayer left - rightLayer <- insideLayer right - overlay <- admit (overlayLayers leftLayer rightLayer) - - unionCells <- admit (overlayClosedUnion id id overlay) - intersectionCells <- admit (overlayClosedIntersection id id overlay) - differenceCells <- admit (overlayRegularizedDifference id id overlay) - traverse cellSummary [unionCells, intersectionCells, differenceCells] - >>= print - - kernelLoop <- rectangleLoop (-1) (-1) 1 1 - kernel <- admit (convexPolygon (exactLoopPoints kernelLoop)) >>= admit . structuringElement - (sumRegion, _) <- admit (minkowskiSum left right) - (offsetRegion, _) <- admit (polygonOffset kernel left) - (insetRegion, _) <- admit (polygonInset kernel left) - (openedRegion, _) <- admit (openWith kernel left) - (closedRegion, _) <- admit (closeWith kernel left) - traverse regionArea [sumRegion, offsetRegion, insetRegion, openedRegion, closedRegion] - >>= print -``` - -The Boolean summaries are union `(χ = 1, area = 20, perimeter = 20)`, -intersection `(1, 4, 8)`, and regularized difference `(1, 12, 20)`. The -morphology areas are `(48, 36, 4, 16, 16)`: Minkowski sum, one-unit square -offset, inset, opening, and closing respectively. - -## The growing city - -A triangulation is a value so that a large one can be extended without being -rebuilt or locked: a city mesh a district is added to, and then another. - -`union` rebuilds last. `planPair` classifies the pair first — an empty or -repeated operand returns the other verbatim, separable operands merge along -their seam, a subset inserts into its superset, skewed sizes insert the smaller -into the larger. +Use the main facade with explicit `Vector` inputs. Construction and set algebra +retain their typed obstruction in `Either`: -```haskell -insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8 +```cabal +build-depends: + base >= 4.19 && < 5, + moonlight-triangulation >= 1.4 && < 1.5, + vector >= 0.13 && < 0.14 ``` -A district is small against a city, so it inserts through a local copy-on-write -transaction. Publication scales with the insertion work and pages dirtied -rather than copying and renumbering the whole city. - -The mesh being read is never the mesh being written. A render or pathfinding -thread queries the published value while the next is built: no lock, no -defensive copy, no interval in which the world and the mesh disagree. Mutation -offers only the choice between stalling in place and answering from a clone -that does not yet know what was built, and both are visible from the frame. - -The same fact makes a failed union a `Left` over an untouched operand, -reverting an edit a selection, and a preview a second value rather than a copy. - -`Moonlight.Triangulation.Parallel` reads the operation the other way: regions -triangulated apart, folded up a balanced tournament, each node's sides -concurrent. - -## Representation - -Structure-of-arrays over paged, copy-on-write storage. Half-edge twins are index -complements (`e xor 1`), so traversal is arithmetic rather than indirection. -Local insertion transactions copy only the pages they touch; mutation is -confined to `ST` behind `Moonlight.Triangulation.Internal.Mutable` and never -escapes. - -## Predicates - -`Moonlight.Triangulation.Internal.Dyadic` carries the exact layer: mantissas are -decoded and aligned to a common exponent, with bounded predicates evaluated in -machine words and larger cases over `Integer`. Floating approximations are -trusted only inside proved error bounds and fall through to exact evaluation -otherwise. - -## Public sublibraries - -Depend on the sublibrary you actually use, not on the facade. The footprint is -the interface: each row states what the token costs you, and a build that pulls -more than the row says is a bug in this table or in the cabal. - -| Sublibrary | Surface | -| --- | --- | -| `core` | Exact-arithmetic scalars (`Scalar`, `LineSideInfo`) over paged, copy-on-write storage (`Internal.Dyadic`, `.Paged`, `.BoxedPaged`, `.PageDirectory`, `.Growable`, `.PackedIndex`, `.FaceQueue`). Depends only on `base`/`containers`/`deepseq`/`vector` — no other sublibrary. | -| `dcel` | The finite half-edge mesh and its whole read surface: `Types`, `Math`, 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` | 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 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: +[`SetAlgebra.hs`](docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs) +is the smallest compile-checked workflow. The +[example index](docs/examples/README.md) adds constrained interiors, +alpha-boundary descent, exact overlay and valuations, and polygonal morphology. - ../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ - --project-file=cabal.project.triangulation-dev \ - --builddir=dist-newstyle-triangulation-dev +## Architecture -For type-and-interface feedback where no benchmarkable artifact is required, -use the same component and cache at `-O0`: +The resident DCEL is immutable structure-of-arrays over paged copy-on-write +storage; local mutation is sealed in `ST`. Half-edge twins are index +complements. Exact predicates use bounded machine-word evaluation and fall +through to aligned `Integer` arithmetic when required. - ../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ - --project-file=cabal.project.triangulation-dev \ - --builddir=dist-newstyle-triangulation-fast \ - --disable-optimization +## Consumer libraries -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. +The Cabal manifest owns component visibility and dependencies; this is its +consumer-facing projection. External packages normally use the main library +and add only the public sublibraries whose modules they import. The finite DCEL +and construction kernel remain private behind the main facade. -## Surface +| Dependency | Imports | Purpose | +| --- | --- | --- | +| `moonlight-triangulation` | `Moonlight.Triangulation`, `.HintGenerator`, `.Overlay`, `.Minkowski` | Construction, observations, set algebra, CDT, refinement, alpha geometry, and exact planar operations. | +| `moonlight-triangulation:core` | `.Scalar`, `.LineSideInfo` | Low-level exact scalars and paged storage primitives. | +| `moonlight-triangulation:dual` | `.Voronoi`, `.Voronoi.Handles`, `.Interpolation` | Voronoi observations and natural-neighbour interpolation. | +| `moonlight-triangulation:parallel` | `.Parallel` | Bounded concurrent union; adds `async`. | +| `moonlight-triangulation:serialize` | `.Serialization` | Versioned binary envelopes; adds `binary`, `bytestring`, and `transformers`. | +| `moonlight-triangulation:cell-complex` (GHC 9.14+) | `.CellComplex` | Cell, chain, and filtered-alpha interpretations; adds Homology. | -* `Moonlight.Triangulation` — the apex facade. -* `.BulkLoad` — circle-sweep construction and incremental insertion. -* `.Cdt` — constraint recovery by conflict strip, with requeue on re-intersection. -* `.PointLocation`, `.HintGenerator` — walk location and Delaunay hierarchy hints. -* `.IntersectionIterator`, `.FloodFillIterator` — ordered line traversal, - barrier fill, labelled face components, and boundary loops. -* `.Alpha` — exact vertex/edge/face births, closed alpha subcomplexes, and the - constant-work bounded-face membership projection. -* `.Exact`, `.CellSet`, `.Region`, `.Valuation` — exact rational geometry, - closed cell selections, admitted polygonal regions, and intrinsic measures. -* `.Overlay`, `.Minkowski` — labelled common refinement, planar Booleans, - polygonal convolution, offset, erosion, opening, and closing. -* `.Voronoi`, `.Interpolation` — dual cells and natural-neighbour interpolation. -* `.Refinement` — Ruppert-style angle and area refinement. -* `.Validation` — structural and Delaunay-property audits. -* `.Serialization` (sublibrary `serialize`) — versioned binary envelope. +[Build and validate package components locally.](docs/development.md) diff --git a/app/category-observatory/Main.hs b/app/category-observatory/Main.hs deleted file mode 100644 --- a/app/category-observatory/Main.hs +++ /dev/null @@ -1,562 +0,0 @@ -{-# 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/app/persistence-rose/Main.hs b/app/persistence-rose/Main.hs deleted file mode 100644 --- a/app/persistence-rose/Main.hs +++ /dev/null @@ -1,211 +0,0 @@ -module Main (main) where - -import Control.Exception (IOException, try) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except - ( ExceptT (..), - except, - runExceptT, - ) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) -import Data.ByteString qualified as ByteString -import Data.Foldable (traverse_) -import Moonlight.Triangulation.Exhibit.PersistenceRose - ( PersistenceRoseError, - PersistenceRoseScene, - alphaEclipseReceipt, - buildAlphaEclipseScene, - buildPersistenceRoseScene, - persistenceRoseFrameSpecs, - persistenceRoseReceipt, - renderAlphaEclipse, - renderAlphaEclipseReceipt, - renderPersistenceRoseAnimationReceipt, - renderPersistenceRoseFrame, - renderPersistenceRosePoster, - renderPersistenceRoseReceipt, - stampPersistenceRoseGif, - verifyPersistenceRoseGif, - ) -import System.Directory (createDirectoryIfMissing) -import System.Environment (getArgs) -import System.Exit (die) -import System.FilePath ((), takeDirectory) -import Text.Printf (printf) -import Text.Read (readMaybe) - -data PersistenceRoseCommand - = WritePoster !FilePath - | WriteEclipse !FilePath - | WriteFrames !Int !FilePath - | StampGif !FilePath !FilePath - | VerifyArtifacts !FilePath - | PrintReceipt - -data PersistenceRoseCommandError - = PersistenceRoseUsage ![String] - | PersistenceRoseInvalidFrameCount !String - | PersistenceRoseConstructionFailed !PersistenceRoseError - | PersistenceRoseDirectoryFailed !FilePath !IOException - | PersistenceRoseReadFailed !FilePath !IOException - | PersistenceRoseWriteFailed !FilePath !IOException - | PersistenceRoseArtifactMismatch !FilePath - -instance Show PersistenceRoseCommandError where - show commandError = - case commandError of - PersistenceRoseUsage arguments -> - "invalid persistence-rose command " - <> show arguments - <> "; expected: poster OUTPUT.svg | eclipse OUTPUT.svg | frames FRAME_COUNT OUTPUT_DIRECTORY | stamp-gif INPUT.gif OUTPUT.gif | verify-artifacts PACKAGE_ROOT | receipt" - PersistenceRoseInvalidFrameCount submitted -> - "frame count must be an integer greater than one, received " <> show submitted - PersistenceRoseConstructionFailed sceneError -> show sceneError - PersistenceRoseDirectoryFailed path caughtError -> - "could not create output directory " <> show path <> ": " <> show caughtError - PersistenceRoseReadFailed path caughtError -> - "could not read " <> show path <> ": " <> show caughtError - PersistenceRoseWriteFailed path caughtError -> - "could not write " <> show path <> ": " <> show caughtError - PersistenceRoseArtifactMismatch path -> - "tracked exhibit differs from its canonical renderer: " <> show path - -main :: IO () -main = do - arguments <- getArgs - result <- runExceptT (runPersistenceRoseCommand arguments) - either (die . show) pure result - -runPersistenceRoseCommand :: [String] -> ExceptT PersistenceRoseCommandError IO () -runPersistenceRoseCommand arguments = do - command <- except (parseCommand arguments) - case command of - WriteEclipse outputPath -> do - scene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene) - createOutputDirectory (takeDirectory outputPath) - writeOutput outputPath (renderAlphaEclipse scene) - lift - ( putStrLn - (renderAlphaEclipseReceipt (alphaEclipseReceipt scene) <> "\nwrote alpha eclipse " <> outputPath) - ) - StampGif inputPath outputPath -> do - scene <- requirePersistenceRoseScene - inputBytes <- readBytes inputPath - (receipt, stamped) <- except (first PersistenceRoseConstructionFailed (stampPersistenceRoseGif scene inputBytes)) - createOutputDirectory (takeDirectory outputPath) - writeBytes outputPath stamped - lift - ( putStrLn - (renderPersistenceRoseAnimationReceipt receipt <> "\nwrote stamped GIF " <> outputPath) - ) - VerifyArtifacts packageRoot -> verifyTrackedArtifacts packageRoot - PrintReceipt -> do - scene <- requirePersistenceRoseScene - lift (putStrLn (renderPersistenceRoseReceipt (persistenceRoseReceipt scene))) - WritePoster outputPath -> do - scene <- requirePersistenceRoseScene - let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene) - createOutputDirectory (takeDirectory outputPath) - writeOutput outputPath (renderPersistenceRosePoster scene) - lift (putStrLn (receiptText <> "\nwrote poster " <> outputPath)) - WriteFrames frameCount outputDirectory -> do - scene <- requirePersistenceRoseScene - let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene) - frames <- except (first PersistenceRoseConstructionFailed (persistenceRoseFrameSpecs frameCount)) - createOutputDirectory outputDirectory - traverse_ - (\(frameIndex, frame) -> writeOutput (framePath outputDirectory frameIndex) (renderPersistenceRoseFrame scene frame)) - (zip [0 :: Int ..] frames) - lift - ( putStrLn - ( receiptText - <> "\nwrote " - <> show (length frames) - <> " frames to " - <> outputDirectory - ) - ) - -requirePersistenceRoseScene :: ExceptT PersistenceRoseCommandError IO PersistenceRoseScene -requirePersistenceRoseScene = - except (first PersistenceRoseConstructionFailed buildPersistenceRoseScene) - -parseCommand :: [String] -> Either PersistenceRoseCommandError PersistenceRoseCommand -parseCommand arguments = - case arguments of - ["poster", outputPath] -> Right (WritePoster outputPath) - ["eclipse", outputPath] -> Right (WriteEclipse outputPath) - ["stamp-gif", inputPath, outputPath] -> Right (StampGif inputPath outputPath) - ["verify-artifacts", packageRoot] -> Right (VerifyArtifacts packageRoot) - ["frames", submittedCount, outputDirectory] -> - case readMaybe submittedCount of - Just frameCount - | frameCount > 1 -> Right (WriteFrames frameCount outputDirectory) - _ -> Left (PersistenceRoseInvalidFrameCount submittedCount) - ["receipt"] -> Right PrintReceipt - _ -> Left (PersistenceRoseUsage arguments) - -createOutputDirectory :: FilePath -> ExceptT PersistenceRoseCommandError IO () -createOutputDirectory outputDirectory = - liftIOException - (PersistenceRoseDirectoryFailed outputDirectory) - (createDirectoryIfMissing True outputDirectory) - -writeOutput :: FilePath -> String -> ExceptT PersistenceRoseCommandError IO () -writeOutput outputPath contents = - liftIOException (PersistenceRoseWriteFailed outputPath) (writeFile outputPath contents) - -readOutput :: FilePath -> ExceptT PersistenceRoseCommandError IO String -readOutput inputPath = - liftIOException (PersistenceRoseReadFailed inputPath) (readFile inputPath) - -readBytes :: FilePath -> ExceptT PersistenceRoseCommandError IO ByteString -readBytes inputPath = - liftIOException (PersistenceRoseReadFailed inputPath) (ByteString.readFile inputPath) - -writeBytes :: FilePath -> ByteString -> ExceptT PersistenceRoseCommandError IO () -writeBytes outputPath contents = - liftIOException (PersistenceRoseWriteFailed outputPath) (ByteString.writeFile outputPath contents) - -verifyTrackedArtifacts :: FilePath -> ExceptT PersistenceRoseCommandError IO () -verifyTrackedArtifacts packageRoot = do - roseScene <- requirePersistenceRoseScene - eclipseScene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene) - let posterPath = packageRoot "docs" "moonlight-triangulation-persistence-rose.svg" - eclipsePath = packageRoot "docs" "moonlight-triangulation-alpha-eclipse.svg" - gifPath = packageRoot "docs" "social" "moonlight-triangulation-persistence-rose.gif" - verifyTextArtifact posterPath (renderPersistenceRosePoster roseScene) - verifyTextArtifact eclipsePath (renderAlphaEclipse eclipseScene) - gifBytes <- readBytes gifPath - animationReceipt <- - except - (first PersistenceRoseConstructionFailed (verifyPersistenceRoseGif roseScene gifBytes)) - lift - ( putStrLn - ( "verified poster, alpha eclipse, and stamped GIF\n" - <> renderPersistenceRoseAnimationReceipt animationReceipt - ) - ) - -verifyTextArtifact - :: FilePath - -> String - -> ExceptT PersistenceRoseCommandError IO () -verifyTextArtifact artifactPath expectedContents = do - actualContents <- readOutput artifactPath - except - ( if actualContents == expectedContents - then Right () - else Left (PersistenceRoseArtifactMismatch artifactPath) - ) - -liftIOException - :: (IOException -> PersistenceRoseCommandError) - -> IO value - -> ExceptT PersistenceRoseCommandError IO value -liftIOException wrapFailure = ExceptT . fmap (first wrapFailure) . try - -framePath :: FilePath -> Int -> FilePath -framePath outputDirectory frameIndex = - outputDirectory printf "frame-%04d.svg" frameIndex diff --git a/app/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs b/app/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs deleted file mode 100644 --- a/app/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs +++ /dev/null @@ -1,1625 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - --- | A deterministic, pure observatory assembled from Moonlight's existing --- geometry, exact filtration, interpolation, and persistence owners. -module Moonlight.Triangulation.Exhibit.PersistenceRose - ( PersistenceRoseError (..), - PersistenceRoseReceipt (..), - PersistenceRoseScene, - PersistenceRoseFrame, - PersistenceRoseAnimationReceipt (..), - AlphaEclipseReceipt (..), - AlphaEclipseScene, - buildPersistenceRoseScene, - buildAlphaEclipseScene, - persistenceRoseReceipt, - alphaEclipseReceipt, - renderPersistenceRoseReceipt, - renderAlphaEclipseReceipt, - renderPersistenceRosePoster, - renderAlphaEclipse, - persistenceRoseFrameSpecs, - renderPersistenceRoseFrame, - persistenceRoseAnimationReceipt, - renderPersistenceRoseAnimationReceipt, - stampPersistenceRoseGif, - verifyPersistenceRoseGif, - ) -where - -import Control.Monad (foldM) -import Control.Monad.ST (runST) -import Data.Bifunctor (first) -import Data.Bits ((.&.), xor) -import Data.ByteString (ByteString) -import Data.ByteString qualified as ByteString -import Data.ByteString.Char8 qualified as ByteString.Char8 -import Data.List (find, intercalate, sortOn) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) -import Data.Ord (Down (..)) -import Data.Set qualified as Set -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text.Encoding -import Data.Vector qualified as Vector -import Data.Word (Word64, Word8) -import Moonlight.Homology.Chain - ( HomologicalDegree (..), - HomologyFailure, - PersistencePair (..), - ) -import Moonlight.Homology.Persistence - ( criticalBettiVectors, - mod2PersistentPairsWithCriticalBettiTable, - ) -import Moonlight.Triangulation - ( AlphaBirth, - AlphaFiltration, - AlphaFiltrationError, - BuildError, - DelaunayTriangulation, - ExactLoop, - MinkowskiError, - OverlayError, - PlanarRegion, - Point (..), - PointValidationError, - PolygonComponent, - QueryPoint, - RegionPublicationError, - RegionValidationError, - alphaBirthDenominator, - alphaBirthNumerator, - alphaBirthToDouble, - alphaEdgeBirth, - alphaFaceBirth, - alphaFiltration, - alphaFiltrationCriticalBirths, - convexPolygon, - delaunayGeometry, - exactLoop, - exactLoopPoints, - exactPointFromPoint, - exactPointToEmbeddingCandidate, - innerFaces, - innerFaceVertexTriples, - mkQueryPoint, - overlayLayers, - overlaySelectedRegion, - planarLayer, - planarRegion, - planarRegionComponents, - polygonComponent, - polygonHoleLoops, - polygonOffset, - polygonOuterLoop, - queryPointValue, - structuringElement, - undirectedEdges, - undirectedEndpoints, - vertexPoint, - vertices, - ) -import Moonlight.Triangulation.CellComplex - ( DCELError, - filteredAlphaComplex, - ) -import Moonlight.Triangulation.FloodFillIterator - ( BoundaryObstruction, - FaceComponent, - boundaryLoopVertices, - componentBoundaryLoops, - faceComponentFaces, - faceComponentsBy, - outerFaceFloodFill, - ) -import Moonlight.Triangulation.Handles.HandleDefs - ( FaceId (..), - UndirectedEdgeId, - VertexId, - normalizedDirected, - ) -import Moonlight.Triangulation.Interpolation - ( InterpolationStats (..), - NaturalNeighborResult (..), - naturalNeighborWeights, - newNaturalNeighborWorkspace, - ) -import Moonlight.Triangulation.Voronoi - ( VoronoiEdgeGeometry (..), - asDirectedVoronoiEdge, - voronoiEdgeGeometry, - ) -import Numeric (showFFloat, showHex) - --- | Every boundary at which the exhibit may be refused. The renderer never --- invents a fallback geometry or topology state. -data PersistenceRoseError - = RoseDelaunayBuildFailed !BuildError - | RoseAlphaFiltrationFailed !AlphaFiltrationError - | RoseCellComplexLoweringFailed !DCELError - | RosePersistenceFailed !HomologyFailure - | RoseCriticalProfileCountMismatch !Int !Int - | RoseCriticalProfileDegreeCountMismatch !Int !Int - | RoseBirthRankMissing !AlphaBirth - | RoseEdgeBirthMissing !UndirectedEdgeId - | RoseFaceBirthMissing !FaceId - | RoseBoundaryDescentFailed !Int !BoundaryObstruction - | RoseNoCriticalStates - | RoseNoMaskRegions - | RoseNoPersistentHole - | RoseNoCoherentHero !Int ![(Int, Int)] - | RoseVoronoiGeometryMissing !UndirectedEdgeId - | RoseNaturalNeighborFallbacks !Int - | RosePointInvalid !PointValidationError - | RoseRegionInvalid !RegionValidationError - | RoseOverlayFailed !(OverlayError Bool Bool) - | RoseOverlayPublicationFailed !RegionPublicationError - | RoseMinkowskiFailed !MinkowskiError - | RoseFrameCountTooSmall !Int - | RoseEclipseFiniteHoleCountMismatch !Int - | RoseEclipseFiniteHoleMissingDeath - | RoseEclipseBettiProfileMismatch !Int !Int !Int - | RoseGifInvalidSignature - | RoseGifTruncated !Int - | RoseGifUnexpectedBlock !Int !Word8 - | RoseGifDimensionMismatch !Int !Int !Int !Int - | RoseGifFrameCountMismatch !Int !Int - | RoseGifFrameDelayCountMismatch !Int !Int - | RoseGifDurationMismatch !Int !Int - | RoseGifProvenanceMismatch - | RoseGifMarkerTooLong !Int - deriving stock (Show) - --- | A compact, test-readable projection of everything the scene actually --- computed. It is intentionally not another geometry representation. -data PersistenceRoseReceipt = PersistenceRoseReceipt - { roseSiteCount :: !Int, - roseEdgeCount :: !Int, - roseFaceCount :: !Int, - roseCriticalBirthCount :: !Int, - roseFinitePersistentHoleCount :: !Int, - roseEssentialPersistentHoleCount :: !Int, - roseHeroCriticalRank :: !Int, - roseHeroBettiOne :: !Int, - roseHeroGeometricHoleCount :: !Int, - roseVoronoiSegmentCount :: !Int, - roseNaturalNeighborSampleCount :: !Int, - roseNaturalNeighborFallbackCount :: !Int, - roseMaskComponentCount :: !Int - } - deriving stock (Eq, Show) - -data PersistenceRoseScene = PersistenceRoseScene - { sceneSites :: ![Point], - sceneEdges :: ![RankedSegment], - sceneFaces :: ![RankedTriangle], - sceneCriticalStates :: !(NonEmpty CriticalState), - sceneHeroState :: !CriticalState, - sceneVoronoiSegments :: ![Segment], - sceneFieldSamples :: ![FieldSample], - sceneMaskComponents :: ![MaskComponent], - scenePersistenceArcs :: ![PersistenceArc], - sceneReceipt :: !PersistenceRoseReceipt - } - --- | The canonical source projection carried inside the retained GIF. The GIF --- codec remains an effect-boundary view; this receipt binds that binary view --- to the exact deterministic SVG frame section used to produce it. -data PersistenceRoseAnimationReceipt = PersistenceRoseAnimationReceipt - { roseAnimationFrameCount :: !Int, - roseAnimationFramesPerSecond :: !Int, - roseAnimationWidth :: !Int, - roseAnimationHeight :: !Int, - roseAnimationSourceFingerprint :: !Word64 - } - deriving stock (Eq, Show) - --- | The exact, test-readable facts shown by the alpha eclipse. The numerator --- and denominator fields are projections of opaque 'AlphaBirth' values; the --- renderer never chooses thresholds independently of the filtration. -data AlphaEclipseReceipt = AlphaEclipseReceipt - { eclipseSiteCount :: !Int, - eclipseEdgeCount :: !Int, - eclipseFaceCount :: !Int, - eclipseHoleBirthNumerator :: !Integer, - eclipseHoleBirthDenominator :: !Integer, - eclipseHoleDeathNumerator :: !Integer, - eclipseHoleDeathDenominator :: !Integer, - eclipseBettiBeforeBirth :: !Int, - eclipseBettiAtBirth :: !Int, - eclipseBettiAtDeath :: !Int - } - deriving stock (Eq, Show) - --- | A three-section observation of one fixed resident Delaunay DCEL. Every --- displayed edge and face is projected from that DCEL with its exact birth --- rank; only the selected sublevel differs between sections. -data AlphaEclipseScene = AlphaEclipseScene - { eclipseSites :: ![Point], - eclipseEdges :: ![RankedSegment], - eclipseFaces :: ![RankedTriangle], - eclipseBeforeState :: !CriticalState, - eclipseBirthState :: !CriticalState, - eclipseDeathState :: !CriticalState, - eclipseReceipt :: !AlphaEclipseReceipt - } - --- | The shared local descent used by both exhibits. This is not a second --- filtration carrier: it retains the canonical mesh and filtration beside --- their checked Homology projection and only the ranked rendering views. -data AlphaProjection = AlphaProjection - { projectionTriangulation :: !(DelaunayTriangulation ()), - projectionPersistencePairs :: ![PersistencePair AlphaBirth], - projectionCriticalStates :: !(NonEmpty CriticalState), - projectionBirthRanks :: !(Map AlphaBirth Int), - projectionEdges :: ![RankedSegment], - projectionFaces :: ![RankedTriangle] - } - -newtype PersistenceRoseFrame = PersistenceRoseFrame - { frameProgress :: Double - } - deriving stock (Eq, Show) - -data CriticalState = CriticalState - { criticalRank :: !Int, - criticalBirth :: !AlphaBirth, - criticalBettiOne :: !Int, - criticalHoles :: ![HoleComponent] - } - -data RankedSegment = RankedSegment - { rankedSegmentGeometry :: !Segment, - rankedSegmentBirthRank :: !Int - } - -data RankedTriangle = RankedTriangle - { rankedTrianglePoints :: !(Point, Point, Point), - rankedTriangleBirthRank :: !Int - } - -data Segment = Segment !Point !Point - -newtype HoleComponent = HoleComponent [[Point]] - -data FieldSample = FieldSample - { fieldSamplePoint :: !Point, - fieldSampleValue :: !Double, - fieldSampleNeighborCount :: !Int - } - -data MaskComponent = MaskComponent - { maskOuterLoop :: ![Point], - maskHoleLoops :: ![[Point]] - } - -data PersistenceArc = PersistenceArc - { persistenceArcBirthRank :: !Int, - persistenceArcDeathRank :: !Int - } - -buildPersistenceRoseScene :: Either PersistenceRoseError PersistenceRoseScene -buildPersistenceRoseScene = do - projection <- buildAlphaProjection roseSites - let triangulation = projectionTriangulation projection - criticalStates = projectionCriticalStates projection - persistencePairs = projectionPersistencePairs projection - criticalBirthCount = NonEmpty.length criticalStates - heroState <- chooseHeroState criticalStates - finiteVoronoiSegments <- projectFiniteVoronoiSegments triangulation - (fieldSamples, fallbackCount) <- naturalNeighborField triangulation - if fallbackCount == 0 - then pure () - else Left (RoseNaturalNeighborFallbacks fallbackCount) - maskComponents <- buildRoseMask - persistenceArcs <- - projectPersistenceArcs - (projectionBirthRanks projection) - criticalBirthCount - persistencePairs - let finiteHoles = filter isFinitePositiveHole persistencePairs - essentialHoles = filter isEssentialHole persistencePairs - heroHoleCount = length (criticalHoles heroState) - receipt = - PersistenceRoseReceipt - { roseSiteCount = length (vertices triangulation), - roseEdgeCount = length (projectionEdges projection), - roseFaceCount = length (projectionFaces projection), - roseCriticalBirthCount = criticalBirthCount, - roseFinitePersistentHoleCount = length finiteHoles, - roseEssentialPersistentHoleCount = length essentialHoles, - roseHeroCriticalRank = criticalRank heroState, - roseHeroBettiOne = criticalBettiOne heroState, - roseHeroGeometricHoleCount = heroHoleCount, - roseVoronoiSegmentCount = length finiteVoronoiSegments, - roseNaturalNeighborSampleCount = length fieldSamples, - roseNaturalNeighborFallbackCount = fallbackCount, - roseMaskComponentCount = length maskComponents - } - pure - PersistenceRoseScene - { sceneSites = fmap (vertexPoint triangulation) (vertices triangulation), - sceneEdges = projectionEdges projection, - sceneFaces = projectionFaces projection, - sceneCriticalStates = criticalStates, - sceneHeroState = heroState, - sceneVoronoiSegments = finiteVoronoiSegments, - sceneFieldSamples = fieldSamples, - sceneMaskComponents = maskComponents, - scenePersistenceArcs = persistenceArcs, - sceneReceipt = receipt - } - -buildAlphaProjection :: [Point] -> Either PersistenceRoseError AlphaProjection -buildAlphaProjection sites = do - triangulation <- first RoseDelaunayBuildFailed (delaunayGeometry (Vector.fromList sites)) - filtration <- first RoseAlphaFiltrationFailed (alphaFiltration triangulation) - filteredComplex <- first RoseCellComplexLoweringFailed (filteredAlphaComplex filtration) - (persistencePairs, criticalBettiTable) <- - first RosePersistenceFailed - (mod2PersistentPairsWithCriticalBettiTable filteredComplex) - let criticalBirths = alphaFiltrationCriticalBirths filtration - criticalProfiles = criticalBettiVectors criticalBettiTable - birthRanks = Map.fromDistinctAscList (zip criticalBirths [0 ..]) - if length criticalBirths == length criticalProfiles - then pure () - else Left (RoseCriticalProfileCountMismatch (length criticalBirths) (length criticalProfiles)) - criticalStates <- - traverse - (buildCriticalState triangulation filtration) - (zip3 [0 ..] criticalBirths criticalProfiles) - >>= maybe (Left RoseNoCriticalStates) Right . NonEmpty.nonEmpty - rankedEdges <- - traverse - (projectRankedEdge triangulation filtration birthRanks) - (undirectedEdges triangulation) - rankedFaces <- - traverse - (projectRankedFace triangulation filtration birthRanks) - (zip [1 ..] (Vector.toList (innerFaceVertexTriples triangulation))) - pure - AlphaProjection - { projectionTriangulation = triangulation, - projectionPersistencePairs = persistencePairs, - projectionCriticalStates = criticalStates, - projectionBirthRanks = birthRanks, - projectionEdges = rankedEdges, - projectionFaces = rankedFaces - } - -buildAlphaEclipseScene :: Either PersistenceRoseError AlphaEclipseScene -buildAlphaEclipseScene = do - projection <- buildAlphaProjection alphaEclipseSites - finiteHoles <- - case filter isFinitePositiveHole (projectionPersistencePairs projection) of - [finiteHole] -> Right finiteHole - holes -> Left (RoseEclipseFiniteHoleCountMismatch (length holes)) - deathBirth <- - maybe - (Left RoseEclipseFiniteHoleMissingDeath) - Right - (persistenceDeath finiteHoles) - let birth = persistenceBirth finiteHoles - birthRanks = projectionBirthRanks projection - states = projectionCriticalStates projection - birthRank <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) - deathRank <- maybe (Left (RoseBirthRankMissing deathBirth)) Right (Map.lookup deathBirth birthRanks) - let beforeState = criticalStateAt (max 0 (birthRank - 1)) states - birthState = criticalStateAt birthRank states - deathState = criticalStateAt deathRank states - bettiProfile = - ( criticalBettiOne beforeState, - criticalBettiOne birthState, - criticalBettiOne deathState - ) - case bettiProfile of - (0, 1, 0) -> pure () - (beforeBetti, birthBetti, deathBetti) -> - Left (RoseEclipseBettiProfileMismatch beforeBetti birthBetti deathBetti) - let triangulation = projectionTriangulation projection - receipt = - AlphaEclipseReceipt - { eclipseSiteCount = length (vertices triangulation), - eclipseEdgeCount = length (projectionEdges projection), - eclipseFaceCount = length (projectionFaces projection), - eclipseHoleBirthNumerator = alphaBirthNumerator birth, - eclipseHoleBirthDenominator = alphaBirthDenominator birth, - eclipseHoleDeathNumerator = alphaBirthNumerator deathBirth, - eclipseHoleDeathDenominator = alphaBirthDenominator deathBirth, - eclipseBettiBeforeBirth = criticalBettiOne beforeState, - eclipseBettiAtBirth = criticalBettiOne birthState, - eclipseBettiAtDeath = criticalBettiOne deathState - } - pure - AlphaEclipseScene - { eclipseSites = fmap (vertexPoint triangulation) (vertices triangulation), - eclipseEdges = projectionEdges projection, - eclipseFaces = projectionFaces projection, - eclipseBeforeState = beforeState, - eclipseBirthState = birthState, - eclipseDeathState = deathState, - eclipseReceipt = receipt - } - -persistenceRoseReceipt :: PersistenceRoseScene -> PersistenceRoseReceipt -persistenceRoseReceipt = sceneReceipt - -alphaEclipseReceipt :: AlphaEclipseScene -> AlphaEclipseReceipt -alphaEclipseReceipt = eclipseReceipt - -renderPersistenceRoseReceipt :: PersistenceRoseReceipt -> String -renderPersistenceRoseReceipt receipt = - intercalate - " · " - [ "sites " <> show (roseSiteCount receipt), - "edges " <> show (roseEdgeCount receipt), - "faces " <> show (roseFaceCount receipt), - "critical births " <> show (roseCriticalBirthCount receipt), - "finite H1 intervals " <> show (roseFinitePersistentHoleCount receipt), - "essential H1 intervals " <> show (roseEssentialPersistentHoleCount receipt), - "hero rank " <> show (roseHeroCriticalRank receipt), - "beta1 " <> show (roseHeroBettiOne receipt), - "geometric holes " <> show (roseHeroGeometricHoleCount receipt), - "Voronoi segments " <> show (roseVoronoiSegmentCount receipt), - "Sibson samples " <> show (roseNaturalNeighborSampleCount receipt), - "fallbacks " <> show (roseNaturalNeighborFallbackCount receipt), - "mask components " <> show (roseMaskComponentCount receipt) - ] - -renderAlphaEclipseReceipt :: AlphaEclipseReceipt -> String -renderAlphaEclipseReceipt receipt = - intercalate - " · " - [ "sites " <> show (eclipseSiteCount receipt), - "edges " <> show (eclipseEdgeCount receipt), - "faces " <> show (eclipseFaceCount receipt), - "H1 [" - <> renderExactRatio (eclipseHoleBirthNumerator receipt) (eclipseHoleBirthDenominator receipt) - <> ", " - <> renderExactRatio (eclipseHoleDeathNumerator receipt) (eclipseHoleDeathDenominator receipt) - <> ")", - "beta1 " - <> show - ( eclipseBettiBeforeBirth receipt, - eclipseBettiAtBirth receipt, - eclipseBettiAtDeath receipt - ) - ] - -buildCriticalState - :: DelaunayTriangulation () - -> AlphaFiltration - -> (Int, AlphaBirth, [Int]) - -> Either PersistenceRoseError CriticalState -buildCriticalState triangulation filtration (rankValue, birthValue, profile) = do - bettiOne <- - case profile of - _ : secondDegree : _ : _ -> Right secondDegree - _ -> Left (RoseCriticalProfileDegreeCountMismatch rankValue (length profile)) - holes <- holeComponentsAt rankValue triangulation filtration birthValue - pure - CriticalState - { criticalRank = rankValue, - criticalBirth = birthValue, - criticalBettiOne = bettiOne, - criticalHoles = holes - } - -chooseHeroState :: NonEmpty CriticalState -> Either PersistenceRoseError CriticalState -chooseHeroState states = - let stateList = NonEmpty.toList states - maximumBettiOne = foldl' (\best state -> max best (criticalBettiOne state)) 0 stateList - maximalStates = filter ((== maximumBettiOne) . criticalBettiOne) stateList - agreements = fmap (\state -> (criticalBettiOne state, length (criticalHoles state))) maximalStates - coherentStates = - filter - (\state -> criticalBettiOne state > 0 && criticalBettiOne state == length (criticalHoles state)) - stateList - sevenPetalStates = filter ((== rosePetalCount) . criticalBettiOne) coherentStates - in if maximumBettiOne <= 0 - then Left RoseNoPersistentHole - else - case NonEmpty.nonEmpty sevenPetalStates of - Just preferredStates -> Right (latestCriticalState preferredStates) - Nothing -> - maybe - (Left (RoseNoCoherentHero maximumBettiOne agreements)) - Right - (find (\state -> criticalBettiOne state == length (criticalHoles state)) maximalStates) - -latestCriticalState :: NonEmpty CriticalState -> CriticalState -latestCriticalState (firstState :| remainingStates) = - foldl' - (\latest candidate -> if criticalRank candidate > criticalRank latest then candidate else latest) - firstState - remainingStates - -holeComponentsAt - :: Int - -> DelaunayTriangulation () - -> AlphaFiltration - -> AlphaBirth - -> Either PersistenceRoseError [HoleComponent] -holeComponentsAt rankValue triangulation filtration threshold = do - inactiveEdges <- - inactiveHandlesAt - RoseEdgeBirthMissing - (alphaEdgeBirth filtration) - (undirectedEdges triangulation) - threshold - inactiveFaces <- - inactiveHandlesAt - RoseFaceBirthMissing - (alphaFaceBirth filtration) - (innerFaces triangulation) - threshold - let edgeInactive edge = Set.member edge inactiveEdges - faceInactive face = Set.member face inactiveFaces - exteriorFaces = Set.fromList (outerFaceFloodFill triangulation edgeInactive) - inactiveComponents = - fmap snd - ( faceComponentsBy - triangulation - (\face -> if faceInactive face then Just () else Nothing) - edgeInactive - ) - boundedComponents = - filter - (all (`Set.notMember` exteriorFaces) . faceComponentFaces) - inactiveComponents - traverse - (projectHoleComponent rankValue triangulation) - boundedComponents - -inactiveHandlesAt - :: Ord handle - => (handle -> PersistenceRoseError) - -> (handle -> Maybe AlphaBirth) - -> [handle] - -> AlphaBirth - -> Either PersistenceRoseError (Set.Set handle) -inactiveHandlesAt missingBirth birthAt handles threshold = - Set.fromList . mapMaybe id - <$> traverse - ( \handle -> - maybe - (Left (missingBirth handle)) - (\birth -> Right (if birth > threshold then Just handle else Nothing)) - (birthAt handle) - ) - handles - -projectHoleComponent - :: Int - -> DelaunayTriangulation () - -> FaceComponent - -> Either PersistenceRoseError HoleComponent -projectHoleComponent rankValue triangulation component = do - loops <- - first (RoseBoundaryDescentFailed rankValue) - (componentBoundaryLoops triangulation component) - pure - ( HoleComponent - ( fmap - (fmap (vertexPoint triangulation) . NonEmpty.toList . boundaryLoopVertices) - (NonEmpty.toList loops) - ) - ) - -projectRankedEdge - :: DelaunayTriangulation () - -> AlphaFiltration - -> Map AlphaBirth Int - -> UndirectedEdgeId - -> Either PersistenceRoseError RankedSegment -projectRankedEdge triangulation filtration birthRanks edge = do - birth <- maybe (Left (RoseEdgeBirthMissing edge)) Right (alphaEdgeBirth filtration edge) - rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) - let (fromVertex, toVertex) = undirectedEndpoints triangulation edge - pure - RankedSegment - { rankedSegmentGeometry = Segment (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex), - rankedSegmentBirthRank = rankValue - } - -projectRankedFace - :: DelaunayTriangulation () - -> AlphaFiltration - -> Map AlphaBirth Int - -> (Int, (VertexId, VertexId, VertexId)) - -> Either PersistenceRoseError RankedTriangle -projectRankedFace triangulation filtration birthRanks (rawFace, (firstVertex, secondVertex, thirdVertex)) = do - let face = toFaceId rawFace - birth <- maybe (Left (RoseFaceBirthMissing face)) Right (alphaFaceBirth filtration face) - rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) - pure - RankedTriangle - { rankedTrianglePoints = - ( vertexPoint triangulation firstVertex, - vertexPoint triangulation secondVertex, - vertexPoint triangulation thirdVertex - ), - rankedTriangleBirthRank = rankValue - } - -toFaceId :: Int -> FaceId -toFaceId = FaceId . fromIntegral - -projectFiniteVoronoiSegments - :: DelaunayTriangulation () - -> Either PersistenceRoseError [Segment] -projectFiniteVoronoiSegments triangulation = - fmap (mapMaybe id) - . traverse projectSegment - $ undirectedEdges triangulation - where - projectSegment :: UndirectedEdgeId -> Either PersistenceRoseError (Maybe Segment) - projectSegment edge = - case voronoiEdgeGeometry triangulation (asDirectedVoronoiEdge (normalizedDirected edge)) of - Nothing -> Left (RoseVoronoiGeometryMissing edge) - Just (VoronoiSegment fromPoint toPoint) -> Right (Just (Segment fromPoint toPoint)) - Just (VoronoiRay _ _) -> Right Nothing - Just (VoronoiLine _ _) -> Right Nothing - -naturalNeighborField - :: DelaunayTriangulation () - -> Either PersistenceRoseError ([FieldSample], Int) -naturalNeighborField triangulation = do - admittedQueries <- traverse (first RosePointInvalid . mkQueryPoint) fieldQueryPoints - let results = runST $ do - workspace <- newNaturalNeighborWorkspace triangulation - traverse (naturalNeighborWeights workspace Nothing) admittedQueries - pairedResults = zip admittedQueries results - fallbackCount = length (filter (interpolationUsedFallback . naturalNeighborStats . snd) pairedResults) - samples = mapMaybe (fieldSampleFromResult triangulation) pairedResults - pure (samples, fallbackCount) - -fieldSampleFromResult - :: DelaunayTriangulation () - -> (QueryPoint, NaturalNeighborResult) - -> Maybe FieldSample -fieldSampleFromResult triangulation (query, result) - | Vector.null weights = Nothing - | interpolationUsedFallback (naturalNeighborStats result) = Nothing - | otherwise = - let weightedValue = - Vector.foldl' - (\total (vertex, weight) -> total + weight * siteSignal (vertexPoint triangulation vertex)) - 0 - weights - in Just - FieldSample - { fieldSamplePoint = queryPointValue query, - fieldSampleValue = clamp 0 1 weightedValue, - fieldSampleNeighborCount = Vector.length weights - } - where - weights = naturalNeighborValues result - -siteSignal :: Point -> Double -siteSignal (Point x y) = - clamp 0 1 (0.5 + 0.24 * sin (1.31 * x - 0.73 * y) + 0.18 * cos (0.61 * x + 1.17 * y)) - -fieldQueryPoints :: [Point] -fieldQueryPoints = - [ Point (fromIntegral column * 0.34 - 5.1) (fromIntegral row * 0.34 - 4.42) - | row <- [0 .. 26 :: Int], - column <- [0 .. 30 :: Int] - ] - -projectPersistenceArcs - :: Map AlphaBirth Int - -> Int - -> [PersistencePair AlphaBirth] - -> Either PersistenceRoseError [PersistenceArc] -projectPersistenceArcs birthRanks criticalCount pairs = do - arcs <- traverse pairArc (filter isPositiveHole pairs) - pure (take 36 (sortOn (Down . persistenceArcLifetime) arcs)) - where - finalRank = max 0 (criticalCount - 1) - pairArc pair = do - birthRank <- rankOf (persistenceBirth pair) - deathRank <- maybe (Right finalRank) rankOf (persistenceDeath pair) - pure - PersistenceArc - { persistenceArcBirthRank = birthRank, - persistenceArcDeathRank = deathRank - } - rankOf birth = maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) - -persistenceArcLifetime :: PersistenceArc -> Int -persistenceArcLifetime PersistenceArc{persistenceArcBirthRank, persistenceArcDeathRank} = - max 0 (persistenceArcDeathRank - persistenceArcBirthRank) - -isPositiveHole :: PersistencePair AlphaBirth -> Bool -isPositiveHole pair = - persistenceDegree pair == HomologicalDegree 1 - && maybe True (> persistenceBirth pair) (persistenceDeath pair) - -isFinitePositiveHole :: PersistencePair AlphaBirth -> Bool -isFinitePositiveHole pair = isPositiveHole pair && maybe False (> persistenceBirth pair) (persistenceDeath pair) - -isEssentialHole :: PersistencePair AlphaBirth -> Bool -isEssentialHole pair = persistenceDegree pair == HomologicalDegree 1 && persistenceDeath pair == Nothing - -buildRoseMask :: Either PersistenceRoseError [MaskComponent] -buildRoseMask = do - kernelPoints <- traverse (first RosePointInvalid . exactPointFromPoint) minkowskiKernel - kernel <- first RoseMinkowskiFailed (convexPolygon kernelPoints >>= structuringElement) - authoredRegions <- traverse authoredRegion roseMaskLoops - offsetRegions <- - traverse - (fmap fst . first RoseMinkowskiFailed . polygonOffset kernel) - authoredRegions - unioned <- - case NonEmpty.nonEmpty offsetRegions of - Nothing -> Left RoseNoMaskRegions - Just (firstRegion :| remainingRegions) -> foldM exactRegionUnion firstRegion remainingRegions - traverse projectMaskComponent (planarRegionComponents unioned) - -authoredRegion :: NonEmpty Point -> Either PersistenceRoseError PlanarRegion -authoredRegion points = do - exactPoints <- traverse (first RosePointInvalid . exactPointFromPoint) points - loop <- first RoseRegionInvalid (exactLoop exactPoints) - component <- first RoseRegionInvalid (polygonComponent loop []) - first RoseRegionInvalid (planarRegion [component]) - -exactRegionUnion :: PlanarRegion -> PlanarRegion -> Either PersistenceRoseError PlanarRegion -exactRegionUnion leftRegion rightRegion = do - leftLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True leftRegion)) - rightLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True rightRegion)) - overlaid <- first RoseOverlayFailed (overlayLayers leftLayer rightLayer) - first RoseOverlayPublicationFailed (overlaySelectedRegion (uncurry (||)) overlaid) - -projectMaskComponent :: PolygonComponent -> Either PersistenceRoseError MaskComponent -projectMaskComponent component = - MaskComponent - <$> projectExactLoop (polygonOuterLoop component) - <*> traverse projectExactLoop (polygonHoleLoops component) - -projectExactLoop :: ExactLoop -> Either PersistenceRoseError [Point] -projectExactLoop = - traverse - (first RosePointInvalid . exactPointToEmbeddingCandidate) - . NonEmpty.toList - . exactLoopPoints - -roseSites :: [Point] -roseSites = - concatMap petalSites [0 .. rosePetalCount - 1] - <> centerSites - -petalSites :: Int -> [Point] -petalSites petalIndex = - fmap - (petalPoint petalIndex 2.52 1.82 0.69) - (sampleAngles 22 (0.021 * fromIntegral petalIndex)) - -centerSites :: [Point] -centerSites = - Point 0 0 - : fmap - (\angle -> Point (0.56 * cos angle) (0.56 * sin angle)) - (sampleAngles 14 0.037) - -roseMaskLoops :: [NonEmpty Point] -roseMaskLoops = - fmap - (\petalIndex -> fmap (petalPoint petalIndex 2.42 2.12 0.9) (sampleAnglesNonEmpty 34 0)) - [0 .. rosePetalCount - 1] - <> [fmap (\angle -> Point (1.08 * cos angle) (1.08 * sin angle)) (sampleAnglesNonEmpty 30 0)] - -petalPoint :: Int -> Double -> Double -> Double -> Double -> Point -petalPoint petalIndex centerRadius radialRadius tangentialRadius localAngle = - let orientation = twoPi * fromIntegral petalIndex / fromIntegral rosePetalCount - pi / 2 - radial = centerRadius + radialRadius * cos localAngle - tangential = tangentialRadius * sin localAngle * (0.91 + 0.09 * cos (2 * localAngle)) - radialX = cos orientation - radialY = sin orientation - tangentX = -radialY - tangentY = radialX - in Point - (radial * radialX + tangential * tangentX) - (radial * radialY + tangential * tangentY) - -sampleAngles :: Int -> Double -> [Double] -sampleAngles sampleCount phase = - fmap - (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase) - [0 .. sampleCount - 1] - -sampleAnglesNonEmpty :: Int -> Double -> NonEmpty Double -sampleAnglesNonEmpty sampleCount phase = - phase - :| fmap - (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase) - [1 .. max 1 sampleCount - 1] - -minkowskiKernel :: NonEmpty Point -minkowskiKernel = - Point 0.085 0 - :| [ Point 0.043 0.074, - Point (-0.043) 0.074, - Point (-0.085) 0, - Point (-0.043) (-0.074), - Point 0.043 (-0.074) - ] - -rosePetalCount :: Int -rosePetalCount = 7 - --- | The package's canonical exact persistence witness. Its four hull edges --- enter at squared radius one; the resident diagonal and two resident faces --- enter at squared radius two. Homology therefore observes exactly one finite --- degree-one interval @[1,2)@ over this fixed DCEL. -alphaEclipseSites :: [Point] -alphaEclipseSites = - [ Point (-1) (-1), - Point 1 (-1), - Point 1 1, - Point (-1) 1 - ] - -renderPersistenceRosePoster :: PersistenceRoseScene -> String -renderPersistenceRosePoster scene = - renderScene scene (criticalRank (sceneHeroState scene)) 1 True - -renderAlphaEclipse :: AlphaEclipseScene -> String -renderAlphaEclipse scene = - let receipt = eclipseReceipt scene - birthLabel = - renderExactRatio - (eclipseHoleBirthNumerator receipt) - (eclipseHoleBirthDenominator receipt) - deathLabel = - renderExactRatio - (eclipseHoleDeathNumerator receipt) - (eclipseHoleDeathDenominator receipt) - in concat - [ "\n", - "Moonlight Triangulation alpha eclipse\n", - "One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius ", - birthLabel, - ", and its resident diagonal and faces kill that hole at squared radius ", - deathLabel, - ".\n", - renderAlphaEclipseDefinitions, - "\n", - "\n", - "MOONLIGHT TRIANGULATION\n", - "ALPHA ECLIPSE\n", - "ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS\n", - renderAlphaEclipseStage - scene - 245 - "BEFORE BIRTH" - "four isolated sites" - (eclipseBeforeState scene), - renderAlphaEclipseStage - scene - 720 - "LOOP BORN" - "resident boundary closes" - (eclipseBirthState scene), - renderAlphaEclipseStage - scene - 1195 - "CYCLE KILLED" - "resident faces fill it" - (eclipseDeathState scene), - "\n", - "ONE EXACT H₁ INTERVAL\n", - "\n", - "\n", - "\n", - "\n", - "α² = 0\n", - "birth α² = ", - birthLabel, - "\n", - "the eclipse hole persists\n", - "death α² = ", - deathLabel, - "\n", - "exact α² increases →\n", - "\n", - "\n" - ] - -renderAlphaEclipseDefinitions :: String -renderAlphaEclipseDefinitions = - concat - [ "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n" - ] - -renderAlphaEclipseStage - :: AlphaEclipseScene - -> Double - -> String - -> String - -> CriticalState - -> String -renderAlphaEclipseStage scene centerX stageLabel explanation state = - let rankValue = criticalRank state - activeFaces = filter ((<= rankValue) . rankedTriangleBirthRank) (eclipseFaces scene) - activeEdges = filter ((<= rankValue) . rankedSegmentBirthRank) (eclipseEdges scene) - highlighted = criticalBettiOne state > 0 - frameStroke = if highlighted then "#ff6fbd" else "#344070" - frameOpacity = if highlighted then "0.72" else "0.55" - in concat - [ "\n", - "\n", - "", - stageLabel, - "\n", - "\n", - "", - concatMap renderAlphaEclipseTriangle activeFaces, - "\n", - "", - concatMap renderAlphaEclipseSegment activeEdges, - "\n", - "", - concatMap renderAlphaEclipseHole (criticalHoles state), - "\n", - "", - concatMap renderAlphaEclipseSite (eclipseSites scene), - "\n", - "\n", - "", - explanation, - "\n", - "β₁ = ", - show (criticalBettiOne state), - "\n", - "α² = ", - renderAlphaBirth (criticalBirth state), - "\n", - "\n" - ] - -renderAlphaEclipseTriangle :: RankedTriangle -> String -renderAlphaEclipseTriangle RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint)} = - " renderScreenPoints (fmap toAlphaEclipseLocal [firstPoint, secondPoint, thirdPoint]) - <> "\"/>\n" - -renderAlphaEclipseSegment :: RankedSegment -> String -renderAlphaEclipseSegment RankedSegment{rankedSegmentGeometry = Segment firstPoint secondPoint} = - let Point firstX firstY = toAlphaEclipseLocal firstPoint - Point secondX secondY = toAlphaEclipseLocal secondPoint - in " formatDouble firstX - <> "\" y1=\"" - <> formatDouble firstY - <> "\" x2=\"" - <> formatDouble secondX - <> "\" y2=\"" - <> formatDouble secondY - <> "\"/>\n" - -renderAlphaEclipseHole :: HoleComponent -> String -renderAlphaEclipseHole (HoleComponent loops) = - concatMap - (\points -> " renderClosedPath (fmap toAlphaEclipseLocal points) <> "\"/>\n") - loops - -renderAlphaEclipseSite :: Point -> String -renderAlphaEclipseSite point = - let Point x y = toAlphaEclipseLocal point - in " formatDouble x - <> "\" cy=\"" - <> formatDouble y - <> "\" r=\"6\"/>\n" - -toAlphaEclipseLocal :: Point -> Point -toAlphaEclipseLocal (Point x y) = - let scale = 72 - inverseSquareRootTwo = sqrt 0.5 - in Point - (scale * inverseSquareRootTwo * (x - y)) - (scale * inverseSquareRootTwo * (x + y)) - -renderAlphaBirth :: AlphaBirth -> String -renderAlphaBirth birth = - renderExactRatio (alphaBirthNumerator birth) (alphaBirthDenominator birth) - -renderExactRatio :: Integer -> Integer -> String -renderExactRatio numerator denominator - | denominator == 1 = show numerator - | otherwise = show numerator <> "/" <> show denominator - -persistenceRoseFrameSpecs :: Int -> Either PersistenceRoseError [PersistenceRoseFrame] -persistenceRoseFrameSpecs frameCount - | frameCount < 2 = Left (RoseFrameCountTooSmall frameCount) - | otherwise = - Right - ( fmap - (\frameIndex -> - PersistenceRoseFrame - { frameProgress = frameProgressAt frameCount frameIndex - }) - [0 .. frameCount - 1] - ) - -renderPersistenceRoseFrame :: PersistenceRoseScene -> PersistenceRoseFrame -> String -renderPersistenceRoseFrame scene frame = - let finalRank = criticalRank (NonEmpty.last (sceneCriticalStates scene)) - selectedRank = clampInt 0 finalRank (floor (frameProgress frame * fromIntegral finalRank)) - in renderScene scene selectedRank (frameProgress frame) False - -persistenceRoseAnimationReceipt - :: PersistenceRoseScene - -> Either PersistenceRoseError PersistenceRoseAnimationReceipt -persistenceRoseAnimationReceipt scene = do - frames <- persistenceRoseFrameSpecs canonicalAnimationFrameCount - let renderedFrames = fmap (renderPersistenceRoseFrame scene) frames - pure - PersistenceRoseAnimationReceipt - { roseAnimationFrameCount = canonicalAnimationFrameCount, - roseAnimationFramesPerSecond = canonicalAnimationFramesPerSecond, - roseAnimationWidth = canonicalAnimationWidth, - roseAnimationHeight = canonicalAnimationHeight, - roseAnimationSourceFingerprint = fingerprintSections renderedFrames - } - -renderPersistenceRoseAnimationReceipt :: PersistenceRoseAnimationReceipt -> String -renderPersistenceRoseAnimationReceipt receipt = - intercalate - " " - [ "MOONLIGHT_PERSISTENCE_ROSE", - "frame-count=" <> show (roseAnimationFrameCount receipt), - "fps=" <> show (roseAnimationFramesPerSecond receipt), - "size=" <> show (roseAnimationWidth receipt) <> "x" <> show (roseAnimationHeight receipt), - "source-fnv1a64=" <> renderWord64Hex (roseAnimationSourceFingerprint receipt) - ] - -stampPersistenceRoseGif - :: PersistenceRoseScene - -> ByteString - -> Either PersistenceRoseError (PersistenceRoseAnimationReceipt, ByteString) -stampPersistenceRoseGif scene gifBytes = do - receipt <- persistenceRoseAnimationReceipt scene - summary <- inspectGif gifBytes - validateGifSummary receipt summary - let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt) - markerLength = ByteString.length marker - if markerLength > 255 - then Left (RoseGifMarkerTooLong markerLength) - else - if marker `ByteString.isInfixOf` gifBytes - then Right (receipt, gifBytes) - else - if gifMarkerPrefix `ByteString.isInfixOf` gifBytes - then Left RoseGifProvenanceMismatch - else do - insertionOffset <- gifDataStart gifBytes - let (prefix, suffix) = ByteString.splitAt insertionOffset gifBytes - commentExtension = - ByteString.pack [0x21, 0xfe, fromIntegral markerLength] - <> marker - <> ByteString.singleton 0 - pure (receipt, prefix <> commentExtension <> suffix) - -verifyPersistenceRoseGif - :: PersistenceRoseScene - -> ByteString - -> Either PersistenceRoseError PersistenceRoseAnimationReceipt -verifyPersistenceRoseGif scene gifBytes = do - receipt <- persistenceRoseAnimationReceipt scene - summary <- inspectGif gifBytes - validateGifSummary receipt summary - let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt) - if marker `ByteString.isInfixOf` gifBytes - then Right receipt - else Left RoseGifProvenanceMismatch - -data GifSummary = GifSummary - { gifSummaryWidth :: !Int, - gifSummaryHeight :: !Int, - gifSummaryFrameCount :: !Int, - gifSummaryFrameDelayCount :: !Int, - gifSummaryDurationCentiseconds :: !Int - } - -inspectGif :: ByteString -> Either PersistenceRoseError GifSummary -inspectGif gifBytes = do - dataStart <- gifDataStart gifBytes - width <- gifLittleEndianWord16 gifBytes 6 - height <- gifLittleEndianWord16 gifBytes 8 - (frameCount, frameDelayCount, durationCentiseconds) <- - countGifFrames gifBytes dataStart 0 0 0 - pure - GifSummary - { gifSummaryWidth = width, - gifSummaryHeight = height, - gifSummaryFrameCount = frameCount, - gifSummaryFrameDelayCount = frameDelayCount, - gifSummaryDurationCentiseconds = durationCentiseconds - } - -gifDataStart :: ByteString -> Either PersistenceRoseError Int -gifDataStart gifBytes = do - signature <- maybe (Left (RoseGifTruncated 0)) Right (gifSlice gifBytes 0 6) - if signature == ByteString.Char8.pack "GIF87a" || signature == ByteString.Char8.pack "GIF89a" - then pure () - else Left RoseGifInvalidSignature - packed <- maybe (Left (RoseGifTruncated 10)) Right (gifByteAt gifBytes 10) - let globalColourTableBytes = - if packed .&. 0x80 == 0 - then 0 - else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int)) - dataStart = 13 + globalColourTableBytes - maybe (Left (RoseGifTruncated dataStart)) (const (Right dataStart)) (gifSlice gifBytes 0 dataStart) - -countGifFrames - :: ByteString - -> Int - -> Int - -> Int - -> Int - -> Either PersistenceRoseError (Int, Int, Int) -countGifFrames gifBytes offset frameCount frameDelayCount durationCentiseconds = do - block <- maybe (Left (RoseGifTruncated offset)) Right (gifByteAt gifBytes offset) - case block of - 0x3b -> Right (frameCount, frameDelayCount, durationCentiseconds) - 0x21 -> do - extensionLabel <- maybe (Left (RoseGifTruncated (offset + 1))) Right (gifByteAt gifBytes (offset + 1)) - nextOffset <- skipGifSubBlocks gifBytes (offset + 2) - if extensionLabel == 0xf9 - then do - delay <- gifLittleEndianWord16 gifBytes (offset + 4) - countGifFrames - gifBytes - nextOffset - frameCount - (frameDelayCount + 1) - (durationCentiseconds + delay) - else - countGifFrames - gifBytes - nextOffset - frameCount - frameDelayCount - durationCentiseconds - 0x2c -> do - packed <- maybe (Left (RoseGifTruncated (offset + 9))) Right (gifByteAt gifBytes (offset + 9)) - let localColourTableBytes = - if packed .&. 0x80 == 0 - then 0 - else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int)) - imageDataStart = offset + 11 + localColourTableBytes - maybe (Left (RoseGifTruncated imageDataStart)) (const (Right ())) (gifByteAt gifBytes (imageDataStart - 1)) - skipGifSubBlocks gifBytes imageDataStart >>= \next -> - countGifFrames - gifBytes - next - (frameCount + 1) - frameDelayCount - durationCentiseconds - 0x00 -> - countGifFrames - gifBytes - (offset + 1) - frameCount - frameDelayCount - durationCentiseconds - unexpected -> Left (RoseGifUnexpectedBlock offset unexpected) - -skipGifSubBlocks :: ByteString -> Int -> Either PersistenceRoseError Int -skipGifSubBlocks gifBytes offset = do - blockLength <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset) - if blockLength == 0 - then Right (offset + 1) - else do - let nextOffset = offset + 1 + blockLength - maybe (Left (RoseGifTruncated nextOffset)) (const (Right ())) (gifSlice gifBytes offset (1 + blockLength)) - skipGifSubBlocks gifBytes nextOffset - -validateGifSummary - :: PersistenceRoseAnimationReceipt - -> GifSummary - -> Either PersistenceRoseError () -validateGifSummary receipt summary - | actualWidth /= expectedWidth || actualHeight /= expectedHeight = - Left (RoseGifDimensionMismatch expectedWidth expectedHeight actualWidth actualHeight) - | actualFrameCount /= expectedFrameCount = - Left (RoseGifFrameCountMismatch expectedFrameCount actualFrameCount) - | actualFrameDelayCount /= expectedFrameCount = - Left (RoseGifFrameDelayCountMismatch expectedFrameCount actualFrameDelayCount) - | actualDurationCentiseconds /= canonicalAnimationDurationCentiseconds = - Left - ( RoseGifDurationMismatch - canonicalAnimationDurationCentiseconds - actualDurationCentiseconds - ) - | otherwise = Right () - where - expectedWidth = roseAnimationWidth receipt - expectedHeight = roseAnimationHeight receipt - actualWidth = gifSummaryWidth summary - actualHeight = gifSummaryHeight summary - expectedFrameCount = roseAnimationFrameCount receipt - actualFrameCount = gifSummaryFrameCount summary - actualFrameDelayCount = gifSummaryFrameDelayCount summary - actualDurationCentiseconds = gifSummaryDurationCentiseconds summary - -gifLittleEndianWord16 :: ByteString -> Int -> Either PersistenceRoseError Int -gifLittleEndianWord16 gifBytes offset = do - low <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset) - high <- maybe (Left (RoseGifTruncated (offset + 1))) (Right . fromIntegral) (gifByteAt gifBytes (offset + 1)) - pure (low + 256 * high) - -gifByteAt :: ByteString -> Int -> Maybe Word8 -gifByteAt gifBytes offset = fst <$> ByteString.uncons (ByteString.drop offset gifBytes) - -gifSlice :: ByteString -> Int -> Int -> Maybe ByteString -gifSlice gifBytes offset width = - let selected = ByteString.take width (ByteString.drop offset gifBytes) - in if ByteString.length selected == width then Just selected else Nothing - -fingerprintSections :: [String] -> Word64 -fingerprintSections = - foldl' - (\fingerprint section -> fingerprintByte (fingerprintText fingerprint section) 0) - fnvOffsetBasis - -fingerprintText :: Word64 -> String -> Word64 -fingerprintText fingerprint = - ByteString.foldl' fingerprintByte fingerprint - . Text.Encoding.encodeUtf8 - . Text.pack - -fingerprintByte :: Word64 -> Word8 -> Word64 -fingerprintByte fingerprint byte = - (fingerprint `xor` fromIntegral byte) * fnvPrime - -renderWord64Hex :: Word64 -> String -renderWord64Hex value = - let rendered = showHex value "" - in replicate (16 - length rendered) '0' <> rendered - -gifMarkerPrefix :: ByteString -gifMarkerPrefix = ByteString.Char8.pack "MOONLIGHT_PERSISTENCE_ROSE " - -canonicalAnimationFrameCount :: Int -canonicalAnimationFrameCount = 65 - -canonicalAnimationFramesPerSecond :: Int -canonicalAnimationFramesPerSecond = 8 - -canonicalAnimationWidth :: Int -canonicalAnimationWidth = 960 - -canonicalAnimationHeight :: Int -canonicalAnimationHeight = 540 - -canonicalAnimationDurationCentiseconds :: Int -canonicalAnimationDurationCentiseconds = 813 - -fnvOffsetBasis :: Word64 -fnvOffsetBasis = 14695981039346656037 - -fnvPrime :: Word64 -fnvPrime = 1099511628211 - -frameProgressAt :: Int -> Int -> Double -frameProgressAt frameCount frameIndex - | frameIndex <= 0 || frameIndex >= frameCount - 1 = 0 - | otherwise = - let phase = fromIntegral frameIndex / fromIntegral (frameCount - 1) - in 0.5 - 0.5 * cos (twoPi * phase) - -renderScene :: PersistenceRoseScene -> Int -> Double -> Bool -> String -renderScene scene selectedRank progress poster = - let selectedState = criticalStateAt selectedRank (sceneCriticalStates scene) - finalRank = max 1 (criticalRank (NonEmpty.last (sceneCriticalStates scene))) - activation = if poster then fromIntegral selectedRank / fromIntegral finalRank else progress - in concat - [ "\n", - "Moonlight Triangulation Persistence Rose\n", - "Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose.\n", - renderDefinitions (sceneMaskComponents scene), - "\n", - renderAmbientOrbits activation, - renderPersistenceHalo finalRank selectedRank (scenePersistenceArcs scene), - "\n", - "\n", - "", concatMap renderFieldSample (sceneFieldSamples scene), "\n", - "", concatMap renderVoronoiSegment (sceneVoronoiSegments scene), "\n", - concatMap (renderRankedTriangle finalRank activation) (sceneFaces scene), - concatMap (renderRankedSegment finalRank activation) (sceneEdges scene), - "", concatMap renderHoleComponent (criticalHoles selectedState), "\n", - concatMap (renderSite activation) (sceneSites scene), - "\n", - "\n", - renderTitle selectedState, - "\n" - ] - -criticalStateAt :: Int -> NonEmpty CriticalState -> CriticalState -criticalStateAt target (firstState :| remainingStates) = - foldl' - (\chosen candidate -> if criticalRank candidate <= target then candidate else chosen) - firstState - remainingStates - -renderDefinitions :: [MaskComponent] -> String -renderDefinitions maskComponents = - concat - [ "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n", - "\n" - ] - -renderAmbientOrbits :: Double -> String -renderAmbientOrbits activation = - concatMap - ( \orbit -> - let radius = 322 + fromIntegral orbit * 34 - opacity = 0.055 + activation * 0.025 - in " formatDouble radius - <> "\" fill=\"none\" stroke=\"#8ba5ff\" stroke-width=\"0.8\" stroke-dasharray=\"2 12\" opacity=\"" - <> formatDouble opacity - <> "\"/>\n" - ) - [0 .. 5 :: Int] - -renderPersistenceHalo :: Int -> Int -> [PersistenceArc] -> String -renderPersistenceHalo finalRank selectedRank arcs = - "\n" - <> concatMap renderArc (zip ([0 :: Int ..]) arcs) - <> "\n" - where - renderArc :: (Int, PersistenceArc) -> String - renderArc (index, arc) = - let active = persistenceArcBirthRank arc <= selectedRank && selectedRank < persistenceArcDeathRank arc - radius = 414 + fromIntegral (index `mod` 7) * 7.5 - start = rankAngle finalRank (persistenceArcBirthRank arc) - finish = rankAngle finalRank (persistenceArcDeathRank arc) - points = arcPolyline radius start finish 42 - hue = 188 + (index * 17 `mod` 122) - opacity = if active then 0.72 else 0.16 - width = if active then 2.6 else 1.1 - in " renderScreenPoints points - <> "\" stroke=\"hsl(" - <> show hue - <> " 92% 72%)\" stroke-width=\"" - <> formatDouble width - <> "\" opacity=\"" - <> formatDouble opacity - <> "\"/>\n" - -rankAngle :: Int -> Int -> Double -rankAngle finalRank rankValue = - -pi / 2 + twoPi * fromIntegral rankValue / fromIntegral (max 1 finalRank) - -arcPolyline :: Double -> Double -> Double -> Int -> [Point] -arcPolyline radius start finish sampleCount = - fmap - ( \sampleIndex -> - let fraction = fromIntegral sampleIndex / fromIntegral sampleCount - angle = start + fraction * (finish - start) - in screenPointFromPolar radius angle - ) - [0 .. sampleCount] - -screenPointFromPolar :: Double -> Double -> Point -screenPointFromPolar radius angle = - Point (960 + radius * cos angle) (552 + radius * sin angle) - -renderFieldSample :: FieldSample -> String -renderFieldSample FieldSample{fieldSamplePoint, fieldSampleValue, fieldSampleNeighborCount} = - let Point x y = toScreen fieldSamplePoint - hue = round (186 + 126 * fieldSampleValue) :: Int - radius = 30 + min 5 (fromIntegral fieldSampleNeighborCount) - opacity = 0.16 + 0.16 * fieldSampleValue - in " formatDouble x - <> "\" cy=\"" - <> formatDouble y - <> "\" r=\"" - <> formatDouble radius - <> "\" fill=\"hsl(" - <> show hue - <> " 94% 61%)\" opacity=\"" - <> formatDouble opacity - <> "\"/>\n" - -renderVoronoiSegment :: Segment -> String -renderVoronoiSegment segment = - renderLine segment "#61efff" 1.15 0.5 "" - -renderRankedTriangle :: Int -> Double -> RankedTriangle -> String -renderRankedTriangle finalRank activation RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint), rankedTriangleBirthRank} = - let opacity = activationOpacity finalRank activation rankedTriangleBirthRank - hue :: Int - hue = 282 - round (94 * fromIntegral rankedTriangleBirthRank / fromIntegral (max 1 finalRank) :: Double) - in if opacity <= 0.001 - then "" - else - " renderWorldPoints [firstPoint, secondPoint, thirdPoint] - <> "\" fill=\"hsl(" - <> show hue - <> " 88% 60%)\" opacity=\"" - <> formatDouble (0.06 + 0.17 * opacity) - <> "\"/>\n" - -renderRankedSegment :: Int -> Double -> RankedSegment -> String -renderRankedSegment finalRank activation RankedSegment{rankedSegmentGeometry, rankedSegmentBirthRank} = - let opacity = activationOpacity finalRank activation rankedSegmentBirthRank - width = 0.75 + 1.25 * opacity - color = if opacity > 0.72 then "#ffd56a" else "#dd78ff" - in renderLine rankedSegmentGeometry color width (0.06 + 0.82 * opacity) "filter=\"url(#edge-glow)\"" - -activationOpacity :: Int -> Double -> Int -> Double -activationOpacity finalRank activation birthRank = - let level = activation * fromIntegral finalRank - distance = level - fromIntegral birthRank - in smoothstep (distance + 0.6) - -smoothstep :: Double -> Double -smoothstep value = - let bounded = clamp 0 1 value - in bounded * bounded * (3 - 2 * bounded) - -renderHoleComponent :: HoleComponent -> String -renderHoleComponent (HoleComponent loops) = - concatMap - ( \points -> - " renderClosedWorldPath points - <> "\" fill=\"none\" stroke=\"url(#hole-stroke)\" stroke-width=\"5.4\" stroke-linejoin=\"round\" opacity=\"0.98\"/>\n" - ) - loops - -renderSite :: Double -> Point -> String -renderSite activation point = - let Point x y = toScreen point - radius = 2.5 + 1.5 * activation - in " formatDouble x - <> "\" cy=\"" - <> formatDouble y - <> "\" r=\"" - <> formatDouble radius - <> "\" fill=\"#fff8d9\" stroke=\"#ff9ad7\" stroke-width=\"1.2\" opacity=\"0.95\"/>\n" - -renderLine :: Segment -> String -> Double -> Double -> String -> String -renderLine (Segment fromPoint toPoint) color width opacity extraAttributes = - let Point fromX fromY = toScreen fromPoint - Point toX toY = toScreen toPoint - in " formatDouble fromX - <> "\" y1=\"" - <> formatDouble fromY - <> "\" x2=\"" - <> formatDouble toX - <> "\" y2=\"" - <> formatDouble toY - <> "\" stroke=\"" - <> color - <> "\" stroke-width=\"" - <> formatDouble width - <> "\" stroke-linecap=\"round\" opacity=\"" - <> formatDouble opacity - <> "\" " - <> extraAttributes - <> "/>\n" - -renderTitle :: CriticalState -> String -renderTitle state = - let alphaFraction = exactFractionSummary (criticalBirth state) - alphaDecimal = formatDouble (alphaBirthToDouble (criticalBirth state)) - bettiMeaning = bettiOneMeaning (criticalBettiOne state) - in concat - [ "\n", - "MOONLIGHT TRIANGULATION\n", - "PERSISTENCE ROSE\n", - "\n", - "TOPOLOGICAL HOLES AT THIS SCALE\n", - "β₁ = ", - show (criticalBettiOne state), - "\n", - "", - bettiMeaning, - "\n", - "in the exact alpha complex\n", - "critical rank ", - show (criticalRank state), - " · α² = ", - alphaDecimal, - "\n", - "", - alphaFraction, - "\n", - "\n", - "\n" - ] - -bettiOneMeaning :: Int -> String -bettiOneMeaning holeCount = - case holeCount of - 0 -> "no independent one-dimensional holes" - 1 -> "1 independent one-dimensional hole" - _ -> show holeCount <> " independent one-dimensional holes" - -exactFractionSummary :: AlphaBirth -> String -exactFractionSummary birth = - let numeratorDigits = length (show (abs (alphaBirthNumerator birth))) - denominatorDigits = length (show (alphaBirthDenominator birth)) - in "exact " <> show numeratorDigits <> "-digit / " <> show denominatorDigits <> "-digit rational" - -renderMaskPath :: [MaskComponent] -> String -renderMaskPath = - intercalate " " - . concatMap - (\MaskComponent{maskOuterLoop, maskHoleLoops} -> renderClosedScreenPath maskOuterLoop : fmap renderClosedScreenPath maskHoleLoops) - -renderClosedWorldPath :: [Point] -> String -renderClosedWorldPath = renderClosedPath . fmap toScreen - -renderClosedScreenPath :: [Point] -> String -renderClosedScreenPath = renderClosedPath . fmap toScreen - -renderClosedPath :: [Point] -> String -renderClosedPath points = - case points of - [] -> "" - firstPoint : remainingPoints -> - "M " <> renderPoint firstPoint <> concatMap (" L " <>) (fmap renderPoint remainingPoints) <> " Z" - -renderWorldPoints :: [Point] -> String -renderWorldPoints = renderScreenPoints . fmap toScreen - -renderScreenPoints :: [Point] -> String -renderScreenPoints = unwords . fmap renderPoint - -renderPoint :: Point -> String -renderPoint (Point x y) = formatDouble x <> "," <> formatDouble y - -toScreen :: Point -> Point -toScreen (Point x y) = Point (960 + x * 101) (552 + y * 101) - -formatDouble :: Double -> String -formatDouble value = showFFloat (Just 3) value "" - -clamp :: Double -> Double -> Double -> Double -clamp lower upper = min upper . max lower - -clampInt :: Int -> Int -> Int -> Int -clampInt lower upper = min upper . max lower - -twoPi :: Double -twoPi = 2 * pi 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 @@ -19,7 +19,7 @@ import Moonlight.Triangulation import Moonlight.Triangulation.BulkLoad (empty, insert) import Moonlight.Triangulation.Cdt (recoverConstraints) -import Moonlight.Triangulation.Foreign.ABI (insertGeometryBatch) +import Moonlight.Triangulation.Foreign.Mesh (insertGeometryBatch) -- The facade withholds this constructor. The benchmark indexes the builder's -- own input mapping, so every handle it forges is one the builder issued, and -- it owns that obligation explicitly by naming the module that grants it. diff --git a/bench/delaunay-compare/Main.hs b/bench/delaunay-compare/Main.hs deleted file mode 100644 --- a/bench/delaunay-compare/Main.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | 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 deleted file mode 100644 --- a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs +++ /dev/null @@ -1,466 +0,0 @@ -{-# 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) - <> [""] - 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) - -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 deleted file mode 100644 --- a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bench/delaunay-compare/PictureMain.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/bench/delaunay-compare/README.md +++ /dev/null @@ -1,192 +0,0 @@ -# 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: `24 / 24` -- Moonlight mean below Spade hierarchy: `24 / 24` -- Moonlight below plain Spade with non-overlapping reported 2σ: `18 / 24` -- Moonlight below Spade hierarchy with non-overlapping reported 2σ: `22 / 24` -- lowest fixture mean: `delaunator` `21 / 24`; `cdt` `3 / 24` -- median reported 2σ / mean: Moonlight `6.88%`; plain Spade `6.67%` - -Selected means are in milliseconds. Δ is -`100 × (Moonlight / competitor − 1)`. - -| fixture | points | Moonlight | plain Spade | Δ | Spade hierarchy | Δ | -|---|---:|---:|---:|---:|---:|---:| -| local insertion | 4,000 | 0.587 | 0.771 | −23.8% | 0.800 | −26.6% | -| local insertion | 6,000 | 0.971 | 1.300 | −25.3% | 1.365 | −28.9% | -| local insertion | 8,000 | 1.354 | 1.776 | −23.7% | 1.903 | −28.8% | -| local insertion | 250,000 | 60.300 | 72.713 | −17.1% | 77.496 | −22.2% | -| uniform | 4,000 | 0.552 | 0.706 | −21.8% | 0.741 | −25.6% | -| uniform | 14,000 | 2.663 | 3.067 | −13.2% | 3.318 | −19.7% | -| uniform | 250,000 | 60.028 | 72.783 | −17.5% | 77.435 | −22.5% | - -The measured Moonlight path is the canonical circle-sweep bulk loader. Its -geometry ingress keeps coordinates in immutable planes, moves only a 32-bit -vertex-id plane through three radix passes, and restores the complete -`(distance, x, y, vertex)` order inside equal-prefix fibres before descent. -Fresh dense vertices are committed once, and the sweep consumes reserved cells -without constructing a second packed geometry arena. - -Receipt identity: - -- command completed: `2026-08-23T00:00:15Z`, 318.68 s over 120 cases -- host: Apple M4 Pro, arm64, macOS 26.5.2, GHC 9.14.1, rustc 1.92.0 -- Haskell build: cabal-install 3.16.1.0, focused `-O1` package profile, - comparison executable `-O2`, hot predicate, sweep, and repair modules LLVM - `-O3` -- checkout base HEAD: `41906f44f0`, plus the three optimized runtime-source - owners named by the manifest -- CSV: [`moonlight-delaunay-compare-2026-08-22.csv`](results/moonlight-delaunay-compare-2026-08-22.csv), SHA-256 - `cce6af4ac7d570970a69124f5648db4e13ca41e91e05383306407a0dca323be7` -- benchmark runtime-source hashes: - [`moonlight-delaunay-compare-2026-08-22.source-sha256`](results/moonlight-delaunay-compare-2026-08-22.source-sha256), SHA-256 - `069d3bb1639b6d865fe4491b2fbbb9d0cdc8324173e30bebf690ed6592190c20` - -The Haskell projection in -`Moonlight.Triangulation.Bench.DelaunayCompare.Picture` parses the tasty-bench -CSV against the exact closed 120-case registry and reports typed obstructions -for malformed, unknown, duplicated, or missing observations before gluing -either picture. - -## Run - -From the repository root, list the complete benchmark tree: - -```console -scripts/safe-cabal.sh run \ - moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ - --project-file=cabal.project.triangulation-dev \ - -- --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 \ - --project-file=cabal.project.triangulation-dev \ - -- --time-mode wall -j1 -``` - -The Haskell executable builds the pinned Rust library through Cargo before it -loads the library. Cargo's incremental no-op is cheap after the first run. Set -`MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST` only when invoking an installed executable -outside this repository layout. - -## Reproduce a board - -Every candidate run uses one CPU-time worker, a 30-second per-case timeout, and -tasty-bench's `--stdev 5` calibration target. Name the candidate by the date it -completed; after validation, it replaces the retained CSV and source manifest -rather than accumulating a benchmark diary. - -```console -caffeinate -i scripts/safe-cabal.sh run \ - moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ - --project-file=cabal.project.triangulation-dev -- \ - --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 \ - --project-file=cabal.project.triangulation-dev -- \ - 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 regenerated from the measured -worktree immediately after a completed command. It hashes the closed list of -files that entered timed actions; picture sources and package-only metadata are -excluded because they did not. The receipt, CSV, and big SVG stay -benchmark-owned beside the executable and outside Cabal package inputs. The -small SVG is also the package README projection, so it enters the sdist as -documentation without entering any compiled component. - -## Upstream-compatible fixtures - -Both distributions use the 32-byte `StdRng` seed from upstream, including its -embedded newline byte. Rust unit tests pin the first three points of both -streams by their exact binary64 bit patterns. - -- `local insertion` starts at `(0, 1)` and adds independent inclusive steps - from `[-1, 1]`. -- `uniform` draws each coordinate independently and inclusively from - `[-1e9, 1e9]`. -- `small` contains 2,000 through 14,000 points in increments of 2,000. -- `big` contains 50,000 through 250,000 points in increments of 50,000. - -Native input conversion happens once during suite preparation, outside every -timed action, exactly as upstream's `DelaunayCrate.init` separates conversion -from `run_creation`. Spade still clones its owned vertex vector inside each -construction call because that is what its bulk-load API and upstream adapter -require; `cdt`, `delaunator`, and Moonlight consume their prepared vectors by -reference. - -## Compatibility gate - -Before `tasty-bench` runs, every one of the 24 fixtures descends across all five -implementations. The sections glue only when vertex and inner-triangle counts -agree. A generator, preparation, construction, foreign-boundary, or summary -failure is a typed obstruction and terminates the command before timing. - -This count gate is deliberately not a second topology authority. The 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/results/moonlight-delaunay-compare-small.svg b/bench/delaunay-compare/results/moonlight-delaunay-compare-small.svg deleted file mode 100644 --- a/bench/delaunay-compare/results/moonlight-delaunay-compare-small.svg +++ /dev/null @@ -1,415 +0,0 @@ - - -Moonlight Delaunay construction · small point sets -CPU construction time for Spade, cdt, delaunator, and Moonlight over the upstream Delaunay comparison fixtures. Lower lines are faster. - - - - - - - - -Moonlight Delaunay construction · small point sets -Moonlight against Spade's construction referents · CPU time · lower is faster - - - - spade 2 - - - - - spade 2 hierarchy - - - - - cdt - - - - - delaunator - - - - - moonlight-triangulation - - -local insertion - -0.00 - -1.0 - -2.0 - -3.0 - -4.0 - -5.0 - -2k - -4k - -6k - -8k - -10k - -12k - -14k - -input size (points) -CPU time (ms) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -uniform - -0.00 - -1.0 - -2.0 - -3.0 - -4.0 - -5.0 - -2k - -4k - -6k - -8k - -10k - -12k - -14k - -input size (points) -CPU time (ms) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Whiskers show tasty-bench's reported 2× standard-deviation spread. - diff --git a/bench/delaunay-compare/rust/Cargo.lock b/bench/delaunay-compare/rust/Cargo.lock deleted file mode 100644 --- a/bench/delaunay-compare/rust/Cargo.lock +++ /dev/null @@ -1,264 +0,0 @@ -# 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 deleted file mode 100644 --- a/bench/delaunay-compare/rust/Cargo.toml +++ /dev/null @@ -1,20 +0,0 @@ -[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 deleted file mode 100644 --- a/bench/delaunay-compare/rust/src/lib.rs +++ /dev/null @@ -1,397 +0,0 @@ -//! 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/join/Moonlight/Triangulation/JoinBench.hs b/bench/join/Moonlight/Triangulation/JoinBench.hs --- a/bench/join/Moonlight/Triangulation/JoinBench.hs +++ b/bench/join/Moonlight/Triangulation/JoinBench.hs @@ -575,8 +575,12 @@ preview <- requireRight (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters base extension) signature <- requireRight (extensionSignature preview) let expectedConstraints = Set.union expectedBaseConstraints expectedExtensionConstraints - unless (extensionConstraintGeometry signature == expectedConstraints) $ - fail "source-preserving seam did not retain the fixed A/B contour constraints" + actualConstraints = extensionConstraintGeometry signature + unless (expectedConstraints `Set.isSubsetOf` actualConstraints) $ + fail + ( "source-preserving seam did not retain the fixed A/B contour constraints; missing=" + <> show (Set.toAscList (Set.difference expectedConstraints actualConstraints)) + ) pure PreparedSeparatedExtension { preparedBase = base @@ -626,7 +630,6 @@ (const ()) parameters permitted - interface joined ) ) @@ -679,8 +682,6 @@ <> show (V.length (constrainedSeamJoinFaces joinedReceipt)) <> " a-constraints=" <> show (constrainedSeamLeftConstraintCount joinedReceipt) - <> " b-constraints=" - <> show (V.length (constrainedSeamRightConstraintEvidence joinedReceipt)) <> " gamma=" <> show (Set.size interface) <> " final-omega=" diff --git a/bench/spade-compare/hs-alpha/Main.hs b/bench/spade-compare/hs-alpha/Main.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs-alpha/Main.hs @@ -0,0 +1,66 @@ +-- | Narrow Haskell interpreter for the opt-in alpha-persistence diagnostic. +module Main (main) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Vector qualified as Vector +import Moonlight.Triangulation.Bench.SpadeCompare.Alpha + ( alphaPersistenceReceipt + , renderAlphaPersistenceReceipt + ) +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) +import Moonlight.Triangulation.Bench.SpadeCompare.Lane + ( LaneKind (AlphaPersistenceLane) + , LaneObstruction + , LaneRequest (..) + , parseLaneRequest + , renderLaneObstruction + ) +import Moonlight.Triangulation.Bench.SpadeCompare.Timing (measureLane) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.IO (hPutStrLn, stderr) + +main :: IO () +main = do + arguments <- getArgs + case arguments of + ["alpha-receipt", rawCount] -> + either refuseLane reportReceipt + (parseLaneRequest "alpha-persistence" rawCount "0") + ["bench-one", lane, first, second] -> + either refuseLane runAlphaLane (parseLaneRequest lane first second) + _ -> refuseUsage + +runAlphaLane :: LaneRequest -> IO () +runAlphaLane request@(LaneRequest AlphaPersistenceLane pointCount _) = do + points <- + evaluate + (force (Vector.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount))) + measureLane request (requireResult (alphaPersistenceReceipt points)) +runAlphaLane _ = refuseUsage + +reportReceipt :: LaneRequest -> IO () +reportReceipt (LaneRequest AlphaPersistenceLane pointCount _) = do + let points = Vector.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount) + receipt <- requireResult (alphaPersistenceReceipt points) + putStrLn (renderAlphaPersistenceReceipt receipt) +reportReceipt _ = refuseUsage + +requireResult :: Show obstruction => Either obstruction value -> IO value +requireResult result = + case result of + Left obstruction -> do + hPutStrLn stderr ("alpha persistence refused: " <> show obstruction) + exitWith (ExitFailure 1) + Right value -> pure value + +refuseLane :: LaneObstruction -> IO value +refuseLane obstruction = do + hPutStrLn stderr (renderLaneObstruction obstruction) + exitWith (ExitFailure 2) + +refuseUsage :: IO value +refuseUsage = do + hPutStrLn stderr "usage: moonlight-triangulation-alpha-spade-referent (alpha-receipt COUNT | bench-one alpha-persistence COUNT 0)" + exitWith (ExitFailure 2) diff --git a/bench/spade-compare/hs/Main.hs b/bench/spade-compare/hs/Main.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Main.hs @@ -0,0 +1,290 @@ +-- | Haskell half of the spade external referent. +-- +-- @moonlight-triangulation@ is a port of the Rust @spade@ crate, so spade is the +-- referent that grades it. Both halves generate their inputs from the same LCG +-- with the same seeds and emit their gate output in the same encoding, so +-- neither side can reformat a disagreement into agreement. +-- +-- Vertex handles are NOT comparable across the two implementations — both bulk +-- loaders reorder. Anything naming a vertex names it by input index or by +-- coordinate, never by handle. +{-# LANGUAGE DataKinds #-} + +module Main (main) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Control.Monad.ST (runST) +import Data.Word (Word64) +import Moonlight.Triangulation.Internal.Mutable (freezeTriangulation, thawTriangulation) +import System.Environment (getArgs) +import System.Exit (exitWith, ExitCode (ExitFailure)) +import System.IO (hPutStrLn, stderr) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad +import Moonlight.Triangulation.Cdt +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.HintGenerator +import Moonlight.Triangulation.Interpolation +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Bench.SpadeCompare.Constraint +import Moonlight.Triangulation.Bench.SpadeCompare.Dcel +import Moonlight.Triangulation.Bench.SpadeCompare.Delaunay +import Moonlight.Triangulation.Bench.SpadeCompare.Gates +import Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy +import Moonlight.Triangulation.Bench.SpadeCompare.Interpolation +import Moonlight.Triangulation.Bench.SpadeCompare.Intersection +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) +import Moonlight.Triangulation.Bench.SpadeCompare.Lane +import Moonlight.Triangulation.Bench.SpadeCompare.Removal +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Timing (measureLane) +import Moonlight.Triangulation.Bench.SpadeCompare.Voronoi + +main :: IO () +main = do + arguments <- getArgs + case arguments of + ["gate", directory] -> writeGate directory + ["divergence", path] -> writeDivergence path + ["inventory-csv"] -> putStr renderInventoryCsv + ["inventory-human"] -> putStr renderInventoryHuman + ["lane-specs", laneClass] -> either refuseLane putStr (renderLaneSpecs laneClass) + ["snapshot-specs"] -> putStr renderSnapshotSpecs + ["bench-one", lane, first, second] -> + either refuseLane runLane (parseLaneRequest lane first second) + ["counters", budget] -> reportRefinementCounters (read budget) + ["sweep-stats", count] -> reportSweepStats (read count) + ["removal-audit", count, removals] -> reportRemovalAudit (read count) (read removals) + ["removal-context", count, index] -> reportRemovalContext (read count) (read index) + ["fresh-suffix", count, dropped, path] -> writeFreshSuffix (read count) (read dropped) path + ["interp-audit", count, queries] -> reportInterpolationAudit (read count) (read queries) + ["interp-context", count] -> reportInterpolationContext (read count) Nothing + ["interp-context", count, index] -> reportInterpolationContext (read count) (Just (read index)) + ["interp-locate-audit", count, queries] -> reportInterpolationLocateAudit (read count) (read queries) + ["interp-cavity-audit", count, queries] -> reportInterpolationCavityAudit (read count) (read queries) + _ -> do + hPutStrLn stderr "usage: moonlight-triangulation-spade-referent (gate DIR | divergence FILE | inventory-csv | inventory-human | lane-specs CLASS | snapshot-specs | bench-one LANE A B | counters BUDGET | sweep-stats COUNT | removal-audit COUNT REMOVALS | removal-context COUNT INDEX | fresh-suffix COUNT DROPPED PATH | interp-audit COUNT QUERIES | interp-context COUNT [INDEX])" + exitWith (ExitFailure 2) + +refuseLane :: LaneObstruction -> IO value +refuseLane obstruction = do + hPutStrLn stderr (renderLaneObstruction obstruction) + exitWith (ExitFailure 2) + +-- Everything each lane needs before the clock starts. Handle resolution and +-- input generation are setup, not work. +runLane :: LaneRequest -> IO () +runLane request@(LaneRequest lane first second) = case lane of + -- The input vector is forced here rather than inside 'measure'. A lazy + -- 'V.fromList' handed to the clock puts the generator, the list, every boxed + -- coordinate, and the vector's own construction inside the lane — none of + -- which the Rust side pays, because it builds its @Vec@ before its @Instant@. + BulkLoadLane -> do + points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first))) + measure (require (delaunayGeometry points)) + IncrementalLane -> do + points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first))) + measure (insertAllIncrementally points) + -- One immutable snapshot per point. This is deliberately not a cross- + -- language lane: spade's referent is timed only on the mutable session + -- operation, while this stress lane is paired with the Haskell session + -- reference by the driver. + SnapshotInsertLane -> do + points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first))) + measure (insertAllPersistently points) + -- The angular index both bulk loaders open with, given one angle to work + -- with. The input stays in general position, so the load runs the ordinary + -- face-building path from the third point on and every insertion locates by + -- walking; what degrades is the hull lookup that walk starts from, whose + -- buckets all collapse into one. This lane is that degradation and nothing + -- else — the face-less path it does NOT reach is "degenerate-line" below. + SweepAngleCollapseLane -> do + points <- evaluate (force (V.fromList (nearCollinearPoints 0x9e3779b97f4a7c15 first))) + measure (buildTriangulation <$> require (delaunay unitElementDefaults points)) + -- Exactly collinear input, which never builds a face, so both loaders fall + -- out of their sweep and degrade to plain incremental insertion for the + -- whole load — and neither has a sub-linear answer for locating against a + -- face-less mesh. This side scans every vertex and then every half-edge per + -- insertion; spade collects and sorts all vertices per insertion. Both are + -- quadratic in the load, so the ratio reports which quadratic costs more + -- rather than whether one exists, and spade's carries the extra log factor. + DegenerateLineLane -> do + points <- evaluate (force (V.fromList (exactlyCollinearPoints first))) + measure (buildTriangulation <$> require (delaunay unitElementDefaults points)) + BatchSweepLane -> do + points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first))) + measure (buildTriangulation <$> require (insertMany (empty unitElementDefaults) points)) + NearestLane -> do + triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef first))) + hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation) + queries <- requireQueryPoints (V.fromList (randomPoints 0x3141592653589793 second)) >>= evaluate . force + measure (evaluate (V.sum (V.map (resolve triangulation hierarchy) queries))) + CdtRecoveryLane -> do + let points = V.fromList (randomPoints 0x94d049bb133111eb first) + base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points) + queryPoints <- requireQueryPoints points + handles <- evaluate (force (V.map (locateVertex base) queryPoints)) + pairs <- + evaluate + ( force + (V.fromList [(handles V.! a, handles V.! b) | (a, b) <- constraintPairs first second]) + ) + measure (evaluate (recover base pairs)) + -- The same constraint program, requested one edge at a time through the + -- singleton entry point instead of as a batch. The endpoints are handed over + -- as points rather than handles because that is what this entry point takes; + -- the strict side's counterpart takes points too, so both pay the same two + -- locates per request. + ConstraintIncrementalLane -> do + let points = V.fromList (randomPoints 0x94d049bb133111eb first) + base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points) + requests <- + evaluate + ( force + [ (points V.! fromIndex, points V.! toIndex) + | (fromIndex, toIndex) <- constraintPairs first second + ] + ) + measure (evaluate (length (snd (addConstraintsIncrementally base requests)))) + ConstraintSplitLane -> do + (base, handles) <- splitBandCdt first + resolved <- evaluate (force handles) + measure (evaluate (numVertices (splitConstraints base resolved))) + PublicationFloorLane -> do + triangulation <- delaunayOf first + measure $ do + reopened <- require + ( V.foldl' + reopenTriangulation + (Right triangulation) + (V.enumFromN (0 :: Int) second) + ) + evaluate (numVertices reopened) + -- Removal by coordinate, against the same input prefix on both sides. The + -- build is setup on both sides; the measured region is the removals alone. + RemovalLane -> do + let input = randomPoints 0x9e3779b97f4a7c15 first + points <- evaluate (force (V.fromList input)) + base <- buildTriangulation <$> require (delaunay unitElementDefaults points) + removals <- evaluate (force (V.fromList (take second input))) + measure (removeAllByCoordinate base removals) + -- One immutable snapshot per removal. Like snapshot insertion, this is a + -- Haskell-only publication stress lane paired with the session reference; + -- it is not a spade timing ratio. + SnapshotRemovalLane -> do + let input = randomPoints 0x9e3779b97f4a7c15 first + points <- evaluate (force (V.fromList input)) + base <- buildTriangulation <$> require (delaunay unitElementDefaults points) + removals <- evaluate (force (V.fromList (take second input))) + measure (removeAllPersistently base removals) + -- The hierarchy lanes. spade's hint generator maintains itself from inside + -- the triangulation, so an insert or a removal there is the whole maintenance + -- cost; here the hierarchy is a separate value and the maintenance is a + -- separate call, and both are inside the clock. + HierarchyIncrementalLane -> do + points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first))) + measure (insertAllWithHierarchy points) + HierarchyDuplicateLane -> do + base <- hierarchyOf first + duplicates <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 second))) + measure (reinsertAllWithHierarchy base duplicates) + HierarchyRemovalLane -> do + let input = randomPoints 0x9e3779b97f4a7c15 first + base <- hierarchyOf first + removals <- evaluate (force (V.fromList (take second input))) + measure (removeAllWithHierarchy base removals) + HierarchyRemovalOnlyLane -> do + let input = randomPoints 0x9e3779b97f4a7c15 first + (triangulation, _) <- hierarchyOf first + removals <- evaluate (force (V.fromList (take second input))) + measure (removeAllByCoordinate triangulation removals) + HierarchyRebuildOnlyLane -> do + let input = randomPoints 0x9e3779b97f4a7c15 first + (triangulation, hierarchy) <- hierarchyOf first + removals <- evaluate (force (V.fromList (take second input))) + surviving <- removeAllByCoordinate triangulation removals + measure (require (rebuildHierarchyHint hierarchy surviving)) + -- Sibson weights through the reusable workspace; the strict side holds the + -- same buffers behind its NaturalNeighbor handle. The sum forces every + -- weight, the way the nearest lane's index sum forces every search. + InterpolationLane -> do + triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef first))) + workspace <- newNaturalNeighborWorkspace triangulation + queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 second)) >>= evaluate . force + measure (interpolationWeightSum workspace queries) + -- The dual. Both sides hold it as a view of the primal mesh rather than as a + -- second structure, so the mesh is setup on both and the sweep alone is timed. + VoronoiSweepLane -> do + triangulation <- delaunayOf first + measure (evaluate (voronoiSweep triangulation)) + DcelWalkLane -> do + triangulation <- delaunayOf first + measure (evaluate (dcelWalk triangulation)) + AlphaPersistenceLane -> + refuseLane AlphaPersistenceRequiresSpecializedRunner + -- Corridor walks between interior endpoints. Both sides locate the start on a + -- face and step edge to edge from there. + IntersectionLane -> do + triangulation <- delaunayOf first + chords <- requireQueryChords (intersectionChords second) >>= evaluate . force + measure (evaluate (intersectionWalk triangulation chords)) + -- The same walk from outside the hull. spade steps around the hull from the + -- edge its locate returned; this side has no such entry and scans every + -- vertex and every edge to find where the line goes in, once per query. + IntersectionOutsideLane -> do + triangulation <- delaunayOf first + chords <- requireQueryChords (outsideChords second) >>= evaluate . force + measure (evaluate (intersectionWalk triangulation chords)) + RefineLane -> do + let (points, constraints) = refinementInput + cdt <- buildTriangulation <$> require (constrainedDelaunay unitElementDefaults points constraints) + let parameters = defaultRefinementParameters + { refineMaxAdditionalVertices = Just first + , refineMaxArea = Just 0.5 + , refineMaxRadiusEdgeRatio = Just 1.0 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + measure (refinementAddedVertices <$> require (refine id parameters (cdt :: ConstrainedDelaunayTriangulation Point))) + where + reopenTriangulation state _ = do + triangulation <- state + runST $ do + mutable <- thawTriangulation (numVertices triangulation) triangulation + freezeTriangulation mutable + + measure :: NFData value => IO value -> IO () + measure = measureLane request + + -- The answer is summed rather than merely tested for presence. A 'Maybe' + -- scrutinised only to its outer constructor can be a 'Just' wrapping a thunk, + -- and the lane would then time the allocation of a search rather than the + -- search; the strict side has no such option and must be matched. + resolve triangulation hierarchy query = + let hint = case hierarchyHint hierarchy query of + Just (VertexHint vertex) -> Just vertex + _ -> Nothing + in case nearestNeighbor triangulation hint query of + Nothing -> 0 :: Word64 + Just (VertexId vertex, _) -> fromIntegral vertex + + locateVertex cdt point = case locatePoint cdt point of + OnVertex vertex -> vertex + other -> error ("input point is not a vertex: " <> show other) + + recover triangulation pairs = + case recoverConstraints triangulation pairs of + Left failure -> error (show failure) + Right batch -> + V.length + ( V.filter + (\outcome -> + case outcome of + ConstraintAccepted _ _ -> True + ConstraintRejected _ -> False + ) + (constraintBatchOutcomes batch) + ) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Alpha.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Alpha.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Alpha.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Matched end-to-end alpha-persistence work and its canonical receipt. +-- Input generation remains outside the timed action; Delaunay construction, +-- exact alpha births, cellular lowering, one reduction, and all critical-birth +-- Betti queries remain inside it. +module Moonlight.Triangulation.Bench.SpadeCompare.Alpha + ( AlphaPersistenceObstruction (..) + , AlphaPersistenceReceipt (..) + , alphaPersistenceReceipt + , renderAlphaPersistenceReceipt + ) where + +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import Data.Bits (xor) +import Data.List (intercalate) +import Data.Vector (Vector) +import Data.Vector.Unboxed qualified as UnboxedVector +import Data.Word (Word64) +import GHC.Generics (Generic) +import Moonlight.Homology.Boundary + ( degreeCardinality + ) +import Moonlight.Homology.Chain + ( HomologicalDegree (..) + , HomologyFailure + , PersistencePair (..) + ) +import Moonlight.Homology.Persistence + ( criticalBettiTableValues + , filteredBaseComplex + , filteredCriticalValues + , mod2PersistentPairsWithCriticalBettiTable + ) +import Moonlight.Triangulation.Alpha + ( AlphaFiltrationError + , alphaFiltration + ) +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.CellComplex + ( DCELError + , filteredAlphaComplex + ) +import Moonlight.Triangulation.Types + ( BuildError + , Point + ) + +data AlphaPersistenceObstruction + = AlphaPersistenceBuildRefused !BuildError + | AlphaPersistenceBirthRefused !AlphaFiltrationError + | AlphaPersistenceLoweringRefused !DCELError + | AlphaPersistenceReductionRefused !HomologyFailure + deriving stock (Eq, Show) + +data AlphaPersistenceReceipt = AlphaPersistenceReceipt + { alphaReceiptCriticalBirths :: !Int + , alphaReceiptVertexCells :: !Int + , alphaReceiptEdgeCells :: !Int + , alphaReceiptFaceCells :: !Int + , alphaReceiptFinitePairs :: !Int + , alphaReceiptEssentialPairs :: !Int + , alphaReceiptProfileChecksum :: !Word64 + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +alphaPersistenceReceipt + :: Vector Point + -> Either AlphaPersistenceObstruction AlphaPersistenceReceipt +alphaPersistenceReceipt points = do + triangulation <- + first AlphaPersistenceBuildRefused (delaunayGeometry points) + filtration <- + first AlphaPersistenceBirthRefused (alphaFiltration triangulation) + filtered <- + first AlphaPersistenceLoweringRefused (filteredAlphaComplex filtration) + (pairs, criticalBettiTable) <- + first AlphaPersistenceReductionRefused + (mod2PersistentPairsWithCriticalBettiTable filtered) + let criticalBirths = filteredCriticalValues filtered + finite = filteredBaseComplex filtered + isFinitePair = maybe False (const True) . persistenceDeath + pure + AlphaPersistenceReceipt + { alphaReceiptCriticalBirths = length criticalBirths + , alphaReceiptVertexCells = degreeCardinality finite (HomologicalDegree 0) + , alphaReceiptEdgeCells = degreeCardinality finite (HomologicalDegree 1) + , alphaReceiptFaceCells = degreeCardinality finite (HomologicalDegree 2) + , alphaReceiptFinitePairs = length (filter isFinitePair pairs) + , alphaReceiptEssentialPairs = length (filter (not . isFinitePair) pairs) + , alphaReceiptProfileChecksum = + UnboxedVector.foldl' + mixChecksum + fnvOffset + (criticalBettiTableValues criticalBettiTable) + } + +mixChecksum :: Word64 -> Int -> Word64 +mixChecksum accumulator value = + (accumulator `xor` fromIntegral value) * fnvPrime + +fnvOffset :: Word64 +fnvOffset = 14695981039346656037 + +fnvPrime :: Word64 +fnvPrime = 1099511628211 + +renderAlphaPersistenceReceipt :: AlphaPersistenceReceipt -> String +renderAlphaPersistenceReceipt receipt = + intercalate + "," + ( fmap + show + [ fromIntegral (alphaReceiptCriticalBirths receipt) :: Word64 + , fromIntegral (alphaReceiptVertexCells receipt) + , fromIntegral (alphaReceiptEdgeCells receipt) + , fromIntegral (alphaReceiptFaceCells receipt) + , fromIntegral (alphaReceiptFinitePairs receipt) + , fromIntegral (alphaReceiptEssentialPairs receipt) + , alphaReceiptProfileChecksum receipt + ] + ) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Constraint.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Constraint.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Constraint.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} + +-- | Constraint recovery and splitting lanes and their gates. +module Moonlight.Triangulation.Bench.SpadeCompare.Constraint where + +import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray) +import System.FilePath (()) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Cdt +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +-- | Disjoint split cells, stacked in y: the points, the vertical constraints +-- the build starts from, and the crossing requests. Band @i@ carries a +-- constraint from (16, 4i) to (16, 4i + 2) and a crossing request from +-- (0, 4i + a) to (32, 4i + b), with a and b jittered inside the band, so every +-- request crosses exactly one constraint and no request reaches another band. +-- +-- The geometry is chosen so the split point is not merely close on the two +-- sides but identical. spade solves the two line equations by Cramer's rule and +-- this side walks the parametric form; here every coefficient either vanishes +-- or is a power of two, both reduce to one rounding of @u + (v - u) / 2@, and +-- neither can round it differently. A generic crossing would leave the two +-- formulas free to disagree in the last bit and there would be nothing to gate. +splitBands :: Int -> (V.Vector Point, V.Vector (Int, Int), [(Int, Int)]) +splitBands bandCount = + ( V.fromList (concatMap bandPoints (zip [0 ..] jitter)) + , V.fromList [(4 * index, 4 * index + 1) | index <- [0 .. bandCount - 1]] + , [(4 * index + 2, 4 * index + 3) | index <- [0 .. bandCount - 1]] + ) + where + jitter = randomPoints 0x51ed270b7c1fd1a3 bandCount + + bandPoints (index, Point offsetX offsetY) = + let base = 4 * fromIntegral (index :: Int) + in [ Point 16 base + , Point 16 (base + 2) + , Point 0 (base + 1 + 0.5 * offsetX) + , Point 32 (base + 1 + 0.5 * offsetY) + ] + +-- | The same constraint program the batch recovery runs, one request at a time +-- through the persistent singleton entry point. A request whose corridor is +-- blocked by an existing constraint is refused and the previous triangulation +-- stands, which is what the strict side's 'can_add_constraint' guard arranges. +addConstraintsIncrementally + :: ConstrainedDelaunayTriangulation Point + -> [(Point, Point)] + -> (ConstrainedDelaunayTriangulation Point, [Int]) +addConstraintsIncrementally base requests = + case foldl' step (base, []) (zip [0 ..] requests) of + (triangulation, accepted) -> (triangulation, reverse accepted) + where + step (triangulation, accepted) (index, (from, to)) = + case addConstraintEdge triangulation from to of + Left (ConstraintIntersection _) -> (triangulation, accepted) + Left failure -> error (show failure) + Right result -> (constraintRecoveryTriangulation result, index : accepted) + +-- | Splitting requests, one per band, carried by the batch verb: one +-- transaction for every corridor, published once -- the shape of the strict +-- side's fold over one mutable CDT, which publishes nothing between splits. +-- Every crossed constraint is split at the intersection rather than refused, +-- so every request is accepted. Splitting appends vertices and never removes +-- one, so the handles resolved before the first request stay valid through +-- the last. +splitConstraints + :: ConstrainedDelaunayTriangulation Point + -> [(VertexId, VertexId)] + -> ConstrainedDelaunayTriangulation Point +splitConstraints base requests = + case addConstraintsAndSplit id base (V.fromList requests) of + Left failure -> error (show failure) + Right result -> constraintRecoveryTriangulation result + +-- | The singleton constraint program's accepted request indices and final +-- constrained edge set. A blocked request must be refused at the same index on +-- both sides, or the two are not running the same program. +writeConstraintIncrementalGate :: FilePath -> Int -> Int -> IO () +writeConstraintIncrementalGate directory pointCount constraintCount = do + let points = V.fromList (randomPoints 0x94d049bb133111eb pointCount) + requests = + [ (points V.! fromIndex, points V.! toIndex) + | (fromIndex, toIndex) <- constraintPairs pointCount constraintCount + ] + base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points) + let (recovered, accepted) = addConstraintsIncrementally base requests + prefix = + directory + ("constraint-incremental-" <> show pointCount <> "-" <> show constraintCount) + writeFile (prefix <> "-accepted.txt") (unlines (map show accepted)) + writeFile (prefix <> "-constraints.txt") (unlines (canonicalConstraintEdges recovered)) + +-- | Both the split vertices and the constrained edges they carve. The edge set +-- names every vertex by coordinate, so a split point that landed one ulp away +-- on one side shows up here rather than hiding behind a matching edge count. +writeConstraintSplitGate :: FilePath -> Int -> IO () +writeConstraintSplitGate directory bandCount = do + (base, handles) <- splitBandCdt bandCount + let split = splitConstraints base handles + prefix = directory ("constraint-split-" <> show bandCount) + writeFile (prefix <> "-edges.txt") (unlines (canonicalEdges split)) + writeFile (prefix <> "-constraints.txt") (unlines (canonicalConstraintEdges split)) + +-- | The banded CDT and the crossing requests named by handle. Handle resolution +-- goes through the build's own input mapping rather than a locate, which is the +-- constraint gate's convention; the strict side has no such mapping and locates +-- instead. Either way both name the vertex standing at the same coordinate. +splitBandCdt + :: Int + -> IO (ConstrainedDelaunayTriangulation Point, [(VertexId, VertexId)]) +splitBandCdt bandCount = do + let (points, constraints, crossings) = splitBands bandCount + built <- require (constrainedDelaunay unitElementDefaults points constraints) + let mapping = buildInputVertices built + len = sizeofPrimArray mapping + resolve index + | index >= 0 && index < len = VertexId (indexPrimArray mapping index) + | otherwise = error ("split band endpoint is out of range: " <> show index) + pure + ( buildTriangulation built + , [(resolve fromIndex, resolve toIndex) | (fromIndex, toIndex) <- crossings] + ) + +writeConstraintGate :: FilePath -> IO () +writeConstraintGate directory = do + let points = V.fromList (randomPoints 0x94d049bb133111eb 8000) + requestIndices = V.fromList (constraintPairs 8000 800) + built <- require (delaunay unitElementDefaults points) + let mapping = buildInputVertices built + len = sizeofPrimArray mapping + requests <- + V.mapM + (\(fromIndex, toIndex) -> + let mFrom = if fromIndex >= 0 && fromIndex < len then Just (VertexId (indexPrimArray mapping fromIndex)) else Nothing + mTo = if toIndex >= 0 && toIndex < len then Just (VertexId (indexPrimArray mapping toIndex)) else Nothing + in case (mFrom, mTo) of + (Just from, Just to) -> pure (from, to) + _ -> fail "constraint gate endpoint is out of range" + ) + requestIndices + batch <- + require + ( recoverConstraints + (fromDelaunay (buildTriangulation built)) + requests + ) + let accepted = + V.ifoldr + (\index outcome indices -> + case outcome of + ConstraintAccepted _ _ -> index : indices + ConstraintRejected _ -> indices + ) + [] + (constraintBatchOutcomes batch) + writeFile + (directory "cdt-accepted-8000-800.txt") + (unlines (map show accepted)) + writeFile + (directory "cdt-constraints-8000-800.txt") + (unlines (canonicalConstraintEdges (constraintBatchTriangulation batch))) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Dcel.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Dcel.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Dcel.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} + +-- | The primal DCEL traversal gate and the walk lane. +module Moonlight.Triangulation.Bench.SpadeCompare.Dcel where + +import Data.List (sort) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (allFaces, directedEdges) +import Moonlight.Triangulation.Handles.Iterators.HullIterator (hullEdges) +import System.FilePath (()) +import Moonlight.Triangulation +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Bench.SpadeCompare.Support + +-- | Every iterator over the mesh that spade also offers. The hull cycle and +-- each vertex's counterclockwise link are cycles with no determined starting +-- point and are rotated; the inner faces are a set and are sorted. The +-- enumerator lengths are stated because they are the only cross-comparable +-- claim the fixed and dynamic iterators make: their elements are handles, and +-- handles do not cross implementations. +writeDcelWalkGate :: FilePath -> Int -> IO () +writeDcelWalkGate directory count = do + triangulation <- delaunayOf count + writeFile + (directory ("dcel-hull-" <> show count <> ".txt")) + (unlines (hullGateLines triangulation)) + writeFile + (directory ("dcel-circular-" <> show count <> ".txt")) + (unlines (circularGateLines triangulation)) + writeFile + (directory ("dcel-faces-" <> show count <> ".txt")) + (unlines (innerFaceGateLines triangulation)) + +hullGateLines :: DelaunayTriangulation Point -> [String] +hullGateLines triangulation = + ("hull-size " <> show (length ring)) : rotateToSmallest ring + where + ring = + [ coordHex (vertexPoint triangulation (origin triangulation edge)) + <> coordHex (vertexPoint triangulation (destination triangulation edge)) + | edge <- hullEdges triangulation + ] + +circularGateLines :: DelaunayTriangulation Point -> [String] +circularGateLines triangulation = + [ "vertices " <> show (length (vertices triangulation)) + , "directed-edges " <> show (length (directedEdges triangulation)) + , "undirected-edges " <> show (length (undirectedEdges triangulation)) + , "all-faces " <> show (length (allFaces triangulation)) + , "inner-faces " <> show (length (innerFaces triangulation)) + ] + <> sort + [ coordHex (vertexPoint triangulation vertex) <> concat (rotateToSmallest ring) + | vertex <- vertices triangulation + , let ring = + [ coordHex (vertexPoint triangulation (destination triangulation edge)) + | edge <- vertexOutgoingEdges triangulation vertex + ] + ] + +innerFaceGateLines :: DelaunayTriangulation Point -> [String] +innerFaceGateLines triangulation = + sort + [ concat (sort (map (coordHex . vertexPoint triangulation) [a, b, c])) + | face <- innerFaces triangulation + , Just (a, b, c) <- [innerFaceVertices triangulation face] + ] + +-- | Every traversal the DCEL offers, in one pass: the hull cycle, each vertex's +-- counterclockwise link, and each inner face's vertex triple. The coordinates +-- are summed so that no step can be satisfied by a thunk. +dcelWalk :: DelaunayTriangulation Point -> (Double, Int) +dcelWalk triangulation = overFaces (overVertices (overHull (0, 0))) + where + overHull accumulator = + foldl' (\acc edge -> charge acc (origin triangulation edge)) accumulator (hullEdges triangulation) + + overVertices accumulator = foldl' overLink accumulator (vertices triangulation) + + overLink accumulator vertex = + foldl' + (\acc edge -> charge acc (destination triangulation edge)) + accumulator + (vertexOutgoingEdges triangulation vertex) + + overFaces accumulator = foldl' overCorners accumulator (innerFaces triangulation) + + overCorners accumulator face = + case innerFaceVertices triangulation face of + Nothing -> accumulator + Just (a, b, c) -> foldl' charge accumulator [a, b, c] + + charge (!total, !count) vertex = + let Point x y = vertexPoint triangulation vertex + in (total + x + y, count + 1) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Delaunay.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Delaunay.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Delaunay.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE DataKinds #-} + +-- | Bulk-load, incremental, nearest, and refinement lanes and their gates. +module Moonlight.Triangulation.Bench.SpadeCompare.Delaunay where + +import Control.Exception (evaluate) +import Data.Foldable (traverse_) +import System.Exit (exitWith, ExitCode (ExitFailure)) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.HintGenerator +import Moonlight.Triangulation.Session +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +writeBulkLoadGate :: FilePath -> Int -> IO () +writeBulkLoadGate directory count = do + triangulation <- + require + ( delaunayGeometry + (V.fromList (randomPoints 0x9e3779b97f4a7c15 count)) + ) + writeFile + (directory ("bulk-load-" <> show count <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + +writeIncrementalGate :: FilePath -> Int -> IO () +writeIncrementalGate directory count = do + triangulation <- + insertAllIncrementally + (V.fromList (randomPoints 0x9e3779b97f4a7c15 count)) + writeFile + (directory ("incremental-" <> show count <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + +writeNearestGate :: FilePath -> IO () +writeNearestGate directory = do + let pointCount = 20000 + queryCount = 5000 + triangulation <- + buildTriangulation + <$> require + ( delaunay + unitElementDefaults + (V.fromList (randomPoints 0x0123456789abcdef pointCount)) + ) + hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation) + queries <- requireQueryPoints (randomPoints 0x3141592653589793 queryCount) + writeFile + (directory "nearest-20000-5000.txt") + (unlines (map (nearestAnswer triangulation hierarchy) queries)) + +writeRefinementGate :: FilePath -> Int -> IO () +writeRefinementGate directory steinerBudget = do + let (points, constraints) = refinementInput + parameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just steinerBudget + , refineMaxArea = Just 0.5 + , refineMaxRadiusEdgeRatio = Just 1.0 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + cdtBuild <- require (constrainedDelaunay unitElementDefaults points constraints) + refined <- + require + ( refine + id + parameters + (buildTriangulation cdtBuild :: ConstrainedDelaunayTriangulation Point) + ) + let triangulation = refinedTriangulation refined + prefix = directory ("refine-" <> show steinerBudget) + completion = if refinementComplete refined then "1" else "0" + summary = + [ "added " <> show (refinementAddedVertices refined) + , "vertices " <> show (numVertices triangulation) + , "edges " <> show (numUndirectedEdges triangulation) + , "inner-faces " <> show (numInnerFaces triangulation) + , "excluded " <> show (V.length (refinementExcludedFaces refined)) + , "complete " <> completion + ] + writeFile (prefix <> "-summary.txt") (unlines summary) + writeFile (prefix <> "-edges.txt") (unlines (canonicalEdges triangulation)) + writeFile + (prefix <> "-constraints.txt") + (unlines (canonicalConstraintEdges triangulation)) + +-- | Arrival-order insertion through immutable snapshots. The artifact proves +-- final-state agreement with Spade; it is not a cross-language timing row. +writePersistentGate :: FilePath -> Int -> IO () +writePersistentGate directory count = do + triangulation <- + insertAllPersistently (V.fromList (randomPoints 0x9e3779b97f4a7c15 count)) + writeFile + (directory ("persistent-" <> show count <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + +writeSweepAngleGate :: FilePath -> Int -> IO () +writeSweepAngleGate directory count = do + triangulation <- + buildTriangulation + <$> require + ( delaunay + unitElementDefaults + (V.fromList (nearCollinearPoints 0x9e3779b97f4a7c15 count)) + ) + writeFile + (directory ("sweep-angle-collapse-" <> show count <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + +-- | The degenerate chain, pinned by the only thing it has: its edges. +-- +-- There are no faces to compare and no circumcentres to argue about, so unlike +-- every other gate here this one has no per-side half and no exclusion. The +-- answer is @n - 1@ consecutive segments and the two sides either both produce +-- it or one of them is wrong. +writeDegenerateLineGate :: FilePath -> Int -> IO () +writeDegenerateLineGate directory count = do + triangulation <- + buildTriangulation + <$> require + (delaunay unitElementDefaults (V.fromList (exactlyCollinearPoints count))) + writeFile + (directory ("degenerate-line-" <> show count <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + +-- Arrival-order insertion with one publication: the transactional comparison +-- against Spade's @&mut self@ insertion. The per-operation snapshot fold is +-- measured separately as Moonlight publication stress. +insertAllIncrementally + :: V.Vector Point + -> IO (DelaunayTriangulation Point) +insertAllIncrementally points = + evaluate + ( case either (error . show) id + ( withSession + (empty unitElementDefaults) + (V.length points) + (V.mapM_ insertVertex points) + ) of + (_, frozen, _) -> frozen + ) + +insertAllPersistently + :: V.Vector Point + -> IO (DelaunayTriangulation Point) +insertAllPersistently = + V.foldM' + (\triangulation point -> + insertionTriangulation <$> require (insert triangulation point) + ) + (empty unitElementDefaults) + +-- | The refinement lane's own counters, so the worklist question is answered by +-- measurement rather than by assertion. +-- +-- @faceChecks@ is not a worklist counter: the terminal audit runs the complete +-- face evaluation over every final inner face without popping anything. So the +-- amplification ratio is @pops / steiner@, and @faceChecks - pops@ should equal +-- the final inner-face count less any pop discarded as excluded. +-- | The circle sweep's placement split, on the same generator the bulk lanes +-- use. A point takes the fast path when the hull edge its own angle selected +-- has the point strictly to its left; otherwise it is deferred to a generic +-- insertion after the sweep finishes. spade takes the identical branch on +-- @is_on_right_side_or_on_line@ and its own source calls that fallback "very +-- slow", so a materially non-zero skip count is wasted work in the bulk lane +-- rather than a curiosity. @seed + fast + skipped@ must exhaust the unique +-- points; this reports the identity rather than asserting it silently. +reportSweepStats :: Int -> IO () +reportSweepStats count = do + let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count) + built <- require (delaunay unitElementDefaults points) + let stats = buildStats (built :: BuildResult 'Unconstrained Point () () ()) + seeded = statSpatialSeedPoints stats + fast = statSweepFastPoints stats + skippedPoints = statSweepSkippedPoints stats + unique = statUniquePoints stats + accounted = seeded + fast + skippedPoints + share :: Int -> String + share value + | unique == 0 = "n/a" + | otherwise = show (100 * fromIntegral value / fromIntegral unique :: Double) <> "%" + traverse_ + putStrLn + [ "input-points " <> show (statInputPoints stats) + , "unique-points " <> show unique + , "duplicate-points " <> show (statDuplicatePoints stats) + , "seed-points " <> show seeded + , "sweep-fast-points " <> show fast + , "sweep-skipped-points " <> show skippedPoints + , "skipped-share " <> share skippedPoints + , "accounted " <> show accounted + , "identity-holds " <> show (accounted == unique) + , "edge-flips " <> show (statEdgeFlips stats) + , "hull-insertions " <> show (statHullInsertions stats) + , "legalization-max-stack " <> show (statLegalizationMaxStack stats) + ] + if accounted == unique + then pure () + else do + hPutStrLn + stderr + ( "sweep-stats: seed + fast + skipped = " + <> show accounted + <> " but unique = " + <> show unique + ) + exitWith (ExitFailure 1) + +reportRefinementCounters :: Int -> IO () +reportRefinementCounters budget = do + let (points, constraints) = refinementInput + parameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just budget + , refineMaxArea = Just 0.5 + , refineMaxRadiusEdgeRatio = Just 1.0 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + cdt <- buildTriangulation <$> require (constrainedDelaunay unitElementDefaults points constraints) + result <- + require (refine id parameters (cdt :: ConstrainedDelaunayTriangulation Point)) + let stats = refinementStats result + steiner = statSteinerPoints stats + pops = statRefinementQueuePops stats + checks = statRefinementFaceChecks stats + inner = numInnerFaces (refinedTriangulation result) + excluded = V.length (refinementExcludedFaces result) + ratio :: Int -> Int -> String + ratio numerator denominator + | denominator == 0 = "n/a" + | otherwise = + show (fromIntegral numerator / fromIntegral denominator :: Double) + traverse_ + putStrLn + [ "budget " <> show budget + , "steiner " <> show steiner + , "queue-pops " <> show pops + , "face-checks " <> show checks + , "inner-faces " <> show inner + , "excluded " <> show excluded + , "edge-flips " <> show (statEdgeFlips stats) + , "location-walk-steps " <> show (statLocationWalkSteps stats) + , "complete " <> show (refinementComplete result) + , "pops/steiner " <> ratio pops steiner + , "checks/steiner " <> ratio checks steiner + , "flips/steiner " <> ratio (statEdgeFlips stats) steiner + , "walk-steps/steiner " <> ratio (statLocationWalkSteps stats) steiner + , "checks-minus-pops " <> show (checks - pops) + -- Every face check is now a queue pop. The terminal audit used to make the + -- difference equal the final inner-face count; if this ever reads False + -- again, a second whole-mesh quality pass has come back. + , "no-second-pass " <> show (checks == pops) + ] diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Gates.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Gates.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Gates.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE DataKinds #-} + +-- | The artifact rosters: every gate the binary writes, and the divergence set. +module Moonlight.Triangulation.Bench.SpadeCompare.Gates where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Bifunctor (first) +import Data.Foldable (traverse_) +import System.Directory (createDirectoryIfMissing) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Removal +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Bench.SpadeCompare.Constraint +import Moonlight.Triangulation.Bench.SpadeCompare.Dcel +import Moonlight.Triangulation.Bench.SpadeCompare.Delaunay +import Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy +import Moonlight.Triangulation.Bench.SpadeCompare.Interpolation +import Moonlight.Triangulation.Bench.SpadeCompare.Intersection +import Moonlight.Triangulation.Bench.SpadeCompare.Removal +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) +import Moonlight.Triangulation.Bench.SpadeCompare.Voronoi + +-- | The exact observable mesh egress retained by the persistent witnesses. +-- +-- These artifacts validate immutable predecessor and final-state agreement; +-- they are not Spade timing ratios. Snapshot publication is measured only on +-- the Haskell side against its session reference. +-- +-- The cross-language gate already compares the canonical-edge projection. +-- This witness additionally retains the geometry-labelled circular DCEL +-- section, so an isolated or face-less predecessor cannot change unseen. It +-- deliberately observes geometric topology rather than internal storage, and +-- remains a gate-only sink outside every timed lane. +data PersistentEndpoint = PersistentEndpoint + { persistentEndpointVertices :: !Int + , persistentEndpointUndirectedEdges :: !Int + , persistentEndpointInnerFaces :: !Int + , persistentEndpointCanonicalEdges :: ![String] + , persistentEndpointCircularDcel :: ![String] + } + deriving (Eq, Show) + +-- | Every retained section is named by its operation and completed edit count, +-- never by a formatting-only string. +data PersistentWitnessLabel + = PersistentInsertionWitness !Int + | PersistentRemovalWitness !Int + deriving (Eq, Show) + +-- | A preserved immutable section together with its authoritative egress at +-- capture time. Insert and removal each supply one concrete use, so this is +-- the shared gate algebra rather than a second triangulation representation. +data PersistentSnapshotWitness = PersistentSnapshotWitness + { persistentSnapshotLabel :: !PersistentWitnessLabel + , persistentSnapshotEndpoint :: !PersistentEndpoint + , persistentSnapshotTriangulation :: !(DelaunayTriangulation Point) + } + +-- | Complete typed refusal surface for the persistence gate. The public +-- operations already return 'BuildError'; the witness transports it instead +-- of manufacturing a stringly failure. A changed snapshot carries its exact +-- observed endpoint so the gate failure is inspectable without a unilateral +-- artifact. +data PersistentSnapshotObstruction + = PersistentInitialBuildRefused !BuildError + | PersistentInsertionRefused !Int !BuildError + | PersistentRemovalRefused !Int !BuildError + | PersistentRemovalTargetMissing !Int + | PersistentSnapshotChanged + !PersistentWitnessLabel + !PersistentEndpoint + !PersistentEndpoint + deriving Show + +persistentEndpoint + :: DelaunayTriangulation Point + -> IO PersistentEndpoint +persistentEndpoint triangulation = do + edges <- evaluate (force (canonicalEdges triangulation)) + circular <- evaluate (force (circularGateLines triangulation)) + pure $! + PersistentEndpoint + { persistentEndpointVertices = numVertices triangulation + , persistentEndpointUndirectedEdges = numUndirectedEdges triangulation + , persistentEndpointInnerFaces = numInnerFaces triangulation + , persistentEndpointCanonicalEdges = edges + , persistentEndpointCircularDcel = circular + } + +capturePersistentSnapshot + :: PersistentWitnessLabel + -> DelaunayTriangulation Point + -> IO PersistentSnapshotWitness +capturePersistentSnapshot label triangulation = do + endpoint <- persistentEndpoint triangulation + pure + PersistentSnapshotWitness + { persistentSnapshotLabel = label + , persistentSnapshotEndpoint = endpoint + , persistentSnapshotTriangulation = triangulation + } + +verifyPersistentSnapshot + :: PersistentSnapshotWitness + -> IO (Either PersistentSnapshotObstruction ()) +verifyPersistentSnapshot witness = do + observed <- persistentEndpoint (persistentSnapshotTriangulation witness) + pure + ( if observed == persistentSnapshotEndpoint witness + then Right () + else + Left + ( PersistentSnapshotChanged + (persistentSnapshotLabel witness) + (persistentSnapshotEndpoint witness) + observed + ) + ) + +verifyPersistentSnapshots :: [PersistentSnapshotWitness] -> IO (Either PersistentSnapshotObstruction ()) +verifyPersistentSnapshots = fmap sequence_ . traverse verifyPersistentSnapshot + +assertPersistentSnapshot + :: Either PersistentSnapshotObstruction value + -> IO value +assertPersistentSnapshot = require + +-- | Fixed sparse checkpoints of a longer immutable chain. Each one has later +-- edits behind it, so the test distinguishes persistence from merely producing +-- the correct final mesh. +persistentCheckpoint :: Int -> Bool +persistentCheckpoint index = index `elem` [0, 1, 2, 7, 31, 63] + +verifyPersistentInsertionSnapshots :: IO () +verifyPersistentInsertionSnapshots = do + let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 96) + initial = empty unitElementDefaults + initialWitness <- capturePersistentSnapshot (PersistentInsertionWitness 0) initial + (final, witnesses) <- + V.ifoldM' + (\(current, preserved) index point -> do + nextTriangulation <- + assertPersistentSnapshot + ( insertionTriangulation + <$> first (PersistentInsertionRefused index) (insert current point) + ) + if persistentCheckpoint index + then do + witness <- capturePersistentSnapshot (PersistentInsertionWitness (index + 1)) nextTriangulation + pure (nextTriangulation, preserved <> [witness]) + else pure (nextTriangulation, preserved) + ) + (initial, [initialWitness]) + points + -- Force the terminal endpoint as an out-of-clock comparable sink before + -- checking predecessors; its edge projection is the same projection the + -- Rust gate emits for the timed lanes. + _ <- persistentEndpoint final + assertPersistentSnapshot =<< verifyPersistentSnapshots witnesses + +verifyPersistentRemovalSnapshots :: IO () +verifyPersistentRemovalSnapshots = do + let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 128) + removals = V.take 96 points + initial <- + buildTriangulation + <$> assertPersistentSnapshot + (first PersistentInitialBuildRefused (delaunay unitElementDefaults points)) + initialWitness <- capturePersistentSnapshot (PersistentRemovalWitness 0) initial + (final, witnesses) <- + V.ifoldM' + (\(current, preserved) index point -> do + outcome <- + assertPersistentSnapshot + (first (PersistentRemovalRefused index) (locateAndRemove current point)) + nextTriangulation <- + case outcome of + Nothing -> assertPersistentSnapshot (Left (PersistentRemovalTargetMissing index)) + Just removal -> pure (removalTriangulation removal) + if persistentCheckpoint index + then do + witness <- capturePersistentSnapshot (PersistentRemovalWitness (index + 1)) nextTriangulation + pure (nextTriangulation, preserved <> [witness]) + else pure (nextTriangulation, preserved) + ) + (initial, [initialWitness]) + removals + _ <- persistentEndpoint final + assertPersistentSnapshot =<< verifyPersistentSnapshots witnesses + +-- | The Haskell side's immutable-contract gate. It emits no extra artifact: +-- adding a unilateral file would make the cross-language artifact diff fail. +-- Its selected predecessor sections are instead verified before the existing +-- shared endpoint artifacts are written. +verifyPersistentSnapshotWitnesses :: IO () +verifyPersistentSnapshotWitnesses = do + verifyPersistentInsertionSnapshots + verifyPersistentRemovalSnapshots + +-- | Pin the exact output of every timed workload before comparing its cost. +-- Persistent witness artifacts above are final-state agreement gates, not +-- cross-language timing rows. +writeGate :: FilePath -> IO () +writeGate directory = do + createDirectoryIfMissing True directory + verifyPersistentSnapshotWitnesses + traverse_ (writeBulkLoadGate directory) [1000, 10000] + traverse_ (writeIncrementalGate directory) [1000, 10000] + writeNearestGate directory + writeConstraintGate directory + traverse_ (writeRefinementGate directory) [625, 2500] + traverse_ (uncurry (writeRemovalGate directory)) [(1000, 250), (10000, 2500)] + traverse_ (uncurry (writeInterpolationGate directory)) [(10000, 1000), (100000, 2000)] + writeVoronoiGate directory 1000 + writeDcelWalkGate directory 2000 + writeIntersectionGate directory 10000 500 + writeIntersectionVertexGate directory 2000 + -- Persistent artifacts validate final-state agreement only; they are not + -- Spade timing rows. Their canonical egress is retained for the hard gate. + writePersistentGate directory 1000 + writePersistentRemovalGate directory 10000 2500 + -- The remaining cliff lanes. Each times an entry point of this side that is + -- expected to lose badly, which is worth nothing unless the two are first + -- shown to compute the same thing — a quadratic path and a linear one that + -- disagree are not a comparison. + writeConstraintIncrementalGate directory 8000 800 + writeConstraintSplitGate directory 1000 + writeSweepAngleGate directory 2000 + writeDegenerateLineGate directory 2000 + writeHierarchyIncrementalGate directory 1000 + writeHierarchyDuplicateGate directory 10000 500 + writeHierarchyRemovalGate directory 10000 250 + writeIntersectionOutsideGate directory 2000 100 + +-- | The shapes on which the two implementations classify the constrained +-- domain. They do not agree, so this is a characterization rather than a gate: +-- the committed baselines lock in the known divergence and fail if either side +-- moves. See @README.md@ for the compatibility rule. +divergenceShapes :: [(String, [Point], [(Int, Int)])] +divergenceShapes = + [ ("flush", square 8 <> [Point 4 4], loop4) + , ("notched", square 8 <> [Point 13 4, Point 4 4], loop4) + , ("flush-plus-dangling-segment", square 8 <> [Point 2 2, Point 6 6], loop4 <> [(4, 5)]) + , ("notched-plus-dangling-segment", square 8 <> [Point 13 4, Point 2 2, Point 6 6], loop4 <> [(5, 6)]) + , ( "annulus" + , square 12 <> [Point 4 4, Point 8 4, Point 8 8, Point 4 8] + , loop4 <> [(4, 5), (5, 6), (6, 7), (7, 4)] + ) + ] + where + square scale = [Point 0 0, Point scale 0, Point scale scale, Point 0 scale] + loop4 = [(0, 1), (1, 2), (2, 3), (3, 0)] + +writeDivergence :: FilePath -> IO () +writeDivergence path = do + rows <- mapM row divergenceShapes + writeFile path (unlines rows) + where + row (label, points, constraints) = do + built <- require (constrainedDelaunay unitElementDefaults (V.fromList points) (V.fromList constraints)) + let cdt = buildTriangulation built + parameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just 0 + , refineExcludeOuterFaces = True + } + classified <- require (refine id parameters cdt) + pure + ( label + <> ": inner " <> show (numInnerFaces cdt) + <> ", excluded " <> show (V.length (refinementExcludedFaces classified)) + ) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Hierarchy.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Hierarchy.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Hierarchy.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} + +-- | Hierarchy-hint lanes, their gates, and the maintained-hint step. +module Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy where + +import System.FilePath (()) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad +import Moonlight.Triangulation.HintGenerator +import Moonlight.Triangulation.Session +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +-- | The step both insertion lanes run: one insert, one hierarchy update, and +-- nothing between them. It is what spade's @insert@ does internally through +-- @notify_vertex_inserted@, and both sides carry branch factor 16. +-- +-- The point handed to 'updateHierarchyAfterInsertion' is the same binding +-- handed to 'insertVertexAt', never one read back out of the harness's input +-- vector. The mesh stores 'canonicalPoint' of what it was given, so a +-- harness-side copy would part company from it on a signed zero, seed a +-- different nearest neighbour, and move the gate against spade. Same function, +-- same argument, same bits. +hierarchyStep + :: HierarchyHint + -> Point + -> Session s Point () () () HierarchyHint +hierarchyStep hierarchy point = do + (vertex, disposition) <- insertVertexAt point point + either refuse pure (updateHierarchyAfterInsertion hierarchy point vertex disposition) + +-- | Arrival-order insertion with the hierarchy maintained alongside it. +-- +-- One session spans the whole run. The hierarchy no longer asks for a +-- triangulation, so the per-point publication that existed only to hand it one +-- is gone: the mesh is thawed once and published once for the program, where +-- before it was once per point. The measured operation is unchanged — still an +-- insert per point with the hint maintained against it, which is spade's loop. +insertAllWithHierarchy + :: V.Vector Point + -> IO (DelaunayTriangulation Point, HierarchyHint) +insertAllWithHierarchy points = do + let base = empty unitElementDefaults + initial <- require (buildHierarchyHint defaultHierarchyBranchFactor base) + (hierarchy, mesh, _) <- + require (withSession base (V.length points) (V.foldM' hierarchyStep initial points)) + pure (mesh, hierarchy) + +-- | The same step over a mesh that already holds every point, which is the +-- duplicate lane. Each insert locates a site that is already there and answers +-- 'AlreadyPresent', so the hierarchy comes back unexamined and the level walk +-- is never entered. What remains on the clock is the locate and the +-- disposition test, with no rebuild standing behind either. +reinsertAllWithHierarchy + :: (DelaunayTriangulation Point, HierarchyHint) + -> V.Vector Point + -> IO (DelaunayTriangulation Point, HierarchyHint) +reinsertAllWithHierarchy (triangulation, hierarchy) points = + case withSession triangulation (V.length points) (V.foldM' hierarchyStep hierarchy points) of + Left refusal -> fail (show refusal) + Right (updated, mesh, _) -> pure (mesh, updated) + +-- | Remove a program of coordinates through the hierarchy: every locate +-- starts at the hierarchy's nearest sample, one base session publishes once, +-- and the hierarchy of the resulting value is published once. +-- +-- No query observes an intermediate hierarchy in this lane. A triangulation +-- and its hierarchy denote their current values rather than the edit history, +-- so the lawful physical schedule is one base session followed by one +-- hierarchy publication — the shape of the strict side's +-- @HierarchyTriangulation@, whose removals also locate through the hierarchy. +removeAllWithHierarchy + :: (DelaunayTriangulation Point, HierarchyHint) + -> V.Vector Point + -> IO (DelaunayTriangulation Point, HierarchyHint) +removeAllWithHierarchy (triangulation, hierarchy) points = + case removeManyWithHierarchy hierarchy triangulation points of + Left refusal -> fail (show refusal) + Right (outcomes, surviving, repaired) -> do + V.imapM_ checkRemoved outcomes + pure (surviving, repaired) + where + checkRemoved index outcome = case outcome of + Nothing -> + error + ( "removal target is not a vertex: index=" + <> show index + <> " point=" + <> ( case points V.! index of + Point x y -> hex64 x <> "," <> hex64 y + ) + ) + Just _ -> pure () + +-- | The hierarchy lanes' gate, in two parts. The base mesh alone would not see +-- a hierarchy whose nesting law has drifted, because a search started from a +-- bad hint still walks to the right answer; a hint naming a vertex that does +-- not exist, or one the search cannot walk out of, moves the answers. Both are +-- pinned. +hierarchyGateQueries :: Int +hierarchyGateQueries = 1000 + +writeHierarchyGate + :: FilePath + -> String + -> (DelaunayTriangulation Point, HierarchyHint) + -> IO () +writeHierarchyGate directory label (triangulation, hierarchy) = do + queries <- requireQueryPoints (randomPoints 0x3141592653589793 hierarchyGateQueries) + writeFile + (directory (label <> "-edges.txt")) + (unlines (canonicalEdges triangulation)) + writeFile + (directory (label <> "-nearest.txt")) + ( unlines + ( map + (nearestAnswer triangulation hierarchy) + queries + ) + ) + +writeHierarchyIncrementalGate :: FilePath -> Int -> IO () +writeHierarchyIncrementalGate directory pointCount = do + built <- insertAllWithHierarchy (V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)) + writeHierarchyGate directory ("hierarchy-incremental-" <> show pointCount) built + +writeHierarchyDuplicateGate :: FilePath -> Int -> Int -> IO () +writeHierarchyDuplicateGate directory pointCount duplicateCount = do + base <- hierarchyOf pointCount + built <- + reinsertAllWithHierarchy + base + (V.fromList (randomPoints 0x9e3779b97f4a7c15 duplicateCount)) + writeHierarchyGate + directory + ("hierarchy-duplicate-" <> show pointCount <> "-" <> show duplicateCount) + built + +writeHierarchyRemovalGate :: FilePath -> Int -> Int -> IO () +writeHierarchyRemovalGate directory pointCount removalCount = do + base <- hierarchyOf pointCount + built <- + removeAllWithHierarchy + base + (V.fromList (take removalCount (randomPoints 0x9e3779b97f4a7c15 pointCount))) + writeHierarchyGate + directory + ("hierarchy-removal-" <> show pointCount <> "-" <> show removalCount) + built + +-- | A bulk-loaded mesh and the hierarchy over it, which is where the duplicate +-- and removal lanes start. The strict side reaches the same pair through +-- @HierarchyTriangulation::bulk_load@. +hierarchyOf + :: Int + -> IO (DelaunayTriangulation Point, HierarchyHint) +hierarchyOf count = do + triangulation <- delaunayOf count + hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation) + pure (triangulation, hierarchy) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Input.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Input.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Input.hs @@ -0,0 +1,20 @@ +-- | Cross-language benchmark input programs. Both Haskell interpreters import +-- this owner directly; neither keeps a private copy of the LCG stream. +module Moonlight.Triangulation.Bench.SpadeCompare.Input + ( randomPoints + ) where + +import Data.Word (Word64) +import Moonlight.Triangulation.Types (Point (..)) + +-- | The Rust generator, bit for bit. +randomPoints :: Word64 -> Int -> [Point] +randomPoints seed count = take count (go seed) + where + go :: Word64 -> [Point] + go state = + let state1 = state * 6364136223846793005 + 1442695040888963407 + state2 = state1 * 6364136223846793005 + 1442695040888963407 + unit :: Word64 -> Double + unit value = fromIntegral (value `div` 2048) / 9007199254740992 + in Point (2 * unit state1 - 1) (2 * unit state2 - 1) : go state2 diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Interpolation.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Interpolation.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Interpolation.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE DataKinds #-} + +-- | Sibson interpolation lanes, gates, and diagnostics. +module Moonlight.Triangulation.Bench.SpadeCompare.Interpolation where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad.ST (stToIO) +import GHC.Exts (RealWorld) +import Data.Foldable (traverse_) +import Data.List (sort, sortOn) +import System.Exit (exitWith, ExitCode (ExitFailure)) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Interpolation +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +-- | The Sibson query reports its own cavity size, so the distribution of +-- (cavity faces, neighbours returned) says which step degenerates: a cavity of +-- one face means 'discoverCavity' never expanded, while a larger cavity paired +-- with three neighbours means the cell or the normalization was rejected. +reportInterpolationAudit :: Int -> Int -> IO () +reportInterpolationAudit pointCount queryCount = do + triangulation <- + buildTriangulation + <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount))) + workspace <- stToIO (newNaturalNeighborWorkspace triangulation) + queries <- requireQueryPoints (randomPoints 0x2718281828459045 queryCount) + pairs <- + traverse + ( \query -> do + (count, _, stats) <- + stToIO (foldNaturalNeighborWeights (\total _ _ -> total + (1 :: Int)) 0 workspace Nothing query) + pure ((interpolationCavityFaces stats, count), interpolationUsedFallback stats) + ) + queries + let tally = + [ (representative, 1 + length rest) + | representative : rest <- groupSorted (sort (map fst pairs)) + ] + fallbacks = length (filter snd pairs) + putStrLn ("queries " <> show (length pairs)) + putStrLn ("fallbacks " <> show fallbacks) + traverse_ + (\((cavity, neighbors), n) -> putStrLn ("cavityFaces=" <> show cavity <> " neighbors=" <> show neighbors <> " count=" <> show n)) + tally + where + groupSorted [] = [] + groupSorted (x : xs) = let (same, rest) = span (== x) xs in (x : same) : groupSorted rest + +-- | Isolates the cavity flood of the Sibson pipeline: per query, the BFS +-- over 'inCircle' and nothing else. The margin tally counts tests whose +-- determinant is inside the filtered predicate's error bound — the exact +-- dyadic path, which allocates Integer arithmetic per call. +reportInterpolationCavityAudit :: Int -> Int -> IO () +reportInterpolationCavityAudit pointCount queryCount = do + triangulation <- + buildTriangulation + <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount))) + queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount)) + (faces, tests, margins) <- + V.foldM' + ( \(faceAcc, testAcc, marginAcc) query -> + case locatePoint triangulation query of + InFace start -> do + let (!cavitySize, !testCount, !marginCount) = flood triangulation (queryPointValue query) start + pure (faceAcc + cavitySize, testAcc + testCount, marginAcc + marginCount) + _ -> pure (faceAcc, testAcc, marginAcc) + ) + (0 :: Int, 0 :: Int, 0 :: Int) + queries + putStrLn ("queries " <> show queryCount) + putStrLn ("cavity-faces " <> show faces) + putStrLn ("incircle-tests " <> show tests) + putStrLn ("exact-path-margins " <> show margins) + where + flood triangulation query start = go [start] [] 0 0 + where + go [] seen tests margins = (length seen, tests, margins) + go (face : rest) seen tests margins + | face `elem` seen = go rest seen tests margins + | otherwise = + case innerFaceVertices triangulation face of + Nothing -> go rest seen tests margins + Just (a, b, c) -> + let !pa = vertexPoint triangulation a + !pb = vertexPoint triangulation b + !pc = vertexPoint triangulation c + !verdict = inCircle pa pb pc query + !margins' = if insideMargin pa pb pc query then margins + 1 else margins + in if verdict == GT + then go (adjacent triangulation face ++ rest) (face : seen) (tests + 1) margins' + else go rest seen (tests + 1) margins' + + adjacent triangulation face = + case innerFaceDirectedEdges triangulation face of + Nothing -> [] + Just (e0, e1, e2) -> + [ opposite + | edge <- [e0, e1, e2] + , let opposite = incidentFace triangulation (reverseEdge edge) + , opposite /= outerFace + ] + + -- The branch condition of the filtered Double inCircle, recomputed over + -- public coordinates: inside the error bound means the exact dyadic path. + insideMargin (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) = + abs determinant <= 1.1102230246251577e-15 * permanent + where + !adx = ax - dx + !ady = ay - dy + !bdx = bx - dx + !bdy = by - dy + !cdx = cx - dx + !cdy = cy - dy + !abdet = adx * bdy - bdx * ady + !bcdet = bdx * cdy - cdx * bdy + !cadet = cdx * ady - adx * cdy + !alift = adx * adx + ady * ady + !blift = bdx * bdx + bdy * bdy + !clift = cdx * cdx + cdy * cdy + !determinant = alift * bcdet + blift * cadet + clift * abdet + !permanent = + (abs (bdx * cdy) + abs (cdx * bdy)) * alift + + (abs (cdx * ady) + abs (adx * cdy)) * blift + + (abs (adx * bdy) + abs (bdx * ady)) * clift + +-- | Isolates the locate half of the interpolation lane: same triangulation, +-- same queries, but only 'locatePointWithHint' runs — no cavity, no Sibson. +-- With the allocation of this in hand against the full lane's, the owner of +-- the per-query cost is named by subtraction rather than by guesswork. +reportInterpolationLocateAudit :: Int -> Int -> IO () +reportInterpolationLocateAudit pointCount queryCount = do + triangulation <- + buildTriangulation + <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount))) + queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount)) + (steps, fallbacks) <- + V.foldM' + ( \(stepAcc, fallbackAcc) query -> do + let (!location, !stats) = locatePointWithHint triangulation Nothing query + _ <- evaluate (force (show location)) + pure (stepAcc + locationWalkSteps stats, fallbackAcc + (if locationUsedFallback stats then 1 else 0)) + ) + (0 :: Int, 0 :: Int) + queries + putStrLn ("queries " <> show queryCount) + putStrLn ("walk-steps " <> show steps) + putStrLn ("fallbacks " <> show fallbacks) + +-- | The Sibson pipeline re-implemented over public API only, stage by stage, +-- mirroring the library's 'sibsonQuery': cavity flood, boundary collection, +-- loop ordering, insertion cell, stolen-area walks, normalization. The stage +-- sets are order-independent, so where the replica succeeds while the library +-- falls back the workspace layer is convicted, and where it fails the stage's +-- own algorithm is. With no index it tallies the first 1000 gate queries by +-- failing stage; with an index it dumps one query's full geometry. +reportInterpolationContext :: Int -> Maybe Int -> IO () +reportInterpolationContext pointCount maybeIndex = do + triangulation <- + buildTriangulation + <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount))) + queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 1000)) + case maybeIndex of + Just index -> case queries V.!? index of + Nothing -> do + hPutStrLn stderr "interp-context: query index out of range" + exitWith (ExitFailure 2) + Just query -> do + let (_, detail) = replicateQuery triangulation query + putStrLn ("query " <> pointHex (queryPointValue query)) + traverse_ putStrLn detail + Nothing -> do + let reports = map (fst . replicateQuery triangulation) (V.toList queries) + tally = + [ (representative, 1 + length rest) + | representative : rest <- groupByHead (sort reports) + ] + putStrLn ("queries " <> show (length reports)) + traverse_ (\(stage, count) -> putStrLn (stage <> " count=" <> show count)) tally + where + groupByHead [] = [] + groupByHead (x : xs) = let (same, rest) = span (== x) xs in (x : same) : groupByHead rest + + replicateQuery triangulation queryPoint = + let query = queryPointValue queryPoint + in case locatePoint triangulation queryPoint of + OnVertex _ -> ("special-on-vertex", ["on-vertex"]) + OnEdge edge + | isBoundaryEdge triangulation (asUndirected edge) -> ("special-boundary-edge", ["boundary-edge"]) + | otherwise -> + let !left = incidentFace triangulation edge + !right = incidentFace triangulation (reverseEdge edge) + !start = if left /= outerFace then left else right + in sibson triangulation query start + InFace face -> sibson triangulation query face + OutsideConvexHull _ -> ("special-outside-hull", ["outside-hull"]) + EmptyTriangulation -> ("special-empty", ["empty"]) + + sibson triangulation query startFace = + let cavity = flood [startFace] [] + boundary = + [ edge + | face <- cavity + , Just (e0, e1, e2) <- [innerFaceDirectedEdges triangulation face] + , edge <- [e0, e1, e2] + , let opposite = incidentFace triangulation (reverseEdge edge) + , opposite == outerFace || not (opposite `elem` cavity) + ] + header = + [ "cavity " <> show (length cavity) + , "boundary " <> show (length boundary) + ] + in case orderLoop boundary of + Left reason -> ("fail-order", header ++ ["order-failure " <> reason]) + Right ordered + | length ordered < 3 -> ("fail-order-small", header ++ ["ordered " <> show (length ordered)]) + | otherwise -> + case insertionCell ordered of + Left reason -> ("fail-cell", header ++ ["ordered " <> show (length ordered), "cell-failure " <> reason]) + Right cell -> + let walks = stolenAreas ordered cell + in case sequence walks of + Left reason -> ("fail-stolen", header ++ ["ordered " <> show (length ordered), "stolen-failure " <> reason]) + Right areas -> + let !total = sum areas + !minimumWeight = minimum areas + !tolerance = max 1.0e-12 (128 * 2.220446049250313e-16) + !clampedTotal = sum (map (max 0) areas) + verdict + | any (not . isFinite) areas || total == 0 || minimumWeight < negate tolerance = + Left ("normalize total=" <> show total <> " min=" <> show minimumWeight) + | clampedTotal <= 0 || not (isFinite clampedTotal) = + Left ("clamped-total " <> show clampedTotal) + | otherwise = Right () + in case verdict of + Left reason -> + ( "fail-normalize" + , header + ++ ["ordered " <> show (length ordered)] + ++ ["area " <> show area | area <- areas] + ++ ["normalize-failure " <> reason] + ) + Right () -> + ( "sibson-success" + , header + ++ ["ordered " <> show (length ordered)] + ++ zipWith areaLine ordered areas + ++ ["total " <> show total <> " min " <> show minimumWeight] + ) + where + areaLine edge area = + " vertex " + <> pointHex (vertexPoint triangulation (origin triangulation edge)) + <> " area " + <> show area + + contains face = + case innerFaceVertices triangulation face of + Nothing -> False + Just (a, b, c) -> + inCircle + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + query + /= LT + + adjacent face = + case innerFaceDirectedEdges triangulation face of + Nothing -> [] + Just (e0, e1, e2) -> + [ opposite + | edge <- [e0, e1, e2] + , let opposite = incidentFace triangulation (reverseEdge edge) + , opposite /= outerFace + ] + + flood [] seen = seen + flood (face : rest) seen + | face `elem` seen = flood rest seen + | not (contains face) = flood rest seen + | otherwise = flood (adjacent face ++ rest) (face : seen) + + orderLoop [] = Left "empty-boundary" + orderLoop boundary@(first : _) = chain first first [] 0 + where + !count = length boundary + origins = [(origin triangulation edge, edge) | edge <- boundary] + chain start current acc index + | index >= count = + if current == start then Right (reverse acc) else Left "no-closure" + | otherwise = + case lookup (destination triangulation current) origins of + Nothing -> + Left + ( "broken-chain " + <> pointHex (vertexPoint triangulation (destination triangulation current)) + ) + Just nextEdge + | nextEdge == start && index + 1 == count -> Right (reverse (current : acc)) + | nextEdge == start -> Left "premature-closure" + | otherwise -> chain start nextEdge (current : acc) (index + 1) + + relative point = case point of Point x y -> Point (x - qx) (y - qy) + (qx, qy) = case query of Point x y -> (x, y) + + insertionCell ordered = traverse cellCenter ordered + where + cellCenter edge = + let !from = vertexPoint triangulation (origin triangulation edge) + !to = vertexPoint triangulation (destination triangulation edge) + in case circumcenter (relative to) (relative from) (Point 0 0) of + Nothing -> + Left + ( "edge " + <> pointHex from + <> " " + <> pointHex to + ) + Just center -> Right center + + stolenAreas ordered cell = + let !count = length ordered + pairs = zip ordered cell + predecessors = drop (count - 1) pairs ++ take (count - 1) pairs + in zipWith walk pairs predecessors + where + walk (stopEdge, first) (initialEdge, initialPoint) = go initialEdge initialPoint 0 initialPositive initialNegative + where + !target = reverseEdge stopEdge + !limit = numDirectedEdges triangulation + 1 + !initialPositive = px first * py initialPoint + !initialNegative = py first * px initialPoint + !vertex = vertexPoint triangulation (origin triangulation stopEdge) + go lastEdge lastPoint steps positive negative + | steps >= limit = Left "step-limit" + | incidentFace triangulation lastEdge == outerFace = + Left ("outer-face vertex=" <> pointHex vertex <> " steps=" <> show steps) + | otherwise = + case innerFaceVertices triangulation (incidentFace triangulation lastEdge) of + Nothing -> Left "no-face-vertices" + Just (a, b, c) -> + case circumcenter + (relative (vertexPoint triangulation a)) + (relative (vertexPoint triangulation b)) + (relative (vertexPoint triangulation c)) of + Nothing -> + Left ("circumcenter vertex=" <> pointHex vertex <> " steps=" <> show steps) + Just current -> + let !positive' = positive + px lastPoint * py current + !negative' = negative + py lastPoint * px current + !nextEdge = reverseEdge (next triangulation lastEdge) + in if nextEdge == target + then Right ((negative' + py current * px first) - (positive' + px current * py first)) + else go nextEdge current (steps + 1) positive' negative' + px (Point x _) = x + py (Point _ y) = y + +-- | The interpolation gate, two artifacts per query. The neighbour set is +-- exact-predicate determined over triangulations that already agree +-- bit-for-bit, so it crosses implementations. The weights cannot: each +-- neighbour's stolen area uses the same operation sequence on both sides, +-- but the normalization total accumulates those areas in each side's own +-- neighbour order, and floating-point addition is not associative. The +-- weights are pinned per side in the driver instead. +writeInterpolationGate :: FilePath -> Int -> Int -> IO () +writeInterpolationGate directory pointCount queryCount = do + triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount))) + workspace <- stToIO (newNaturalNeighborWorkspace triangulation) + queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount)) + (neighborLines, weightLines) <- + V.foldM' + ( \(neighborAcc, weightAcc) query -> do + (entries, _, _) <- stToIO (foldNaturalNeighborWeights (\acc vertex weight -> (vertex, weight) : acc) [] workspace Nothing query) + let sortedEntries = + sortOn + (\(x, y, _) -> (x, y)) + [ case vertexPoint triangulation vertex of + Point x y -> (x, y, weight) + | (vertex, weight) <- entries + ] + queryHex = case queryPointValue query of Point x y -> hex64 x <> hex64 y + pure + ( queryHex <> concatMap (\(x, y, _) -> hex64 x <> hex64 y) sortedEntries : neighborAcc + , queryHex <> concatMap (\(x, y, weight) -> hex64 x <> hex64 y <> hex64 weight) sortedEntries : weightAcc + ) + ) + ([], []) + queries + writeFile + (directory ("interpolation-" <> show pointCount <> "-" <> show queryCount <> "-neighbors.txt")) + (unlines (reverse neighborLines)) + writeFile + (directory ("interpolation-" <> show pointCount <> "-" <> show queryCount <> "-weights.txt")) + (unlines (reverse weightLines)) + +-- | The sum of one query's Sibson weights through the reusable workspace — +-- the allocation-free path, matching what the strict side's buffer reuse +-- does inside its measured region. +interpolationWeightSum + :: NaturalNeighborWorkspace RealWorld 'Unconstrained Point () () () + -> V.Vector QueryPoint + -> IO Double +interpolationWeightSum workspace = + V.foldM' + ( \total query -> do + (weightSum, _, _) <- stToIO (foldNaturalNeighborWeights (\acc _ weight -> acc + weight) 0 workspace Nothing query) + pure (total + weightSum) + ) + 0 diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Intersection.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Intersection.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Intersection.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DataKinds #-} + +-- | Corridor-walk lanes, their inputs, and their gates. +module Moonlight.Triangulation.Bench.SpadeCompare.Intersection where + +import Data.List (sortOn) +import Data.Word (Word64) +import System.FilePath (()) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.IntersectionIterator +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +-- | Query endpoints pulled inward. The generator fills [-1, 1]^2, so a point +-- with both coordinates inside [-0.5, 0.5] is strictly inside the hull of a +-- few thousand of them and locating it lands on a face. A chord that starts +-- OUTSIDE the hull takes a different route on each side — spade walks the hull +-- from the located hull edge while this side falls back to a scan over every +-- element — so those chords are the "intersection-outside" cliff lane and are +-- kept out of this one deliberately. +interiorQueryPoints :: Word64 -> Int -> [Point] +interiorQueryPoints seed count = + [Point (0.5 * x) (0.5 * y) | Point x y <- randomPoints seed count] + +-- | Query origins pushed well clear of the hull, so locating one is certain to +-- report the outside of the convex hull rather than a face. +exteriorQueryPoints :: Word64 -> Int -> [Point] +exteriorQueryPoints seed count = + [Point (4 * x) (4 * y) | Point x y <- randomPoints seed count] + +intersectionChords :: Int -> [(Point, Point)] +intersectionChords queryCount = + zip + (interiorQueryPoints 0x3141592653589793 queryCount) + (interiorQueryPoints 0x2718281828459045 queryCount) + +outsideChords :: Int -> [(Point, Point)] +outsideChords queryCount = + zip + (exteriorQueryPoints 0x243f6a8885a308d3 queryCount) + (interiorQueryPoints 0x2718281828459045 queryCount) + +-- | One line per query: the line's own endpoints, then its intersection +-- sequence in the order the walk reports it. Every branch of the walk turns on +-- an orientation predicate over a mesh that already agrees bit for bit, so the +-- whole sequence is exactly determined and crosses implementations — order +-- included, which is why nothing here is sorted. +writeIntersectionGate :: FilePath -> Int -> Int -> IO () +writeIntersectionGate directory pointCount queryCount = do + triangulation <- delaunayOf pointCount + chords <- requireQueryChords (intersectionChords queryCount) + writeFile + (directory ("intersection-" <> show pointCount <> "-" <> show queryCount <> "-chords.txt")) + (unlines (map (intersectionLine triangulation) chords)) + +writeIntersectionOutsideGate :: FilePath -> Int -> Int -> IO () +writeIntersectionOutsideGate directory pointCount queryCount = do + triangulation <- delaunayOf pointCount + chords <- requireQueryChords (outsideChords queryCount) + writeFile + ( directory + ("intersection-outside-" <> show pointCount <> "-" <> show queryCount <> ".txt") + ) + (unlines (map (intersectionLine triangulation) chords)) + +-- | Lines whose endpoints are mesh vertices, which is the only way to reach the +-- vertex and overlap branches of the walk at all: over generated doubles no +-- chord lands exactly on a site, so a gate built from chords alone exercises +-- one branch of three. The first family joins vertices the constraint +-- generator's index pairs select, which starts and ends the walk on a vertex; +-- the second runs along an existing edge, which is the only shape that produces +-- an overlap. Both name their endpoints by coordinate, the second from a list +-- both sides sort by the same encoding, because vertex handles do not cross. +writeIntersectionVertexGate :: FilePath -> Int -> IO () +writeIntersectionVertexGate directory pointCount = do + triangulation <- delaunayOf pointCount + let sites = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount) + joins = + [ (sites V.! fromIndex, sites V.! toIndex) + | (fromIndex, toIndex) <- constraintPairs pointCount intersectionVertexLines + ] + alongEdges = take intersectionVertexLines (sortedEdgeEndpoints triangulation) + queryLines <- requireQueryChords (joins <> alongEdges) + writeFile + (directory ("intersection-vertexlines-" <> show pointCount <> ".txt")) + (unlines (map (intersectionLine triangulation) queryLines)) + +intersectionVertexLines :: Int +intersectionVertexLines = 100 + +sortedEdgeEndpoints + :: DelaunayTriangulation Point + -> [(Point, Point)] +sortedEdgeEndpoints triangulation = + map snd + ( sortOn + fst + [ (coordHex first <> coordHex second, (first, second)) + | edge <- undirectedEdges triangulation + , let (from, to) = undirectedEndpoints triangulation edge + p = vertexPoint triangulation from + q = vertexPoint triangulation to + (first, second) = if pointKey p <= pointKey q then (p, q) else (q, p) + ] + ) + where + pointKey (Point x y) = (x, y) + +intersectionLine + :: DelaunayTriangulation Point + -> (QueryPoint, QueryPoint) + -> String +intersectionLine triangulation (from, to) = + coordHex (queryPointValue from) + <> coordHex (queryPointValue to) + <> concatMap (encodeIntersection triangulation) (lineIntersections triangulation from to) + +encodeIntersection + :: DelaunayTriangulation Point + -> Intersection + -> String +encodeIntersection triangulation event = case event of + VertexIntersection vertex -> "V" <> coordHex (vertexPoint triangulation vertex) + EdgeIntersection edge -> "E" <> directedHex edge + EdgeOverlap edge -> "O" <> directedHex edge + where + directedHex edge = + coordHex (vertexPoint triangulation (origin triangulation edge)) + <> coordHex (vertexPoint triangulation (destination triangulation edge)) + +-- | The corridor walk, counted. 'lineIntersections' materializes its answer, so +-- forcing the spine forces every step that produced it; spade's iterator is +-- lazy and is consumed by the same count. +intersectionWalk + :: DelaunayTriangulation Point + -> [(QueryPoint, QueryPoint)] + -> Int +intersectionWalk triangulation = + foldl' (\total (from, to) -> total + length (lineIntersections triangulation from to)) 0 diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Lane.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Lane.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Lane.hs @@ -0,0 +1,302 @@ +-- | The closed comparison vocabulary and its boundary projections. +-- +-- The driver executes these requests, the report orders and names them, and +-- the Haskell runner interprets their command constructors. None of those +-- boundaries authors another lane universe. +module Moonlight.Triangulation.Bench.SpadeCompare.Lane + ( LaneClass (..) + , LaneKind (..) + , LaneRequest (..) + , LaneObstruction (..) + , laneKindName + , laneRequestLabel + , parseLaneRequest + , renderInventoryCsv + , renderInventoryHuman + , renderLaneSpecs + , renderLaneObstruction + , renderSnapshotSpecs + ) where + +import Data.List (find, intercalate) +import Text.Read (readMaybe) + +data LaneClass + = ParityLane + | CliffLane + deriving stock (Eq, Show) + +-- | Every benchmark command understood by the Moonlight runner. The board is +-- a closed subset of this vocabulary; the remaining constructors are focused +-- diagnostics rather than Spade comparison rows. +data LaneKind + = BulkLoadLane + | IncrementalLane + | SnapshotInsertLane + | SweepAngleCollapseLane + | DegenerateLineLane + | BatchSweepLane + | NearestLane + | CdtRecoveryLane + | ConstraintIncrementalLane + | ConstraintSplitLane + | PublicationFloorLane + | RemovalLane + | SnapshotRemovalLane + | HierarchyIncrementalLane + | HierarchyDuplicateLane + | HierarchyRemovalLane + | HierarchyRemovalOnlyLane + | HierarchyRebuildOnlyLane + | InterpolationLane + | VoronoiSweepLane + | DcelWalkLane + | AlphaPersistenceLane + | IntersectionLane + | IntersectionOutsideLane + | RefineLane + deriving stock (Bounded, Enum, Eq, Show) + +data LaneRequest = LaneRequest + { laneRequestKind :: !LaneKind + , laneRequestFirst :: !Int + , laneRequestSecond :: !Int + } + deriving stock (Eq, Show) + +data LaneObstruction + = UnknownLane !String + | UnknownLaneClass !String + | MalformedWorkSize !String + | NegativeWorkSize !Int + | AlphaPersistenceRequiresSpecializedRunner + deriving stock (Eq, Show) + +data LaneSpec = LaneSpec + { laneSpecClass :: !LaneClass + , laneSpecRequest :: !LaneRequest + , laneSpecDisplay :: !String + } + +data SnapshotStressSpec = SnapshotStressSpec + { snapshotSessionRequest :: !LaneRequest + , snapshotPublicationRequest :: !LaneRequest + , snapshotDisplay :: !String + } + +laneKindName :: LaneKind -> String +laneKindName = \case + BulkLoadLane -> "bulk-load" + IncrementalLane -> "incremental" + SnapshotInsertLane -> "snapshot-insert" + SweepAngleCollapseLane -> "sweep-angle-collapse" + DegenerateLineLane -> "degenerate-line" + BatchSweepLane -> "batch-sweep" + NearestLane -> "nearest" + CdtRecoveryLane -> "cdt-recovery" + ConstraintIncrementalLane -> "constraint-incremental" + ConstraintSplitLane -> "constraint-split" + PublicationFloorLane -> "publication-floor" + RemovalLane -> "removal" + SnapshotRemovalLane -> "snapshot-removal" + HierarchyIncrementalLane -> "hierarchy-incremental" + HierarchyDuplicateLane -> "hierarchy-duplicate" + HierarchyRemovalLane -> "hierarchy-removal" + HierarchyRemovalOnlyLane -> "hierarchy-removal-only" + HierarchyRebuildOnlyLane -> "hierarchy-rebuild-only" + InterpolationLane -> "interpolation" + VoronoiSweepLane -> "voronoi-sweep" + DcelWalkLane -> "dcel-walk" + AlphaPersistenceLane -> "alpha-persistence" + IntersectionLane -> "intersection" + IntersectionOutsideLane -> "intersection-outside" + RefineLane -> "refine" + +laneRequestLabel :: LaneRequest -> String +laneRequestLabel request = + intercalate + "-" + [ laneKindName (laneRequestKind request) + , show (laneRequestFirst request) + , show (laneRequestSecond request) + ] + +parseLaneRequest :: String -> String -> String -> Either LaneObstruction LaneRequest +parseLaneRequest rawKind rawFirst rawSecond = + LaneRequest + <$> parseLaneKind rawKind + <*> parseWorkSize rawFirst + <*> parseWorkSize rawSecond + +renderLaneObstruction :: LaneObstruction -> String +renderLaneObstruction = \case + UnknownLane lane -> "unknown benchmark lane: " <> lane + UnknownLaneClass laneClass -> "unknown benchmark lane class: " <> laneClass + MalformedWorkSize raw -> "benchmark work size is not an integer: " <> raw + NegativeWorkSize size -> "benchmark work size is negative: " <> show size + AlphaPersistenceRequiresSpecializedRunner -> + "alpha-persistence is owned by moonlight-triangulation-alpha-spade-referent" + +renderInventoryCsv :: String +renderInventoryCsv = + unlines + ( fmap renderBoardLane boardLaneSpecs + <> fmap renderSnapshotLane snapshotStressSpecs + ) + where + renderBoardLane specification = + csvRow + [ "lane" + , laneClassName (laneSpecClass specification) + , laneRequestLabel (laneSpecRequest specification) + , laneSpecDisplay specification + ] + + renderSnapshotLane specification = + csvRow + [ "lane" + , "snapshot" + , laneRequestLabel (snapshotPublicationRequest specification) + , snapshotDisplay specification + , laneRequestLabel (snapshotSessionRequest specification) + ] + +renderInventoryHuman :: String +renderInventoryHuman = + concatMap renderClass [ParityLane, CliffLane] + <> "snapshot lanes (" + <> show (length snapshotStressSpecs) + <> ")\n" + <> concatMap renderSnapshot snapshotStressSpecs + where + renderClass laneClass = + let specifications = laneSpecs laneClass + in laneClassName laneClass + <> " lanes (" + <> show (length specifications) + <> ")\n" + <> concatMap + ((<> "\n") . (" " <>) . laneRequestLabel . laneSpecRequest) + specifications + + renderSnapshot specification = + " " + <> laneRequestLabel (snapshotPublicationRequest specification) + <> " against " + <> laneRequestLabel (snapshotSessionRequest specification) + <> "\n" + +renderLaneSpecs :: String -> Either LaneObstruction String +renderLaneSpecs rawClass = + unlines . fmap (renderRequestWords . laneSpecRequest) . laneSpecs + <$> parseLaneClass rawClass + +renderSnapshotSpecs :: String +renderSnapshotSpecs = + unlines + ( fmap + ( \specification -> + renderRequestWords (snapshotSessionRequest specification) + <> " " + <> renderRequestWords (snapshotPublicationRequest specification) + ) + snapshotStressSpecs + ) + +parseLaneKind :: String -> Either LaneObstruction LaneKind +parseLaneKind raw = + maybe + (Left (UnknownLane raw)) + Right + (find ((== raw) . laneKindName) [minBound .. maxBound]) + +parseLaneClass :: String -> Either LaneObstruction LaneClass +parseLaneClass = \case + "parity" -> Right ParityLane + "cliff" -> Right CliffLane + other -> Left (UnknownLaneClass other) + +parseWorkSize :: String -> Either LaneObstruction Int +parseWorkSize raw = + maybe + (Left (MalformedWorkSize raw)) + (\size -> if size < 0 then Left (NegativeWorkSize size) else Right size) + (readMaybe raw) + +laneClassName :: LaneClass -> String +laneClassName = \case + ParityLane -> "parity" + CliffLane -> "cliff" + +laneSpecs :: LaneClass -> [LaneSpec] +laneSpecs laneClass = filter ((== laneClass) . laneSpecClass) boardLaneSpecs + +renderRequestWords :: LaneRequest -> String +renderRequestWords request = + unwords + [ laneKindName (laneRequestKind request) + , show (laneRequestFirst request) + , show (laneRequestSecond request) + ] + +csvRow :: [String] -> String +csvRow = intercalate "," . fmap csvField + +csvField :: String -> String +csvField field + | any (`elem` [',', '"', '\n', '\r']) field = + '"' : concatMap escapeQuote field <> "\"" + | otherwise = field + where + escapeQuote '"' = "\"\"" + escapeQuote character = [character] + +boardLaneSpecs :: [LaneSpec] +boardLaneSpecs = + [ parity BulkLoadLane 1000 0 "Bulk load, 1k points" + , parity BulkLoadLane 10000 0 "Bulk load, 10k" + , parity IncrementalLane 1000 0 "Incremental insert, 1k" + , parity IncrementalLane 10000 0 "Incremental insert, 10k" + , parity IncrementalLane 500000 0 "Incremental insert, 500k" + , parity NearestLane 20000 5000 "Nearest, 5k queries / 20k points" + , parity CdtRecoveryLane 8000 800 "CDT recovery, 800 / 8k" + , parity RefineLane 625 0 "Refinement, 625 Steiner" + , parity RefineLane 2500 0 "Refinement, 2,500 Steiner" + , parity RemovalLane 1000 250 "Removal, 250 / 1k" + , parity RemovalLane 10000 2500 "Removal, 2.5k / 10k" + , parity RemovalLane 100000 25000 "Removal, 25k / 100k" + , parity InterpolationLane 10000 1000 "Interpolation, 1k queries / 10k" + , parity InterpolationLane 100000 2000 "Interpolation, 2k queries / 100k" + , parity VoronoiSweepLane 1000 0 "Voronoi dual sweep, 1k sites" + , parity DcelWalkLane 2000 0 "DCEL traversal, 2k points" + , parity IntersectionLane 10000 500 "Line intersection, 500 chords / 10k" + , cliff ConstraintIncrementalLane 8000 800 "Constraint one at a time, 800 / 8k" + , cliff ConstraintSplitLane 1000 0 "Constraint split, 1k crossings" + -- This deliberately stays at 1k while its parity twin also reaches 10k. + , cliff HierarchyIncrementalLane 1000 0 "Hierarchy insert, 1k" + , cliff HierarchyDuplicateLane 10000 500 "Hierarchy duplicate insert, 500 / 10k" + , cliff HierarchyRemovalLane 10000 250 "Hierarchy removal, 250 / 10k" + , cliff SweepAngleCollapseLane 2000 0 "Sweep hull index at one angle, 2k" + , cliff DegenerateLineLane 2000 0 "Exactly collinear load, face-less locate, 2k" + , cliff IntersectionOutsideLane 2000 100 "Line intersection from outside the hull, 100 / 2k" + ] + where + parity :: LaneKind -> Int -> Int -> String -> LaneSpec + parity kind first second display = + LaneSpec ParityLane (LaneRequest kind first second) display + + cliff :: LaneKind -> Int -> Int -> String -> LaneSpec + cliff kind first second display = + LaneSpec CliffLane (LaneRequest kind first second) display + +snapshotStressSpecs :: [SnapshotStressSpec] +snapshotStressSpecs = + [ SnapshotStressSpec + (LaneRequest IncrementalLane 1000 0) + (LaneRequest SnapshotInsertLane 1000 0) + "Insert snapshots, 1k points" + , SnapshotStressSpec + (LaneRequest RemovalLane 10000 2500) + (LaneRequest SnapshotRemovalLane 10000 2500) + "Removal snapshots, 2.5k / 10k" + ] diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Removal.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Removal.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Removal.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE DataKinds #-} + +-- | Removal lanes, their gates, and the removal diagnostics. +module Moonlight.Triangulation.Bench.SpadeCompare.Removal where + +import Control.Monad (when) +import Data.Foldable (traverse_) +import Data.List (sortOn) +import System.Exit (exitWith, ExitCode (ExitFailure)) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Removal +import Moonlight.Triangulation.Session +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Bench.SpadeCompare.Support +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) + +-- | The removal gate: a deterministic prefix of the input, removed by +-- coordinate, and the surviving canonical edge set. Delaunay triangulations +-- of point sets in general position are unique, so the survivor is forced +-- and both implementations must agree bit-for-bit. +writeRemovalGate :: FilePath -> Int -> Int -> IO () +writeRemovalGate directory pointCount removalCount = do + let points = randomPoints 0x9e3779b97f4a7c15 pointCount + triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList points)) + surviving <- removeAllByCoordinate triangulation (V.fromList (take removalCount points)) + writeFile + (directory ("removal-" <> show pointCount <> "-" <> show removalCount <> "-edges.txt")) + (unlines (canonicalEdges surviving)) + +-- | Remove vertices by coordinate inside one session: one O(n) dense thaw and +-- publication for the whole program, then O(degree) topology work per removal. +-- The snapshot 'locateAndRemove' fold pays that O(n) boundary per removal. +removeAllByCoordinate + :: DelaunayTriangulation Point + -> V.Vector Point + -> IO (DelaunayTriangulation Point) +removeAllByCoordinate triangulation removals = + case withSession triangulation 0 (removeManyAt removals) of + Left refusal -> fail (show refusal) + Right (outcomes, surviving, _) -> do + V.imapM_ checkRemoved outcomes + pure surviving + where + checkRemoved index outcome = case outcome of + Nothing -> + error + ( "removal target is not a vertex: index=" + <> show index + <> " point=" + <> ( case removals V.! index of + Point x y -> hex64 x <> "," <> hex64 y + ) + ) + Just _ -> pure () + +-- | Removal by coordinate through the persistent entry point: a thaw and a +-- publication per removal, against the session fold's one of each for the whole +-- program. Same removals, same order, same survivor — only the price differs. +removeAllPersistently + :: DelaunayTriangulation Point + -> V.Vector Point + -> IO (DelaunayTriangulation Point) +removeAllPersistently = + V.foldM' + (\current point -> do + outcome <- require (locateAndRemove current point) + case outcome of + Nothing -> fail ("removal target is not a vertex: " <> pointHex point) + Just result -> pure (removalTriangulation result) + ) + +writePersistentRemovalGate :: FilePath -> Int -> Int -> IO () +writePersistentRemovalGate directory pointCount removalCount = do + let points = randomPoints 0x9e3779b97f4a7c15 pointCount + base <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList points)) + surviving <- removeAllPersistently base (V.fromList (take removalCount points)) + writeFile + ( directory + ("persistent-removal-" <> show pointCount <> "-" <> show removalCount <> "-edges.txt") + ) + (unlines (canonicalEdges surviving)) + +-- | Removal audited against the one oracle that needs no second implementation: +-- the Delaunay triangulation of a point set in general position is unique, so +-- removing a prefix must leave exactly the triangulation a fresh bulk load of +-- the survivors produces. Reports the first removal at which that identity +-- breaks, so a divergence is dated rather than merely observed. +-- +-- Every removal also reports the handle swap-compaction relocated into the +-- freed slot, and that handle is the caller's only re-anchor after a removal +-- invalidates the rest. An out-of-range or misnamed handle is invisible to the +-- edge-set oracle, so it is checked here against the vertex the mesh moved. +reportRemovalAudit :: Int -> Int -> IO () +reportRemovalAudit pointCount removalCount = do + let allPoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount) + base <- buildTriangulation <$> require (delaunay unitElementDefaults allPoints) + let step current index + | index >= removalCount = putStrLn ("clean-through " <> show removalCount) + | otherwise = + case allPoints V.!? index of + Nothing -> putStrLn ("input-exhausted-at-removal " <> show index) + Just point -> do + outcome <- require (locateAndRemove current point) + case outcome of + Nothing -> putStrLn ("located-nothing-at-removal " <> show index) + Just result -> do + let nextTriangulation = removalTriangulation result + movedPoint = + vertexPoint current (VertexId (fromIntegral (numVertices current - 1))) + case removalOutcomeSwap (removalOutcome result) of + Nothing + | vertexPoint current (VertexId (fromIntegral (numVertices current - 1))) /= point -> + putStrLn ("swap-handle-missing-at-removal " <> show index) + | otherwise -> pure () + Just (swappedIn@(VertexId rawSwappedIn), _) + | toInteger rawSwappedIn >= toInteger (numVertices nextTriangulation) -> + putStrLn + ( "swap-handle-out-of-range-at-removal " + <> show index + <> " handle=" + <> show rawSwappedIn + <> " vertices=" + <> show (numVertices nextTriangulation) + ) + | vertexPoint nextTriangulation swappedIn /= movedPoint -> + putStrLn + ( "swap-handle-misnamed-at-removal " + <> show index + <> " handle=" + <> show rawSwappedIn + ) + | otherwise -> pure () + fresh <- + buildTriangulation + <$> require (delaunay unitElementDefaults (V.drop (index + 1) allPoints)) + let removalEdges = canonicalEdges nextTriangulation + freshEdges = canonicalEdges fresh + if removalEdges == freshEdges + then step nextTriangulation (index + 1) + else do + let (onlyRemoval, onlyFresh) = sortedDifference removalEdges freshEdges + putStrLn ("diverged-at-removal " <> show index) + putStrLn + ( "removed-point " + <> case point of + Point x y -> hex64 x <> "," <> hex64 y + ) + putStrLn ("removal-vertices " <> show (numVertices nextTriangulation)) + putStrLn ("fresh-vertices " <> show (numVertices fresh)) + putStrLn ("removal-edges " <> show (length removalEdges)) + putStrLn ("fresh-edges " <> show (length freshEdges)) + putStrLn ("only-in-removal " <> show (length onlyRemoval)) + putStrLn ("only-in-fresh " <> show (length onlyFresh)) + let (invertedRemoval, illegalRemoval) = meshHealth nextTriangulation + (invertedFresh, illegalFresh) = meshHealth fresh + putStrLn ("removal-inverted-faces " <> show invertedRemoval) + putStrLn ("removal-illegal-half-edges " <> show illegalRemoval) + putStrLn ("fresh-inverted-faces " <> show invertedFresh) + putStrLn ("fresh-illegal-half-edges " <> show illegalFresh) + traverse_ (putStrLn . (" removal-only " <>)) (take 8 onlyRemoval) + traverse_ (putStrLn . (" fresh-only " <>)) (take 8 onlyFresh) + step base 0 + +-- | The geometry around one removal, reconstructed with public API only. For +-- an interior removal the cavity border is the cyclic link of the removed +-- vertex, and nothing but a drain flip can destroy one of those non-star +-- edges: cleanup removes only the star, and swap-remove touches only the +-- removed vertex. The reported hull predicate guards that interpretation. +-- The fan origin 'remeshRing' would pick is also public: 'collectOutgoing' +-- starts at the stored out-edge, so the origin is the destination of that +-- edge. +reportRemovalContext :: Int -> Int -> IO () +reportRemovalContext pointCount target = do + let allPoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount) + case allPoints V.!? target of + Nothing -> do + hPutStrLn stderr "removal-context: target index out of range" + exitWith (ExitFailure 2) + Just removedPoint -> do + base <- buildTriangulation <$> require (delaunay unitElementDefaults allPoints) + before <- removeAllByCoordinate base (V.take target allPoints) + after <- removeAllByCoordinate before (V.singleton removedPoint) + fresh <- buildTriangulation <$> require (delaunay unitElementDefaults (V.drop (target + 1) allPoints)) + lab <- buildTriangulation <$> require (delaunay unitElementDefaults (V.drop target allPoints)) + removedQuery <- require (mkQueryPoint removedPoint) + putStrLn ("lab-clean " <> show (canonicalEdges before == canonicalEdges lab)) + case locatePoint before removedQuery of + OnVertex removedVertex -> do + let ring = ringOf before removedVertex + ringPoints = map snd ring + ringMember point = any (== point) ringPoints + rOnHull = any (\(edge, _) -> incidentFace before edge == outerFace) ring + afterPairs = canonicalEdgePairs after + freshPairs = canonicalEdgePairs fresh + borderPairs = cyclicPairs ringPoints + destroyedBorder = [pair | pair <- borderPairs, not (any (== pair) afterPairs)] + removalOnly = [pair | pair <- afterPairs, not (any (== pair) freshPairs)] + freshOnly = [pair | pair <- freshPairs, not (any (== pair) afterPairs)] + putStrLn ("r-on-hull " <> show rOnHull) + putStrLn ("ring-size " <> show (length ringPoints)) + traverse_ + (\(index, (_, point)) -> putStrLn (" ring " <> show index <> " " <> pointHex point)) + (zip [(0 :: Int) ..] ring) + putStrLn ("border-edges-before " <> show (length borderPairs)) + putStrLn ("border-edges-destroyed " <> show (length destroyedBorder)) + traverse_ + (\(p, q) -> putStrLn (" destroyed " <> pointHex p <> " " <> pointHex q)) + destroyedBorder + case ringPoints of + [] -> putStrLn "fan-unavailable empty-ring" + fanOriginPoint : ringTail -> + if rOnHull + then putStrLn "fan-unavailable hull-removal" + else do + let fanOrientations = + zipWith3 + (\index p q -> (index, p, q, orient2d fanOriginPoint p q)) + [(1 :: Int) ..] + ringTail + (drop 1 ringTail) + fanCandidates = + zipWith3 + ( \(index, priorPoint) current following -> + ( index + , current + , orient2d priorPoint following fanOriginPoint == GT + && orient2d following priorPoint current == GT + , inCircle current fanOriginPoint priorPoint following + ) + ) + (zip [(2 :: Int) ..] ringTail) + (drop 1 ringTail) + (drop 2 ringTail) + putStrLn ("fan-origin " <> pointHex fanOriginPoint) + putStrLn + ( "fan-inverted " + <> show (length [() | (_, _, _, verdict) <- fanOrientations, verdict == LT]) + <> " of " + <> show (length fanOrientations) + ) + traverse_ + ( \(index, p, q, verdict) -> + when (verdict == LT) $ + putStrLn + ( " fan-inverted-at " + <> show index + <> " " + <> pointHex fanOriginPoint + <> " " + <> pointHex p + <> " " + <> pointHex q + ) + ) + fanOrientations + traverse_ + ( \(index, current, convex, circle) -> + putStrLn + ( " fan-candidate " + <> show index + <> " " + <> pointHex current + <> "->" + <> pointHex fanOriginPoint + <> " convex=" + <> show convex + <> " incircle=" + <> show circle + ) + ) + fanCandidates + putStrLn ("only-in-removal " <> show (length removalOnly)) + traverse_ + ( \(p, q) -> + putStrLn + ( " removal-only " + <> pointHex p + <> " " + <> pointHex q + <> " ring=" + <> show (ringMember p, ringMember q) + ) + ) + removalOnly + putStrLn ("only-in-fresh " <> show (length freshOnly)) + traverse_ + ( \(p, q) -> + putStrLn + ( " fresh-only " + <> pointHex p + <> " " + <> pointHex q + <> " ring=" + <> show (ringMember p, ringMember q) + ) + ) + freshOnly + let inverted = invertedFaces after + putStrLn ("inverted-faces " <> show (length inverted)) + traverse_ + ( \(p, q, r) -> + putStrLn + ( " inverted-face " + <> pointHex p + <> " " + <> pointHex q + <> " " + <> pointHex r + <> " ring=" + <> show (ringMember p, ringMember q, ringMember r) + ) + ) + inverted + other -> putStrLn ("locate-unexpected " <> show other) + where + ringOf triangulation vertex = + case vertexOutEdge triangulation vertex of + Nothing -> [] + Just start -> walk start start [] + where + walk start current acc = + let ringVertex = destination triangulation current + nextEdge = counterClockwise triangulation current + acc' = (current, vertexPoint triangulation ringVertex) : acc + in if nextEdge == start + then reverse acc' + else walk start nextEdge acc' + + cyclicPairs (first : second : rest) = + zipWith canonicalPair (first : second : rest) ((second : rest) ++ [first]) + cyclicPairs _ = [] + + canonicalEdgePairs triangulation = + sortOn + (\(p, q) -> (pointKey p, pointKey q)) + [ canonicalPair p q + | edge <- undirectedEdges triangulation + , let (from, to) = undirectedEndpoints triangulation edge + p = vertexPoint triangulation from + q = vertexPoint triangulation to + ] + + canonicalPair p q = + if pointKey p <= pointKey q then (p, q) else (q, p) + + pointKey (Point x y) = (x, y) + + invertedFaces triangulation = + [ (vertexPoint triangulation a, vertexPoint triangulation b, vertexPoint triangulation c) + | face <- innerFaces triangulation + , Just (a, b, c) <- [innerFaceVertices triangulation face] + , orient2d + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + == LT + ] + +-- | Two independent health measures, which together decide what a divergence +-- means. Delaunay's theorem says a /valid/ triangulation with no locally +-- illegal edge is globally Delaunay — so a mesh that differs from the fresh +-- build while carrying no illegal edge cannot be a valid triangulation, and +-- one carrying illegal edges was simply left under-legalized. +meshHealth + :: Triangulation mode vertex directed undirected face + -> (Int, Int) +meshHealth triangulation = + ( length [() | face <- innerFaces triangulation, not (isCounterClockwise face)] + , length + [ () + | face <- innerFaces triangulation + , edge <- faceEdgeList face + , edgeIsIllegal edge + ] + ) + where + faceEdgeList face = case innerFaceDirectedEdges triangulation face of + Nothing -> [] + Just (e0, e1, e2) -> [e0, e1, e2] + + isCounterClockwise face = case innerFaceVertices triangulation face of + Nothing -> True + Just (a, b, c) -> + orient2d + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + == GT + + edgeIsIllegal edge = + let twin = reverseEdge edge + in incidentFace triangulation twin /= outerFace + && inCircle + (vertexPoint triangulation (origin triangulation edge)) + (vertexPoint triangulation (destination triangulation edge)) + (vertexPoint triangulation (destination triangulation (next triangulation edge))) + (vertexPoint triangulation (destination triangulation (next triangulation twin))) + == GT + +-- | The Delaunay triangulation of the survivors, built from scratch. Diffed +-- against a removal result it decides whether that result is the Delaunay +-- triangulation it is required to be. +writeFreshSuffix :: Int -> Int -> FilePath -> IO () +writeFreshSuffix pointCount dropped path = do + triangulation <- + buildTriangulation + <$> require + ( delaunay + unitElementDefaults + (V.drop dropped (V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount))) + ) + writeFile path (unlines (canonicalEdges triangulation)) + +-- | Symmetric difference of two ascending lists, by merge. +sortedDifference :: Ord a => [a] -> [a] -> ([a], [a]) +sortedDifference [] right = ([], right) +sortedDifference left [] = (left, []) +sortedDifference left@(l : ls) right@(r : rs) + | l == r = sortedDifference ls rs + | l < r = let (onlyLeft, onlyRight) = sortedDifference ls right in (l : onlyLeft, onlyRight) + | otherwise = let (onlyLeft, onlyRight) = sortedDifference left rs in (onlyLeft, r : onlyRight) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Support.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Support.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Support.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} + +-- | Input generation, canonical encoding, and the shared build helpers. +module Moonlight.Triangulation.Bench.SpadeCompare.Support where + +import Data.List (sort) +import Data.Word (Word64) +import GHC.Float (castDoubleToWord64) +import Numeric (showHex) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints) +import Moonlight.Triangulation.HintGenerator + +-- | The same generated points flattened onto a sliver a picometre thick. No +-- coordinate becomes equal to another and no four points become cocircular, so +-- the input stays in general position and the load stays on the ordinary +-- face-building path; what collapses is the angular spread the bulk loaders +-- index their hulls by. That collapse is the whole of what this input +-- measures, and it does not reach the face-less location path — that one needs +-- exact collinearity, which 'exactlyCollinearPoints' supplies and gates. +nearCollinearPoints :: Word64 -> Int -> [Point] +nearCollinearPoints seed count = + [Point x (y * 1.0e-12) | Point x y <- randomPoints seed count] + +-- | Points on one exact line: @(i, 0)@, every coordinate an integer that a +-- 'Double' holds exactly. No three are in general position, so 'orient2d' +-- returns an exact zero on both sides and no face is ever built. +-- +-- Uniqueness does not need general position, only one valid answer. A +-- collinear set admits exactly one triangulation — the chain of consecutive +-- segments, @n - 1@ of them and no triangle — so the canonical edge set is +-- fully determined and gates bit for bit against the strict side. Both +-- implementations state that same count as their own degenerate Euler +-- invariant, which is what makes this a shared answer rather than a +-- coincidence. +exactlyCollinearPoints :: Int -> [Point] +exactlyCollinearPoints count = [Point (fromIntegral index) 0 | index <- [0 .. count - 1]] + +hex64 :: Double -> String +hex64 value = + let raw = showHex (castDoubleToWord64 value) "" + in replicate (16 - length raw) '0' <> raw + +-- | Canonical edge set: each undirected edge as its two endpoint coordinates in +-- IEEE-754 bit patterns, endpoint-ordered then globally sorted. Formatting +-- cannot introduce a spurious disagreement and rounding cannot hide a real one. +canonicalEdges :: Triangulation mode vertex directed undirected face -> [String] +canonicalEdges triangulation = + sort + [ encodeCanonicalEdge first second + | edge <- undirectedEdges triangulation + , let (from, to) = undirectedEndpoints triangulation edge + p = vertexPoint triangulation from + q = vertexPoint triangulation to + (first, second) = if key p <= key q then (p, q) else (q, p) + ] + where + key (Point x y) = (x, y) + +canonicalConstraintEdges + :: ConstrainedDelaunayTriangulation vertex + -> [String] +canonicalConstraintEdges triangulation = + sort + [ encodeCanonicalEdge first second + | edge <- constraintEdges triangulation + , let (from, to) = undirectedEndpoints triangulation edge + p = vertexPoint triangulation from + q = vertexPoint triangulation to + (first, second) = + if pointKey p <= pointKey q + then (p, q) + else (q, p) + ] + where + pointKey (Point x y) = (x, y) + +encodeCanonicalEdge :: Point -> Point -> String +encodeCanonicalEdge (Point ax ay) (Point bx by) = + concatMap hex64 [ax, ay, bx, by] + +coordHex :: Point -> String +coordHex (Point x y) = hex64 x <> hex64 y + +-- | A cycle, rotated to begin at its smallest encoded element. +-- +-- Both implementations keep one entry edge per vertex and per face — whichever +-- their builder wrote last — so the two walk the same cycle from different +-- places. Rotating pins the order, which the mesh determines, and declines to +-- pin the starting point, which it does not. The rotation compares the encoded +-- strings rather than the coordinates so that both sides order by the same +-- comparison: the bit pattern of a negative double does not sort in numeric +-- order, so a Haskell 'Ord' on 'Point' and a Rust @partial_cmp@ on a tuple +-- would each have to be argued to agree where two byte strings simply do. +rotateToSmallest :: [String] -> [String] +rotateToSmallest [] = [] +rotateToSmallest ring = + let !smallest = minimum ring + (before, after) = break (== smallest) ring + in after <> before + +require :: Show failure => Either failure value -> IO value +require (Left failure) = fail (show failure) +require (Right value) = pure value + +requireQueryPoints + :: Traversable container + => container Point + -> IO (container QueryPoint) +requireQueryPoints = require . traverse mkQueryPoint + +requireQueryChords + :: Traversable container + => container (Point, Point) + -> IO (container (QueryPoint, QueryPoint)) +requireQueryChords = + require + . traverse + (\(from, to) -> (,) <$> mkQueryPoint from <*> mkQueryPoint to) + +delaunayOf :: Int -> IO (DelaunayTriangulation Point) +delaunayOf count = + buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x9e3779b97f4a7c15 count))) + +-- | One line per query: the coordinates of the nearest vertex the hierarchy +-- routed the search to, or @none@. +nearestAnswer + :: DelaunayTriangulation Point + -> HierarchyHint + -> QueryPoint + -> String +nearestAnswer triangulation hierarchy query = + let hint = case hierarchyHint hierarchy query of + Just (VertexHint vertex) -> Just vertex + _ -> Nothing + in case nearestNeighbor triangulation hint query of + Nothing -> "none" + Just (vertex, _) -> + let Point x y = vertexPoint triangulation vertex + in hex64 x <> hex64 y + +pointHex :: Point -> String +pointHex (Point x y) = hex64 x <> "," <> hex64 y + +constraintPairs :: Int -> Int -> [(Int, Int)] +constraintPairs pointCount constraintCount = + take constraintCount + [ (a, b) + | index <- [0 ..] + , let a = index `mod` pointCount + b = (index * 6151 + pointCount `quot` 2) `mod` pointCount + , a /= b + ] + +-- | A closed square with no dangling constraint. The interior segment used by +-- the package's own benchmark is outside spade's documented "closed shape" +-- contract and makes it refuse the whole domain — not a workload the two can be +-- timed on. +refinementInput :: (V.Vector Point, V.Vector (Int, Int)) +refinementInput = + ( V.fromList [Point 0 0, Point 64 0, Point 64 64, Point 0 64] + , V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)] + ) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Timing.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Timing.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Timing.hs @@ -0,0 +1,23 @@ +-- | The single fresh-process timing boundary shared by both Haskell runners. +module Moonlight.Triangulation.Bench.SpadeCompare.Timing + ( measureLane + ) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import GHC.Clock (getMonotonicTimeNSec) +import Moonlight.Triangulation.Bench.SpadeCompare.Lane + ( LaneRequest + , laneRequestLabel + ) +import System.Mem (performGC) + +-- | Time exactly one fully forced iteration. Input construction belongs to +-- each interpreter before this boundary; the driver supplies fresh processes. +measureLane :: NFData value => LaneRequest -> IO value -> IO () +measureLane request work = do + performGC + start <- getMonotonicTimeNSec + _ <- work >>= evaluate . force + stop <- getMonotonicTimeNSec + putStrLn (laneRequestLabel request <> "," <> show (stop - start)) diff --git a/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Voronoi.hs b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Voronoi.hs new file mode 100644 --- /dev/null +++ b/bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Voronoi.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} + +-- | The Voronoi dual gate and the dual sweep lane. +module Moonlight.Triangulation.Bench.SpadeCompare.Voronoi where + +import Data.List (sort) +import System.FilePath (()) +import Moonlight.Triangulation +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Voronoi +import Moonlight.Triangulation.Bench.SpadeCompare.Support + +-- | The dual, pinned by its combinatorics and by nothing else. +-- +-- Every verb the dual offers resolves a primal element, so its answers are +-- exact over a mesh the bulk-load gate already pins bit for bit. Voronoi vertex +-- POSITIONS are the exception and are deliberately absent from every artifact +-- here: a position is a circumcentre, and the two implementations do not form +-- one the same way. spade takes the reciprocal of the determinant and +-- multiplies by it; this side first rescales both difference vectors by their +-- largest component and only then divides. Each rounds where the other does +-- not, so the positions cannot be bit-identical, and a gate over them would be +-- grading the arithmetic rather than the dual. What IS determined about a +-- position is whether it exists at all, and the vertex artifact pins that. +-- +-- Direction vectors are pinned in full: each component is one subtraction of +-- two stored coordinates on both sides, so there is nothing left to round. +writeVoronoiGate :: FilePath -> Int -> IO () +writeVoronoiGate directory count = do + triangulation <- delaunayOf count + let prefix = directory ("voronoi-" <> show count) + writeFile + (prefix <> "-dual.txt") + (unlines (sort (map (dualEdgeRecord triangulation) (directedVoronoiEdges triangulation)))) + writeFile (prefix <> "-cells.txt") (unlines (voronoiCellLines triangulation)) + writeFile (prefix <> "-vertices.txt") (unlines (voronoiVertexLines triangulation)) + +-- | One directed dual edge: the primal edge it names, the site of the dual face +-- to its left, the dual vertex at each end, the destinations its dual @next@ +-- and @prev@ reach, and its direction vector. @next@ and @prev@ rotate about +-- the primal origin, so naming them by destination alone loses nothing. +dualEdgeRecord + :: DelaunayTriangulation Point + -> DirectedVoronoiEdgeId + -> String +dualEdgeRecord triangulation edge = + concat + [ coordHex (site (origin triangulation primal)) + , coordHex (site (destination triangulation primal)) + , coordHex (site (voronoiFaceSite (voronoiIncidentFace triangulation edge))) + , dualVertexName triangulation primal (voronoiFrom triangulation edge) + , dualVertexName triangulation primal (voronoiTo triangulation edge) + , coordHex (site (destination triangulation (asDelaunayDirectedEdge (voronoiNext triangulation edge)))) + , coordHex (site (destination triangulation (asDelaunayDirectedEdge (voronoiPrevious triangulation edge)))) + , coordHex (voronoiDirectionVector triangulation edge) + ] + where + primal = asDelaunayDirectedEdge edge + site = vertexPoint triangulation + +-- | An inner dual vertex named by the one corner of its dual face that is not +-- an endpoint of the edge the question was asked about — the record already +-- carries the other two, so the apex completes the face. An outer dual vertex +-- is the edge itself and needs no name. +-- +-- The @X@ tag cannot be reached: an inner dual vertex names an inner face by +-- construction, and 'innerFaceVertices' refuses only the outer one. spade +-- cannot emit it at all, its dual vertex carrying a face handle already typed +-- inner, so an @X@ appearing here is a disagreement rather than a crash. +dualVertexName + :: DelaunayTriangulation Point + -> DirectedEdgeId + -> VoronoiVertexId + -> String +dualVertexName _ _ (OuterVoronoiVertex _) = "O" +dualVertexName triangulation primal (InnerVoronoiVertex face) = + case innerFaceVertices triangulation face of + Nothing -> "X" + Just (a, b, c) + | isApex a -> named a + | isApex b -> named b + | otherwise -> named c + where + from = origin triangulation primal + to = destination triangulation primal + isApex vertex = vertex /= from && vertex /= to + named vertex = "I" <> coordHex (vertexPoint triangulation vertex) + +-- | The dual faces, one line each, plus the three enumerator lengths. The +-- undirected dual carries no artifact of its own: it is the primal undirected +-- edge set relabelled, which every existing edge gate already pins, so its +-- length is the only claim left to make about it. +voronoiCellLines :: DelaunayTriangulation Point -> [String] +voronoiCellLines triangulation = + [ "faces " <> show (length (voronoiFaces triangulation)) + , "directed " <> show (length (directedVoronoiEdges triangulation)) + , "undirected " <> show (length (undirectedVoronoiEdges triangulation)) + ] + <> sort + [ coordHex (vertexPoint triangulation (voronoiFaceSite face)) <> concat (rotateToSmallest ring) + | face <- voronoiFaces triangulation + , let ring = + [ coordHex + ( vertexPoint + triangulation + (destination triangulation (asDelaunayDirectedEdge edge)) + ) + | edge <- voronoiFaceAdjacentEdges triangulation face + ] + ] + +-- | The inner dual vertices, keyed by their dual face's three corners. Each +-- line carries whether the vertex has a position — the only exactly determined +-- thing about a circumcentre — and the outgoing triple the dual reports. +voronoiVertexLines :: DelaunayTriangulation Point -> [String] +voronoiVertexLines triangulation = + sort + [ concat (sort (map coordHex [site a, site b, site c])) + <> existence dual + <> concat (rotateToSmallest (outgoing dual)) + | face <- innerFaces triangulation + , Just (a, b, c) <- [innerFaceVertices triangulation face] + , let dual = InnerVoronoiVertex face + ] + where + site = vertexPoint triangulation + + existence dual = case voronoiVertexPosition triangulation dual of + Nothing -> "N" + Just _ -> "J" + + outgoing dual = case voronoiVertexOutgoingEdges triangulation dual of + Nothing -> [] + Just edges -> + [ coordHex (site (origin triangulation primal)) <> coordHex (site (destination triangulation primal)) + | edge <- edges + , let primal = asDelaunayDirectedEdge edge + ] + +-- | The whole dual, walked the way spade's own documentation walks it: every +-- dual face, its adjacent dual edges, and the dual vertex each of those runs +-- to. The position of an inner dual vertex is summed rather than merely +-- reached, because a 'Maybe' scrutinised only to its outer constructor can wrap +-- a thunk and the lane would then be timing the allocation of a circumcentre +-- instead of the circumcentre. Unbounded cells are counted, so a dual that +-- stopped classifying hull edges as outer moves the answer rather than the cost. +voronoiSweep :: DelaunayTriangulation Point -> (Double, Int) +voronoiSweep triangulation = foldl' overCell (0, 0) (voronoiFaces triangulation) + where + overCell accumulator face = + foldl' overEdge accumulator (voronoiFaceAdjacentEdges triangulation face) + + overEdge (!total, !unbounded) edge = + case voronoiVertexPosition triangulation (voronoiTo triangulation edge) of + Nothing -> (total, unbounded + 1) + Just (Point x y) -> (total + x + y, unbounded) diff --git a/bindings/README.md b/bindings/README.md deleted file mode 100644 --- a/bindings/README.md +++ /dev/null @@ -1,95 +0,0 @@ -# Foreign bindings - -`moonlight-triangulation.cabal` owns the private Haskell `ffi` sublibrary and -`moonlight-triangulation-c` foreign library. Python, TypeScript, and Rust are -thin lifecycle and bulk-layout leaves over that sole ABI; none implements -triangulation, overlay, publication, valuation, or morphology. - -From `compiler`, build and locate the shared library: - -```bash -../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`. - -## ABI version 2 - -Three opaque immutable carriers cross the boundary: - -- `ml_mesh` retains a binary64 Delaunay mesh. Its `ml_mesh_site_*` algebra - combines sites, not polygon interiors. -- `ml_region` retains the authoritative exact rational `PlanarRegion`. - `ml_region_create_f64` admits every input coordinate exactly as its binary64 - dyadic value in one call, using point counts per loop and loop counts per - component. The inverse bulk projection returns component/loop offsets and - binary64 rendering points; it does not replace the exact retained geometry. -- `ml_structuring_element` retains one admitted origin-containing convex - polygon for repeated offset, inset, opening, and closing calls. - -Region union, intersection, difference, and symmetric difference call the one -Haskell overlay and grouped-publication path. Point location is exact. A single -valuation call returns Euler characteristic, exact reduced area as -`numerator/denominator`, and certified conventional-perimeter bounds. Morphology -returns a new region plus the existing operation/work receipt. - -Every status-returning call accepts an optional `ml_obstruction` distinguishing -pointer/count/buffer failures from region layout, validation, overlay, -publication, valuation, projection, morphology, and runtime failures. Handles -remain valid until explicitly freed; every operation publishes a fresh output -handle. `ml_runtime_initialize` is idempotent and process-lifetime. - -Python and Rust owned handles are thread-affine: create, use, and close each -handle on one thread. This prevents explicit close from racing a foreign call -after the runtime has received the raw handle. - -Batch related mesh edits into one `insert_many` call. Author a whole region with -one component list; there is deliberately no mutable builder or per-vertex FFI -surface. - -## Python - -```python -from fractions import Fraction -from moonlight_triangulation import Moonlight, PolygonComponent - -moonlight = Moonlight() -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, 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, 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 deleted file mode 100644 --- a/bindings/python/pyproject.toml +++ /dev/null @@ -1,13 +0,0 @@ -[build-system] -requires = ["hatchling>=1.27,<2"] -build-backend = "hatchling.build" - -[project] -name = "moonlight-triangulation" -version = "2.0.0" -description = "Python bindings for Moonlight exact regions and immutable Delaunay meshes." -requires-python = ">=3.11" -license = { text = "MIT" } - -[tool.hatch.build.targets.wheel] -packages = ["src/moonlight_triangulation"] diff --git a/bindings/python/src/moonlight_triangulation/__init__.py b/bindings/python/src/moonlight_triangulation/__init__.py deleted file mode 100644 --- a/bindings/python/src/moonlight_triangulation/__init__.py +++ /dev/null @@ -1,632 +0,0 @@ -from __future__ import annotations - -import ctypes -import os -import weakref -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 threading import get_ident -from typing import Final, Self - - -class _Obstruction(ctypes.Structure): - _fields_ = [ - ("code", ctypes.c_uint32), - ("coordinate_error", ctypes.c_uint32), - ("input_index", ctypes.c_uint64), - ("first_index", ctypes.c_uint64), - ("second_index", ctypes.c_uint64), - ("first_value", ctypes.c_double), - ("second_value", ctypes.c_double), - ("point_x", ctypes.c_double), - ("point_y", ctypes.c_double), - ("message", ctypes.c_char * 256), - ] - - -class _NativeMinkowskiReceipt(ctypes.Structure): - _fields_ = [ - ("operation", ctypes.c_uint32), - ("reserved", ctypes.c_uint32), - ("input_components", ctypes.c_uint64), - ("convex_pieces", ctypes.c_uint64), - ("generated_pieces", ctypes.c_uint64), - ("generated_convolution_edges", ctypes.c_uint64), - ("overlay_passes", ctypes.c_uint64), - ("exact_crossings", ctypes.c_uint64), - ("output_cells", ctypes.c_uint64), - ("exact_coordinate_bit_growth", ctypes.c_uint64), - ] - - -class MoonlightError(RuntimeError): - def __init__(self, status: int, obstruction: _Obstruction) -> None: - self.status = status - self.code = obstruction.code - self.coordinate_error = obstruction.coordinate_error - self.input_index = obstruction.input_index - self.first_index = obstruction.first_index - self.second_index = obstruction.second_index - self.first_value = obstruction.first_value - self.second_value = obstruction.second_value - self.point = (obstruction.point_x, obstruction.point_y) - message = bytes(obstruction.message).split(b"\0", 1)[0].decode("utf-8", errors="replace") - super().__init__(message or f"Moonlight ABI failure {status}:{self.code}") - - -class _NativeApi: - _OK: Final = 0 - _ABI_VERSION: Final = 2 - - def __init__(self, library_path: Path) -> None: - library = ctypes.CDLL(str(library_path)) - 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, 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 != self._ABI_VERSION: - raise RuntimeError(f"unsupported Moonlight ABI version {abi_version}") - self.library = library - - def check(self, status: int, obstruction: _Obstruction) -> None: - if status != self._OK: - raise MoonlightError(status, obstruction) - - -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") - if configured_path is None: - raise ValueError("set MOONLIGHT_TRIANGULATION_LIBRARY or pass library_path") - self._native = _NativeApi(Path(configured_path)) - - def delaunay(self, points: Sequence[Point]) -> Mesh: - coordinates, pointer = _coordinate_buffer(points) - handle = _produce_handle( - self._native, - lambda output, obstruction: self._native.library.ml_delaunay_f64( - pointer, len(coordinates) // 2, output, obstruction - ), - ) - return Mesh(self._native, handle) - - def region(self, components: Sequence[PolygonComponent]) -> Region: - loops, loop_counts, component_counts = _component_layout(components) - coordinates, coordinate_pointer = _coordinate_buffer( - point for loop in loops for point in loop - ) - loop_buffer = _size_buffer(loop_counts) - component_buffer = _size_buffer(component_counts) - handle = _produce_handle( - self._native, - lambda output, obstruction: self._native.library.ml_region_create_f64( - coordinate_pointer, - len(coordinates) // 2, - loop_buffer, - len(loop_counts), - component_buffer, - len(component_counts), - output, - obstruction, - ), - ) - return Region(self._native, handle) - - def structuring_element(self, points: Sequence[Point]) -> StructuringElement: - coordinates, pointer = _coordinate_buffer(points) - handle = _produce_handle( - self._native, - lambda output, obstruction: self._native.library.ml_structuring_element_create_f64( - pointer, len(coordinates) // 2, output, obstruction - ), - ) - return StructuringElement(self._native, handle) - - -class _OwnedHandle: - __slots__ = ("_native", "_handle", "_finalizer", "_kind", "_owner_thread", "__weakref__") - - def __init__(self, native: _NativeApi, handle: ctypes.c_void_p, free: Callable[[ctypes.c_void_p], None], kind: str) -> None: - self._native = native - self._handle = handle - self._kind = kind - self._owner_thread = get_ident() - self._finalizer = weakref.finalize(self, free, handle) - - def close(self) -> None: - self._require_owner_thread() - self._finalizer() - self._handle = ctypes.c_void_p() - - 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: - self._require_owner_thread() - if not self._finalizer.alive: - raise RuntimeError(f"{self._kind} is closed") - return self._handle - - def _require_owner_thread(self) -> None: - if get_ident() != self._owner_thread: - raise RuntimeError(f"{self._kind} belongs to another thread") - - def _require_same_runtime(self, other: _OwnedHandle) -> None: - if self._native is not other._native: - raise ValueError("both values must belong to the same Moonlight runtime") - - -class Mesh(_OwnedHandle): - __slots__ = () - - def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: - super().__init__(native, handle, native.library.ml_mesh_free, "mesh") - - @property - def vertex_count(self) -> int: - return self._count(self._native.library.ml_mesh_vertex_count) - - @property - def triangle_count(self) -> int: - return self._count(self._native.library.ml_mesh_triangle_count) - - @property - def vertices(self) -> tuple[Point, ...]: - count = self.vertex_count - output = (ctypes.c_double * (count * 2))() - written = ctypes.c_size_t() - obstruction = _Obstruction() - status = int( - self._native.library.ml_mesh_copy_vertices_f64( - self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) - ) - ) - self._native.check(status, obstruction) - return tuple((float(output[index * 2]), float(output[index * 2 + 1])) for index in range(written.value)) - - @property - def triangles(self) -> tuple[Triangle, ...]: - count = self.triangle_count - output = (ctypes.c_uint32 * (count * 3))() - written = ctypes.c_size_t() - obstruction = _Obstruction() - status = int( - self._native.library.ml_mesh_copy_triangles_u32( - self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) - ) - ) - self._native.check(status, obstruction) - return tuple( - (int(output[index * 3]), int(output[index * 3 + 1]), int(output[index * 3 + 2])) - for index in range(written.value) - ) - - def insert_many(self, points: Sequence[Point]) -> Mesh: - coordinates, pointer = _coordinate_buffer(points) - handle = _produce_handle( - self._native, - lambda output, obstruction: self._native.library.ml_mesh_insert_many_f64( - self._live_handle(), pointer, len(coordinates) // 2, output, obstruction - ), - ) - return Mesh(self._native, handle) - - def site_union(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_site_union) - - def site_intersection(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_site_intersection) - - def site_difference(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_site_difference) - - def site_symmetric_difference(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_site_symmetric_difference) - - def _binary(self, other: Mesh, operation: _BinaryNativeOperation) -> Mesh: - self._require_same_runtime(other) - handle = _produce_handle( - 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_region_copy_f64( - self._live_handle(), - coordinates, - point_count, - loop_offsets, - loop_count + 1, - component_offsets, - component_count + 1, - ctypes.byref(obstruction), - ) - ) - self._native.check(status, obstruction) - points = tuple((float(coordinates[index * 2]), float(coordinates[index * 2 + 1])) for index in range(point_count)) - loops = tuple( - points[int(loop_offsets[index]) : int(loop_offsets[index + 1])] - for index in range(loop_count) - ) - component_ranges = tuple( - (int(component_offsets[index]), int(component_offsets[index + 1])) - for index in range(component_count) - ) - if any(start >= end for start, end in component_ranges): - raise RuntimeError("Moonlight returned a component without an outer loop") - return tuple( - PolygonComponent(loops[start], loops[start + 1 : end]) - for start, end in component_ranges - ) - - @property - def valuations(self) -> RegionValuations: - return self._measure_with_capacity(128) - - def locate(self, point: Point) -> RegionLocation: - output = ctypes.c_uint32() - obstruction = _Obstruction() - status = int( - self._native.library.ml_region_locate_point_f64( - self._live_handle(), point[0], point[1], ctypes.byref(output), ctypes.byref(obstruction) - ) - ) - self._native.check(status, obstruction) - return RegionLocation(output.value) - - def union(self, other: Region) -> Region: - return self._binary(other, self._native.library.ml_region_union) - - def intersection(self, other: Region) -> Region: - return self._binary(other, self._native.library.ml_region_intersection) - - def difference(self, other: Region) -> Region: - return self._binary(other, self._native.library.ml_region_difference) - - def symmetric_difference(self, other: Region) -> Region: - return self._binary(other, self._native.library.ml_region_symmetric_difference) - - def minkowski_sum(self, other: Region) -> tuple[Region, MinkowskiReceipt]: - self._require_same_runtime(other) - return self._morph( - lambda output, receipt, obstruction: self._native.library.ml_region_minkowski_sum( - self._live_handle(), other._live_handle(), output, receipt, obstruction - ) - ) - - def offset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: - return self._with_element(element, self._native.library.ml_region_offset) - - def inset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: - return self._with_element(element, self._native.library.ml_region_inset) - - def open(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: - return self._with_element(element, self._native.library.ml_region_open) - - def close_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( - self._native.library.ml_region_counts( - self._live_handle(), - ctypes.byref(component_count), - ctypes.byref(loop_count), - ctypes.byref(point_count), - ctypes.byref(obstruction), - ) - ) - self._native.check(status, obstruction) - return int(component_count.value), int(loop_count.value), int(point_count.value) - - def _measure_with_capacity(self, capacity: int) -> RegionValuations: - euler = ctypes.c_int64() - area = ctypes.create_string_buffer(capacity) - area_bytes = ctypes.c_size_t() - lower = ctypes.c_double() - upper = ctypes.c_double() - obstruction = _Obstruction() - status = int( - self._native.library.ml_region_measure( - self._live_handle(), - ctypes.byref(euler), - area, - capacity, - ctypes.byref(area_bytes), - ctypes.byref(lower), - ctypes.byref(upper), - ctypes.byref(obstruction), - ) - ) - if status == 3 and obstruction.code == 102: - return self._measure_with_capacity(int(area_bytes.value) + 1) - self._native.check(status, obstruction) - numerator, separator, denominator = area.value.decode("ascii").partition("/") - if separator != "/": - raise RuntimeError("Moonlight returned a malformed exact-area ratio") - return RegionValuations(int(euler.value), Fraction(int(numerator), int(denominator)), (lower.value, upper.value)) - - -class StructuringElement(_OwnedHandle): - __slots__ = () - - def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: - super().__init__(native, handle, native.library.ml_structuring_element_free, "structuring element") - - -def _component_layout( - components: Sequence[PolygonComponent], -) -> tuple[tuple[Sequence[Point], ...], tuple[int, ...], tuple[int, ...]]: - loops = tuple( - loop - for component in components - for loop in (component.outer, *component.holes) - ) - loop_counts = tuple(len(loop) for loop in loops) - component_counts = tuple(len(component.holes) + 1 for component in components) - return loops, loop_counts, component_counts - - -def _coordinate_buffer(points: Iterable[Point]) -> tuple[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 handle") - return handle - - -def _configure(library: ctypes.CDLL, name: str, parameters: Sequence[object], result: object = ctypes.c_uint32) -> None: - function = getattr(library, name) - setattr(function, "argtypes", list(parameters)) - setattr(function, "restype", result) - - -__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 deleted file mode 100644 --- a/bindings/python/tests/test_binding.py +++ /dev/null @@ -1,115 +0,0 @@ -from __future__ import annotations - -import math -import os -import unittest -from collections.abc import Sequence -from concurrent.futures import ThreadPoolExecutor -from fractions import Fraction -from typing import ClassVar - -from moonlight_triangulation import ( - MinkowskiOperation, - Moonlight, - MoonlightError, - PolygonComponent, - RegionLocation, -) - - -class LengthInflatingPoints(Sequence[tuple[float, float]]): - def __len__(self) -> int: - return 1_000 - - def __getitem__(self, index: int) -> tuple[float, float]: - if index == 0: - return (0.0, 0.0) - raise IndexError(index) - - -class MoonlightBindingTest(unittest.TestCase): - engine: ClassVar[Moonlight] - - @classmethod - def setUpClass(cls) -> None: - cls.engine = Moonlight(os.environ["MOONLIGHT_TRIANGULATION_LIBRARY"]) - - def test_immutable_site_set_algebra_and_dense_projection(self) -> None: - left = self.engine.delaunay([(0, 0), (2, 0), (0, 2), (2, 2)]) - right = self.engine.delaunay([(2, 0), (4, 0), (2, 2), (4, 2)]) - union = left.site_union(right) - intersection = left.site_intersection(right) - difference = left.site_difference(right) - symmetric = left.site_symmetric_difference(right) - extended = left.insert_many([(1, 1), (3, 1)]) - self.addCleanup(left.close) - self.addCleanup(right.close) - self.addCleanup(union.close) - self.addCleanup(intersection.close) - self.addCleanup(difference.close) - self.addCleanup(symmetric.close) - self.addCleanup(extended.close) - - self.assertEqual(left.vertex_count, 4) - self.assertEqual(union.vertex_count, 6) - self.assertEqual(intersection.vertex_count, 2) - self.assertEqual(difference.vertex_count, 2) - self.assertEqual(symmetric.vertex_count, 4) - self.assertEqual(extended.vertex_count, 6) - self.assertEqual(len(left.vertices), left.vertex_count) - self.assertEqual(len(left.triangles), left.triangle_count) - self.assertTrue(all(max(triangle) < left.vertex_count for triangle in left.triangles)) - - def test_exact_region_boolean_valuation_and_morphology(self) -> None: - left = self.engine.region([PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2)))]) - right = self.engine.region([PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2)))]) - intersection = left.intersection(right) - difference = left.difference(right) - symmetric = left.symmetric_difference(right) - kernel = self.engine.structuring_element(((-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5))) - offset, receipt = left.offset(kernel) - self.addCleanup(left.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: - self.engine.delaunay([(0, 0), (math.nan, 1), (1, 0)]) - self.assertEqual(raised.exception.status, 4) - self.assertEqual(raised.exception.code, 1) - self.assertEqual(raised.exception.coordinate_error, 1) - self.assertEqual(raised.exception.input_index, 1) - - def test_native_count_descends_from_materialized_coordinates(self) -> None: - mesh = self.engine.delaunay(LengthInflatingPoints()) - self.addCleanup(mesh.close) - self.assertEqual(mesh.vertex_count, 1) - - def test_owned_handles_are_thread_affine(self) -> None: - mesh = self.engine.delaunay([(0, 0), (1, 0), (0, 1)]) - self.addCleanup(mesh.close) - with ThreadPoolExecutor(max_workers=1) as executor: - foreign_access = executor.submit(lambda: mesh.vertex_count) - with self.assertRaisesRegex(RuntimeError, "belongs to another thread"): - foreign_access.result() - self.assertEqual(mesh.vertex_count, 3) - - -if __name__ == "__main__": - unittest.main() diff --git a/bindings/rust/Cargo.toml b/bindings/rust/Cargo.toml deleted file mode 100644 --- a/bindings/rust/Cargo.toml +++ /dev/null @@ -1,14 +0,0 @@ -[package] -name = "moonlight-triangulation" -version = "2.0.0" -edition = "2024" -license = "MIT" -description = "Rust bindings for Moonlight exact regions and immutable Delaunay meshes." -repository = "https://github.com/PaleRoses/moonlight.git" -build = "build.rs" -links = "moonlight-triangulation-c" - -[lib] -path = "src/lib.rs" - -[workspace] diff --git a/bindings/rust/build.rs b/bindings/rust/build.rs deleted file mode 100644 --- a/bindings/rust/build.rs +++ /dev/null @@ -1,11 +0,0 @@ -use std::env; - -fn main() { - println!("cargo:rerun-if-env-changed=MOONLIGHT_TRIANGULATION_LIB_DIR"); - if let Some(directory) = env::var_os("MOONLIGHT_TRIANGULATION_LIB_DIR") { - println!( - "cargo:rustc-link-search=native={}", - directory.to_string_lossy() - ); - } -} diff --git a/bindings/rust/src/lib.rs b/bindings/rust/src/lib.rs deleted file mode 100644 --- a/bindings/rust/src/lib.rs +++ /dev/null @@ -1,966 +0,0 @@ -use std::error::Error; -use std::ffi::{c_char, c_double, c_uint}; -use std::fmt::{Display, Formatter}; -use std::marker::PhantomData; -use std::ptr::NonNull; -use std::rc::Rc; - -const STATUS_OK: u32 = 0; -const STATUS_BUFFER_TOO_SMALL: u32 = 3; -const ABI_VERSION: u32 = 2; - -#[repr(C)] -struct NativeMesh { - _private: [u8; 0], -} - -#[repr(C)] -struct NativeRegion { - _private: [u8; 0], -} - -#[repr(C)] -struct NativeStructuringElement { - _private: [u8; 0], -} - -#[repr(C)] -struct NativeObstruction { - code: u32, - coordinate_error: u32, - input_index: u64, - first_index: u64, - second_index: u64, - first_value: f64, - second_value: f64, - point_x: f64, - point_y: f64, - message: [c_char; 256], -} - -impl Default for NativeObstruction { - fn default() -> Self { - Self { - code: 0, - coordinate_error: 0, - input_index: u64::MAX, - first_index: 0, - second_index: 0, - first_value: 0.0, - second_value: 0.0, - point_x: 0.0, - point_y: 0.0, - message: [0; 256], - } - } -} - -#[repr(C)] -#[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; - fn ml_runtime_initialize() -> c_uint; - fn ml_delaunay_f64( - coordinates: *const c_double, - point_count: usize, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_insert_many_f64( - mesh: *const NativeMesh, - coordinates: *const c_double, - point_count: usize, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_site_union( - left: *const NativeMesh, - right: *const NativeMesh, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_site_intersection( - left: *const NativeMesh, - right: *const NativeMesh, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_site_difference( - left: *const NativeMesh, - right: *const NativeMesh, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_site_symmetric_difference( - left: *const NativeMesh, - right: *const NativeMesh, - result: *mut *mut NativeMesh, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_vertex_count( - mesh: *const NativeMesh, - count: *mut usize, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_triangle_count( - mesh: *const NativeMesh, - count: *mut usize, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_copy_vertices_f64( - mesh: *const NativeMesh, - coordinates: *mut c_double, - point_capacity: usize, - points_written: *mut usize, - obstruction: *mut NativeObstruction, - ) -> c_uint; - fn ml_mesh_copy_triangles_u32( - mesh: *const NativeMesh, - triangles: *mut u32, - triangle_capacity: usize, - triangles_written: *mut usize, - 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( - *const NativeMesh, - *const NativeMesh, - *mut *mut NativeMesh, - *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, - pub code: u32, - pub coordinate_error: u32, - pub input_index: u64, - pub first_index: u64, - pub second_index: u64, - pub first_value: f64, - pub second_value: f64, - pub point: [f64; 2], - pub message: String, -} - -impl Display for MoonlightError { - fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result { - write!(formatter, "{}", self.message) - } -} - -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 { - pub fn initialize() -> Result { - let status = unsafe { ml_runtime_initialize() }; - if status != STATUS_OK { - return Err(synthetic_error( - status, - "Moonlight runtime initialization failed", - 0, - 0, - )); - } - let version = unsafe { ml_abi_version() }; - if version != ABI_VERSION { - return Err(synthetic_error( - 5, - format!("unsupported Moonlight ABI version {version}"), - u64::from(version), - u64::from(ABI_VERSION), - )); - } - Ok(Self) - } - - pub fn delaunay(&self, points: &[[f64; 2]]) -> Result { - let coordinates = flatten_points(points); - create_handle(|output, obstruction| unsafe { - ml_delaunay_f64(coordinates.as_ptr(), points.len(), output, obstruction) - }) - .map(Mesh::from_handle) - } - - pub fn region(&self, components: &[PolygonComponent]) -> Result { - 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 { - handle: NonNull, - _thread_affinity: PhantomData>, -} - -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) - } - - pub fn triangle_count(&self) -> Result { - self.count(ml_mesh_triangle_count) - } - - pub fn vertices(&self) -> Result, MoonlightError> { - let count = self.vertex_count()?; - let mut coordinates = vec![0.0; count * 2]; - let mut written = 0; - let mut obstruction = NativeObstruction::default(); - let status = unsafe { - ml_mesh_copy_vertices_f64( - self.handle.as_ptr(), - coordinates.as_mut_ptr(), - count, - &mut written, - &mut obstruction, - ) - }; - status_result(status, obstruction)?; - coordinates.truncate(written * 2); - coordinate_pairs(&coordinates) - } - - pub fn triangles(&self) -> Result, MoonlightError> { - let count = self.triangle_count()?; - let mut triangles = vec![0; count * 3]; - let mut written = 0; - let mut obstruction = NativeObstruction::default(); - let status = unsafe { - ml_mesh_copy_triangles_u32( - self.handle.as_ptr(), - triangles.as_mut_ptr(), - count, - &mut written, - &mut obstruction, - ) - }; - status_result(status, obstruction)?; - triangles.truncate(written * 3); - triangles - .chunks_exact(3) - .map(|triangle| { - Ok([ - *triangle.first().ok_or_else(projection_shape_error)?, - *triangle.get(1).ok_or_else(projection_shape_error)?, - *triangle.get(2).ok_or_else(projection_shape_error)?, - ]) - }) - .collect() - } - - pub fn insert_many(&self, points: &[[f64; 2]]) -> Result { - let coordinates = flatten_points(points); - create_handle(|output, obstruction| unsafe { - ml_mesh_insert_many_f64( - self.handle.as_ptr(), - coordinates.as_ptr(), - points.len(), - output, - obstruction, - ) - }) - .map(Self::from_handle) - } - - pub fn site_union(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_site_union) - } - - pub fn site_intersection(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_site_intersection) - } - - pub fn site_difference(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_site_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_handle(|output, obstruction| unsafe { - operation( - self.handle.as_ptr(), - other.handle.as_ptr(), - output, - obstruction, - ) - }) - .map(Self::from_handle) - } - - fn count( - &self, - operation: unsafe extern "C" fn( - *const NativeMesh, - *mut usize, - *mut NativeObstruction, - ) -> c_uint, - ) -> Result { - let mut count = 0; - let mut obstruction = NativeObstruction::default(); - let status = unsafe { operation(self.handle.as_ptr(), &mut count, &mut obstruction) }; - status_result(status, obstruction)?; - Ok(count) - } -} - -impl Drop for Mesh { - fn drop(&mut self) { - unsafe { ml_mesh_free(self.handle.as_ptr()) } - } -} - -pub struct Region { - handle: NonNull, - _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() -} - -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).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(()) - } else { - Err(MoonlightError::from_native(status, obstruction)) - } -} - -impl MoonlightError { - fn from_native(status: u32, obstruction: NativeObstruction) -> Self { - let message_end = obstruction - .message - .iter() - .position(|character| *character == 0) - .unwrap_or(obstruction.message.len()); - let message_bytes = obstruction - .message - .get(..message_end) - .unwrap_or_default() - .iter() - .map(|character| *character as u8) - .collect::>(); - Self { - status, - code: obstruction.code, - coordinate_error: obstruction.coordinate_error, - input_index: obstruction.input_index, - first_index: obstruction.first_index, - second_index: obstruction.second_index, - first_value: obstruction.first_value, - second_value: obstruction.second_value, - point: [obstruction.point_x, obstruction.point_y], - message: String::from_utf8_lossy(&message_bytes).into_owned(), - } - } -} - -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 handle", 0, 0) -} - -fn synthetic_error( - status: u32, - message: impl Into, - first_index: u64, - second_index: u64, -) -> MoonlightError { - MoonlightError { - status, - code: 103, - coordinate_error: 0, - input_index: u64::MAX, - first_index, - second_index, - first_value: 0.0, - second_value: 0.0, - point: [0.0, 0.0], - message: message.into(), - } -} diff --git a/bindings/rust/tests/binding.rs b/bindings/rust/tests/binding.rs deleted file mode 100644 --- a/bindings/rust/tests/binding.rs +++ /dev/null @@ -1,116 +0,0 @@ -use moonlight_triangulation::{ - ExactRational, MinkowskiOperation, Moonlight, PolygonComponent, RegionLocation, -}; - -#[test] -fn immutable_site_set_algebra_and_dense_projection() { - let engine = Moonlight::initialize().expect("runtime"); - let left = engine - .delaunay(&[[0.0, 0.0], [2.0, 0.0], [0.0, 2.0], [2.0, 2.0]]) - .expect("left mesh"); - let right = engine - .delaunay(&[[2.0, 0.0], [4.0, 0.0], [2.0, 2.0], [4.0, 2.0]]) - .expect("right mesh"); - let union = left.site_union(&right).expect("site union"); - let intersection = left.site_intersection(&right).expect("site intersection"); - let difference = left.site_difference(&right).expect("site difference"); - let symmetric = left - .site_symmetric_difference(&right) - .expect("site symmetric difference"); - let extended = left - .insert_many(&[[1.0, 1.0], [3.0, 1.0]]) - .expect("batch insertion"); - - assert_eq!(left.vertex_count().expect("left count"), 4); - assert_eq!(union.vertex_count().expect("union count"), 6); - assert_eq!(intersection.vertex_count().expect("intersection count"), 2); - assert_eq!(difference.vertex_count().expect("difference count"), 2); - assert_eq!(symmetric.vertex_count().expect("symmetric count"), 4); - assert_eq!(extended.vertex_count().expect("extended count"), 6); - assert_eq!( - left.vertices().expect("vertices").len(), - left.vertex_count().expect("vertex count") - ); - assert_eq!( - left.triangles().expect("triangles").len(), - left.triangle_count().expect("triangle count") - ); -} - -#[test] -fn exact_region_boolean_valuation_and_morphology() { - let engine = Moonlight::initialize().expect("runtime"); - let left = engine - .region(&[PolygonComponent { - outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]], - holes: vec![], - }]) - .expect("left region"); - let right = engine - .region(&[PolygonComponent { - outer: vec![[1.0, 0.0], [3.0, 0.0], [3.0, 2.0], [1.0, 2.0]], - holes: vec![], - }]) - .expect("right region"); - let intersection = left.intersection(&right).expect("intersection"); - let symmetric = left - .symmetric_difference(&right) - .expect("symmetric difference"); - let kernel = engine - .structuring_element(&[[-0.5, -0.5], [0.5, -0.5], [0.5, 0.5], [-0.5, 0.5]]) - .expect("structuring element"); - let (offset, receipt) = left.offset(&kernel).expect("offset"); - - assert_eq!(left.components().expect("components").len(), 1); - assert_eq!( - intersection - .valuations() - .expect("intersection valuation") - .area, - ExactRational { - numerator: "2".to_owned(), - denominator: "1".to_owned(), - } - ); - assert_eq!( - symmetric - .valuations() - .expect("symmetric valuation") - .euler_characteristic, - 2 - ); - assert_eq!( - left.locate([1.0, 1.0]).expect("interior"), - RegionLocation::Interior - ); - assert_eq!( - left.locate([0.0, 1.0]).expect("boundary"), - RegionLocation::Boundary - ); - assert_eq!( - left.locate([3.0, 1.0]).expect("exterior"), - RegionLocation::Exterior - ); - assert_eq!( - offset.valuations().expect("offset valuation").area, - ExactRational { - numerator: "9".to_owned(), - denominator: "1".to_owned(), - } - ); - assert_eq!(receipt.operation, MinkowskiOperation::Addition); - assert!(receipt.generated_pieces >= 1); -} - -#[test] -fn invalid_coordinate_preserves_typed_witness() { - let engine = Moonlight::initialize().expect("runtime"); - let failure = engine - .delaunay(&[[0.0, 0.0], [f64::NAN, 1.0], [1.0, 0.0]]) - .err() - .expect("invalid coordinate refusal"); - assert_eq!(failure.status, 4); - assert_eq!(failure.code, 1); - assert_eq!(failure.coordinate_error, 1); - assert_eq!(failure.input_index, 1); -} diff --git a/bindings/typescript/package.json b/bindings/typescript/package.json deleted file mode 100644 --- a/bindings/typescript/package.json +++ /dev/null @@ -1,33 +0,0 @@ -{ - "name": "@moonlight/triangulation", - "version": "2.0.0", - "description": "TypeScript bindings for Moonlight exact regions and immutable Delaunay meshes.", - "type": "module", - "main": "./dist/src/index.js", - "types": "./dist/src/index.d.ts", - "exports": { - ".": { - "types": "./dist/src/index.d.ts", - "import": "./dist/src/index.js" - } - }, - "files": [ - "dist/src" - ], - "scripts": { - "build": "tsc -p tsconfig.json", - "test": "node --test dist/test/binding.test.js" - }, - "engines": { - "node": ">=20" - }, - "dependencies": { - "koffi": "3.1.4" - }, - "devDependencies": { - "@types/node": "26.2.0", - "typescript": "7.0.2" - }, - "license": "MIT", - "packageManager": "pnpm@11.21.0" -} diff --git a/bindings/typescript/pnpm-workspace.yaml b/bindings/typescript/pnpm-workspace.yaml deleted file mode 100644 --- a/bindings/typescript/pnpm-workspace.yaml +++ /dev/null @@ -1,5 +0,0 @@ -packages: - - . - -allowBuilds: - koffi: true diff --git a/bindings/typescript/src/index.ts b/bindings/typescript/src/index.ts deleted file mode 100644 --- a/bindings/typescript/src/index.ts +++ /dev/null @@ -1,759 +0,0 @@ -import koffi from "koffi"; - -const STATUS_OK = 0; -const STATUS_BUFFER_TOO_SMALL = 3; -const ABI_VERSION = 2; -const bindingCapability: unique symbol = Symbol("moonlight binding capability"); -type BindingCapability = typeof bindingCapability; - -export type Point = readonly [x: number, y: number]; -export type Triangle = readonly [first: number, second: number, third: number]; - -export interface PolygonComponent { - readonly outer: readonly Point[]; - readonly holes?: readonly (readonly Point[])[]; -} - -export 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; - coordinate_error?: number; - input_index?: NativeInteger; - first_index?: NativeInteger; - second_index?: NativeInteger; - first_value?: number; - second_value?: number; - point_x?: number; - point_y?: number; - message?: string | readonly number[]; -} - -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 meshSiteUnion: BinaryOperation; - readonly meshSiteIntersection: BinaryOperation; - readonly meshSiteDifference: BinaryOperation; - readonly meshSiteSymmetricDifference: BinaryOperation; - readonly vertexCount: CountOperation; - readonly triangleCount: CountOperation; - 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: (handle: NativeHandle) => void; - readonly handle: NativeHandle; -} - -const handleFinalizer = new FinalizationRegistry(({ free, handle }) => free(handle)); - -function requireBindingCapability(capability: BindingCapability): void { - if (capability !== bindingCapability) { - throw new Error("native binding capability is unavailable"); - } -} - -export class MoonlightError extends Error { - readonly status: number; - readonly code: number; - readonly coordinateError: number; - readonly inputIndex: bigint; - readonly firstIndex: bigint; - readonly secondIndex: bigint; - readonly firstValue: number; - readonly secondValue: number; - readonly point: Point; - - constructor(status: number, obstruction: NativeObstruction) { - super(obstructionMessage(obstruction)); - this.name = "MoonlightError"; - this.status = status; - this.code = obstruction.code ?? 0; - this.coordinateError = obstruction.coordinate_error ?? 0; - this.inputIndex = toBigInt(obstruction.input_index); - this.firstIndex = toBigInt(obstruction.first_index); - this.secondIndex = toBigInt(obstruction.second_index); - this.firstValue = obstruction.first_value ?? 0; - this.secondValue = obstruction.second_value ?? 0; - this.point = [obstruction.point_x ?? 0, obstruction.point_y ?? 0]; - } -} - -export class Moonlight { - readonly #native: NativeApi; - - constructor(libraryPath = process.env.MOONLIGHT_TRIANGULATION_LIBRARY) { - if (libraryPath === undefined || libraryPath.length === 0) { - throw new Error("set MOONLIGHT_TRIANGULATION_LIBRARY or pass libraryPath"); - } - const native = createNativeApi(libraryPath); - const initializationStatus = native.runtimeInitialize(); - if (initializationStatus !== STATUS_OK) { - throw new Error(`Moonlight runtime initialization failed with status ${initializationStatus}`); - } - const abiVersion = native.abiVersion(); - if (abiVersion !== ABI_VERSION) { - throw new Error(`unsupported Moonlight ABI version ${abiVersion}`); - } - this.#native = native; - } - - delaunay(points: readonly Point[]): Mesh { - const coordinates = flattenPoints(points); - return new Mesh( - bindingCapability, - this.#native, - produceHandle((output, obstruction) => - this.#native.delaunay(coordinates, coordinates.length / 2, 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( - bindingCapability, - this.#native, - produceHandle((output, obstruction) => - this.#native.regionCreate( - coordinates, - coordinates.length / 2, - loopPointCounts, - loopPointCounts.length, - componentLoopCounts, - componentLoopCounts.length, - output, - obstruction, - ), - ), - ); - } - - structuringElement(points: readonly Point[]): StructuringElement { - const coordinates = flattenPoints(points); - return new StructuringElement( - bindingCapability, - this.#native, - produceHandle((output, obstruction) => - this.#native.structuringElementCreate(coordinates, coordinates.length / 2, output, obstruction), - ), - ); - } -} - -abstract class OwnedHandle { - readonly #native: NativeApi; - readonly #free: (handle: NativeHandle) => void; - readonly #kind: string; - #handle: NativeHandle | null; - - protected constructor( - capability: BindingCapability, - native: NativeApi, - handle: NativeHandle, - free: (handle: NativeHandle) => void, - kind: string, - ) { - requireBindingCapability(capability); - this.#native = native; - this.#free = free; - this.#kind = kind; - this.#handle = handle; - handleFinalizer.register(this, { free, handle }, this); - } - - close(): void { - const handle = this.#handle; - if (handle !== null) { - handleFinalizer.unregister(this); - this.#free(handle); - this.#handle = null; - } - } - - protected native(capability: BindingCapability): NativeApi { - requireBindingCapability(capability); - return this.#native; - } - - nativeHandle(capability: BindingCapability): NativeHandle { - requireBindingCapability(capability); - 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(capability: BindingCapability, native: NativeApi, handle: NativeHandle) { - super(capability, native, handle, native.meshFree, "mesh"); - } - - vertexCount(): number { - return this.count(this.native(bindingCapability).vertexCount); - } - - triangleCount(): number { - return this.count(this.native(bindingCapability).triangleCount); - } - - vertices(): readonly Point[] { - const count = this.vertexCount(); - const coordinates = new Float64Array(count * 2); - const written: NativeInteger[] = [0]; - const obstruction: NativeObstruction = {}; - const status = this.native(bindingCapability).copyVertices(this.nativeHandle(bindingCapability), coordinates, count, written, obstruction); - checkStatus(status, obstruction); - return Array.from({ length: toSafeNumber(written[0]) }, (_unused, index): Point => [ - coordinates[index * 2] ?? 0, - coordinates[index * 2 + 1] ?? 0, - ]); - } - - triangles(): readonly Triangle[] { - const count = this.triangleCount(); - const triangles = new Uint32Array(count * 3); - const written: NativeInteger[] = [0]; - const obstruction: NativeObstruction = {}; - const status = this.native(bindingCapability).copyTriangles(this.nativeHandle(bindingCapability), triangles, count, written, obstruction); - checkStatus(status, obstruction); - return Array.from({ length: toSafeNumber(written[0]) }, (_unused, index): Triangle => [ - triangles[index * 3] ?? 0, - triangles[index * 3 + 1] ?? 0, - triangles[index * 3 + 2] ?? 0, - ]); - } - - insertMany(points: readonly Point[]): Mesh { - const coordinates = flattenPoints(points); - return new Mesh( - bindingCapability, - this.native(bindingCapability), - produceHandle((output, obstruction) => - this.native(bindingCapability).insertMany(this.nativeHandle(bindingCapability), coordinates, coordinates.length / 2, output, obstruction), - ), - ); - } - - siteUnion(other: Mesh): Mesh { - return this.binary(other, this.native(bindingCapability).meshSiteUnion); - } - - siteIntersection(other: Mesh): Mesh { - return this.binary(other, this.native(bindingCapability).meshSiteIntersection); - } - - siteDifference(other: Mesh): Mesh { - return this.binary(other, this.native(bindingCapability).meshSiteDifference); - } - - siteSymmetricDifference(other: Mesh): Mesh { - return this.binary(other, this.native(bindingCapability).meshSiteSymmetricDifference); - } - - private binary(other: Mesh, operation: BinaryOperation): Mesh { - this.requireSameRuntime(other); - return new Mesh( - bindingCapability, - this.native(bindingCapability), - produceHandle((output, obstruction) => - operation(this.nativeHandle(bindingCapability), other.nativeHandle(bindingCapability), output, obstruction), - ), - ); - } - - private count(operation: CountOperation): number { - const output: NativeInteger[] = [0]; - const obstruction: NativeObstruction = {}; - const status = operation(this.nativeHandle(bindingCapability), output, obstruction); - checkStatus(status, obstruction); - return toSafeNumber(output[0]); - } -} - -export class Region extends OwnedHandle { - constructor(capability: BindingCapability, native: NativeApi, handle: NativeHandle) { - super(capability, native, handle, native.regionFree, "region"); - } - - 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(bindingCapability).regionCopy( - this.nativeHandle(bindingCapability), - 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) }; - }); - } - - valuations(): RegionValuations { - return this.measureWithCapacity(128); - } - - locate([x, y]: Point): RegionLocation { - const location = [0]; - const obstruction: NativeObstruction = {}; - const status = this.native(bindingCapability).regionLocate(this.nativeHandle(bindingCapability), x, y, location, obstruction); - checkStatus(status, obstruction); - return locationCode(location[0]); - } - - union(other: Region): Region { - return this.binary(other, this.native(bindingCapability).regionUnion); - } - - intersection(other: Region): Region { - return this.binary(other, this.native(bindingCapability).regionIntersection); - } - - difference(other: Region): Region { - return this.binary(other, this.native(bindingCapability).regionDifference); - } - - symmetricDifference(other: Region): Region { - return this.binary(other, this.native(bindingCapability).regionSymmetricDifference); - } - - minkowskiSum(other: Region): readonly [Region, MinkowskiReceipt] { - this.requireSameRuntime(other); - return this.morph( - this.native(bindingCapability).regionMinkowskiSum, - this.nativeHandle(bindingCapability), - other.nativeHandle(bindingCapability), - ); - } - - offset(element: StructuringElement): readonly [Region, MinkowskiReceipt] { - return this.withElement(element, this.native(bindingCapability).regionOffset); - } - - inset(element: StructuringElement): readonly [Region, MinkowskiReceipt] { - return this.withElement(element, this.native(bindingCapability).regionInset); - } - - open(element: StructuringElement): readonly [Region, MinkowskiReceipt] { - return this.withElement(element, this.native(bindingCapability).regionOpen); - } - - closeWith(element: StructuringElement): readonly [Region, MinkowskiReceipt] { - return this.withElement(element, this.native(bindingCapability).regionClose); - } - - private binary(other: Region, operation: BinaryOperation): Region { - this.requireSameRuntime(other); - return new Region( - bindingCapability, - this.native(bindingCapability), - produceHandle((output, obstruction) => - operation(this.nativeHandle(bindingCapability), other.nativeHandle(bindingCapability), output, obstruction), - ), - ); - } - - private withElement( - element: StructuringElement, - operation: MorphologyOperation, - ): readonly [Region, MinkowskiReceipt] { - this.requireSameRuntime(element); - return this.morph( - operation, - element.nativeHandle(bindingCapability), - this.nativeHandle(bindingCapability), - ); - } - - 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(bindingCapability, this.native(bindingCapability), 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 = this.native(bindingCapability).regionCounts( - this.nativeHandle(bindingCapability), - componentCount, - loopCount, - pointCount, - obstruction, - ); - checkStatus(status, obstruction); - return [toSafeNumber(componentCount[0]), toSafeNumber(loopCount[0]), toSafeNumber(pointCount[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 = this.native(bindingCapability).regionMeasure( - this.nativeHandle(bindingCapability), - 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); - 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], - }; - } -} - -export class StructuringElement extends OwnedHandle { - constructor(capability: BindingCapability, native: NativeApi, handle: NativeHandle) { - super(capability, 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", - input_index: "uint64_t", - first_index: "uint64_t", - second_index: "uint64_t", - first_value: "double", - second_value: "double", - point_x: "double", - point_y: "double", - message: koffi.array("char", 256), - }); - const receipt = koffi.struct({ - operation: "uint32_t", - reserved: "uint32_t", - input_components: "uint64_t", - convex_pieces: "uint64_t", - generated_pieces: "uint64_t", - generated_convolution_edges: "uint64_t", - overlay_passes: "uint64_t", - exact_crossings: "uint64_t", - output_cells: "uint64_t", - exact_coordinate_bit_growth: "uint64_t", - }); - const obstructionOutput = koffi.out(koffi.pointer(obstruction)); - const receiptOutput = koffi.out(koffi.pointer(receipt)); - const sizeOutput = koffi.out(koffi.pointer("size_t")); - const uint32Output = koffi.out(koffi.pointer("uint32_t")); - const int64Output = koffi.out(koffi.pointer("int64_t")); - const doubleOutput = koffi.out(koffi.pointer("double")); - const sizeArray = koffi.pointer("size_t"); - return { - 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]), - 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]), - }; -} - -function flattenPoints(points: readonly Point[]): Float64Array { - 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: NativeHandle | null | undefined): NativeHandle { - if (handle === null || handle === undefined) { - 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 { - const message = obstruction.message; - if (message === undefined) { - return `Moonlight ABI failure ${obstruction.code ?? 0}`; - } - if (typeof message === "string") { - return message.split("\0", 1)[0] ?? ""; - } - const terminator = message.indexOf(0); - const length = terminator === -1 ? message.length : terminator; - return new TextDecoder().decode(Uint8Array.from(message.slice(0, length))); -} diff --git a/bindings/typescript/test/binding.test.ts b/bindings/typescript/test/binding.test.ts deleted file mode 100644 --- a/bindings/typescript/test/binding.test.ts +++ /dev/null @@ -1,103 +0,0 @@ -import assert from "node:assert/strict"; -import test from "node:test"; - -import { - MinkowskiOperation, - Moonlight, - MoonlightError, - RegionLocation, -} from "../src/index.js"; - -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 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", () => { - const engine = new Moonlight(); - assert.throws( - () => engine.delaunay([[0, 0], [Number.NaN, 1], [1, 0]]), - (failure: unknown) => - failure instanceof MoonlightError && - failure.status === 4 && - failure.code === 1 && - failure.coordinateError === 1 && - failure.inputIndex === 1n, - ); -}); - -test("native count descends from materialized coordinates", () => { - const engine = new Moonlight(); - const points = new Proxy([[0, 0]], { - get(target, property, receiver) { - return property === "length" ? 1_000 : Reflect.get(target, property, receiver); - }, - }); - const mesh = engine.delaunay(points); - assert.equal(mesh.vertexCount(), 1); - mesh.close(); -}); - -test("raw native handles require the module capability", () => { - const engine = new Moonlight(); - const mesh = engine.delaunay([[0, 0]]); - const capabilityGuarded = mesh as unknown as { - nativeHandle(capability: symbol): object; - }; - assert.throws( - () => capabilityGuarded.nativeHandle(Symbol("forged capability")), - /native binding capability is unavailable/, - ); - mesh.close(); -}); diff --git a/bindings/typescript/tsconfig.json b/bindings/typescript/tsconfig.json deleted file mode 100644 --- a/bindings/typescript/tsconfig.json +++ /dev/null @@ -1,23 +0,0 @@ -{ - "compilerOptions": { - "target": "ES2023", - "module": "NodeNext", - "moduleResolution": "NodeNext", - "strict": true, - "noImplicitAny": true, - "strictNullChecks": true, - "noUncheckedIndexedAccess": true, - "exactOptionalPropertyTypes": true, - "types": [ - "node" - ], - "declaration": true, - "rootDir": ".", - "outDir": "dist", - "skipLibCheck": false - }, - "include": [ - "src/**/*.ts", - "test/**/*.ts" - ] -} diff --git a/cbits/moonlight-triangulation.def b/cbits/moonlight-triangulation.def deleted file mode 100644 --- a/cbits/moonlight-triangulation.def +++ /dev/null @@ -1,32 +0,0 @@ -LIBRARY moonlight-triangulation-c -EXPORTS - ml_abi_version - ml_runtime_initialize - ml_delaunay_f64 - ml_mesh_insert_many_f64 - ml_mesh_site_union - ml_mesh_site_intersection - ml_mesh_site_difference - ml_mesh_site_symmetric_difference - ml_mesh_vertex_count - ml_mesh_triangle_count - ml_mesh_copy_vertices_f64 - ml_mesh_copy_triangles_u32 - ml_mesh_free - ml_region_create_f64 - ml_region_counts - ml_region_copy_f64 - ml_region_union - ml_region_intersection - ml_region_difference - ml_region_symmetric_difference - ml_region_locate_point_f64 - ml_region_measure - ml_region_free - ml_structuring_element_create_f64 - ml_structuring_element_free - ml_region_minkowski_sum - ml_region_offset - ml_region_inset - ml_region_open - ml_region_close diff --git a/cbits/moonlight_runtime.c b/cbits/moonlight_runtime.c deleted file mode 100644 --- a/cbits/moonlight_runtime.c +++ /dev/null @@ -1,55 +0,0 @@ -#include "moonlight_triangulation.h" -#include "HsFFI.h" - -_Static_assert(ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE == 60, "maximum-edge ABI code drift"); -_Static_assert(ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE == 61, "maximum-edge ABI code drift"); -_Static_assert(ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE == 62, "maximum-edge ABI code drift"); -_Static_assert(ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED == 63, "seam-bridge ABI code drift"); -_Static_assert(ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED == 64, "seam-bridge ABI code drift"); -_Static_assert(ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE == 65, "boundary-split ABI code drift"); - -#if defined(_WIN32) -#include - -static INIT_ONCE moonlight_runtime_once = INIT_ONCE_STATIC_INIT; - -static BOOL CALLBACK moonlight_initialize_runtime(PINIT_ONCE once, PVOID parameter, PVOID *context) { - int argc = 1; - char program_name[] = "moonlight-triangulation"; - char *argv[] = {program_name, NULL}; - char **argv_pointer = argv; - (void)once; - (void)parameter; - (void)context; - hs_init(&argc, &argv_pointer); - return TRUE; -} - -ML_API ml_status ml_runtime_initialize(void) { - return InitOnceExecuteOnce(&moonlight_runtime_once, moonlight_initialize_runtime, NULL, NULL) - ? ML_STATUS_OK - : ML_STATUS_RUNTIME_FAILURE; -} -#else -#include - -static pthread_once_t moonlight_runtime_once = PTHREAD_ONCE_INIT; - -static void moonlight_initialize_runtime(void) { - int argc = 1; - char program_name[] = "moonlight-triangulation"; - char *argv[] = {program_name, NULL}; - char **argv_pointer = argv; - hs_init(&argc, &argv_pointer); -} - -ML_API ml_status ml_runtime_initialize(void) { - return pthread_once(&moonlight_runtime_once, moonlight_initialize_runtime) == 0 - ? ML_STATUS_OK - : ML_STATUS_RUNTIME_FAILURE; -} -#endif - -ML_API uint32_t ml_abi_version(void) { - return 2; -} diff --git a/docs/README.md b/docs/README.md --- a/docs/README.md +++ b/docs/README.md @@ -1,29 +1,19 @@ -# Moonlight Triangulation exhibits - -These are the full-size visual artifacts shipped with `moonlight-triangulation`. -They are derived observations of the package's existing geometry and Homology -owners, not a second visualization data model. - -## Persistence rose - -![Animated Moonlight persistence rose](./social/moonlight-triangulation-persistence-rose.gif) - -[Open the animation directly.](./social/moonlight-triangulation-persistence-rose.gif) -· [Open the static vector poster.](./moonlight-triangulation-persistence-rose.svg) -· [Read its provenance and reproduction commands.](../README.md#persistence-rose) - -The GIF carries the source fingerprint of the package-owned 65-frame SVG -section. `moonlight-triangulation-persistence-rose verify-artifacts` checks it -beside byte-exact regeneration of both retained SVGs. - -## Alpha eclipse - -![Moonlight alpha eclipse](./moonlight-triangulation-alpha-eclipse.svg) +# Moonlight Triangulation documentation -[Open the full-size vector.](./moonlight-triangulation-alpha-eclipse.svg) -· [Read the exact-filtration semantics.](../README.md#exact-alpha-filtration-and-persistent-topology) +This page is navigation only. Each question below has one canonical owner; +indexes and retained pictures are derived views of those owners. -This is the real four-site square alpha complex: four resident boundary edges -create one hole at exact `α² = 1`, then the resident diagonal and two resident -faces kill it at exact `α² = 2`. No decorative centre site is smuggled into the -final panel. Geometry is not improv theatre. +| Question | Canonical owner | +| --- | --- | +| Which public operation should I call? | [Package operation index](../README.md#operations) | +| What algebraic laws do meshes satisfy? | [Package algebraic contract](../README.md#algebraic-contract) | +| What are the set-operation types? | [Package type signatures](../README.md#set-operation-types) | +| Which execution schedule publishes each result? | [Mesh publication guide](./mesh-publication.md) | +| How do I build and validate components locally? | [Development guide](./development.md) | +| Which workflows are compile-checked? | [Example index](./examples/README.md) | +| How does the C ABI serve Python, TypeScript, and Rust? | [Foreign bindings](../ffi/bindings/README.md) | +| How are exact alpha filtrations lowered into persistence? | [Persistence rose](./persistence-rose/README.md) | +| What does one finite alpha interval look like? | [Alpha eclipse](./persistence-rose/alpha-eclipse.md) | +| How does an exact cell set become an incidence category and nerve? | [Category observatory](./category-observatory/README.md) | +| How does Moonlight compare on Spade's construction suite? | [Delaunay construction comparison](./delaunay-compare/README.md) | +| How does Moonlight compare across the broader operation surface? | [Moonlight–Spade operation comparison](../bench/spade-compare/README.md) | diff --git a/docs/category-observatory/Main.hs b/docs/category-observatory/Main.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Main.hs @@ -0,0 +1,160 @@ +module Main (main) where + +import Control.Exception (IOException, try) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except + ( ExceptT (..), + except, + runExceptT, + ) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (first) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Moonlight.Triangulation.Exhibit.CategoryObservatory + ( Exhibit, + ExhibitError, + buildExhibit, + renderExhibitError, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture + ( PictureObstruction, + categoryObservatoryPictureFileName, + renderCategoryObservatoryPicture, + renderPictureObstruction, + ) +import System.Directory (createDirectoryIfMissing) +import System.Environment (getArgs) +import System.Exit (die) +import System.FilePath ((), takeDirectory) + +data CategoryObservatoryCommand + = ExportJson + | WritePicture !FilePath + | VerifyArtifacts !FilePath + +data CategoryObservatoryCommandError + = CategoryObservatoryUsage ![String] + | CategoryObservatoryConstructionFailed !ExhibitError + | CategoryObservatoryPictureFailed !PictureObstruction + | CategoryObservatoryDirectoryFailed !FilePath !IOException + | CategoryObservatoryReadFailed !FilePath !IOException + | CategoryObservatoryWriteFailed !FilePath !IOException + | CategoryObservatoryArtifactMismatch !FilePath + +main :: IO () +main = do + arguments <- getArgs + result <- runExceptT (runCategoryObservatoryCommand arguments) + either (die . renderCommandError) pure result + +runCategoryObservatoryCommand :: + [String] -> + ExceptT CategoryObservatoryCommandError IO () +runCategoryObservatoryCommand arguments = do + command <- except (parseCommand arguments) + exhibit <- requireExhibit + case command of + ExportJson -> lift (LazyByteString.putStrLn (Aeson.encode exhibit)) + WritePicture outputPath -> do + picture <- requirePicture exhibit + createOutputDirectory (takeDirectory outputPath) + writeOutput outputPath picture + lift (putStrLn ("wrote category-observatory picture " <> outputPath)) + VerifyArtifacts packageRoot -> do + picture <- requirePicture exhibit + let picturePath = + packageRoot + "docs" + "category-observatory" + categoryObservatoryPictureFileName + actualPicture <- readOutput picturePath + except + ( if actualPicture == picture + then Right () + else Left (CategoryObservatoryArtifactMismatch picturePath) + ) + lift (putStrLn ("verified category-observatory picture " <> picturePath)) + +parseCommand :: + [String] -> + Either CategoryObservatoryCommandError CategoryObservatoryCommand +parseCommand arguments = + case arguments of + [] -> Right ExportJson + ["picture", outputPath] -> Right (WritePicture outputPath) + ["verify-artifacts", packageRoot] -> Right (VerifyArtifacts packageRoot) + _ -> Left (CategoryObservatoryUsage arguments) + +requireExhibit :: ExceptT CategoryObservatoryCommandError IO Exhibit +requireExhibit = + except (first CategoryObservatoryConstructionFailed buildExhibit) + +requirePicture :: + Exhibit -> + ExceptT CategoryObservatoryCommandError IO String +requirePicture exhibit = + except + ( first + CategoryObservatoryPictureFailed + (renderCategoryObservatoryPicture exhibit) + ) + +createOutputDirectory :: + FilePath -> + ExceptT CategoryObservatoryCommandError IO () +createOutputDirectory outputDirectory = + liftIOException + (CategoryObservatoryDirectoryFailed outputDirectory) + (createDirectoryIfMissing True outputDirectory) + +readOutput :: FilePath -> ExceptT CategoryObservatoryCommandError IO String +readOutput inputPath = + liftIOException + (CategoryObservatoryReadFailed inputPath) + (readFile inputPath) + +writeOutput :: + FilePath -> + String -> + ExceptT CategoryObservatoryCommandError IO () +writeOutput outputPath contents = + liftIOException + (CategoryObservatoryWriteFailed outputPath) + (writeFile outputPath contents) + +liftIOException :: + (IOException -> CategoryObservatoryCommandError) -> + IO value -> + ExceptT CategoryObservatoryCommandError IO value +liftIOException wrapFailure = + ExceptT . fmap (first wrapFailure) . try + +renderCommandError :: CategoryObservatoryCommandError -> String +renderCommandError commandError = + case commandError of + CategoryObservatoryUsage arguments -> + "invalid category-observatory command " + <> show arguments + <> "; expected no arguments (JSON) | picture OUTPUT.svg | verify-artifacts PACKAGE_ROOT" + CategoryObservatoryConstructionFailed exhibitError -> + renderExhibitError exhibitError + CategoryObservatoryPictureFailed pictureError -> + renderPictureObstruction pictureError + CategoryObservatoryDirectoryFailed path caughtError -> + "could not create category-observatory output directory " + <> show path + <> ": " + <> show caughtError + CategoryObservatoryReadFailed path caughtError -> + "could not read category-observatory artifact " + <> show path + <> ": " + <> show caughtError + CategoryObservatoryWriteFailed path caughtError -> + "could not write category-observatory artifact " + <> show path + <> ": " + <> show caughtError + CategoryObservatoryArtifactMismatch path -> + "tracked category-observatory artifact differs from its canonical renderer: " + <> show path diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory.hs @@ -0,0 +1,96 @@ +module Moonlight.Triangulation.Exhibit.CategoryObservatory + ( Exhibit, + ExhibitError, + buildExhibit, + renderExhibitError, + ) +where + +import Data.Bifunctor (first) +import Data.Vector qualified as Vector +import Moonlight.Homology.Pure.Topology.CellCategory (complexCategory) +import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..)) +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.CellComplex + ( DCELComplex, + fromExactCellSet, + ) +import Moonlight.Triangulation.CellSet + ( ExactCellSet, + closeFaceCellSet, + exactCellSetEdgeCount, + exactCellSetFaceCount, + exactCellSetVertexCount, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Category + ( projectCategory, + validateCategoryEnumeration, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry (projectMesh) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( CellInventory (..), + Exhibit (..), + ExhibitError (..), + renderExhibitError, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve + ( projectNerve, + validateNerveCount, + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) +import Moonlight.Triangulation.Types (Point (..)) + +buildExhibit :: Either ExhibitError Exhibit +buildExhibit = do + triangulation <- first ExhibitTriangulationBuildFailed (delaunayGeometry exhibitPoints) + selectedCells <- + first ExhibitCellSelectionFailed + (closeFaceCellSet triangulation (innerFaces triangulation)) + let complexValue = fromExactCellSet selectedCells + categoryValue = complexCategory complexValue + validateInventory selectedCells complexValue + validateCategoryEnumeration complexValue categoryValue + categoryProjection <- projectCategory triangulation categoryValue + nerveProjection <- projectNerve categoryValue + validateNerveCount complexValue nerveProjection + pure + Exhibit + { schemaVersion = 2, + exhibitTitle = "Triangulation, incidence category, and flag nerve", + mesh = projectMesh triangulation complexValue, + category = categoryProjection, + nerve = nerveProjection + } + +validateInventory :: ExactCellSet -> DCELComplex -> Either ExhibitError () +validateInventory cellSet complexValue = + let expectedInventory = + CellInventory + { cellVertexCount = exactCellSetVertexCount cellSet, + cellEdgeCount = exactCellSetEdgeCount cellSet, + cellFaceCount = exactCellSetFaceCount cellSet + } + observedInventory = + CellInventory + { cellVertexCount = length (vertices complexValue), + cellEdgeCount = length (edges complexValue), + cellFaceCount = length (faces complexValue) + } + in if observedInventory == expectedInventory + then Right () + else Left (ExhibitInventoryMismatch expectedInventory observedInventory) + +exhibitPoints :: Vector.Vector Point +exhibitPoints = + Vector.fromList + [ Point 80 72, + Point 222 48, + Point 362 92, + Point 52 208, + Point 176 166, + Point 310 190, + Point 414 232, + Point 112 330, + Point 258 314, + Point 380 354 + ] diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Category.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Category.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Category.hs @@ -0,0 +1,127 @@ +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Category + ( incidenceFlagCount, + projectCategory, + validateCategoryEnumeration, + ) +where + +import Data.Bifunctor (first) +import Data.Containers.ListUtils (nubOrd) +import Moonlight.Category + ( Category (..), + FiniteComposableCategory (..), + ) +import Moonlight.Homology.Pure.Topology.CellCategory + ( ComplexCat, + ComplexMor (..), + ComplexOb, + ) +import Moonlight.Homology.Pure.Topology.CellComplex + ( CellComplex2D (..), + CellTypes (..), + OrientedEdge (..), + ) +import Moonlight.Triangulation.CellComplex (DCELComplex) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry (positionForObject) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier + ( morphismKind, + objectIdentifier, + objectKind, + objectLabel, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( CategoryMorphism (..), + CategoryObject (..), + CategoryProjection (..), + ExhibitError (..), + MorphismEndpoint (..), + MorphismInventory (..), + ) +import Moonlight.Triangulation.Types (DelaunayTriangulation) + +projectCategory :: + DelaunayTriangulation () -> + ComplexCat DCELComplex -> + Either ExhibitError CategoryProjection +projectCategory triangulation categoryValue = + CategoryProjection + <$> traverse + (projectCategoryObject triangulation) + (enumerateObjects categoryValue) + <*> traverse + (projectCategoryMorphism categoryValue) + (zip [0 ..] (enumerateMorphisms categoryValue)) + +projectCategoryObject :: + DelaunayTriangulation () -> + ComplexOb DCELComplex -> + Either ExhibitError CategoryObject +projectCategoryObject triangulation objectValue = + CategoryObject + (objectIdentifier objectValue) + (objectKind objectValue) + (objectLabel objectValue) + <$> positionForObject triangulation objectValue + +projectCategoryMorphism :: + ComplexCat DCELComplex -> + (Int, ComplexMor DCELComplex) -> + Either ExhibitError CategoryMorphism +projectCategoryMorphism categoryValue (morphismIndex, morphismValue) = + CategoryMorphism + ("morphism-" <> show morphismIndex) + (morphismKind morphismValue) + <$> projectedEndpoint MorphismSource source + <*> projectedEndpoint MorphismTarget target + where + projectedEndpoint endpoint endpointProjection = + objectIdentifier + <$> first + (const (ExhibitMorphismEndpointUnavailable endpoint morphismIndex)) + (endpointProjection categoryValue morphismValue) + +validateCategoryEnumeration :: + DCELComplex -> + ComplexCat DCELComplex -> + Either ExhibitError () +validateCategoryEnumeration complexValue categoryValue = + let morphisms = enumerateMorphisms categoryValue + expectedInventory = + MorphismInventory + { identityMorphismCount = + length (vertices complexValue) + + length (edges complexValue) + + length (faces complexValue), + faceEdgeMorphismCount = + sum (fmap (length . faceBoundary complexValue) (faces complexValue)), + edgeVertexMorphismCount = + sum (fmap (edgeEndpointCount complexValue) (edges complexValue)), + faceVertexMorphismCount = + sum (fmap (incidenceFlagCount complexValue) (faces complexValue)) + } + observedInventory = + foldMap morphismInventory morphisms + in if observedInventory == expectedInventory + then Right () + else Left (ExhibitCategoryEnumerationMismatch expectedInventory observedInventory) + +edgeEndpointCount :: DCELComplex -> Edge DCELComplex -> Int +edgeEndpointCount complexValue edgeValue = + let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue + in length (nubOrd [sourceVertex, targetVertex]) + +incidenceFlagCount :: DCELComplex -> Face DCELComplex -> Int +incidenceFlagCount complexValue faceValue = + sum + ( fmap + (edgeEndpointCount complexValue . orientedEdge) + (faceBoundary complexValue faceValue) + ) + +morphismInventory :: ComplexMor DCELComplex -> MorphismInventory +morphismInventory morphismValue = + case morphismValue of + IdentityMor _ -> MorphismInventory 1 0 0 0 + FaceToEdge {} -> MorphismInventory 0 1 0 0 + EdgeToVertex _ _ -> MorphismInventory 0 0 1 0 + FaceToVertex {} -> MorphismInventory 0 0 0 1 diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Geometry.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Geometry.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Geometry.hs @@ -0,0 +1,127 @@ +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry + ( positionForObject, + projectMesh, + ) +where + +import Data.Foldable (foldMap') +import Moonlight.Homology.Pure.Topology.CellCategory (ComplexOb (..)) +import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..)) +import Moonlight.Triangulation.CellComplex (DCELComplex) +import Moonlight.Triangulation.Dcel + ( faceVertices, + undirectedEndpoints, + vertexPoint, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier + ( edgeIdentifier, + edgeObjectIdentifier, + faceIdentifier, + faceObjectIdentifier, + vertexIdentifier, + vertexObjectIdentifier, + ) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( ExhibitError (..), + MeshEdge (..), + MeshFace (..), + MeshProjection (..), + MeshVertex (..), + Position (..), + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId, + UndirectedEdgeId, + VertexId, + ) +import Moonlight.Triangulation.Types + ( DelaunayTriangulation, + Point (..), + ) + +projectMesh :: DelaunayTriangulation () -> DCELComplex -> MeshProjection +projectMesh triangulation complexValue = + MeshProjection + { meshVertices = fmap (projectMeshVertex triangulation) (vertices complexValue), + meshEdges = fmap (projectMeshEdge triangulation) (edges complexValue), + meshFaces = fmap (projectMeshFace triangulation) (faces complexValue) + } + +projectMeshVertex :: DelaunayTriangulation () -> VertexId -> MeshVertex +projectMeshVertex triangulation vertexValue = + MeshVertex + { meshVertexIdentifier = vertexIdentifier vertexValue, + meshVertexObjectIdentifier = vertexObjectIdentifier vertexValue, + meshVertexPosition = pointPosition (vertexPoint triangulation vertexValue) + } + +projectMeshEdge :: DelaunayTriangulation () -> UndirectedEdgeId -> MeshEdge +projectMeshEdge triangulation edgeValue = + let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue + in MeshEdge + { meshEdgeIdentifier = edgeIdentifier edgeValue, + meshEdgeObjectIdentifier = edgeObjectIdentifier edgeValue, + meshEdgeVertexIdentifiers = fmap vertexIdentifier [sourceVertex, targetVertex] + } + +projectMeshFace :: DelaunayTriangulation () -> FaceId -> MeshFace +projectMeshFace triangulation faceValue = + MeshFace + { meshFaceIdentifier = faceIdentifier faceValue, + meshFaceObjectIdentifier = faceObjectIdentifier faceValue, + meshFaceVertexIdentifiers = fmap vertexIdentifier (faceVertices triangulation faceValue) + } + +positionForObject :: + DelaunayTriangulation () -> + ComplexOb DCELComplex -> + Either ExhibitError Position +positionForObject triangulation objectValue = + case objectValue of + VertexOb vertexValue -> + Right (pointPosition (vertexPoint triangulation vertexValue)) + EdgeOb edgeValue -> + let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue + in Right + ( midpoint + (pointPosition (vertexPoint triangulation sourceVertex)) + (pointPosition (vertexPoint triangulation targetVertex)) + ) + FaceOb faceValue -> + centroid faceValue + (fmap (pointPosition . vertexPoint triangulation) (faceVertices triangulation faceValue)) + +data PositionSum = PositionSum Double Double + +instance Semigroup PositionSum where + PositionSum leftX leftY <> PositionSum rightX rightY = + PositionSum (leftX + rightX) (leftY + rightY) + +instance Monoid PositionSum where + mempty = PositionSum 0 0 + +centroid :: FaceId -> [Position] -> Either ExhibitError Position +centroid faceValue positions = + case positions of + [] -> Left (ExhibitFaceWithoutVertices faceValue) + _ -> + let PositionSum summedX summedY = + foldMap' + (\positionValue -> PositionSum (positionX positionValue) (positionY positionValue)) + positions + positionCount = fromIntegral (length positions) + in Right (Position (summedX / positionCount) (summedY / positionCount)) + +midpoint :: Position -> Position -> Position +midpoint firstPosition secondPosition = + Position + { positionX = (positionX firstPosition + positionX secondPosition) / 2, + positionY = (positionY firstPosition + positionY secondPosition) / 2 + } + +pointPosition :: Point -> Position +pointPosition pointValue = + Position + { positionX = pointX pointValue, + positionY = pointY pointValue + } diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Identifier.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Identifier.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Identifier.hs @@ -0,0 +1,78 @@ +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier + ( objectIdentifier, + objectKind, + objectLabel, + morphismKind, + vertexIdentifier, + edgeIdentifier, + faceIdentifier, + vertexObjectIdentifier, + edgeObjectIdentifier, + faceObjectIdentifier, + ) +where + +import Moonlight.Homology.Pure.Topology.CellCategory + ( ComplexMor (..), + ComplexOb (..), + ) +import Moonlight.Triangulation.CellComplex (DCELComplex) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( CategoryMorphismKind (..), + CategoryObjectKind (..), + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId, + UndirectedEdgeId, + VertexId, + unFaceId, + unUndirectedEdgeId, + unVertexId, + ) + +objectIdentifier :: ComplexOb DCELComplex -> String +objectIdentifier objectValue = + case objectValue of + VertexOb vertexValue -> vertexObjectIdentifier vertexValue + EdgeOb edgeValue -> edgeObjectIdentifier edgeValue + FaceOb faceValue -> faceObjectIdentifier faceValue + +objectKind :: ComplexOb DCELComplex -> CategoryObjectKind +objectKind objectValue = + case objectValue of + VertexOb _ -> VertexObject + EdgeOb _ -> EdgeObject + FaceOb _ -> FaceObject + +objectLabel :: ComplexOb DCELComplex -> String +objectLabel objectValue = + case objectValue of + VertexOb vertexValue -> "v" <> show (unVertexId vertexValue) + EdgeOb edgeValue -> "e" <> show (unUndirectedEdgeId edgeValue) + FaceOb faceValue -> "f" <> show (unFaceId faceValue) + +morphismKind :: ComplexMor DCELComplex -> CategoryMorphismKind +morphismKind morphismValue = + case morphismValue of + IdentityMor _ -> IdentityMorphism + FaceToEdge {} -> FaceEdgeMorphism + EdgeToVertex _ _ -> EdgeVertexMorphism + FaceToVertex {} -> FaceVertexComposite + +vertexIdentifier :: VertexId -> String +vertexIdentifier vertexValue = "vertex-" <> show (unVertexId vertexValue) + +edgeIdentifier :: UndirectedEdgeId -> String +edgeIdentifier edgeValue = "edge-" <> show (unUndirectedEdgeId edgeValue) + +faceIdentifier :: FaceId -> String +faceIdentifier faceValue = "face-" <> show (unFaceId faceValue) + +vertexObjectIdentifier :: VertexId -> String +vertexObjectIdentifier vertexValue = "object-" <> vertexIdentifier vertexValue + +edgeObjectIdentifier :: UndirectedEdgeId -> String +edgeObjectIdentifier edgeValue = "object-" <> edgeIdentifier edgeValue + +faceObjectIdentifier :: FaceId -> String +faceObjectIdentifier faceValue = "object-" <> faceIdentifier faceValue diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Model.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Model.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Model.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( Exhibit (..), + MeshProjection (..), + MeshVertex (..), + MeshEdge (..), + MeshFace (..), + Position (..), + CategoryProjection (..), + CategoryObject (..), + CategoryObjectKind (..), + CategoryMorphism (..), + CategoryMorphismKind (..), + NerveProjection (..), + NerveSimplexCount (..), + NerveTwoSimplex (..), + CellInventory (..), + MorphismInventory (..), + ExhibitError (..), + MorphismEndpoint (..), + renderExhibitError, + ) +where + +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) +import Moonlight.Triangulation.CellSet (CellSelectionError) +import Moonlight.Triangulation.Handles.HandleDefs (FaceId) +import Moonlight.Triangulation.Types (BuildError) +import Numeric.Natural (Natural) + +data Exhibit = Exhibit + { schemaVersion :: Int, + exhibitTitle :: String, + mesh :: MeshProjection, + category :: CategoryProjection, + nerve :: NerveProjection + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshProjection = MeshProjection + { meshVertices :: [MeshVertex], + meshEdges :: [MeshEdge], + meshFaces :: [MeshFace] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshVertex = MeshVertex + { meshVertexIdentifier :: String, + meshVertexObjectIdentifier :: String, + meshVertexPosition :: Position + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshEdge = MeshEdge + { meshEdgeIdentifier :: String, + meshEdgeObjectIdentifier :: String, + meshEdgeVertexIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshFace = MeshFace + { meshFaceIdentifier :: String, + meshFaceObjectIdentifier :: String, + meshFaceVertexIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data Position = Position + { positionX :: Double, + positionY :: Double + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryProjection = CategoryProjection + { categoryObjects :: [CategoryObject], + categoryMorphisms :: [CategoryMorphism] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryObject = CategoryObject + { categoryObjectIdentifier :: String, + categoryObjectKind :: CategoryObjectKind, + categoryObjectLabel :: String, + categoryObjectPosition :: Position + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryObjectKind + = VertexObject + | EdgeObject + | FaceObject + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + +data CategoryMorphism = CategoryMorphism + { categoryMorphismIdentifier :: String, + categoryMorphismKind :: CategoryMorphismKind, + categoryMorphismSourceObject :: String, + categoryMorphismTargetObject :: String + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryMorphismKind + = IdentityMorphism + | FaceEdgeMorphism + | EdgeVertexMorphism + | FaceVertexComposite + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveProjection = NerveProjection + { nerveTwoSimplices :: [NerveTwoSimplex], + nerveSimplexCounts :: [NerveSimplexCount] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveSimplexCount = NerveSimplexCount + { nerveDimension :: Natural, + normalizedSimplexCount :: Int, + unnormalizedSimplexCount :: Int + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveTwoSimplex = NerveTwoSimplex + { nerveSimplexIdentifier :: String, + nerveSimplexObjectIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CellInventory = CellInventory + { cellVertexCount :: Int, + cellEdgeCount :: Int, + cellFaceCount :: Int + } + deriving stock (Eq, Show) + +data MorphismInventory = MorphismInventory + { identityMorphismCount :: Int, + faceEdgeMorphismCount :: Int, + edgeVertexMorphismCount :: Int, + faceVertexMorphismCount :: Int + } + deriving stock (Eq, Show) + +instance Semigroup MorphismInventory where + MorphismInventory leftIdentities leftFaceEdges leftEdgeVertices leftFaceVertices + <> MorphismInventory rightIdentities rightFaceEdges rightEdgeVertices rightFaceVertices = + MorphismInventory + (leftIdentities + rightIdentities) + (leftFaceEdges + rightFaceEdges) + (leftEdgeVertices + rightEdgeVertices) + (leftFaceVertices + rightFaceVertices) + +instance Monoid MorphismInventory where + mempty = MorphismInventory 0 0 0 0 + +data ExhibitError + = ExhibitTriangulationBuildFailed BuildError + | ExhibitCellSelectionFailed CellSelectionError + | ExhibitMorphismEndpointUnavailable MorphismEndpoint Int + | ExhibitFaceWithoutVertices FaceId + | ExhibitMalformedTwoSimplex Int + | ExhibitInventoryMismatch CellInventory CellInventory + | ExhibitCategoryEnumerationMismatch MorphismInventory MorphismInventory + | ExhibitNerveCountMismatch Int Int + deriving stock (Show) + +data MorphismEndpoint + = MorphismSource + | MorphismTarget + deriving stock (Show) + +renderExhibitError :: ExhibitError -> String +renderExhibitError = show diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Nerve.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Nerve.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Nerve.hs @@ -0,0 +1,84 @@ +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve + ( projectNerve, + validateNerveCount, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Category (chainVertices) +import Moonlight.Category.Simplicial + ( GeneratedSSet, + NerveSimplex, + TruncatedNormalizedSSet, + generatedSimplicesAtDimension, + nerveSimplexChain, + normalizedNerve, + simplicesAtDimension, + unnormalizedNerve, + ) +import Moonlight.Homology.Pure.Topology.CellCategory (ComplexCat) +import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..)) +import Moonlight.Triangulation.CellComplex (DCELComplex) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Category (incidenceFlagCount) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier (objectIdentifier) +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( ExhibitError (..), + NerveProjection (..), + NerveSimplexCount (..), + NerveTwoSimplex (..), + ) +import Numeric.Natural (Natural) + +projectNerve :: ComplexCat DCELComplex -> Either ExhibitError NerveProjection +projectNerve categoryValue = + let normalizedNerveValue = normalizedNerve categoryValue nerveObservationBound + unnormalizedNerveValue = unnormalizedNerve categoryValue nerveObservationBound + in NerveProjection + <$> traverse + projectTwoSimplex + (zip [0 ..] (simplicesAtDimension normalizedNerveValue nerveObservationBound)) + <*> pure + ( fmap + (projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue) + nerveObservationDimensions + ) + +validateNerveCount :: DCELComplex -> NerveProjection -> Either ExhibitError () +validateNerveCount complexValue nerveProjection = + let expectedCount = sum (fmap (incidenceFlagCount complexValue) (faces complexValue)) + observedCount = length (nerveTwoSimplices nerveProjection) + in if observedCount == expectedCount + then Right () + else Left (ExhibitNerveCountMismatch expectedCount observedCount) + +projectNerveSimplexCount :: + TruncatedNormalizedSSet (NerveSimplex (ComplexCat DCELComplex)) -> + GeneratedSSet (NerveSimplex (ComplexCat DCELComplex)) -> + Natural -> + NerveSimplexCount +projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue dimensionValue = + NerveSimplexCount + { nerveDimension = dimensionValue, + normalizedSimplexCount = length (simplicesAtDimension normalizedNerveValue dimensionValue), + unnormalizedSimplexCount = length (generatedSimplicesAtDimension unnormalizedNerveValue dimensionValue) + } + +projectTwoSimplex :: + (Int, NerveSimplex (ComplexCat DCELComplex)) -> + Either ExhibitError NerveTwoSimplex +projectTwoSimplex (simplexIndex, simplexValue) = + case chainVertices (nerveSimplexChain simplexValue) of + faceObject :| [edgeObject, vertexObject] -> + Right + NerveTwoSimplex + { nerveSimplexIdentifier = "simplex-" <> show simplexIndex, + nerveSimplexObjectIdentifiers = + fmap objectIdentifier [faceObject, edgeObject, vertexObject] + } + _ -> Left (ExhibitMalformedTwoSimplex simplexIndex) + +nerveObservationBound :: Natural +nerveObservationBound = 2 + +nerveObservationDimensions :: [Natural] +nerveObservationDimensions = [0, 1, 2] diff --git a/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Picture.hs b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Picture.hs new file mode 100644 --- /dev/null +++ b/docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Picture.hs @@ -0,0 +1,663 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Pure, compact SVG projection of the checked category-observatory exhibit. +module Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture + ( PictureObstruction (..), + categoryObservatoryPictureFileName, + renderCategoryObservatoryPicture, + renderPictureObstruction, + ) +where + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + ( CategoryObject (..), + CategoryObjectKind (..), + CategoryProjection (..), + Exhibit (..), + MeshEdge (..), + MeshFace (..), + MeshProjection (..), + MeshVertex (..), + NerveProjection (..), + NerveSimplexCount (..), + NerveTwoSimplex (..), + Position (..), + ) +import Numeric (showFFloat) + +data PictureObstruction + = PictureHasNoMeshVertices + | PictureHasNoNerveTwoSimplex + | PictureMissingMeshVertex !String + | PictureMissingCategoryObject !String + | PictureMalformedMeshEdge !String ![String] + | PictureMalformedMeshFace !String ![String] + | PictureMalformedNerveTwoSimplex !String ![String] + | PictureMalformedFlagKinds ![CategoryObjectKind] + deriving stock (Eq, Show) + +data PictureBounds = PictureBounds + { minimumX :: !Double, + minimumY :: !Double, + maximumX :: !Double, + maximumY :: !Double + } + +data PictureFrame = PictureFrame + { frameLeft :: !Double, + frameTop :: !Double, + frameWidth :: !Double, + frameHeight :: !Double + } + +data ResolvedMeshEdge = ResolvedMeshEdge + { resolvedEdge :: !MeshEdge, + resolvedEdgeSource :: !Position, + resolvedEdgeTarget :: !Position + } + +data ResolvedMeshFace = ResolvedMeshFace + { resolvedFace :: !MeshFace, + resolvedFaceVertices :: ![Position] + } + +data ResolvedNerveSimplex = ResolvedNerveSimplex + { resolvedSimplex :: !NerveTwoSimplex, + resolvedSimplexVertices :: ![Position] + } + +data FlagSelection = FlagSelection + { selectedSimplexIdentifier :: !String, + selectedFace :: !CategoryObject, + selectedEdge :: !CategoryObject, + selectedVertex :: !CategoryObject, + selectedObjectIdentifiers :: !(Set.Set String) + } + +data PictureContext = PictureContext + { contextExhibit :: !Exhibit, + contextBounds :: !PictureBounds, + contextEdges :: ![ResolvedMeshEdge], + contextFaces :: ![ResolvedMeshFace], + contextNerveSimplices :: ![ResolvedNerveSimplex], + contextFlag :: !FlagSelection + } + +categoryObservatoryPictureFileName :: FilePath +categoryObservatoryPictureFileName = + "moonlight-triangulation-category-observatory.svg" + +renderCategoryObservatoryPicture :: Exhibit -> Either PictureObstruction String +renderCategoryObservatoryPicture exhibit = + renderPicture <$> preparePicture exhibit + +renderPictureObstruction :: PictureObstruction -> String +renderPictureObstruction = \case + PictureHasNoMeshVertices -> + "category-observatory picture requires at least one mesh vertex" + PictureHasNoNerveTwoSimplex -> + "category-observatory picture requires at least one admitted two-simplex" + PictureMissingMeshVertex identifier -> + "category-observatory picture cannot resolve mesh vertex " <> show identifier + PictureMissingCategoryObject identifier -> + "category-observatory picture cannot resolve category object " <> show identifier + PictureMalformedMeshEdge identifier vertices -> + "category-observatory mesh edge " + <> show identifier + <> " does not name exactly two vertices: " + <> show vertices + PictureMalformedMeshFace identifier vertices -> + "category-observatory mesh face " + <> show identifier + <> " does not name exactly three vertices: " + <> show vertices + PictureMalformedNerveTwoSimplex identifier objects -> + "category-observatory nerve simplex " + <> show identifier + <> " does not name one face, edge, and vertex: " + <> show objects + PictureMalformedFlagKinds kinds -> + "category-observatory selected flag has incompatible object kinds: " <> show kinds + +preparePicture :: Exhibit -> Either PictureObstruction PictureContext +preparePicture exhibit = do + let meshProjection = mesh exhibit + categoryProjection = category exhibit + nerveProjection = nerve exhibit + meshVerticesValue = meshVertices meshProjection + vertexPositions = + Map.fromList + ( fmap + (\vertex -> (meshVertexIdentifier vertex, meshVertexPosition vertex)) + meshVerticesValue + ) + categoryObjectsByIdentifier = + Map.fromList + ( fmap + (\objectValue -> (categoryObjectIdentifier objectValue, objectValue)) + (categoryObjects categoryProjection) + ) + pictureBounds <- boundsFromPositions (meshVertexPosition <$> meshVerticesValue) + resolvedEdges <- traverse (resolveMeshEdge vertexPositions) (meshEdges meshProjection) + resolvedFaces <- traverse (resolveMeshFace vertexPositions) (meshFaces meshProjection) + resolvedSimplices <- + traverse + (resolveNerveSimplex categoryObjectsByIdentifier) + (nerveTwoSimplices nerveProjection) + flagSelection <- selectFlag categoryObjectsByIdentifier (nerveTwoSimplices nerveProjection) + pure + PictureContext + { contextExhibit = exhibit, + contextBounds = pictureBounds, + contextEdges = resolvedEdges, + contextFaces = resolvedFaces, + contextNerveSimplices = resolvedSimplices, + contextFlag = flagSelection + } + +boundsFromPositions :: [Position] -> Either PictureObstruction PictureBounds +boundsFromPositions positions = + case positions of + [] -> Left PictureHasNoMeshVertices + firstPosition : remainingPositions -> + Right + ( foldl' + extendBounds + ( PictureBounds + (positionX firstPosition) + (positionY firstPosition) + (positionX firstPosition) + (positionY firstPosition) + ) + remainingPositions + ) + +extendBounds :: PictureBounds -> Position -> PictureBounds +extendBounds bounds positionValue = + PictureBounds + { minimumX = min (minimumX bounds) (positionX positionValue), + minimumY = min (minimumY bounds) (positionY positionValue), + maximumX = max (maximumX bounds) (positionX positionValue), + maximumY = max (maximumY bounds) (positionY positionValue) + } + +resolveMeshEdge :: + Map.Map String Position -> + MeshEdge -> + Either PictureObstruction ResolvedMeshEdge +resolveMeshEdge vertexPositions edgeValue = + case meshEdgeVertexIdentifiers edgeValue of + [sourceIdentifier, targetIdentifier] -> + ResolvedMeshEdge edgeValue + <$> lookupMeshVertex vertexPositions sourceIdentifier + <*> lookupMeshVertex vertexPositions targetIdentifier + identifiers -> + Left (PictureMalformedMeshEdge (meshEdgeIdentifier edgeValue) identifiers) + +resolveMeshFace :: + Map.Map String Position -> + MeshFace -> + Either PictureObstruction ResolvedMeshFace +resolveMeshFace vertexPositions faceValue = + case meshFaceVertexIdentifiers faceValue of + [firstIdentifier, secondIdentifier, thirdIdentifier] -> + ResolvedMeshFace faceValue + <$> traverse + (lookupMeshVertex vertexPositions) + [firstIdentifier, secondIdentifier, thirdIdentifier] + identifiers -> + Left (PictureMalformedMeshFace (meshFaceIdentifier faceValue) identifiers) + +lookupMeshVertex :: + Map.Map String Position -> + String -> + Either PictureObstruction Position +lookupMeshVertex vertexPositions identifier = + maybe + (Left (PictureMissingMeshVertex identifier)) + Right + (Map.lookup identifier vertexPositions) + +resolveNerveSimplex :: + Map.Map String CategoryObject -> + NerveTwoSimplex -> + Either PictureObstruction ResolvedNerveSimplex +resolveNerveSimplex categoryObjectsByIdentifier simplexValue = + case nerveSimplexObjectIdentifiers simplexValue of + [faceIdentifier, edgeIdentifier, vertexIdentifier] -> + ResolvedNerveSimplex simplexValue + . fmap categoryObjectPosition + <$> traverse + (lookupCategoryObject categoryObjectsByIdentifier) + [faceIdentifier, edgeIdentifier, vertexIdentifier] + identifiers -> + Left + ( PictureMalformedNerveTwoSimplex + (nerveSimplexIdentifier simplexValue) + identifiers + ) + +selectFlag :: + Map.Map String CategoryObject -> + [NerveTwoSimplex] -> + Either PictureObstruction FlagSelection +selectFlag categoryObjectsByIdentifier simplices = + case simplices of + [] -> Left PictureHasNoNerveTwoSimplex + simplexValue : _ -> + case nerveSimplexObjectIdentifiers simplexValue of + identifiers@[faceIdentifier, edgeIdentifier, vertexIdentifier] -> do + faceObject <- lookupCategoryObject categoryObjectsByIdentifier faceIdentifier + edgeObject <- lookupCategoryObject categoryObjectsByIdentifier edgeIdentifier + vertexObject <- lookupCategoryObject categoryObjectsByIdentifier vertexIdentifier + let kinds = categoryObjectKind <$> [faceObject, edgeObject, vertexObject] + case kinds of + [FaceObject, EdgeObject, VertexObject] -> + Right + FlagSelection + { selectedSimplexIdentifier = nerveSimplexIdentifier simplexValue, + selectedFace = faceObject, + selectedEdge = edgeObject, + selectedVertex = vertexObject, + selectedObjectIdentifiers = Set.fromList identifiers + } + _ -> Left (PictureMalformedFlagKinds kinds) + identifiers -> + Left + ( PictureMalformedNerveTwoSimplex + (nerveSimplexIdentifier simplexValue) + identifiers + ) + +lookupCategoryObject :: + Map.Map String CategoryObject -> + String -> + Either PictureObstruction CategoryObject +lookupCategoryObject categoryObjectsByIdentifier identifier = + maybe + (Left (PictureMissingCategoryObject identifier)) + Right + (Map.lookup identifier categoryObjectsByIdentifier) + +renderPicture :: PictureContext -> String +renderPicture context = + unlines + ( renderDocumentOpening + <> renderHeader context + <> renderPanels context + <> renderNerveProfile context + <> [""] + ) + +renderDocumentOpening :: [String] +renderDocumentOpening = + [ "", + "", + "Moonlight category observatory", + "One checked Delaunay section shown as geometry, a local face-edge-vertex incidence flag, and the full path-sensitive flag nerve.", + "", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + "", + "", + "", + "" + ] + +renderHeader :: PictureContext -> [String] +renderHeader context = + [ svgText "mono kicker" 56 38 "start" "MOONLIGHT / FINITE DESCENT", + svgText "serif title" 56 94 "start" "One section, three faithful projections", + svgText + "sans subtitle" + 57 + 127 + "start" + "Delaunay geometry → incidence category → path-sensitive flag nerve" + ] + <> concat + ( zipWith + renderMetric + [56, 212, 368, 524, 680, 856] + (pictureMetrics context) + ) + <> [ "", + svgText "mono panel-note" 1378 168 "end" "ONE HIGHLIGHTED FLAG GLUES ALL THREE PANELS" + ] + +data PictureMetric = PictureMetric + { metricValue :: !Int, + metricLabel :: !String + } + +pictureMetrics :: PictureContext -> [PictureMetric] +pictureMetrics context = + let exhibit = contextExhibit context + meshProjection = mesh exhibit + categoryProjection = category exhibit + nerveProjection = nerve exhibit + in [ PictureMetric (length (meshVertices meshProjection)) "VERTICES", + PictureMetric (length (meshEdges meshProjection)) "EDGES", + PictureMetric (length (meshFaces meshProjection)) "FACES", + PictureMetric (length (categoryObjects categoryProjection)) "OBJECTS", + PictureMetric (length (categoryMorphisms categoryProjection)) "MORPHISMS", + PictureMetric (length (nerveTwoSimplices nerveProjection)) "FLAGS" + ] + +renderMetric :: Double -> PictureMetric -> [String] +renderMetric x metric = + [ " coordinate x <> " 151)\">", + " ", + " " <> svgText "sans metric-value" 16 22 "start" (show (metricValue metric)), + " " <> svgText "mono metric-label" 16 38 "start" (metricLabel metric), + "" + ] + +renderPanels :: PictureContext -> [String] +renderPanels context = + renderPanelBackgrounds + <> renderGeometryPanel context + <> renderCategoryPanel (contextFlag context) + <> renderNervePanel context + +renderPanelBackgrounds :: [String] +renderPanelBackgrounds = + concatMap + (\x -> [" coordinate x <> "\" y=\"222\" width=\"410\" height=\"470\" rx=\"22\" filter=\"url(#soft-shadow)\"/>"]) + [50, 515, 980] + +renderGeometryPanel :: PictureContext -> [String] +renderGeometryPanel context = + renderPanelHeader 50 "01" "Geometric section" "the admitted Delaunay cells" + <> [""] + <> fmap (renderMeshFace context geometryFrame) (contextFaces context) + <> fmap (renderMeshEdge context geometryFrame) (contextEdges context) + <> fmap (renderMeshVertex context geometryFrame) (meshVertices (mesh (contextExhibit context))) + <> renderGeometrySelectionLabels context + +geometryFrame :: PictureFrame +geometryFrame = PictureFrame 83 341 344 290 + +renderMeshFace :: PictureContext -> PictureFrame -> ResolvedMeshFace -> String +renderMeshFace context frame faceValue = + let selected = + Set.member + (meshFaceObjectIdentifier (resolvedFace faceValue)) + (selectedObjectIdentifiers (contextFlag context)) + in " selectedClass selected + <> "\" points=\"" + <> renderPointList (contextBounds context) frame (resolvedFaceVertices faceValue) + <> "\"/>" + +renderMeshEdge :: PictureContext -> PictureFrame -> ResolvedMeshEdge -> String +renderMeshEdge context frame edgeValue = + let selected = + Set.member + (meshEdgeObjectIdentifier (resolvedEdge edgeValue)) + (selectedObjectIdentifiers (contextFlag context)) + (sourceX, sourceY) = projectPosition (contextBounds context) frame (resolvedEdgeSource edgeValue) + (targetX, targetY) = projectPosition (contextBounds context) frame (resolvedEdgeTarget edgeValue) + in " selectedClass selected + <> "\" x1=\"" + <> coordinate sourceX + <> "\" y1=\"" + <> coordinate sourceY + <> "\" x2=\"" + <> coordinate targetX + <> "\" y2=\"" + <> coordinate targetY + <> "\"/>" + +renderMeshVertex :: PictureContext -> PictureFrame -> MeshVertex -> String +renderMeshVertex context frame vertexValue = + let selected = + Set.member + (meshVertexObjectIdentifier vertexValue) + (selectedObjectIdentifiers (contextFlag context)) + (x, y) = projectPosition (contextBounds context) frame (meshVertexPosition vertexValue) + in " selectedClass selected + <> "\" cx=\"" + <> coordinate x + <> "\" cy=\"" + <> coordinate y + <> "\" r=\"" + <> if selected then "7\"/>" else "4.5\"/>" + +renderGeometrySelectionLabels :: PictureContext -> [String] +renderGeometrySelectionLabels context = + let flag = contextFlag context + labelledObjects = [selectedFace flag, selectedEdge flag, selectedVertex flag] + in fmap + (\objectValue -> + let (x, y) = projectPosition (contextBounds context) geometryFrame (categoryObjectPosition objectValue) + in svgText + "mono profile-value" + (x + 10) + (y - 10) + "start" + (categoryObjectLabel objectValue) + ) + labelledObjects + +renderCategoryPanel :: FlagSelection -> [String] +renderCategoryPanel flag = + renderPanelHeader 515 "02" "Incidence category" "one local section; no arrow thicket" + <> [ svgText "mono panel-note" 720 334 "middle" "SELECTED NONDEGENERATE CHAIN", + "", + "", + "", + "", + "", + "", + svgText "mono node-kind" 589 407 "middle" "FACE OBJECT", + svgText "sans node-label" 589 471 "middle" (categoryObjectLabel (selectedFace flag)), + svgText "mono node-kind" 720 407 "middle" "EDGE OBJECT", + svgText "sans node-label" 720 471 "middle" (categoryObjectLabel (selectedEdge flag)), + svgText "mono node-kind" 850 407 "middle" "VERTEX OBJECT", + svgText "sans node-label" 850 471 "middle" (categoryObjectLabel (selectedVertex flag)), + svgText "mono panel-note" 720 535 "middle" "face → edge → vertex", + "", + svgText "serif callout-title" 720 602 "middle" "The intermediate edge survives.", + svgText "sans panel-note" 720 628 "middle" "Same endpoints, different paths, distinct flags." + ] + +renderNervePanel :: PictureContext -> [String] +renderNervePanel context = + renderPanelHeader 980 "03" "Flag nerve" "all 66 admitted two-simplices" + <> [""] + <> fmap (renderNerveSimplex context nerveFrame) (contextNerveSimplices context) + <> fmap (renderNerveObject context nerveFrame) (categoryObjects (category (contextExhibit context))) + <> renderNerveSelectionLabel context + +nerveFrame :: PictureFrame +nerveFrame = PictureFrame 1013 341 344 290 + +renderNerveSimplex :: PictureContext -> PictureFrame -> ResolvedNerveSimplex -> String +renderNerveSimplex context frame simplexValue = + let selected = + nerveSimplexIdentifier (resolvedSimplex simplexValue) + == selectedSimplexIdentifier (contextFlag context) + in " selectedClass selected + <> "\" points=\"" + <> renderPointList (contextBounds context) frame (resolvedSimplexVertices simplexValue) + <> "\"/>" + +renderNerveObject :: PictureContext -> PictureFrame -> CategoryObject -> String +renderNerveObject context frame objectValue = + let selected = + Set.member + (categoryObjectIdentifier objectValue) + (selectedObjectIdentifiers (contextFlag context)) + (x, y) = projectPosition (contextBounds context) frame (categoryObjectPosition objectValue) + radius = if selected then 6 else 3.4 + in " objectKindClass (categoryObjectKind objectValue) + <> "\" cx=\"" + <> coordinate x + <> "\" cy=\"" + <> coordinate y + <> "\" r=\"" + <> coordinate radius + <> "\" opacity=\"" + <> if selected then "1\" stroke=\"#fff\" stroke-width=\"2\"/>" else ".78\"/>" + +renderNerveSelectionLabel :: PictureContext -> [String] +renderNerveSelectionLabel context = + let flag = contextFlag context + faceObject = selectedFace flag + (x, y) = projectPosition (contextBounds context) nerveFrame (categoryObjectPosition faceObject) + in [ svgText "mono profile-value" (x + 12) (y - 12) "start" "selected flag", + svgText "mono panel-note" 1352 642 "end" (selectedSimplexIdentifier flag) + ] + +renderPanelHeader :: Double -> String -> String -> String -> [String] +renderPanelHeader x number titleText note = + [ svgText "mono panel-number" (x + 22) 254 "start" number, + svgText "serif panel-title" (x + 22) 282 "start" titleText, + svgText "sans panel-note" (x + 22) 304 "start" note, + " coordinate (x + 20) + <> " 314H" + <> coordinate (x + 390) + <> "\" stroke=\"#8bbeb2\" stroke-opacity=\".14\"/>" + ] + +renderNerveProfile :: PictureContext -> [String] +renderNerveProfile context = + let counts = nerveSimplexCounts (nerve (contextExhibit context)) + maximumCount = + foldl' + (\current count -> max current (unnormalizedSimplexCount count)) + 1 + counts + in [ "", + svgText "mono kicker" 76 752 "start" "NORMALIZATION PROFILE", + svgText "serif panel-title" 76 789 "start" "Identity insertions are cost, not geometry.", + svgText "sans panel-note" 76 817 "start" "Identity insertions swell dimension two to 385.", + "", + svgText "mono profile-label" 96 845 "start" "NORMALIZED", + "", + svgText "mono profile-label" 216 845 "start" "UNNORMALIZED" + ] + <> concat + ( zipWith + (renderProfileRow maximumCount) + [770, 814, 858] + counts + ) + +renderProfileRow :: Int -> Double -> NerveSimplexCount -> [String] +renderProfileRow maximumCount y count = + let normalizedWidth = profileWidth maximumCount (normalizedSimplexCount count) + unnormalizedWidth = profileWidth maximumCount (unnormalizedSimplexCount count) + in [ svgText "mono profile-label" 590 (y + 5) "end" ("DIM " <> show (nerveDimension count)), + " coordinate (y - 8) <> "\" width=\"230\" height=\"11\" rx=\"5.5\" fill=\"#13272d\"/>", + " coordinate (y - 8) <> "\" width=\"" <> coordinate normalizedWidth <> "\" height=\"11\" rx=\"5.5\" fill=\"#72d6c2\"/>", + svgText "mono profile-value" 858 (y + 3) "start" (show (normalizedSimplexCount count)), + " coordinate (y - 8) <> "\" width=\"310\" height=\"11\" rx=\"5.5\" fill=\"#1d1830\"/>", + " coordinate (y - 8) <> "\" width=\"" <> coordinate (unnormalizedWidth * 310 / 230) <> "\" height=\"11\" rx=\"5.5\" fill=\"#bc8cff\"/>", + svgText "mono profile-value" 1288 (y + 3) "start" (show (unnormalizedSimplexCount count)) + ] + +profileWidth :: Int -> Int -> Double +profileWidth maximumCount count = + 230 * fromIntegral count / fromIntegral maximumCount + +projectPosition :: PictureBounds -> PictureFrame -> Position -> (Double, Double) +projectPosition bounds frame positionValue = + ( frameLeft frame + + frameWidth frame + * normalizedCoordinate (positionX positionValue) (minimumX bounds) (maximumX bounds), + frameTop frame + + frameHeight frame + * normalizedCoordinate (positionY positionValue) (minimumY bounds) (maximumY bounds) + ) + +normalizedCoordinate :: Double -> Double -> Double -> Double +normalizedCoordinate value minimumValue maximumValue = + if maximumValue == minimumValue + then 0.5 + else (value - minimumValue) / (maximumValue - minimumValue) + +renderPointList :: PictureBounds -> PictureFrame -> [Position] -> String +renderPointList bounds frame = + unwords + . fmap + (\positionValue -> + let (x, y) = projectPosition bounds frame positionValue + in coordinate x <> "," <> coordinate y + ) + +selectedClass :: Bool -> String +selectedClass selected = if selected then " selected" else "" + +objectKindClass :: CategoryObjectKind -> String +objectKindClass = \case + FaceObject -> "object-face" + EdgeObject -> "object-edge" + VertexObject -> "object-vertex" + +svgText :: String -> Double -> Double -> String -> String -> String +svgText classes x y anchor contents = + " classes + <> "\" x=\"" + <> coordinate x + <> "\" y=\"" + <> coordinate y + <> "\" text-anchor=\"" + <> anchor + <> "\">" + <> escapeXml contents + <> "" + +coordinate :: Double -> String +coordinate value = showFFloat (Just 1) value "" + +escapeXml :: String -> String +escapeXml = concatMap escapeCharacter + +escapeCharacter :: Char -> String +escapeCharacter = \case + '&' -> "&" + '<' -> "<" + '>' -> ">" + '\"' -> """ + '\'' -> "'" + character -> [character] diff --git a/docs/category-observatory/README.md b/docs/category-observatory/README.md new file mode 100644 --- /dev/null +++ b/docs/category-observatory/README.md @@ -0,0 +1,142 @@ +# Moonlight category observatory + +![The Moonlight category observatory showing one Delaunay cell selection as geometry, its incidence category, and its flag nerve](./moonlight-triangulation-category-observatory.svg) + +[Browse all exhibits.](../README.md) +· [Read the package operation index.](../../README.md#operations) + +The category observatory follows one checked finite section through three +synchronized views: the selected Delaunay cells, their incidence category, and +the normalized nerve of that category. The visual above is the package-owned +compact SVG projection of the same admitted `Exhibit`: one face-edge-vertex +flag is restricted through all three panels while the full mesh and 66 +two-simplices remain visible. It is neither a viewport screenshot nor a second +mathematical model. + +## Cell-complex and category interpretation + +The `cell-complex` component interprets an `ExactCellSet` as Homology's generic +`CellComplex2D`. The opaque carrier retains the authoritative selected handles +and resident DCEL. `fromExactCellSet` is total because `ExactCellSet` +construction has already discharged downward closure and handle validity. + +The interpretation is available on GHC 9.14 and newer. Existing Triangulation +components retain the package's GHC 9.8–9.14 support range: below 9.14 Cabal +marks only `cell-complex`, its focused test, and the category-observatory +exporter unbuildable. Hackage aggregates dependencies from every component on +the package page, but an ordinary main-library consumer does not inherit the +Homology or Category closure. + +```cabal +-- the consumer package +build-depends: + base >= 4.22 && < 5, + moonlight-triangulation >= 1.4 && < 1.5, + moonlight-triangulation:cell-complex >= 1.4 && < 1.5, + moonlight-homology:cell-category >= 0.1 && < 0.2 +``` + +```haskell +import Moonlight.Homology.Pure.Topology.CellCategory (complexCategory) +import Moonlight.Triangulation.CellComplex (fromExactCellSet) + +incidenceCategory = complexCategory . fromExactCellSet +``` + +## What owns what + +The executable composes existing owners in one direction: + +```text +ExactCellSet + -> Moonlight.Triangulation.CellComplex.DCELComplex + -> Moonlight.Homology.Pure.Topology.CellCategory.ComplexCat + -> Moonlight.Category.Simplicial.normalizedNerve + -> checked schema-version-2 JSON + -> Melusine's /category browser projection +``` + +`moonlight-triangulation-category-observatory-export` owns only the checked +projection boundary. Geometry remains in Triangulation, the generic +two-dimensional cell interface and incidence category remain in Homology, and +the browser remains a derived view. There is no observatory-specific mesh, +category implementation, or nerve implementation lurking behind the scenery. + +## Deterministic witness + +The retained ten-point section yields: + +| observation | count | +| --- | ---: | +| vertices | 10 | +| undirected edges | 20 | +| bounded faces | 11 | +| category objects | 41 | +| category morphisms | 180 | +| face-edge-vertex incidence flags | 66 | + +The normalized and identity-saturated unnormalized nerves contain respectively +`41 / 41`, `139 / 180`, and `66 / 385` simplices in dimensions 0, 1, and 2. +Each rendered 2-simplex retains its intermediate edge; this is the +path-sensitive incidence flag nerve, not a thinned face poset. + +Before encoding, the pure builder checks the selected-cell inventory, the four +morphism classes, every morphism endpoint, every 2-simplex shape, and equality +between the face-incidence and rendered-flag counts. Failures inhabit +`ExhibitError`; stdout receives JSON only after those local sections glue. + +## Run the exporter + +The Homology-backed component requires GHC 9.14 or newer. From the repository +root: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-category-observatory-export \ + --project-file=cabal.project.triangulation-dev +``` + +That command emits the deterministic schema-version-2 document to stdout. To +regenerate or verify the retained documentation picture: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-category-observatory-export \ + --project-file=cabal.project.triangulation-dev -- \ + picture compiler/foundation/moonlight-triangulation/docs/category-observatory/moonlight-triangulation-category-observatory.svg +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-category-observatory-export \ + --project-file=cabal.project.triangulation-dev -- \ + verify-artifacts compiler/foundation/moonlight-triangulation +``` + +To run the interactive browser consumer: + +```console +cd compiler/engine/melusine-visualization +pnpm dev:category +``` + +Open `http://127.0.0.1:5173/category`. Hovering a cell, category arrow, or flag +restricts the other two panels to the same semantic objects; the dimension +control reveals the normalized 0-, 1-, and 2-simplex sections. + +## Source decomposition + +`Main.hs` is only the `IO` edge: render a typed obstruction or encode the +admitted exhibit. The pure implementation is split by mathematical +responsibility: + +| module | responsibility | +| --- | --- | +| `Moonlight.Triangulation.Exhibit.CategoryObservatory` | deterministic witness and final descent | +| `.Model` | JSON projection types and typed obstructions | +| `.Geometry` | mesh projection and geometric object placement | +| `.Category` | finite object/morphism projection and inventory law | +| `.Nerve` | normalized/unnormalized nerve projection and flag law | +| `.Identifier` | the single identifier/label interpretation shared by all projections | +| `.Picture` | compact pure SVG projection of the admitted exhibit | + +The split is semantic rather than ceremonial: no wrapper modules, no duplicate +projection types, no hand-maintained duplicate mesh coordinates, and no mutable +orchestration wearing an expensive hat. diff --git a/docs/category-observatory/moonlight-triangulation-category-observatory.svg b/docs/category-observatory/moonlight-triangulation-category-observatory.svg new file mode 100644 --- /dev/null +++ b/docs/category-observatory/moonlight-triangulation-category-observatory.svg @@ -0,0 +1,293 @@ + + +Moonlight category observatory +One checked Delaunay section shown as geometry, a local face-edge-vertex incidence flag, and the full path-sensitive flag nerve. + + + + + + + + + + + + +MOONLIGHT / FINITE DESCENT +One section, three faithful projections +Delaunay geometry → incidence category → path-sensitive flag nerve + + + 10 + VERTICES + + + + 20 + EDGES + + + + 11 + FACES + + + + 41 + OBJECTS + + + + 180 + MORPHISMS + + + + 66 + FLAGS + + +ONE HIGHLIGHTED FLAG GLUES ALL THREE PANELS + + + +01 +Geometric section +the admitted Delaunay cells + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +f1 +e0 +v0 +02 +Incidence category +one local section; no arrow thicket + +SELECTED NONDEGENERATE CHAIN + + + + + + +FACE OBJECT +f1 +EDGE OBJECT +e0 +VERTEX OBJECT +v0 +face → edge → vertex + +The intermediate edge survives. +Same endpoints, different paths, distinct flags. +03 +Flag nerve +all 66 admitted two-simplices + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +selected flag +simplex-0 + +NORMALIZATION PROFILE +Identity insertions are cost, not geometry. +Identity insertions swell dimension two to 385. + +NORMALIZED + +UNNORMALIZED +DIM 0 + + +41 + + +41 +DIM 1 + + +139 + + +180 +DIM 2 + + +66 + + +385 + diff --git a/docs/delaunay-compare/Main.hs b/docs/delaunay-compare/Main.hs new file mode 100644 --- /dev/null +++ b/docs/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/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs new file mode 100644 --- /dev/null +++ b/docs/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/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs new file mode 100644 --- /dev/null +++ b/docs/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 -> + "docs/delaunay-compare/rust/Cargo.toml" + :| [ "foundation/moonlight-triangulation/docs/delaunay-compare/rust/Cargo.toml" + , "compiler/foundation/moonlight-triangulation/docs/delaunay-compare/rust/Cargo.toml" + ] + existing <- filterM doesFileExist (NonEmpty.toList candidates) + case existing of + manifest : _ -> Right <$> makeAbsolute manifest + [] -> pure (Left (RustManifestNotFound candidates)) + +buildRustLibrary :: FilePath -> IO (Either CompareObstruction FilePath) +buildRustLibrary manifest = do + libraryNameResult <- dynamicLibraryName + case libraryNameResult of + Left obstruction -> pure (Left obstruction) + Right libraryName -> do + let rustRoot = takeDirectory manifest + targetDirectory = rustRoot "target" + command = + ( proc + "cargo" + [ "build" + , "--quiet" + , "--release" + , "--lib" + , "--manifest-path" + , manifest + , "--target-dir" + , targetDirectory + ] + ) + { cwd = Just rustRoot + } + invocation <- try @IOException (readCreateProcessWithExitCode command "") + pure $ + case invocation of + Left exception -> + Left (CargoInvocationFailed manifest (displayException exception)) + Right (ExitFailure exitCode, standardOutput, standardError) -> + Left + ( CargoBuildFailed + manifest + exitCode + (standardError <> standardOutput) + ) + Right (ExitSuccess, _, _) -> + Right (targetDirectory "release" libraryName) + +dynamicLibraryName :: IO (Either CompareObstruction FilePath) +dynamicLibraryName = + pure $ + case os of + "darwin" -> Right "libmoonlight_delaunay_compare_referents.dylib" + "linux" -> Right "libmoonlight_delaunay_compare_referents.so" + host -> Left (UnsupportedDynamicLibraryHost host) + +withLoadedNativeApi + :: FilePath + -> (NativeApi -> IO (Either CompareObstruction result)) + -> IO (Either CompareObstruction result) +withLoadedNativeApi libraryPath action = do + opened <- try @IOException (dlopen libraryPath [RTLD_NOW, RTLD_LOCAL]) + case opened of + Left exception -> + pure (Left (DynamicLibraryOpenFailed libraryPath (displayException exception))) + Right handle -> + bracket + (pure handle) + dlclose + ( \loadedHandle -> do + apiResult <- loadNativeApi libraryPath loadedHandle + case apiResult of + Left obstruction -> pure (Left obstruction) + Right api -> action api + ) + +loadNativeApi :: FilePath -> DL -> IO (Either CompareObstruction NativeApi) +loadNativeApi libraryPath handle = + runExceptT $ + NativeApi + <$> loadSymbol libraryPath handle "delaunay_compare_generate" bindGenerateFunction + <*> loadSymbol libraryPath handle "delaunay_compare_prepare" bindPrepareFunction + <*> loadSymbol libraryPath handle "delaunay_compare_run" bindRunFunction + <*> loadSymbol libraryPath handle "delaunay_compare_release" bindReleaseFunction + +loadSymbol + :: FilePath + -> DL + -> String + -> (FunPtr function -> boundFunction) + -> ExceptT CompareObstruction IO boundFunction +loadSymbol libraryPath handle symbol bind = + ExceptT $ do + loaded <- try @IOException (dlsym handle symbol) + pure $ + first + (DynamicSymbolLoadFailed libraryPath symbol . displayException) + (bind <$> loaded) + +generateCoordinates + :: NativeApi + -> FixtureSpec + -> IO (Either NativeStatus GeneratedCoordinates) +generateCoordinates api fixture = do + let pointCount = fixturePointCount fixture + coordinateCount = 2 * pointCountValue pointCount + mutableCoordinates <- MutableStorableVector.new coordinateCount + statusCode <- + MutableStorableVector.unsafeWith mutableCoordinates $ \coordinatePointer -> + nativeGenerate api + (distributionTag (fixturePointDistribution fixture)) + (fromIntegral (pointCountValue pointCount)) + coordinatePointer + (fromIntegral coordinateCount) + case decodeNativeStatus statusCode of + Left status -> pure (Left status) + Right () -> do + coordinates <- StorableVector.unsafeFreeze mutableCoordinates + pure (Right (GeneratedCoordinates pointCount coordinates)) + +generatedCoordinatePairs :: GeneratedCoordinates -> Vector.Vector (Double, Double) +generatedCoordinatePairs generated = + Vector.fromList + ( unfoldr + takeCoordinatePair + (realToFrac <$> StorableVector.toList (generatedCoordinateValues generated)) + ) + where + takeCoordinatePair :: [Double] -> Maybe ((Double, Double), [Double]) + takeCoordinatePair = \case + x : y : remaining -> Just ((x, y), remaining) + _ -> Nothing + +prepareNativeFixture + :: NativeApi + -> NativeImplementation + -> GeneratedCoordinates + -> IO (Either NativePreparationFailure NativeFixture) +prepareNativeFixture api implementation coordinates = + alloca $ \preparedOutput -> do + poke preparedOutput nullPtr + statusCode <- + StorableVector.unsafeWith (generatedCoordinateValues coordinates) $ \coordinatePointer -> + nativePrepare api + (implementationTag implementation) + coordinatePointer + (fromIntegral (pointCountValue (generatedPointCount coordinates))) + preparedOutput + case decodeNativeStatus statusCode of + Left status -> pure (Left (NativePreparationStatus status)) + Right () -> do + prepared <- peek preparedOutput + pure $ + if prepared == nullPtr + then Left NativePreparationReturnedNull + else Right (NativeFixture prepared) + +runNativeFixture + :: NativeApi + -> NativeFixture + -> IO (Either NativeRunFailure DelaunaySummary) +runNativeFixture api (NativeFixture prepared) = + alloca $ \vertexCountOutput -> + alloca $ \triangleCountOutput -> do + statusCode <- nativeRun api prepared vertexCountOutput triangleCountOutput + case decodeNativeStatus statusCode of + Left status -> pure (Left (NativeRunStatus status)) + Right () -> do + vertexCount <- peek vertexCountOutput + triangleCount <- peek triangleCountOutput + pure $ DelaunaySummary <$> cSizeToInt vertexCount <*> cSizeToInt triangleCount + +releaseNativeFixture :: NativeApi -> NativeFixture -> IO () +releaseNativeFixture api (NativeFixture prepared) = nativeRelease api prepared + +decodeNativeStatus :: CInt -> Either NativeStatus () +decodeNativeStatus statusCode = + case fromIntegral statusCode :: Int32 of + 0 -> Right () + 1 -> Left NativeNullPointer + 2 -> Left NativeUnknownTag + 3 -> Left NativeCoordinateCountMismatch + 4 -> Left NativeDistributionConstructionFailed + 5 -> Left NativeTriangulationFailed + 6 -> Left NativePanicked + unknown -> Left (NativeUnknownStatus (fromIntegral unknown)) + +cSizeToInt :: CSize -> Either NativeRunFailure Int +cSizeToInt value = + let integerValue = toInteger value + in if integerValue > toInteger (maxBound :: Int) + then Left (NativeCountExceedsHaskellInt integerValue) + else Right (fromInteger integerValue) + +distributionTag :: PointDistribution -> CInt +distributionTag = \case + LocalInsertion -> 0 + Uniform -> 1 + +implementationTag :: NativeImplementation -> CInt +implementationTag = \case + NativeSpade -> 0 + NativeSpadeHierarchy -> 1 + NativeCdt -> 2 + NativeDelaunator -> 3 diff --git a/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs new file mode 100644 --- /dev/null +++ b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Typed receipt parsing and pure Spade-style SVG projection. +module Moonlight.Triangulation.Bench.DelaunayCompare.Picture + ( BenchmarkReceipt + , PictureObstruction (..) + , parseBenchmarkReceipt + , pictureFileName + , renderComparisonPicture + , renderPictureObstruction + ) where + +import Data.List (group, sort, sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain +import Numeric (showFFloat) +import Text.Read (readMaybe) + +data ObservationKey = ObservationKey + { observationFixture :: !FixtureSpec + , observationImplementation :: !Implementation + } + deriving stock (Eq, Ord, Show) + +data BenchmarkObservation = BenchmarkObservation + { benchmarkKey :: !ObservationKey + , benchmarkMeanPicoseconds :: !Double + , benchmarkSpreadPicoseconds :: !Double + } + deriving stock (Eq, Show) + +newtype BenchmarkReceipt = BenchmarkReceipt + { receiptObservations :: Map.Map ObservationKey BenchmarkObservation + } + +data PictureObstruction + = MissingCsvHeader + | UnexpectedCsvHeader !String + | MalformedCsvRow !Int !String + | UnknownBenchmarkName !Int !String + | InvalidBenchmarkScalar !Int !String !String + | DuplicateBenchmarkObservations ![ObservationKey] + | MissingBenchmarkObservations ![ObservationKey] + deriving stock (Eq, Show) + +parseBenchmarkReceipt :: String -> Either PictureObstruction BenchmarkReceipt +parseBenchmarkReceipt source = + case lines source of + [] -> Left MissingCsvHeader + header : rows + | header /= expectedCsvHeader -> Left (UnexpectedCsvHeader header) + | otherwise -> do + observations <- traverse (uncurry parseObservationRow) (zip [2 ..] rows) + let keys = benchmarkKey <$> observations + duplicateKeys = + mapMaybe + ( \case + key : _ : _ -> Just key + _ -> Nothing + ) + (group (sort keys)) + observationMap = Map.fromList ((\observation -> (benchmarkKey observation, observation)) <$> observations) + missingKeys = Set.toList (expectedObservationKeys `Set.difference` Map.keysSet observationMap) + case (duplicateKeys, missingKeys) of + (duplicate : duplicates, _) -> Left (DuplicateBenchmarkObservations (duplicate : duplicates)) + ([], missing : remaining) -> Left (MissingBenchmarkObservations (missing : remaining)) + ([], []) -> Right (BenchmarkReceipt observationMap) + +renderComparisonPicture + :: SizeBand + -> BenchmarkReceipt + -> String +renderComparisonPicture sizeBand receipt = + renderSvg sizeBand pointCounts axisMaximum panels + where + pointCounts = pointCountValue <$> pointCountsFor sizeBand + panels = picturePanel receipt sizeBand <$> allPointDistributions + allObservations = concatMap (concatMap pictureSeriesObservations . picturePanelSeries) panels + maximumMilliseconds = + foldr + (max . observationUpperMilliseconds) + 0 + allObservations + axisMaximum = niceCeiling maximumMilliseconds + +pictureFileName :: SizeBand -> FilePath +pictureFileName = \case + Small -> "moonlight-delaunay-compare-small.svg" + Big -> "moonlight-delaunay-compare-big.svg" + +renderPictureObstruction :: PictureObstruction -> String +renderPictureObstruction = \case + MissingCsvHeader -> "benchmark CSV has no header" + UnexpectedCsvHeader header -> + "benchmark CSV header was " <> show header <> "; expected " <> show expectedCsvHeader + MalformedCsvRow lineNumber row -> + "benchmark CSV row " <> show lineNumber <> " is not a three-column tasty-bench row: " <> show row + UnknownBenchmarkName lineNumber name -> + "benchmark CSV row " <> show lineNumber <> " names an unknown comparison case: " <> show name + InvalidBenchmarkScalar lineNumber field value -> + "benchmark CSV row " + <> show lineNumber + <> " has invalid " + <> field + <> ": " + <> show value + DuplicateBenchmarkObservations keys -> + "benchmark CSV repeats comparison cases: " <> show keys + MissingBenchmarkObservations keys -> + "benchmark CSV omits comparison cases: " <> show keys + +expectedCsvHeader :: String +expectedCsvHeader = "Name,Mean (ps),2*Stdev (ps)" + +expectedObservationKeys :: Set.Set ObservationKey +expectedObservationKeys = + Set.fromList (liftA2 ObservationKey allFixtureSpecs allImplementations) + +expectedBenchmarkNames :: Map.Map String ObservationKey +expectedBenchmarkNames = + Map.fromList ((\key -> (benchmarkName key, key)) <$> Set.toList expectedObservationKeys) + +benchmarkName :: ObservationKey -> String +benchmarkName key = + "All.comparison: creation benchmark (" + <> sizeBandLabel (fixtureSizeBand fixture) + <> ")." + <> implementationLabel (observationImplementation key) + <> "." + <> pointDistributionLabel (fixturePointDistribution fixture) + <> "." + <> show (pointCountValue (fixturePointCount fixture)) + where + fixture = observationFixture key + +parseObservationRow :: Int -> String -> Either PictureObstruction BenchmarkObservation +parseObservationRow lineNumber row = + case csvTriple row of + Nothing -> Left (MalformedCsvRow lineNumber row) + Just (name, rawMean, rawSpread) -> do + key <- maybe (Left (UnknownBenchmarkName lineNumber name)) Right (Map.lookup name expectedBenchmarkNames) + meanPicoseconds <- parseNonNegativeScalar lineNumber "mean picoseconds" rawMean + spreadPicoseconds <- parseNonNegativeScalar lineNumber "two-standard-deviation spread" rawSpread + pure + BenchmarkObservation + { benchmarkKey = key + , benchmarkMeanPicoseconds = meanPicoseconds + , benchmarkSpreadPicoseconds = spreadPicoseconds + } + +csvTriple :: String -> Maybe (String, String, String) +csvTriple row = + case break (== ',') row of + (firstColumn, ',' : remaining) -> + case break (== ',') remaining of + (secondColumn, ',' : thirdColumn) + | ',' `notElem` thirdColumn -> Just (firstColumn, secondColumn, thirdColumn) + _ -> Nothing + _ -> Nothing + +parseNonNegativeScalar :: Int -> String -> String -> Either PictureObstruction Double +parseNonNegativeScalar lineNumber field rawValue = + case readMaybe rawValue of + Just value + | value >= 0 && not (isInfinite value) && not (isNaN value) -> Right value + _ -> Left (InvalidBenchmarkScalar lineNumber field rawValue) + +data PictureSeries = PictureSeries + { pictureSeriesImplementation :: !Implementation + , pictureSeriesObservations :: ![BenchmarkObservation] + } + +data PicturePanel = PicturePanel + { picturePanelDistribution :: !PointDistribution + , picturePanelSeries :: ![PictureSeries] + } + +picturePanel + :: BenchmarkReceipt + -> SizeBand + -> PointDistribution + -> PicturePanel +picturePanel receipt sizeBand distribution = + PicturePanel distribution (pictureSeries receipt sizeBand distribution <$> allImplementations) + +pictureSeries + :: BenchmarkReceipt + -> SizeBand + -> PointDistribution + -> Implementation + -> PictureSeries +pictureSeries receipt sizeBand distribution implementation = + PictureSeries implementation observations + where + observations = + sortOn (pointCountValue . fixturePointCount . observationFixture . benchmarkKey) + [ observation + | observation <- Map.elems (receiptObservations receipt) + , let key = benchmarkKey observation + fixture = observationFixture key + , fixtureSizeBand fixture == sizeBand + , fixturePointDistribution fixture == distribution + , observationImplementation key == implementation + ] + +data PictureLayout = PictureLayout + { pictureWidth :: !Double + , pictureHeight :: !Double + , picturePlotTop :: !Double + , picturePlotBottom :: !Double + , picturePanelWidth :: !Double + , picturePanelLefts :: ![Double] + } + +pictureLayout :: PictureLayout +pictureLayout = + PictureLayout + { pictureWidth = 1280 + , pictureHeight = 720 + , picturePlotTop = 168 + , picturePlotBottom = 610 + , picturePanelWidth = 540 + , picturePanelLefts = [70, 670] + } + +renderSvg :: SizeBand -> [Int] -> Double -> [PicturePanel] -> String +renderSvg sizeBand pointCounts axisMaximum panels = + unlines + ( [ "" + , " 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) + <> [""] + 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) + +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/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs new file mode 100644 --- /dev/null +++ b/docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Fixture descent, compatibility gluing, and the authoritative benchmark view. +module Moonlight.Triangulation.Bench.DelaunayCompare.Suite + ( PreparedSuite + , withPreparedSuite + , preflightSuite + , suiteBenchmarks + , suiteAgreementMessage + ) where + +import Control.DeepSeq (force) +import Control.Exception (bracket, evaluate) +import Data.Bifunctor (first) +import Data.Either (lefts, rights) +import Data.Foldable (toList, traverse_) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Vector as Vector +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain +import Moonlight.Triangulation.Bench.DelaunayCompare.Native +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices) +import Moonlight.Triangulation.Types (BuildError, Point (Point)) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf, nfIO) + +data NativeSections value = NativeSections + { nativeSpadeSection :: !value + , nativeSpadeHierarchySection :: !value + , nativeCdtSection :: !value + , nativeDelaunatorSection :: !value + } + deriving stock (Functor, Foldable, Traversable) + +nativeImplementationSections :: NativeSections NativeImplementation +nativeImplementationSections = + NativeSections + { nativeSpadeSection = NativeSpade + , nativeSpadeHierarchySection = NativeSpadeHierarchy + , nativeCdtSection = NativeCdt + , nativeDelaunatorSection = NativeDelaunator + } + +nativeSectionAt :: NativeImplementation -> NativeSections value -> value +nativeSectionAt implementation sections = + case implementation of + NativeSpade -> nativeSpadeSection sections + NativeSpadeHierarchy -> nativeSpadeHierarchySection sections + NativeCdt -> nativeCdtSection sections + NativeDelaunator -> nativeDelaunatorSection sections + +data PreparedFixture = PreparedFixture + { preparedSpec :: !FixtureSpec + , preparedMoonlightPoints :: !(Vector.Vector Point) + , preparedNativeFixtures :: !(NativeSections NativeFixture) + } + +newtype PreparedSuite = PreparedSuite [PreparedFixture] + +withPreparedSuite + :: NativeApi + -> (PreparedSuite -> IO (Either CompareObstruction result)) + -> IO (Either CompareObstruction result) +withPreparedSuite api action = do + prepared <- prepareSuite api + case prepared of + Left obstruction -> pure (Left obstruction) + Right suite -> bracket (pure suite) (releaseSuite api) action + +prepareSuite :: NativeApi -> IO (Either CompareObstruction PreparedSuite) +prepareSuite api = do + outcomes <- traverse (prepareFixture api) allFixtureSpecs + case NonEmpty.nonEmpty (lefts outcomes) of + Just obstructions -> do + traverse_ (releasePreparedFixture api) (rights outcomes) + pure (Left (ComparisonObstructions obstructions)) + Nothing -> pure (Right (PreparedSuite (rights outcomes))) + +prepareFixture :: NativeApi -> FixtureSpec -> IO (Either CompareObstruction PreparedFixture) +prepareFixture api fixture = do + generated <- generateCoordinates api fixture + case generated of + Left status -> pure (Left (FixtureGenerationFailed fixture status)) + Right coordinates -> do + nativeFixtures <- prepareNativeFixtures api fixture coordinates + pure $ + PreparedFixture + fixture + (Vector.map (uncurry Point) (generatedCoordinatePairs coordinates)) + <$> nativeFixtures + +prepareNativeFixtures + :: NativeApi + -> FixtureSpec + -> GeneratedCoordinates + -> IO (Either CompareObstruction (NativeSections NativeFixture)) +prepareNativeFixtures api fixture coordinates = do + outcomes <- traverse prepareSection nativeImplementationSections + case sequenceA outcomes of + Right nativeFixtures -> pure (Right nativeFixtures) + Left obstruction -> do + traverse_ (releaseNativeFixture api) (rights (toList outcomes)) + pure (Left obstruction) + where + prepareSection implementation = do + prepared <- prepareNativeFixture api implementation coordinates + pure $ + first + (preparationObstruction implementation) + prepared + + preparationObstruction implementation failure = + case failure of + NativePreparationStatus status -> FixturePreparationFailed fixture implementation status + NativePreparationReturnedNull -> NativePreparedNull fixture implementation + +releaseSuite :: NativeApi -> PreparedSuite -> IO () +releaseSuite api (PreparedSuite fixtures) = + traverse_ (releasePreparedFixture api) fixtures + +releasePreparedFixture :: NativeApi -> PreparedFixture -> IO () +releasePreparedFixture api = releasePreparedNativeFixtures api . preparedNativeFixtures + +releasePreparedNativeFixtures :: NativeApi -> NativeSections NativeFixture -> IO () +releasePreparedNativeFixtures api = traverse_ (releaseNativeFixture api) + +preflightSuite :: NativeApi -> PreparedSuite -> IO (Either CompareObstruction ()) +preflightSuite api (PreparedSuite fixtures) = do + outcomes <- traverse (preflightFixture api) fixtures + pure $ + case NonEmpty.nonEmpty (lefts outcomes) of + Just obstructions -> Left (ComparisonObstructions obstructions) + Nothing -> Right () + +preflightFixture :: NativeApi -> PreparedFixture -> IO (Either CompareObstruction ()) +preflightFixture api fixture = do + moonlightResult <- + evaluate + ( force + (moonlightConstructionSummary (preparedMoonlightPoints fixture)) + ) + nativeOutcomes <- traverse runSection nativeImplementationSections + pure $ do + moonlightSummary <- + first + (MoonlightConstructionFailed spec) + moonlightResult + nativeSummaries <- sequenceA nativeOutcomes + traverse_ + ( \implementation -> + requireSummaryAgreement + spec + moonlightSummary + ( implementationOfNative implementation + , nativeSectionAt implementation nativeSummaries + ) + ) + nativeImplementationSections + where + spec = preparedSpec fixture + nativeFixtures = preparedNativeFixtures fixture + runSection implementation = + first (NativeConstructionFailed spec implementation) + <$> runNativeFixture api (nativeSectionAt implementation nativeFixtures) + +requireSummaryAgreement + :: FixtureSpec + -> DelaunaySummary + -> (Implementation, DelaunaySummary) + -> Either CompareObstruction () +requireSummaryAgreement fixture expected (implementation, observed) = + if observed == expected + then Right () + else Left (SummaryDisagreement fixture implementation expected observed) + +moonlightConstructionSummary + :: Vector.Vector Point + -> Either BuildError DelaunaySummary +moonlightConstructionSummary points = do + triangulation <- delaunayGeometry points + pure + DelaunaySummary + { summaryVertexCount = numVertices triangulation + , summaryTriangleCount = numInnerFaces triangulation + } + +suiteBenchmarks :: NativeApi -> PreparedSuite -> [Benchmark] +suiteBenchmarks api (PreparedSuite fixtures) = + fmap (sizeBandBenchmarks api fixtures) allSizeBands + +sizeBandBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Benchmark +sizeBandBenchmarks api fixtures sizeBand = + bgroup + ("comparison: creation benchmark (" <> sizeBandLabel sizeBand <> ")") + (fmap (implementationBenchmarks api fixtures sizeBand) allImplementations) + +implementationBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Implementation + -> Benchmark +implementationBenchmarks api fixtures sizeBand implementation = + bgroup + (implementationLabel implementation) + ( fmap + (distributionBenchmarks api fixtures sizeBand implementation) + allPointDistributions + ) + +distributionBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Implementation + -> PointDistribution + -> Benchmark +distributionBenchmarks api fixtures sizeBand implementation distribution = + bgroup + (pointDistributionLabel distribution) + ( fmap + (fixtureBenchmark api implementation) + ( filter + (matchesFixture sizeBand distribution . preparedSpec) + fixtures + ) + ) + +matchesFixture :: SizeBand -> PointDistribution -> FixtureSpec -> Bool +matchesFixture sizeBand distribution fixture = + fixtureSizeBand fixture == sizeBand + && fixturePointDistribution fixture == distribution + +fixtureBenchmark :: NativeApi -> Implementation -> PreparedFixture -> Benchmark +fixtureBenchmark api implementation fixture = + bench (show (pointCountValue (fixturePointCount (preparedSpec fixture)))) $ + case implementation of + Moonlight -> nf moonlightConstructionSummary (preparedMoonlightPoints fixture) + Spade -> nativeBenchmark NativeSpade + SpadeHierarchy -> nativeBenchmark NativeSpadeHierarchy + Cdt -> nativeBenchmark NativeCdt + Delaunator -> nativeBenchmark NativeDelaunator + where + nativeFixtures = preparedNativeFixtures fixture + nativeBenchmark nativeImplementation = + nfIO (runNativeFixture api (nativeSectionAt nativeImplementation nativeFixtures)) + +suiteAgreementMessage :: String +suiteAgreementMessage = + "delaunay-compare agreement: " + <> show (length allFixtureSpecs) + <> " fixtures agree on vertex and triangle counts across " + <> show (length allImplementations) + <> " implementations" diff --git a/docs/delaunay-compare/PictureMain.hs b/docs/delaunay-compare/PictureMain.hs new file mode 100644 --- /dev/null +++ b/docs/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/docs/delaunay-compare/README.md b/docs/delaunay-compare/README.md new file mode 100644 --- /dev/null +++ b/docs/delaunay-compare/README.md @@ -0,0 +1,191 @@ +# Moonlight Delaunay Compare + +[Browse all exhibits.](../README.md) + +`moonlight-triangulation-delaunay-compare` is Moonlight's package-owned port of Spade's +[`delaunay_compare`](https://github.com/Stoeoef/spade/tree/c8befc96bbbc1898a89cb19f9f3104a848936374/delaunay_compare) +construction suite. It retains the upstream case matrix and appends +`moonlight-triangulation` to the implementation list: + +1. `spade 2` +2. `spade 2 hierarchy` +3. `cdt` +4. `delaunator` +5. `moonlight-triangulation` + +Haskell owns fixture selection, grouping, compatibility descent, timing, and +reporting. The Rust library under `rust/src/lib.rs` is only a typed foreign +boundary to the four Rust implementations and to the exact upstream `rand` +fixture stream; it contains no benchmark policy. + +This page owns only the construction slice. The +[operation comparison](../../bench/spade-compare/README.md) owns the broader +Moonlight–Spade board. + +## Pictures + +Both pictures are derived from the single retained board. + +![Small-point Delaunay construction comparison](results/moonlight-delaunay-compare-small.svg) + +![Big-point Delaunay construction comparison](results/moonlight-delaunay-compare-big.svg) + +These retain Spade's plain GNUPLOT idiom: white field, Helvetica, dashed grey +grid, jewel-coloured point series, and the same small/big split. Moonlight is +the heavier orange star. The faint triangulation mesh is the sole bit of +levity; benchmark charts need not resemble tax forms. + +## Result + +- timed cases: `120` +- fixture summaries agreeing across all five implementations: `24 / 24` +- Moonlight mean below plain Spade: `24 / 24` +- Moonlight mean below Spade hierarchy: `24 / 24` +- Moonlight below plain Spade with non-overlapping reported 2σ: `18 / 24` +- Moonlight below Spade hierarchy with non-overlapping reported 2σ: `22 / 24` +- lowest fixture mean: `delaunator` `21 / 24`; `cdt` `3 / 24` +- median reported 2σ / mean: Moonlight `6.88%`; plain Spade `6.67%` + +Selected means are in milliseconds. Δ is +`100 × (Moonlight / competitor − 1)`. + +| fixture | points | Moonlight | plain Spade | Δ | Spade hierarchy | Δ | +|---|---:|---:|---:|---:|---:|---:| +| local insertion | 4,000 | 0.587 | 0.771 | −23.8% | 0.800 | −26.6% | +| local insertion | 6,000 | 0.971 | 1.300 | −25.3% | 1.365 | −28.9% | +| local insertion | 8,000 | 1.354 | 1.776 | −23.7% | 1.903 | −28.8% | +| local insertion | 250,000 | 60.300 | 72.713 | −17.1% | 77.496 | −22.2% | +| uniform | 4,000 | 0.552 | 0.706 | −21.8% | 0.741 | −25.6% | +| uniform | 14,000 | 2.663 | 3.067 | −13.2% | 3.318 | −19.7% | +| uniform | 250,000 | 60.028 | 72.783 | −17.5% | 77.435 | −22.5% | + +The measured Moonlight path is the canonical circle-sweep bulk loader. Its +geometry ingress keeps coordinates in immutable planes, moves only a 32-bit +vertex-id plane through three radix passes, and restores the complete +`(distance, x, y, vertex)` order inside equal-prefix fibres before descent. +Fresh dense vertices are committed once, and the sweep consumes reserved cells +without constructing a second packed geometry arena. + +Receipt identity: + +- command completed: `2026-08-23T00:00:15Z`, 318.68 s over 120 cases +- host: Apple M4 Pro, arm64, macOS 26.5.2, GHC 9.14.1, rustc 1.92.0 +- Haskell build: cabal-install 3.16.1.0, focused `-O1` package profile, + comparison executable `-O2`, hot predicate, sweep, and repair modules LLVM + `-O3` +- checkout base HEAD: `41906f44f0`, plus the three optimized runtime-source + owners named by the manifest +- CSV: [`moonlight-delaunay-compare-2026-08-22.csv`](results/moonlight-delaunay-compare-2026-08-22.csv), SHA-256 + `cce6af4ac7d570970a69124f5648db4e13ca41e91e05383306407a0dca323be7` +- benchmark runtime-source hashes: + [`moonlight-delaunay-compare-2026-08-22.source-sha256`](results/moonlight-delaunay-compare-2026-08-22.source-sha256), SHA-256 + `069d3bb1639b6d865fe4491b2fbbb9d0cdc8324173e30bebf690ed6592190c20` + +The Haskell projection in +`Moonlight.Triangulation.Bench.DelaunayCompare.Picture` parses the tasty-bench +CSV against the exact closed 120-case registry and reports typed obstructions +for malformed, unknown, duplicated, or missing observations before gluing +either picture. + +## Run + +From the repository root, list the complete benchmark tree: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ + --project-file=cabal.project.triangulation-dev \ + -- --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 \ + --project-file=cabal.project.triangulation-dev \ + -- --time-mode wall -j1 +``` + +The Haskell executable builds the pinned Rust library through Cargo before it +loads the library. Cargo's incremental no-op is cheap after the first run. Set +`MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST` only when invoking an installed executable +outside this repository layout. + +## Reproduce a board + +Every candidate run uses one CPU-time worker, a 30-second per-case timeout, and +tasty-bench's `--stdev 5` calibration target. Name the candidate by the date it +completed; after validation, it replaces the retained CSV and source manifest +rather than accumulating a benchmark diary. + +```console +caffeinate -i scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ + --project-file=cabal.project.triangulation-dev -- \ + --stdev 5 --timeout 30s --time-mode cpu -j1 \ + --csv foundation/moonlight-triangulation/docs/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \ + --color never --hide-progress --min-duration-to-report 1h +``` + +Both pictures are then regenerated from the candidate CSV, which is the only +CSV they may be derived from: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-pictures \ + --project-file=cabal.project.triangulation-dev -- \ + foundation/moonlight-triangulation/docs/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \ + foundation/moonlight-triangulation/docs/delaunay-compare/results +``` + +The runtime-source manifest beside the CSV is regenerated from the measured +worktree immediately after a completed command. It hashes the closed list of +files that entered timed actions; picture sources and package-only metadata are +excluded because they did not. The receipt, CSV, and big SVG stay +benchmark-owned beside the executable and outside Cabal package inputs. The +small SVG is also the package documentation projection, so it enters the sdist +without entering any compiled component. + +## Upstream-compatible fixtures + +Both distributions use the 32-byte `StdRng` seed from upstream, including its +embedded newline byte. Rust unit tests pin the first three points of both +streams by their exact binary64 bit patterns. + +- `local insertion` starts at `(0, 1)` and adds independent inclusive steps + from `[-1, 1]`. +- `uniform` draws each coordinate independently and inclusively from + `[-1e9, 1e9]`. +- `small` contains 2,000 through 14,000 points in increments of 2,000. +- `big` contains 50,000 through 250,000 points in increments of 50,000. + +Native input conversion happens once during suite preparation, outside every +timed action, exactly as upstream's `DelaunayCrate.init` separates conversion +from `run_creation`. Spade still clones its owned vertex vector inside each +construction call because that is what its bulk-load API and upstream adapter +require; `cdt`, `delaunator`, and Moonlight consume their prepared vectors by +reference. + +## Compatibility gate + +Before `tasty-bench` runs, every one of the 24 fixtures descends across all five +implementations. The sections glue only when vertex and inner-triangle counts +agree. A generator, preparation, construction, foreign-boundary, or summary +failure is a typed obstruction and terminates the command before timing. + +This count gate is deliberately not a second topology authority. The broader +operation comparison owns canonical-edge and operation agreement. This command +answers the narrower upstream question: bulk construction time over the +upstream point distributions and sizes. + +The upstream `examples/real_data_benchmark.rs` CDT/shapefile program is a +separate executable and is not folded into this creation suite. No 45 MB dataset +or network fetch is concealed in benchmark startup. + +## Harness difference + +Upstream uses Rust Criterion. This port uses Haskell `tasty-bench`, so it does +not pretend Criterion's warm-up seconds or sample-count knobs map one-to-one to +another calibrator. The inputs, sizes, implementation calls, and timed/setup +boundary are preserved; calibration and reporting are honestly Haskell. diff --git a/docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg b/docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg new file mode 100644 --- /dev/null +++ b/docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg @@ -0,0 +1,415 @@ + + +Moonlight Delaunay construction · small point sets +CPU construction time for Spade, cdt, delaunator, and Moonlight over the upstream Delaunay comparison fixtures. Lower lines are faster. + + + + + + + + +Moonlight Delaunay construction · small point sets +Moonlight against Spade's construction referents · CPU time · lower is faster + + + + spade 2 + + + + + spade 2 hierarchy + + + + + cdt + + + + + delaunator + + + + + moonlight-triangulation + + +local insertion + +0.00 + +1.0 + +2.0 + +3.0 + +4.0 + +5.0 + +2k + +4k + +6k + +8k + +10k + +12k + +14k + +input size (points) +CPU time (ms) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +uniform + +0.00 + +1.0 + +2.0 + +3.0 + +4.0 + +5.0 + +2k + +4k + +6k + +8k + +10k + +12k + +14k + +input size (points) +CPU time (ms) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Whiskers show tasty-bench's reported 2× standard-deviation spread. + diff --git a/docs/delaunay-compare/rust/Cargo.lock b/docs/delaunay-compare/rust/Cargo.lock new file mode 100644 --- /dev/null +++ b/docs/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/docs/delaunay-compare/rust/Cargo.toml b/docs/delaunay-compare/rust/Cargo.toml new file mode 100644 --- /dev/null +++ b/docs/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/docs/delaunay-compare/rust/src/lib.rs b/docs/delaunay-compare/rust/src/lib.rs new file mode 100644 --- /dev/null +++ b/docs/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/docs/development.md b/docs/development.md new file mode 100644 --- /dev/null +++ b/docs/development.md @@ -0,0 +1,25 @@ +# Local development + +[Return to the package overview.](../README.md#consumer-libraries) +· [Browse the documentation.](./README.md) + +Run component-qualified commands from the repository's `compiler/` directory. +The optimized construction kernel uses the triangulation development project: + +```console +../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ + --project-file=cabal.project.triangulation-dev \ + --builddir=dist-newstyle-triangulation-dev +``` + +For type and interface feedback, use the same component at `-O0`: + +```console +../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ + --project-file=cabal.project.triangulation-dev \ + --builddir=dist-newstyle-triangulation-fast \ + --disable-optimization +``` + +Performance evidence uses the optimized profile; the `-O0` profile is the +shorter feedback path. diff --git a/docs/examples/Moonlight/Triangulation/Example/AlphaBoundary.hs b/docs/examples/Moonlight/Triangulation/Example/AlphaBoundary.hs new file mode 100644 --- /dev/null +++ b/docs/examples/Moonlight/Triangulation/Example/AlphaBoundary.hs @@ -0,0 +1,54 @@ +module Moonlight.Triangulation.Example.AlphaBoundary + ( AlphaBoundaryExampleError (..) + , BoundaryShape (..) + , alphaBoundaryShapes + ) where + +import Data.Bifunctor (first) +import qualified Data.Vector as Vector +import Moonlight.Triangulation + +data AlphaBoundaryExampleError + = AlphaBoundaryBuildFailed !BuildError + | AlphaBoundaryRadiusFailed !RadiusSquaredError + | AlphaBoundaryDescentFailed !BoundaryObstruction + deriving stock (Eq, Show) + +data BoundaryShape = BoundaryShape + { boundaryOuterVertexCount :: !Int + , boundaryHoleCount :: !Int + } + deriving stock (Eq, Show) + +-- | Descend the closed alpha-shape face section of one square to its boundary. +alphaBoundaryShapes :: Either AlphaBoundaryExampleError [BoundaryShape] +alphaBoundaryShapes = do + mesh <- + first AlphaBoundaryBuildFailed + ( delaunayGeometry + ( Vector.fromList + [ Point 0 0 + , Point 2 0 + , Point 2 2 + , Point 0 2 + ] + ) + ) + threshold <- first AlphaBoundaryRadiusFailed (mkRadiusSquared 2) + let selectedComponents = + fmap snd + (filter fst (faceComponents mesh (alphaShapeContainsFace threshold mesh))) + traverse + ( fmap boundaryShape + . first AlphaBoundaryDescentFailed + . componentBoundary mesh + ) + selectedComponents + +boundaryShape :: RegionBoundary -> BoundaryShape +boundaryShape boundary = + BoundaryShape + { boundaryOuterVertexCount = + length (boundaryLoopVertices (regionBoundaryOuterLoop boundary)) + , boundaryHoleCount = length (regionBoundaryHoleLoops boundary) + } diff --git a/docs/examples/Moonlight/Triangulation/Example/ConstrainedRegion.hs b/docs/examples/Moonlight/Triangulation/Example/ConstrainedRegion.hs new file mode 100644 --- /dev/null +++ b/docs/examples/Moonlight/Triangulation/Example/ConstrainedRegion.hs @@ -0,0 +1,37 @@ +module Moonlight.Triangulation.Example.ConstrainedRegion + ( constrainedRegionCounts + ) where + +import qualified Data.Vector as Vector +import Moonlight.Triangulation + +-- | Count every face and only the bounded odd-depth domain faces of an annulus. +constrainedRegionCounts :: Either CdtError (Int, Int) +constrainedRegionCounts = do + result <- + constrainedDelaunay + unitElementDefaults + (Vector.fromList annulusPoints) + (Vector.fromList (closedLoop 0 <> closedLoop 4)) + let annulus = buildTriangulation result + pure (numFaces annulus, length (boundedRegionFaces annulus)) + +annulusPoints :: [Point] +annulusPoints = + [ Point (-2) (-2) + , Point 2 (-2) + , Point 2 2 + , Point (-2) 2 + , Point (-1) (-1) + , Point 1 (-1) + , Point 1 1 + , Point (-1) 1 + ] + +closedLoop :: Int -> [(Int, Int)] +closedLoop offset = + [ (offset, offset + 1) + , (offset + 1, offset + 2) + , (offset + 2, offset + 3) + , (offset + 3, offset) + ] diff --git a/docs/examples/Moonlight/Triangulation/Example/PlanarRegion.hs b/docs/examples/Moonlight/Triangulation/Example/PlanarRegion.hs new file mode 100644 --- /dev/null +++ b/docs/examples/Moonlight/Triangulation/Example/PlanarRegion.hs @@ -0,0 +1,137 @@ +module Moonlight.Triangulation.Example.PlanarRegion + ( ExactFractionSummary (..) + , CellValuationSummary (..) + , PlanarExampleError (..) + , PlanarExampleSummary (..) + , planarExample + ) where + +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Moonlight.Triangulation + +data ExactFractionSummary = ExactFractionSummary + { fractionNumerator :: !Integer + , fractionDenominator :: !Integer + } + deriving stock (Eq, Show) + +data CellValuationSummary = CellValuationSummary + { cellEulerCharacteristic :: !Int + , cellExactArea :: !ExactFractionSummary + } + deriving stock (Eq, Show) + +data PlanarExampleSummary = PlanarExampleSummary + { booleanValuations :: ![CellValuationSummary] + , morphologyAreas :: ![ExactFractionSummary] + } + deriving stock (Eq, Show) + +data PlanarExampleError + = PlanarRegionFailed !RegionValidationError + | PlanarOverlayFailed !(OverlayError Bool Bool) + | PlanarSelectionFailed !OverlaySelectionError + | PlanarValuationFailed !ValuationError + | PlanarMinkowskiFailed !MinkowskiError + deriving stock (Eq, Show) + +-- | Compute exact Boolean valuations and morphology through the public facade. +planarExample :: Either PlanarExampleError PlanarExampleSummary +planarExample = do + left <- rectangleRegion 0 0 4 4 + right <- rectangleRegion 2 1 6 3 + leftLayer <- insideLayer left + rightLayer <- insideLayer right + overlay <- first PlanarOverlayFailed (overlayLayers leftLayer rightLayer) + unionCells <- first PlanarSelectionFailed (overlayClosedUnion id id overlay) + intersectionCells <- + first PlanarSelectionFailed (overlayClosedIntersection id id overlay) + differenceCells <- + first PlanarSelectionFailed (overlayRegularizedDifference id id overlay) + cellSummaries <- + traverse + cellValuationSummary + [unionCells, intersectionCells, differenceCells] + + kernelLoop <- rectangleLoop (-1) (-1) 1 1 + kernelPolygon <- + first PlanarMinkowskiFailed (convexPolygon (exactLoopPoints kernelLoop)) + kernel <- first PlanarMinkowskiFailed (structuringElement kernelPolygon) + (sumRegion, _) <- first PlanarMinkowskiFailed (minkowskiSum left right) + (offsetRegion, _) <- first PlanarMinkowskiFailed (polygonOffset kernel left) + (insetRegion, _) <- first PlanarMinkowskiFailed (polygonInset kernel left) + (openedRegion, _) <- first PlanarMinkowskiFailed (openWith kernel left) + (closedRegion, _) <- first PlanarMinkowskiFailed (closeWith kernel left) + areaSummaries <- + traverse + regionAreaSummary + [sumRegion, offsetRegion, insetRegion, openedRegion, closedRegion] + + pure + PlanarExampleSummary + { booleanValuations = cellSummaries + , morphologyAreas = areaSummaries + } + +rectangleLoop + :: Integer + -> Integer + -> Integer + -> Integer + -> Either PlanarExampleError ExactLoop +rectangleLoop minimumX minimumY maximumX maximumY = + first PlanarRegionFailed + ( exactLoop + ( exactPoint (fromInteger minimumX) (fromInteger minimumY) + :| [ exactPoint (fromInteger maximumX) (fromInteger minimumY) + , exactPoint (fromInteger maximumX) (fromInteger maximumY) + , exactPoint (fromInteger minimumX) (fromInteger maximumY) + ] + ) + ) + +rectangleRegion + :: Integer + -> Integer + -> Integer + -> Integer + -> Either PlanarExampleError PlanarRegion +rectangleRegion minimumX minimumY maximumX maximumY = do + outer <- rectangleLoop minimumX minimumY maximumX maximumY + component <- first PlanarRegionFailed (polygonComponent outer []) + first PlanarRegionFailed (planarRegion [component]) + +insideLayer :: PlanarRegion -> Either PlanarExampleError (PlanarLayer Bool) +insideLayer = + first PlanarRegionFailed + . planarLayer False + . Map.singleton True + +cellValuationSummary + :: ExactCellSet + -> Either PlanarExampleError CellValuationSummary +cellValuationSummary cells = do + valuations <- first PlanarValuationFailed (cellValuations cells) + pure + CellValuationSummary + { cellEulerCharacteristic = + eulerCharacteristicValue (valuationEuler valuations) + , cellExactArea = exactAreaSummary valuations + } + +regionAreaSummary + :: PlanarRegion + -> Either PlanarExampleError ExactFractionSummary +regionAreaSummary region = + exactAreaSummary + <$> first PlanarValuationFailed (regionValuations region) + +exactAreaSummary :: PlanarValuations -> ExactFractionSummary +exactAreaSummary valuations = + let area = exactAreaValue (valuationArea valuations) + in ExactFractionSummary + { fractionNumerator = exactRationalNumerator area + , fractionDenominator = exactRationalDenominator area + } diff --git a/docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs b/docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs new file mode 100644 --- /dev/null +++ b/docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs @@ -0,0 +1,26 @@ +module Moonlight.Triangulation.Example.SetAlgebra + ( siteCounts + ) where + +import qualified Data.Vector as Vector +import Moonlight.Triangulation + +-- | Join and meet two overlapping site sets through the public facade. +siteCounts :: Either BuildError (Int, Int) +siteCounts = do + left <- unitSquareAt 0 + right <- unitSquareAt 1 + joined <- left `union` right + shared <- intersection left right + pure (numVertices joined, numVertices shared) + +unitSquareAt :: Double -> Either BuildError (DelaunayTriangulation ()) +unitSquareAt minimumX = + delaunayGeometry + ( Vector.fromList + [ Point minimumX 0 + , Point (minimumX + 1) 0 + , Point (minimumX + 1) 1 + , Point minimumX 1 + ] + ) diff --git a/docs/examples/README.md b/docs/examples/README.md new file mode 100644 --- /dev/null +++ b/docs/examples/README.md @@ -0,0 +1,18 @@ +# Compile-checked usage examples + +[Return to the package overview.](../../README.md#use) +· [Browse the documentation.](../README.md) + +Each example imports only the public `Moonlight.Triangulation` facade. The +`moonlight-triangulation-examples-test` component compiles the modules and +owns their deterministic expected results. + +| Workflow | Canonical source | +| --- | --- | +| Join and meet overlapping site sets | [`SetAlgebra.hs`](./Moonlight/Triangulation/Example/SetAlgebra.hs) | +| Recover a constrained annulus interior | [`ConstrainedRegion.hs`](./Moonlight/Triangulation/Example/ConstrainedRegion.hs) | +| Descend an alpha face section to its boundary | [`AlphaBoundary.hs`](./Moonlight/Triangulation/Example/AlphaBoundary.hs) | +| Overlay, measure, and morph exact regions | [`PlanarRegion.hs`](./Moonlight/Triangulation/Example/PlanarRegion.hs) | + +[The focused test owner](../../test/examples/Main.hs) checks every published +summary against these sources. diff --git a/docs/mesh-publication.md b/docs/mesh-publication.md new file mode 100644 --- /dev/null +++ b/docs/mesh-publication.md @@ -0,0 +1,56 @@ +# Mesh publication schedules + +[Read the set-operation types.](../README.md#set-operation-types) +· [Choose an operation.](../README.md#operations) + +Programs choose an operation by its semantic result; Moonlight chooses its +execution schedule. The schedule changes identity reuse, allocation, and +throughput, not the represented site set. + +## Persistent publication schedules + +These are the currently measured publication choices. `canonicalize` remains +the explicit global observation when construction-independent numbering is +required. + +| Operation context | Publication schedule | +| --- | --- | +| `siteRelation left right` | Index the smaller support in one transient exact open-addressed section, scan the other operand, then discard the index; no support maps or published cache state. | +| `difference mesh empty`, `symmetricDifference mesh empty`, `symmetricDifference empty mesh` | Return the surviving representative verbatim. | +| `difference left right` with `size right <= (size left - size right) / 128` | Remove the right support through one local copy-on-write session; return `left` verbatim when the supports are disjoint. Larger masks rebuild. | +| Geometry-only `intersection left right` | Return an existing operand for equality or subset, return the empty mesh for disjoint supports, and locally remove the smaller complement when it is at most `overlap / 128`. Other partial overlaps rebuild. | +| `intersectionWith` | Rebuild, because the annotation combiner may rewrite every surviving payload even when topology changes locally. | +| `symmetricDifference left right` with `small <= (large - small) / 128` | Toggle the smaller operand through one local session. Comparable operands and small-output, large-input cases rebuild. | +| Comparable `symmetricDifference left right` | Partition through one transient exact index and a matched bitset, then rebuild only the exclusive output section. | +| Package-internal `BulkLoad.insert` / `BulkLoad.insertAt` | Dense publication below 10,000 resident sites; copy-on-write publication at 10,000 and above. Internal edit sequences descend through one `Session`. | +| `extendConstrainedWith` | Copy-on-write only for a base of at least 200,000 sites, at most 128 incoming sites, exactly one incoming segment, and a pre-thaw corridor with no resident intersection. Every unmeasured or resident-corridor case stays dense. | +| `refineWithinDomain` | Dense publication. The measured local transaction candidate did not improve wall time. | + +## Persistent values at scale + +`union` classifies a pair before selecting its schedule: empty and repeated +operands return an existing value, separated operands merge at their seam, +subsets reuse their superset, skewed pairs insert the smaller support, and the +remaining cases rebuild. + +```haskell +insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8 +``` + +Local schedules publish a fresh immutable mesh from the pages they touched, so +readers continue observing the previous value while the next is built. A failed +operation returns its obstruction with both operands unchanged. + +`Moonlight.Triangulation.Parallel.unionsConcurrently` interprets the same pure +join tournament with bounded concurrency. + +## Source authority + +The executable schedule decisions live in +[`SetAlgebra`](../src-build/Moonlight/Triangulation/SetAlgebra.hs), +[`BulkLoad`](../src-build/Moonlight/Triangulation/BulkLoad.hs), +[`Join.Plan`](../src-build/Moonlight/Triangulation/Internal/Join/Plan.hs), and +[`Cdt.Union`](../src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs). The +focused measurements live in +[`JoinBench`](../bench/join/Moonlight/Triangulation/JoinBench.hs); this page is +their consumer-facing projection. diff --git a/docs/moonlight-triangulation-alpha-eclipse.svg b/docs/moonlight-triangulation-alpha-eclipse.svg deleted file mode 100644 --- a/docs/moonlight-triangulation-alpha-eclipse.svg +++ /dev/null @@ -1,91 +0,0 @@ - -Moonlight Triangulation alpha eclipse -One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius 1, and its resident diagonal and faces kill that hole at squared radius 2. - - - - - - - - - -MOONLIGHT TRIANGULATION -ALPHA ECLIPSE -ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS - - -BEFORE BIRTH - - - - - - - - - - -four isolated sites -β₁ = 0 -α² = 0 - - - -LOOP BORN - - - - - - - - - - - - - - - -resident boundary closes -β₁ = 1 -α² = 1 - - - -CYCLE KILLED - - - - - - - - - - - - - - - - - -resident faces fill it -β₁ = 0 -α² = 2 - - -ONE EXACT H₁ INTERVAL - - - - -α² = 0 -birth α² = 1 -the eclipse hole persists -death α² = 2 -exact α² increases → - - diff --git a/docs/moonlight-triangulation-persistence-rose.svg b/docs/moonlight-triangulation-persistence-rose.svg deleted file mode 100644 --- a/docs/moonlight-triangulation-persistence-rose.svg +++ /dev/null @@ -1,1895 +0,0 @@ - -Moonlight Triangulation Persistence Rose -Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -MOONLIGHT TRIANGULATION -PERSISTENCE ROSE - -TOPOLOGICAL HOLES AT THIS SCALE -β₁ = 7 -7 independent one-dimensional holes -in the exact alpha complex -critical rank 538 · α² = 0.358 -exact 94-digit / 94-digit rational - - - diff --git a/docs/persistence-rose/Main.hs b/docs/persistence-rose/Main.hs new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/Main.hs @@ -0,0 +1,212 @@ +module Main (main) where + +import Control.Exception (IOException, try) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except + ( ExceptT (..), + except, + runExceptT, + ) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Foldable (traverse_) +import Moonlight.Triangulation.Exhibit.PersistenceRose + ( PersistenceRoseError, + PersistenceRoseScene, + alphaEclipseReceipt, + buildAlphaEclipseScene, + buildPersistenceRoseScene, + persistenceRoseFrameSpecs, + persistenceRoseReceipt, + renderAlphaEclipse, + renderAlphaEclipseReceipt, + renderPersistenceRoseAnimationReceipt, + renderPersistenceRoseFrame, + renderPersistenceRosePoster, + renderPersistenceRoseReceipt, + stampPersistenceRoseGif, + verifyPersistenceRoseGif, + ) +import System.Directory (createDirectoryIfMissing) +import System.Environment (getArgs) +import System.Exit (die) +import System.FilePath ((), takeDirectory) +import Text.Printf (printf) +import Text.Read (readMaybe) + +data PersistenceRoseCommand + = WritePoster !FilePath + | WriteEclipse !FilePath + | WriteFrames !Int !FilePath + | StampGif !FilePath !FilePath + | VerifyArtifacts !FilePath + | PrintReceipt + +data PersistenceRoseCommandError + = PersistenceRoseUsage ![String] + | PersistenceRoseInvalidFrameCount !String + | PersistenceRoseConstructionFailed !PersistenceRoseError + | PersistenceRoseDirectoryFailed !FilePath !IOException + | PersistenceRoseReadFailed !FilePath !IOException + | PersistenceRoseWriteFailed !FilePath !IOException + | PersistenceRoseArtifactMismatch !FilePath + +instance Show PersistenceRoseCommandError where + show commandError = + case commandError of + PersistenceRoseUsage arguments -> + "invalid persistence-rose command " + <> show arguments + <> "; expected: poster OUTPUT.svg | eclipse OUTPUT.svg | frames FRAME_COUNT OUTPUT_DIRECTORY | stamp-gif INPUT.gif OUTPUT.gif | verify-artifacts PACKAGE_ROOT | receipt" + PersistenceRoseInvalidFrameCount submitted -> + "frame count must be an integer greater than one, received " <> show submitted + PersistenceRoseConstructionFailed sceneError -> show sceneError + PersistenceRoseDirectoryFailed path caughtError -> + "could not create output directory " <> show path <> ": " <> show caughtError + PersistenceRoseReadFailed path caughtError -> + "could not read " <> show path <> ": " <> show caughtError + PersistenceRoseWriteFailed path caughtError -> + "could not write " <> show path <> ": " <> show caughtError + PersistenceRoseArtifactMismatch path -> + "tracked exhibit differs from its canonical renderer: " <> show path + +main :: IO () +main = do + arguments <- getArgs + result <- runExceptT (runPersistenceRoseCommand arguments) + either (die . show) pure result + +runPersistenceRoseCommand :: [String] -> ExceptT PersistenceRoseCommandError IO () +runPersistenceRoseCommand arguments = do + command <- except (parseCommand arguments) + case command of + WriteEclipse outputPath -> do + scene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene) + createOutputDirectory (takeDirectory outputPath) + writeOutput outputPath (renderAlphaEclipse scene) + lift + ( putStrLn + (renderAlphaEclipseReceipt (alphaEclipseReceipt scene) <> "\nwrote alpha eclipse " <> outputPath) + ) + StampGif inputPath outputPath -> do + scene <- requirePersistenceRoseScene + inputBytes <- readBytes inputPath + (receipt, stamped) <- except (first PersistenceRoseConstructionFailed (stampPersistenceRoseGif scene inputBytes)) + createOutputDirectory (takeDirectory outputPath) + writeBytes outputPath stamped + lift + ( putStrLn + (renderPersistenceRoseAnimationReceipt receipt <> "\nwrote stamped GIF " <> outputPath) + ) + VerifyArtifacts packageRoot -> verifyTrackedArtifacts packageRoot + PrintReceipt -> do + scene <- requirePersistenceRoseScene + lift (putStrLn (renderPersistenceRoseReceipt (persistenceRoseReceipt scene))) + WritePoster outputPath -> do + scene <- requirePersistenceRoseScene + let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene) + createOutputDirectory (takeDirectory outputPath) + writeOutput outputPath (renderPersistenceRosePoster scene) + lift (putStrLn (receiptText <> "\nwrote poster " <> outputPath)) + WriteFrames frameCount outputDirectory -> do + scene <- requirePersistenceRoseScene + let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene) + frames <- except (first PersistenceRoseConstructionFailed (persistenceRoseFrameSpecs frameCount)) + createOutputDirectory outputDirectory + traverse_ + (\(frameIndex, frame) -> writeOutput (framePath outputDirectory frameIndex) (renderPersistenceRoseFrame scene frame)) + (zip [0 :: Int ..] frames) + lift + ( putStrLn + ( receiptText + <> "\nwrote " + <> show (length frames) + <> " frames to " + <> outputDirectory + ) + ) + +requirePersistenceRoseScene :: ExceptT PersistenceRoseCommandError IO PersistenceRoseScene +requirePersistenceRoseScene = + except (first PersistenceRoseConstructionFailed buildPersistenceRoseScene) + +parseCommand :: [String] -> Either PersistenceRoseCommandError PersistenceRoseCommand +parseCommand arguments = + case arguments of + ["poster", outputPath] -> Right (WritePoster outputPath) + ["eclipse", outputPath] -> Right (WriteEclipse outputPath) + ["stamp-gif", inputPath, outputPath] -> Right (StampGif inputPath outputPath) + ["verify-artifacts", packageRoot] -> Right (VerifyArtifacts packageRoot) + ["frames", submittedCount, outputDirectory] -> + case readMaybe submittedCount of + Just frameCount + | frameCount > 1 -> Right (WriteFrames frameCount outputDirectory) + _ -> Left (PersistenceRoseInvalidFrameCount submittedCount) + ["receipt"] -> Right PrintReceipt + _ -> Left (PersistenceRoseUsage arguments) + +createOutputDirectory :: FilePath -> ExceptT PersistenceRoseCommandError IO () +createOutputDirectory outputDirectory = + liftIOException + (PersistenceRoseDirectoryFailed outputDirectory) + (createDirectoryIfMissing True outputDirectory) + +writeOutput :: FilePath -> String -> ExceptT PersistenceRoseCommandError IO () +writeOutput outputPath contents = + liftIOException (PersistenceRoseWriteFailed outputPath) (writeFile outputPath contents) + +readOutput :: FilePath -> ExceptT PersistenceRoseCommandError IO String +readOutput inputPath = + liftIOException (PersistenceRoseReadFailed inputPath) (readFile inputPath) + +readBytes :: FilePath -> ExceptT PersistenceRoseCommandError IO ByteString +readBytes inputPath = + liftIOException (PersistenceRoseReadFailed inputPath) (ByteString.readFile inputPath) + +writeBytes :: FilePath -> ByteString -> ExceptT PersistenceRoseCommandError IO () +writeBytes outputPath contents = + liftIOException (PersistenceRoseWriteFailed outputPath) (ByteString.writeFile outputPath contents) + +verifyTrackedArtifacts :: FilePath -> ExceptT PersistenceRoseCommandError IO () +verifyTrackedArtifacts packageRoot = do + roseScene <- requirePersistenceRoseScene + eclipseScene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene) + let exhibitRoot = packageRoot "docs" "persistence-rose" + posterPath = exhibitRoot "moonlight-triangulation-persistence-rose.svg" + eclipsePath = exhibitRoot "moonlight-triangulation-alpha-eclipse.svg" + gifPath = exhibitRoot "moonlight-triangulation-persistence-rose.gif" + verifyTextArtifact posterPath (renderPersistenceRosePoster roseScene) + verifyTextArtifact eclipsePath (renderAlphaEclipse eclipseScene) + gifBytes <- readBytes gifPath + animationReceipt <- + except + (first PersistenceRoseConstructionFailed (verifyPersistenceRoseGif roseScene gifBytes)) + lift + ( putStrLn + ( "verified poster, alpha eclipse, and stamped GIF\n" + <> renderPersistenceRoseAnimationReceipt animationReceipt + ) + ) + +verifyTextArtifact + :: FilePath + -> String + -> ExceptT PersistenceRoseCommandError IO () +verifyTextArtifact artifactPath expectedContents = do + actualContents <- readOutput artifactPath + except + ( if actualContents == expectedContents + then Right () + else Left (PersistenceRoseArtifactMismatch artifactPath) + ) + +liftIOException + :: (IOException -> PersistenceRoseCommandError) + -> IO value + -> ExceptT PersistenceRoseCommandError IO value +liftIOException wrapFailure = ExceptT . fmap (first wrapFailure) . try + +framePath :: FilePath -> Int -> FilePath +framePath outputDirectory frameIndex = + outputDirectory printf "frame-%04d.svg" frameIndex diff --git a/docs/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs b/docs/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs @@ -0,0 +1,1625 @@ +{-# LANGUAGE NamedFieldPuns #-} + +-- | A deterministic, pure observatory assembled from Moonlight's existing +-- geometry, exact filtration, interpolation, and persistence owners. +module Moonlight.Triangulation.Exhibit.PersistenceRose + ( PersistenceRoseError (..), + PersistenceRoseReceipt (..), + PersistenceRoseScene, + PersistenceRoseFrame, + PersistenceRoseAnimationReceipt (..), + AlphaEclipseReceipt (..), + AlphaEclipseScene, + buildPersistenceRoseScene, + buildAlphaEclipseScene, + persistenceRoseReceipt, + alphaEclipseReceipt, + renderPersistenceRoseReceipt, + renderAlphaEclipseReceipt, + renderPersistenceRosePoster, + renderAlphaEclipse, + persistenceRoseFrameSpecs, + renderPersistenceRoseFrame, + persistenceRoseAnimationReceipt, + renderPersistenceRoseAnimationReceipt, + stampPersistenceRoseGif, + verifyPersistenceRoseGif, + ) +where + +import Control.Monad (foldM) +import Control.Monad.ST (runST) +import Data.Bifunctor (first) +import Data.Bits ((.&.), xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.List (find, intercalate, sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Ord (Down (..)) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Vector qualified as Vector +import Data.Word (Word64, Word8) +import Moonlight.Homology.Chain + ( HomologicalDegree (..), + HomologyFailure, + PersistencePair (..), + ) +import Moonlight.Homology.Persistence + ( criticalBettiVectors, + mod2PersistentPairsWithCriticalBettiTable, + ) +import Moonlight.Triangulation + ( AlphaBirth, + AlphaFiltration, + AlphaFiltrationError, + BuildError, + DelaunayTriangulation, + ExactLoop, + MinkowskiError, + OverlayError, + PlanarRegion, + Point (..), + PointValidationError, + PolygonComponent, + QueryPoint, + RegionPublicationError, + RegionValidationError, + alphaBirthDenominator, + alphaBirthNumerator, + alphaBirthToDouble, + alphaEdgeBirth, + alphaFaceBirth, + alphaFiltration, + alphaFiltrationCriticalBirths, + convexPolygon, + delaunayGeometry, + exactLoop, + exactLoopPoints, + exactPointFromPoint, + exactPointToEmbeddingCandidate, + innerFaces, + innerFaceVertexTriples, + mkQueryPoint, + overlayLayers, + overlaySelectedRegion, + planarLayer, + planarRegion, + planarRegionComponents, + polygonComponent, + polygonHoleLoops, + polygonOffset, + polygonOuterLoop, + queryPointValue, + structuringElement, + undirectedEdges, + undirectedEndpoints, + vertexPoint, + vertices, + ) +import Moonlight.Triangulation.CellComplex + ( DCELError, + filteredAlphaComplex, + ) +import Moonlight.Triangulation.FloodFillIterator + ( BoundaryObstruction, + FaceComponent, + boundaryLoopVertices, + componentBoundaryLoops, + faceComponentFaces, + faceComponentsBy, + outerFaceFloodFill, + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId (..), + UndirectedEdgeId, + VertexId, + normalizedDirected, + ) +import Moonlight.Triangulation.Interpolation + ( InterpolationStats (..), + NaturalNeighborResult (..), + naturalNeighborWeights, + newNaturalNeighborWorkspace, + ) +import Moonlight.Triangulation.Voronoi + ( VoronoiEdgeGeometry (..), + asDirectedVoronoiEdge, + voronoiEdgeGeometry, + ) +import Numeric (showFFloat, showHex) + +-- | Every boundary at which the exhibit may be refused. The renderer never +-- invents a fallback geometry or topology state. +data PersistenceRoseError + = RoseDelaunayBuildFailed !BuildError + | RoseAlphaFiltrationFailed !AlphaFiltrationError + | RoseCellComplexLoweringFailed !DCELError + | RosePersistenceFailed !HomologyFailure + | RoseCriticalProfileCountMismatch !Int !Int + | RoseCriticalProfileDegreeCountMismatch !Int !Int + | RoseBirthRankMissing !AlphaBirth + | RoseEdgeBirthMissing !UndirectedEdgeId + | RoseFaceBirthMissing !FaceId + | RoseBoundaryDescentFailed !Int !BoundaryObstruction + | RoseNoCriticalStates + | RoseNoMaskRegions + | RoseNoPersistentHole + | RoseNoCoherentHero !Int ![(Int, Int)] + | RoseVoronoiGeometryMissing !UndirectedEdgeId + | RoseNaturalNeighborFallbacks !Int + | RosePointInvalid !PointValidationError + | RoseRegionInvalid !RegionValidationError + | RoseOverlayFailed !(OverlayError Bool Bool) + | RoseOverlayPublicationFailed !RegionPublicationError + | RoseMinkowskiFailed !MinkowskiError + | RoseFrameCountTooSmall !Int + | RoseEclipseFiniteHoleCountMismatch !Int + | RoseEclipseFiniteHoleMissingDeath + | RoseEclipseBettiProfileMismatch !Int !Int !Int + | RoseGifInvalidSignature + | RoseGifTruncated !Int + | RoseGifUnexpectedBlock !Int !Word8 + | RoseGifDimensionMismatch !Int !Int !Int !Int + | RoseGifFrameCountMismatch !Int !Int + | RoseGifFrameDelayCountMismatch !Int !Int + | RoseGifDurationMismatch !Int !Int + | RoseGifProvenanceMismatch + | RoseGifMarkerTooLong !Int + deriving stock (Show) + +-- | A compact, test-readable projection of everything the scene actually +-- computed. It is intentionally not another geometry representation. +data PersistenceRoseReceipt = PersistenceRoseReceipt + { roseSiteCount :: !Int, + roseEdgeCount :: !Int, + roseFaceCount :: !Int, + roseCriticalBirthCount :: !Int, + roseFinitePersistentHoleCount :: !Int, + roseEssentialPersistentHoleCount :: !Int, + roseHeroCriticalRank :: !Int, + roseHeroBettiOne :: !Int, + roseHeroGeometricHoleCount :: !Int, + roseVoronoiSegmentCount :: !Int, + roseNaturalNeighborSampleCount :: !Int, + roseNaturalNeighborFallbackCount :: !Int, + roseMaskComponentCount :: !Int + } + deriving stock (Eq, Show) + +data PersistenceRoseScene = PersistenceRoseScene + { sceneSites :: ![Point], + sceneEdges :: ![RankedSegment], + sceneFaces :: ![RankedTriangle], + sceneCriticalStates :: !(NonEmpty CriticalState), + sceneHeroState :: !CriticalState, + sceneVoronoiSegments :: ![Segment], + sceneFieldSamples :: ![FieldSample], + sceneMaskComponents :: ![MaskComponent], + scenePersistenceArcs :: ![PersistenceArc], + sceneReceipt :: !PersistenceRoseReceipt + } + +-- | The canonical source projection carried inside the retained GIF. The GIF +-- codec remains an effect-boundary view; this receipt binds that binary view +-- to the exact deterministic SVG frame section used to produce it. +data PersistenceRoseAnimationReceipt = PersistenceRoseAnimationReceipt + { roseAnimationFrameCount :: !Int, + roseAnimationFramesPerSecond :: !Int, + roseAnimationWidth :: !Int, + roseAnimationHeight :: !Int, + roseAnimationSourceFingerprint :: !Word64 + } + deriving stock (Eq, Show) + +-- | The exact, test-readable facts shown by the alpha eclipse. The numerator +-- and denominator fields are projections of opaque 'AlphaBirth' values; the +-- renderer never chooses thresholds independently of the filtration. +data AlphaEclipseReceipt = AlphaEclipseReceipt + { eclipseSiteCount :: !Int, + eclipseEdgeCount :: !Int, + eclipseFaceCount :: !Int, + eclipseHoleBirthNumerator :: !Integer, + eclipseHoleBirthDenominator :: !Integer, + eclipseHoleDeathNumerator :: !Integer, + eclipseHoleDeathDenominator :: !Integer, + eclipseBettiBeforeBirth :: !Int, + eclipseBettiAtBirth :: !Int, + eclipseBettiAtDeath :: !Int + } + deriving stock (Eq, Show) + +-- | A three-section observation of one fixed resident Delaunay DCEL. Every +-- displayed edge and face is projected from that DCEL with its exact birth +-- rank; only the selected sublevel differs between sections. +data AlphaEclipseScene = AlphaEclipseScene + { eclipseSites :: ![Point], + eclipseEdges :: ![RankedSegment], + eclipseFaces :: ![RankedTriangle], + eclipseBeforeState :: !CriticalState, + eclipseBirthState :: !CriticalState, + eclipseDeathState :: !CriticalState, + eclipseReceipt :: !AlphaEclipseReceipt + } + +-- | The shared local descent used by both exhibits. This is not a second +-- filtration carrier: it retains the canonical mesh and filtration beside +-- their checked Homology projection and only the ranked rendering views. +data AlphaProjection = AlphaProjection + { projectionTriangulation :: !(DelaunayTriangulation ()), + projectionPersistencePairs :: ![PersistencePair AlphaBirth], + projectionCriticalStates :: !(NonEmpty CriticalState), + projectionBirthRanks :: !(Map AlphaBirth Int), + projectionEdges :: ![RankedSegment], + projectionFaces :: ![RankedTriangle] + } + +newtype PersistenceRoseFrame = PersistenceRoseFrame + { frameProgress :: Double + } + deriving stock (Eq, Show) + +data CriticalState = CriticalState + { criticalRank :: !Int, + criticalBirth :: !AlphaBirth, + criticalBettiOne :: !Int, + criticalHoles :: ![HoleComponent] + } + +data RankedSegment = RankedSegment + { rankedSegmentGeometry :: !Segment, + rankedSegmentBirthRank :: !Int + } + +data RankedTriangle = RankedTriangle + { rankedTrianglePoints :: !(Point, Point, Point), + rankedTriangleBirthRank :: !Int + } + +data Segment = Segment !Point !Point + +newtype HoleComponent = HoleComponent [[Point]] + +data FieldSample = FieldSample + { fieldSamplePoint :: !Point, + fieldSampleValue :: !Double, + fieldSampleNeighborCount :: !Int + } + +data MaskComponent = MaskComponent + { maskOuterLoop :: ![Point], + maskHoleLoops :: ![[Point]] + } + +data PersistenceArc = PersistenceArc + { persistenceArcBirthRank :: !Int, + persistenceArcDeathRank :: !Int + } + +buildPersistenceRoseScene :: Either PersistenceRoseError PersistenceRoseScene +buildPersistenceRoseScene = do + projection <- buildAlphaProjection roseSites + let triangulation = projectionTriangulation projection + criticalStates = projectionCriticalStates projection + persistencePairs = projectionPersistencePairs projection + criticalBirthCount = NonEmpty.length criticalStates + heroState <- chooseHeroState criticalStates + finiteVoronoiSegments <- projectFiniteVoronoiSegments triangulation + (fieldSamples, fallbackCount) <- naturalNeighborField triangulation + if fallbackCount == 0 + then pure () + else Left (RoseNaturalNeighborFallbacks fallbackCount) + maskComponents <- buildRoseMask + persistenceArcs <- + projectPersistenceArcs + (projectionBirthRanks projection) + criticalBirthCount + persistencePairs + let finiteHoles = filter isFinitePositiveHole persistencePairs + essentialHoles = filter isEssentialHole persistencePairs + heroHoleCount = length (criticalHoles heroState) + receipt = + PersistenceRoseReceipt + { roseSiteCount = length (vertices triangulation), + roseEdgeCount = length (projectionEdges projection), + roseFaceCount = length (projectionFaces projection), + roseCriticalBirthCount = criticalBirthCount, + roseFinitePersistentHoleCount = length finiteHoles, + roseEssentialPersistentHoleCount = length essentialHoles, + roseHeroCriticalRank = criticalRank heroState, + roseHeroBettiOne = criticalBettiOne heroState, + roseHeroGeometricHoleCount = heroHoleCount, + roseVoronoiSegmentCount = length finiteVoronoiSegments, + roseNaturalNeighborSampleCount = length fieldSamples, + roseNaturalNeighborFallbackCount = fallbackCount, + roseMaskComponentCount = length maskComponents + } + pure + PersistenceRoseScene + { sceneSites = fmap (vertexPoint triangulation) (vertices triangulation), + sceneEdges = projectionEdges projection, + sceneFaces = projectionFaces projection, + sceneCriticalStates = criticalStates, + sceneHeroState = heroState, + sceneVoronoiSegments = finiteVoronoiSegments, + sceneFieldSamples = fieldSamples, + sceneMaskComponents = maskComponents, + scenePersistenceArcs = persistenceArcs, + sceneReceipt = receipt + } + +buildAlphaProjection :: [Point] -> Either PersistenceRoseError AlphaProjection +buildAlphaProjection sites = do + triangulation <- first RoseDelaunayBuildFailed (delaunayGeometry (Vector.fromList sites)) + filtration <- first RoseAlphaFiltrationFailed (alphaFiltration triangulation) + filteredComplex <- first RoseCellComplexLoweringFailed (filteredAlphaComplex filtration) + (persistencePairs, criticalBettiTable) <- + first RosePersistenceFailed + (mod2PersistentPairsWithCriticalBettiTable filteredComplex) + let criticalBirths = alphaFiltrationCriticalBirths filtration + criticalProfiles = criticalBettiVectors criticalBettiTable + birthRanks = Map.fromDistinctAscList (zip criticalBirths [0 ..]) + if length criticalBirths == length criticalProfiles + then pure () + else Left (RoseCriticalProfileCountMismatch (length criticalBirths) (length criticalProfiles)) + criticalStates <- + traverse + (buildCriticalState triangulation filtration) + (zip3 [0 ..] criticalBirths criticalProfiles) + >>= maybe (Left RoseNoCriticalStates) Right . NonEmpty.nonEmpty + rankedEdges <- + traverse + (projectRankedEdge triangulation filtration birthRanks) + (undirectedEdges triangulation) + rankedFaces <- + traverse + (projectRankedFace triangulation filtration birthRanks) + (zip [1 ..] (Vector.toList (innerFaceVertexTriples triangulation))) + pure + AlphaProjection + { projectionTriangulation = triangulation, + projectionPersistencePairs = persistencePairs, + projectionCriticalStates = criticalStates, + projectionBirthRanks = birthRanks, + projectionEdges = rankedEdges, + projectionFaces = rankedFaces + } + +buildAlphaEclipseScene :: Either PersistenceRoseError AlphaEclipseScene +buildAlphaEclipseScene = do + projection <- buildAlphaProjection alphaEclipseSites + finiteHoles <- + case filter isFinitePositiveHole (projectionPersistencePairs projection) of + [finiteHole] -> Right finiteHole + holes -> Left (RoseEclipseFiniteHoleCountMismatch (length holes)) + deathBirth <- + maybe + (Left RoseEclipseFiniteHoleMissingDeath) + Right + (persistenceDeath finiteHoles) + let birth = persistenceBirth finiteHoles + birthRanks = projectionBirthRanks projection + states = projectionCriticalStates projection + birthRank <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) + deathRank <- maybe (Left (RoseBirthRankMissing deathBirth)) Right (Map.lookup deathBirth birthRanks) + let beforeState = criticalStateAt (max 0 (birthRank - 1)) states + birthState = criticalStateAt birthRank states + deathState = criticalStateAt deathRank states + bettiProfile = + ( criticalBettiOne beforeState, + criticalBettiOne birthState, + criticalBettiOne deathState + ) + case bettiProfile of + (0, 1, 0) -> pure () + (beforeBetti, birthBetti, deathBetti) -> + Left (RoseEclipseBettiProfileMismatch beforeBetti birthBetti deathBetti) + let triangulation = projectionTriangulation projection + receipt = + AlphaEclipseReceipt + { eclipseSiteCount = length (vertices triangulation), + eclipseEdgeCount = length (projectionEdges projection), + eclipseFaceCount = length (projectionFaces projection), + eclipseHoleBirthNumerator = alphaBirthNumerator birth, + eclipseHoleBirthDenominator = alphaBirthDenominator birth, + eclipseHoleDeathNumerator = alphaBirthNumerator deathBirth, + eclipseHoleDeathDenominator = alphaBirthDenominator deathBirth, + eclipseBettiBeforeBirth = criticalBettiOne beforeState, + eclipseBettiAtBirth = criticalBettiOne birthState, + eclipseBettiAtDeath = criticalBettiOne deathState + } + pure + AlphaEclipseScene + { eclipseSites = fmap (vertexPoint triangulation) (vertices triangulation), + eclipseEdges = projectionEdges projection, + eclipseFaces = projectionFaces projection, + eclipseBeforeState = beforeState, + eclipseBirthState = birthState, + eclipseDeathState = deathState, + eclipseReceipt = receipt + } + +persistenceRoseReceipt :: PersistenceRoseScene -> PersistenceRoseReceipt +persistenceRoseReceipt = sceneReceipt + +alphaEclipseReceipt :: AlphaEclipseScene -> AlphaEclipseReceipt +alphaEclipseReceipt = eclipseReceipt + +renderPersistenceRoseReceipt :: PersistenceRoseReceipt -> String +renderPersistenceRoseReceipt receipt = + intercalate + " · " + [ "sites " <> show (roseSiteCount receipt), + "edges " <> show (roseEdgeCount receipt), + "faces " <> show (roseFaceCount receipt), + "critical births " <> show (roseCriticalBirthCount receipt), + "finite H1 intervals " <> show (roseFinitePersistentHoleCount receipt), + "essential H1 intervals " <> show (roseEssentialPersistentHoleCount receipt), + "hero rank " <> show (roseHeroCriticalRank receipt), + "beta1 " <> show (roseHeroBettiOne receipt), + "geometric holes " <> show (roseHeroGeometricHoleCount receipt), + "Voronoi segments " <> show (roseVoronoiSegmentCount receipt), + "Sibson samples " <> show (roseNaturalNeighborSampleCount receipt), + "fallbacks " <> show (roseNaturalNeighborFallbackCount receipt), + "mask components " <> show (roseMaskComponentCount receipt) + ] + +renderAlphaEclipseReceipt :: AlphaEclipseReceipt -> String +renderAlphaEclipseReceipt receipt = + intercalate + " · " + [ "sites " <> show (eclipseSiteCount receipt), + "edges " <> show (eclipseEdgeCount receipt), + "faces " <> show (eclipseFaceCount receipt), + "H1 [" + <> renderExactRatio (eclipseHoleBirthNumerator receipt) (eclipseHoleBirthDenominator receipt) + <> ", " + <> renderExactRatio (eclipseHoleDeathNumerator receipt) (eclipseHoleDeathDenominator receipt) + <> ")", + "beta1 " + <> show + ( eclipseBettiBeforeBirth receipt, + eclipseBettiAtBirth receipt, + eclipseBettiAtDeath receipt + ) + ] + +buildCriticalState + :: DelaunayTriangulation () + -> AlphaFiltration + -> (Int, AlphaBirth, [Int]) + -> Either PersistenceRoseError CriticalState +buildCriticalState triangulation filtration (rankValue, birthValue, profile) = do + bettiOne <- + case profile of + _ : secondDegree : _ : _ -> Right secondDegree + _ -> Left (RoseCriticalProfileDegreeCountMismatch rankValue (length profile)) + holes <- holeComponentsAt rankValue triangulation filtration birthValue + pure + CriticalState + { criticalRank = rankValue, + criticalBirth = birthValue, + criticalBettiOne = bettiOne, + criticalHoles = holes + } + +chooseHeroState :: NonEmpty CriticalState -> Either PersistenceRoseError CriticalState +chooseHeroState states = + let stateList = NonEmpty.toList states + maximumBettiOne = foldl' (\best state -> max best (criticalBettiOne state)) 0 stateList + maximalStates = filter ((== maximumBettiOne) . criticalBettiOne) stateList + agreements = fmap (\state -> (criticalBettiOne state, length (criticalHoles state))) maximalStates + coherentStates = + filter + (\state -> criticalBettiOne state > 0 && criticalBettiOne state == length (criticalHoles state)) + stateList + sevenPetalStates = filter ((== rosePetalCount) . criticalBettiOne) coherentStates + in if maximumBettiOne <= 0 + then Left RoseNoPersistentHole + else + case NonEmpty.nonEmpty sevenPetalStates of + Just preferredStates -> Right (latestCriticalState preferredStates) + Nothing -> + maybe + (Left (RoseNoCoherentHero maximumBettiOne agreements)) + Right + (find (\state -> criticalBettiOne state == length (criticalHoles state)) maximalStates) + +latestCriticalState :: NonEmpty CriticalState -> CriticalState +latestCriticalState (firstState :| remainingStates) = + foldl' + (\latest candidate -> if criticalRank candidate > criticalRank latest then candidate else latest) + firstState + remainingStates + +holeComponentsAt + :: Int + -> DelaunayTriangulation () + -> AlphaFiltration + -> AlphaBirth + -> Either PersistenceRoseError [HoleComponent] +holeComponentsAt rankValue triangulation filtration threshold = do + inactiveEdges <- + inactiveHandlesAt + RoseEdgeBirthMissing + (alphaEdgeBirth filtration) + (undirectedEdges triangulation) + threshold + inactiveFaces <- + inactiveHandlesAt + RoseFaceBirthMissing + (alphaFaceBirth filtration) + (innerFaces triangulation) + threshold + let edgeInactive edge = Set.member edge inactiveEdges + faceInactive face = Set.member face inactiveFaces + exteriorFaces = Set.fromList (outerFaceFloodFill triangulation edgeInactive) + inactiveComponents = + fmap snd + ( faceComponentsBy + triangulation + (\face -> if faceInactive face then Just () else Nothing) + edgeInactive + ) + boundedComponents = + filter + (all (`Set.notMember` exteriorFaces) . faceComponentFaces) + inactiveComponents + traverse + (projectHoleComponent rankValue triangulation) + boundedComponents + +inactiveHandlesAt + :: Ord handle + => (handle -> PersistenceRoseError) + -> (handle -> Maybe AlphaBirth) + -> [handle] + -> AlphaBirth + -> Either PersistenceRoseError (Set.Set handle) +inactiveHandlesAt missingBirth birthAt handles threshold = + Set.fromList . mapMaybe id + <$> traverse + ( \handle -> + maybe + (Left (missingBirth handle)) + (\birth -> Right (if birth > threshold then Just handle else Nothing)) + (birthAt handle) + ) + handles + +projectHoleComponent + :: Int + -> DelaunayTriangulation () + -> FaceComponent + -> Either PersistenceRoseError HoleComponent +projectHoleComponent rankValue triangulation component = do + loops <- + first (RoseBoundaryDescentFailed rankValue) + (componentBoundaryLoops triangulation component) + pure + ( HoleComponent + ( fmap + (fmap (vertexPoint triangulation) . NonEmpty.toList . boundaryLoopVertices) + (NonEmpty.toList loops) + ) + ) + +projectRankedEdge + :: DelaunayTriangulation () + -> AlphaFiltration + -> Map AlphaBirth Int + -> UndirectedEdgeId + -> Either PersistenceRoseError RankedSegment +projectRankedEdge triangulation filtration birthRanks edge = do + birth <- maybe (Left (RoseEdgeBirthMissing edge)) Right (alphaEdgeBirth filtration edge) + rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) + let (fromVertex, toVertex) = undirectedEndpoints triangulation edge + pure + RankedSegment + { rankedSegmentGeometry = Segment (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex), + rankedSegmentBirthRank = rankValue + } + +projectRankedFace + :: DelaunayTriangulation () + -> AlphaFiltration + -> Map AlphaBirth Int + -> (Int, (VertexId, VertexId, VertexId)) + -> Either PersistenceRoseError RankedTriangle +projectRankedFace triangulation filtration birthRanks (rawFace, (firstVertex, secondVertex, thirdVertex)) = do + let face = toFaceId rawFace + birth <- maybe (Left (RoseFaceBirthMissing face)) Right (alphaFaceBirth filtration face) + rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) + pure + RankedTriangle + { rankedTrianglePoints = + ( vertexPoint triangulation firstVertex, + vertexPoint triangulation secondVertex, + vertexPoint triangulation thirdVertex + ), + rankedTriangleBirthRank = rankValue + } + +toFaceId :: Int -> FaceId +toFaceId = FaceId . fromIntegral + +projectFiniteVoronoiSegments + :: DelaunayTriangulation () + -> Either PersistenceRoseError [Segment] +projectFiniteVoronoiSegments triangulation = + fmap (mapMaybe id) + . traverse projectSegment + $ undirectedEdges triangulation + where + projectSegment :: UndirectedEdgeId -> Either PersistenceRoseError (Maybe Segment) + projectSegment edge = + case voronoiEdgeGeometry triangulation (asDirectedVoronoiEdge (normalizedDirected edge)) of + Nothing -> Left (RoseVoronoiGeometryMissing edge) + Just (VoronoiSegment fromPoint toPoint) -> Right (Just (Segment fromPoint toPoint)) + Just (VoronoiRay _ _) -> Right Nothing + Just (VoronoiLine _ _) -> Right Nothing + +naturalNeighborField + :: DelaunayTriangulation () + -> Either PersistenceRoseError ([FieldSample], Int) +naturalNeighborField triangulation = do + admittedQueries <- traverse (first RosePointInvalid . mkQueryPoint) fieldQueryPoints + let results = runST $ do + workspace <- newNaturalNeighborWorkspace triangulation + traverse (naturalNeighborWeights workspace Nothing) admittedQueries + pairedResults = zip admittedQueries results + fallbackCount = length (filter (interpolationUsedFallback . naturalNeighborStats . snd) pairedResults) + samples = mapMaybe (fieldSampleFromResult triangulation) pairedResults + pure (samples, fallbackCount) + +fieldSampleFromResult + :: DelaunayTriangulation () + -> (QueryPoint, NaturalNeighborResult) + -> Maybe FieldSample +fieldSampleFromResult triangulation (query, result) + | Vector.null weights = Nothing + | interpolationUsedFallback (naturalNeighborStats result) = Nothing + | otherwise = + let weightedValue = + Vector.foldl' + (\total (vertex, weight) -> total + weight * siteSignal (vertexPoint triangulation vertex)) + 0 + weights + in Just + FieldSample + { fieldSamplePoint = queryPointValue query, + fieldSampleValue = clamp 0 1 weightedValue, + fieldSampleNeighborCount = Vector.length weights + } + where + weights = naturalNeighborValues result + +siteSignal :: Point -> Double +siteSignal (Point x y) = + clamp 0 1 (0.5 + 0.24 * sin (1.31 * x - 0.73 * y) + 0.18 * cos (0.61 * x + 1.17 * y)) + +fieldQueryPoints :: [Point] +fieldQueryPoints = + [ Point (fromIntegral column * 0.34 - 5.1) (fromIntegral row * 0.34 - 4.42) + | row <- [0 .. 26 :: Int], + column <- [0 .. 30 :: Int] + ] + +projectPersistenceArcs + :: Map AlphaBirth Int + -> Int + -> [PersistencePair AlphaBirth] + -> Either PersistenceRoseError [PersistenceArc] +projectPersistenceArcs birthRanks criticalCount pairs = do + arcs <- traverse pairArc (filter isPositiveHole pairs) + pure (take 36 (sortOn (Down . persistenceArcLifetime) arcs)) + where + finalRank = max 0 (criticalCount - 1) + pairArc pair = do + birthRank <- rankOf (persistenceBirth pair) + deathRank <- maybe (Right finalRank) rankOf (persistenceDeath pair) + pure + PersistenceArc + { persistenceArcBirthRank = birthRank, + persistenceArcDeathRank = deathRank + } + rankOf birth = maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks) + +persistenceArcLifetime :: PersistenceArc -> Int +persistenceArcLifetime PersistenceArc{persistenceArcBirthRank, persistenceArcDeathRank} = + max 0 (persistenceArcDeathRank - persistenceArcBirthRank) + +isPositiveHole :: PersistencePair AlphaBirth -> Bool +isPositiveHole pair = + persistenceDegree pair == HomologicalDegree 1 + && maybe True (> persistenceBirth pair) (persistenceDeath pair) + +isFinitePositiveHole :: PersistencePair AlphaBirth -> Bool +isFinitePositiveHole pair = isPositiveHole pair && maybe False (> persistenceBirth pair) (persistenceDeath pair) + +isEssentialHole :: PersistencePair AlphaBirth -> Bool +isEssentialHole pair = persistenceDegree pair == HomologicalDegree 1 && persistenceDeath pair == Nothing + +buildRoseMask :: Either PersistenceRoseError [MaskComponent] +buildRoseMask = do + kernelPoints <- traverse (first RosePointInvalid . exactPointFromPoint) minkowskiKernel + kernel <- first RoseMinkowskiFailed (convexPolygon kernelPoints >>= structuringElement) + authoredRegions <- traverse authoredRegion roseMaskLoops + offsetRegions <- + traverse + (fmap fst . first RoseMinkowskiFailed . polygonOffset kernel) + authoredRegions + unioned <- + case NonEmpty.nonEmpty offsetRegions of + Nothing -> Left RoseNoMaskRegions + Just (firstRegion :| remainingRegions) -> foldM exactRegionUnion firstRegion remainingRegions + traverse projectMaskComponent (planarRegionComponents unioned) + +authoredRegion :: NonEmpty Point -> Either PersistenceRoseError PlanarRegion +authoredRegion points = do + exactPoints <- traverse (first RosePointInvalid . exactPointFromPoint) points + loop <- first RoseRegionInvalid (exactLoop exactPoints) + component <- first RoseRegionInvalid (polygonComponent loop []) + first RoseRegionInvalid (planarRegion [component]) + +exactRegionUnion :: PlanarRegion -> PlanarRegion -> Either PersistenceRoseError PlanarRegion +exactRegionUnion leftRegion rightRegion = do + leftLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True leftRegion)) + rightLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True rightRegion)) + overlaid <- first RoseOverlayFailed (overlayLayers leftLayer rightLayer) + first RoseOverlayPublicationFailed (overlaySelectedRegion (uncurry (||)) overlaid) + +projectMaskComponent :: PolygonComponent -> Either PersistenceRoseError MaskComponent +projectMaskComponent component = + MaskComponent + <$> projectExactLoop (polygonOuterLoop component) + <*> traverse projectExactLoop (polygonHoleLoops component) + +projectExactLoop :: ExactLoop -> Either PersistenceRoseError [Point] +projectExactLoop = + traverse + (fmap queryPointValue . first RosePointInvalid . exactPointToEmbeddingCandidate) + . NonEmpty.toList + . exactLoopPoints + +roseSites :: [Point] +roseSites = + concatMap petalSites [0 .. rosePetalCount - 1] + <> centerSites + +petalSites :: Int -> [Point] +petalSites petalIndex = + fmap + (petalPoint petalIndex 2.52 1.82 0.69) + (sampleAngles 22 (0.021 * fromIntegral petalIndex)) + +centerSites :: [Point] +centerSites = + Point 0 0 + : fmap + (\angle -> Point (0.56 * cos angle) (0.56 * sin angle)) + (sampleAngles 14 0.037) + +roseMaskLoops :: [NonEmpty Point] +roseMaskLoops = + fmap + (\petalIndex -> fmap (petalPoint petalIndex 2.42 2.12 0.9) (sampleAnglesNonEmpty 34 0)) + [0 .. rosePetalCount - 1] + <> [fmap (\angle -> Point (1.08 * cos angle) (1.08 * sin angle)) (sampleAnglesNonEmpty 30 0)] + +petalPoint :: Int -> Double -> Double -> Double -> Double -> Point +petalPoint petalIndex centerRadius radialRadius tangentialRadius localAngle = + let orientation = twoPi * fromIntegral petalIndex / fromIntegral rosePetalCount - pi / 2 + radial = centerRadius + radialRadius * cos localAngle + tangential = tangentialRadius * sin localAngle * (0.91 + 0.09 * cos (2 * localAngle)) + radialX = cos orientation + radialY = sin orientation + tangentX = -radialY + tangentY = radialX + in Point + (radial * radialX + tangential * tangentX) + (radial * radialY + tangential * tangentY) + +sampleAngles :: Int -> Double -> [Double] +sampleAngles sampleCount phase = + fmap + (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase) + [0 .. sampleCount - 1] + +sampleAnglesNonEmpty :: Int -> Double -> NonEmpty Double +sampleAnglesNonEmpty sampleCount phase = + phase + :| fmap + (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase) + [1 .. max 1 sampleCount - 1] + +minkowskiKernel :: NonEmpty Point +minkowskiKernel = + Point 0.085 0 + :| [ Point 0.043 0.074, + Point (-0.043) 0.074, + Point (-0.085) 0, + Point (-0.043) (-0.074), + Point 0.043 (-0.074) + ] + +rosePetalCount :: Int +rosePetalCount = 7 + +-- | The package's canonical exact persistence witness. Its four hull edges +-- enter at squared radius one; the resident diagonal and two resident faces +-- enter at squared radius two. Homology therefore observes exactly one finite +-- degree-one interval @[1,2)@ over this fixed DCEL. +alphaEclipseSites :: [Point] +alphaEclipseSites = + [ Point (-1) (-1), + Point 1 (-1), + Point 1 1, + Point (-1) 1 + ] + +renderPersistenceRosePoster :: PersistenceRoseScene -> String +renderPersistenceRosePoster scene = + renderScene scene (criticalRank (sceneHeroState scene)) 1 True + +renderAlphaEclipse :: AlphaEclipseScene -> String +renderAlphaEclipse scene = + let receipt = eclipseReceipt scene + birthLabel = + renderExactRatio + (eclipseHoleBirthNumerator receipt) + (eclipseHoleBirthDenominator receipt) + deathLabel = + renderExactRatio + (eclipseHoleDeathNumerator receipt) + (eclipseHoleDeathDenominator receipt) + in concat + [ "\n", + "Moonlight Triangulation alpha eclipse\n", + "One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius ", + birthLabel, + ", and its resident diagonal and faces kill that hole at squared radius ", + deathLabel, + ".\n", + renderAlphaEclipseDefinitions, + "\n", + "\n", + "MOONLIGHT TRIANGULATION\n", + "ALPHA ECLIPSE\n", + "ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS\n", + renderAlphaEclipseStage + scene + 245 + "BEFORE BIRTH" + "four isolated sites" + (eclipseBeforeState scene), + renderAlphaEclipseStage + scene + 720 + "LOOP BORN" + "resident boundary closes" + (eclipseBirthState scene), + renderAlphaEclipseStage + scene + 1195 + "CYCLE KILLED" + "resident faces fill it" + (eclipseDeathState scene), + "\n", + "ONE EXACT H₁ INTERVAL\n", + "\n", + "\n", + "\n", + "\n", + "α² = 0\n", + "birth α² = ", + birthLabel, + "\n", + "the eclipse hole persists\n", + "death α² = ", + deathLabel, + "\n", + "exact α² increases →\n", + "\n", + "\n" + ] + +renderAlphaEclipseDefinitions :: String +renderAlphaEclipseDefinitions = + concat + [ "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n" + ] + +renderAlphaEclipseStage + :: AlphaEclipseScene + -> Double + -> String + -> String + -> CriticalState + -> String +renderAlphaEclipseStage scene centerX stageLabel explanation state = + let rankValue = criticalRank state + activeFaces = filter ((<= rankValue) . rankedTriangleBirthRank) (eclipseFaces scene) + activeEdges = filter ((<= rankValue) . rankedSegmentBirthRank) (eclipseEdges scene) + highlighted = criticalBettiOne state > 0 + frameStroke = if highlighted then "#ff6fbd" else "#344070" + frameOpacity = if highlighted then "0.72" else "0.55" + in concat + [ "\n", + "\n", + "", + stageLabel, + "\n", + "\n", + "", + concatMap renderAlphaEclipseTriangle activeFaces, + "\n", + "", + concatMap renderAlphaEclipseSegment activeEdges, + "\n", + "", + concatMap renderAlphaEclipseHole (criticalHoles state), + "\n", + "", + concatMap renderAlphaEclipseSite (eclipseSites scene), + "\n", + "\n", + "", + explanation, + "\n", + "β₁ = ", + show (criticalBettiOne state), + "\n", + "α² = ", + renderAlphaBirth (criticalBirth state), + "\n", + "\n" + ] + +renderAlphaEclipseTriangle :: RankedTriangle -> String +renderAlphaEclipseTriangle RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint)} = + " renderScreenPoints (fmap toAlphaEclipseLocal [firstPoint, secondPoint, thirdPoint]) + <> "\"/>\n" + +renderAlphaEclipseSegment :: RankedSegment -> String +renderAlphaEclipseSegment RankedSegment{rankedSegmentGeometry = Segment firstPoint secondPoint} = + let Point firstX firstY = toAlphaEclipseLocal firstPoint + Point secondX secondY = toAlphaEclipseLocal secondPoint + in " formatDouble firstX + <> "\" y1=\"" + <> formatDouble firstY + <> "\" x2=\"" + <> formatDouble secondX + <> "\" y2=\"" + <> formatDouble secondY + <> "\"/>\n" + +renderAlphaEclipseHole :: HoleComponent -> String +renderAlphaEclipseHole (HoleComponent loops) = + concatMap + (\points -> " renderClosedPath (fmap toAlphaEclipseLocal points) <> "\"/>\n") + loops + +renderAlphaEclipseSite :: Point -> String +renderAlphaEclipseSite point = + let Point x y = toAlphaEclipseLocal point + in " formatDouble x + <> "\" cy=\"" + <> formatDouble y + <> "\" r=\"6\"/>\n" + +toAlphaEclipseLocal :: Point -> Point +toAlphaEclipseLocal (Point x y) = + let scale = 72 + inverseSquareRootTwo = sqrt 0.5 + in Point + (scale * inverseSquareRootTwo * (x - y)) + (scale * inverseSquareRootTwo * (x + y)) + +renderAlphaBirth :: AlphaBirth -> String +renderAlphaBirth birth = + renderExactRatio (alphaBirthNumerator birth) (alphaBirthDenominator birth) + +renderExactRatio :: Integer -> Integer -> String +renderExactRatio numerator denominator + | denominator == 1 = show numerator + | otherwise = show numerator <> "/" <> show denominator + +persistenceRoseFrameSpecs :: Int -> Either PersistenceRoseError [PersistenceRoseFrame] +persistenceRoseFrameSpecs frameCount + | frameCount < 2 = Left (RoseFrameCountTooSmall frameCount) + | otherwise = + Right + ( fmap + (\frameIndex -> + PersistenceRoseFrame + { frameProgress = frameProgressAt frameCount frameIndex + }) + [0 .. frameCount - 1] + ) + +renderPersistenceRoseFrame :: PersistenceRoseScene -> PersistenceRoseFrame -> String +renderPersistenceRoseFrame scene frame = + let finalRank = criticalRank (NonEmpty.last (sceneCriticalStates scene)) + selectedRank = clampInt 0 finalRank (floor (frameProgress frame * fromIntegral finalRank)) + in renderScene scene selectedRank (frameProgress frame) False + +persistenceRoseAnimationReceipt + :: PersistenceRoseScene + -> Either PersistenceRoseError PersistenceRoseAnimationReceipt +persistenceRoseAnimationReceipt scene = do + frames <- persistenceRoseFrameSpecs canonicalAnimationFrameCount + let renderedFrames = fmap (renderPersistenceRoseFrame scene) frames + pure + PersistenceRoseAnimationReceipt + { roseAnimationFrameCount = canonicalAnimationFrameCount, + roseAnimationFramesPerSecond = canonicalAnimationFramesPerSecond, + roseAnimationWidth = canonicalAnimationWidth, + roseAnimationHeight = canonicalAnimationHeight, + roseAnimationSourceFingerprint = fingerprintSections renderedFrames + } + +renderPersistenceRoseAnimationReceipt :: PersistenceRoseAnimationReceipt -> String +renderPersistenceRoseAnimationReceipt receipt = + intercalate + " " + [ "MOONLIGHT_PERSISTENCE_ROSE", + "frame-count=" <> show (roseAnimationFrameCount receipt), + "fps=" <> show (roseAnimationFramesPerSecond receipt), + "size=" <> show (roseAnimationWidth receipt) <> "x" <> show (roseAnimationHeight receipt), + "source-fnv1a64=" <> renderWord64Hex (roseAnimationSourceFingerprint receipt) + ] + +stampPersistenceRoseGif + :: PersistenceRoseScene + -> ByteString + -> Either PersistenceRoseError (PersistenceRoseAnimationReceipt, ByteString) +stampPersistenceRoseGif scene gifBytes = do + receipt <- persistenceRoseAnimationReceipt scene + summary <- inspectGif gifBytes + validateGifSummary receipt summary + let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt) + markerLength = ByteString.length marker + if markerLength > 255 + then Left (RoseGifMarkerTooLong markerLength) + else + if marker `ByteString.isInfixOf` gifBytes + then Right (receipt, gifBytes) + else + if gifMarkerPrefix `ByteString.isInfixOf` gifBytes + then Left RoseGifProvenanceMismatch + else do + insertionOffset <- gifDataStart gifBytes + let (prefix, suffix) = ByteString.splitAt insertionOffset gifBytes + commentExtension = + ByteString.pack [0x21, 0xfe, fromIntegral markerLength] + <> marker + <> ByteString.singleton 0 + pure (receipt, prefix <> commentExtension <> suffix) + +verifyPersistenceRoseGif + :: PersistenceRoseScene + -> ByteString + -> Either PersistenceRoseError PersistenceRoseAnimationReceipt +verifyPersistenceRoseGif scene gifBytes = do + receipt <- persistenceRoseAnimationReceipt scene + summary <- inspectGif gifBytes + validateGifSummary receipt summary + let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt) + if marker `ByteString.isInfixOf` gifBytes + then Right receipt + else Left RoseGifProvenanceMismatch + +data GifSummary = GifSummary + { gifSummaryWidth :: !Int, + gifSummaryHeight :: !Int, + gifSummaryFrameCount :: !Int, + gifSummaryFrameDelayCount :: !Int, + gifSummaryDurationCentiseconds :: !Int + } + +inspectGif :: ByteString -> Either PersistenceRoseError GifSummary +inspectGif gifBytes = do + dataStart <- gifDataStart gifBytes + width <- gifLittleEndianWord16 gifBytes 6 + height <- gifLittleEndianWord16 gifBytes 8 + (frameCount, frameDelayCount, durationCentiseconds) <- + countGifFrames gifBytes dataStart 0 0 0 + pure + GifSummary + { gifSummaryWidth = width, + gifSummaryHeight = height, + gifSummaryFrameCount = frameCount, + gifSummaryFrameDelayCount = frameDelayCount, + gifSummaryDurationCentiseconds = durationCentiseconds + } + +gifDataStart :: ByteString -> Either PersistenceRoseError Int +gifDataStart gifBytes = do + signature <- maybe (Left (RoseGifTruncated 0)) Right (gifSlice gifBytes 0 6) + if signature == ByteString.Char8.pack "GIF87a" || signature == ByteString.Char8.pack "GIF89a" + then pure () + else Left RoseGifInvalidSignature + packed <- maybe (Left (RoseGifTruncated 10)) Right (gifByteAt gifBytes 10) + let globalColourTableBytes = + if packed .&. 0x80 == 0 + then 0 + else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int)) + dataStart = 13 + globalColourTableBytes + maybe (Left (RoseGifTruncated dataStart)) (const (Right dataStart)) (gifSlice gifBytes 0 dataStart) + +countGifFrames + :: ByteString + -> Int + -> Int + -> Int + -> Int + -> Either PersistenceRoseError (Int, Int, Int) +countGifFrames gifBytes offset frameCount frameDelayCount durationCentiseconds = do + block <- maybe (Left (RoseGifTruncated offset)) Right (gifByteAt gifBytes offset) + case block of + 0x3b -> Right (frameCount, frameDelayCount, durationCentiseconds) + 0x21 -> do + extensionLabel <- maybe (Left (RoseGifTruncated (offset + 1))) Right (gifByteAt gifBytes (offset + 1)) + nextOffset <- skipGifSubBlocks gifBytes (offset + 2) + if extensionLabel == 0xf9 + then do + delay <- gifLittleEndianWord16 gifBytes (offset + 4) + countGifFrames + gifBytes + nextOffset + frameCount + (frameDelayCount + 1) + (durationCentiseconds + delay) + else + countGifFrames + gifBytes + nextOffset + frameCount + frameDelayCount + durationCentiseconds + 0x2c -> do + packed <- maybe (Left (RoseGifTruncated (offset + 9))) Right (gifByteAt gifBytes (offset + 9)) + let localColourTableBytes = + if packed .&. 0x80 == 0 + then 0 + else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int)) + imageDataStart = offset + 11 + localColourTableBytes + maybe (Left (RoseGifTruncated imageDataStart)) (const (Right ())) (gifByteAt gifBytes (imageDataStart - 1)) + skipGifSubBlocks gifBytes imageDataStart >>= \next -> + countGifFrames + gifBytes + next + (frameCount + 1) + frameDelayCount + durationCentiseconds + 0x00 -> + countGifFrames + gifBytes + (offset + 1) + frameCount + frameDelayCount + durationCentiseconds + unexpected -> Left (RoseGifUnexpectedBlock offset unexpected) + +skipGifSubBlocks :: ByteString -> Int -> Either PersistenceRoseError Int +skipGifSubBlocks gifBytes offset = do + blockLength <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset) + if blockLength == 0 + then Right (offset + 1) + else do + let nextOffset = offset + 1 + blockLength + maybe (Left (RoseGifTruncated nextOffset)) (const (Right ())) (gifSlice gifBytes offset (1 + blockLength)) + skipGifSubBlocks gifBytes nextOffset + +validateGifSummary + :: PersistenceRoseAnimationReceipt + -> GifSummary + -> Either PersistenceRoseError () +validateGifSummary receipt summary + | actualWidth /= expectedWidth || actualHeight /= expectedHeight = + Left (RoseGifDimensionMismatch expectedWidth expectedHeight actualWidth actualHeight) + | actualFrameCount /= expectedFrameCount = + Left (RoseGifFrameCountMismatch expectedFrameCount actualFrameCount) + | actualFrameDelayCount /= expectedFrameCount = + Left (RoseGifFrameDelayCountMismatch expectedFrameCount actualFrameDelayCount) + | actualDurationCentiseconds /= canonicalAnimationDurationCentiseconds = + Left + ( RoseGifDurationMismatch + canonicalAnimationDurationCentiseconds + actualDurationCentiseconds + ) + | otherwise = Right () + where + expectedWidth = roseAnimationWidth receipt + expectedHeight = roseAnimationHeight receipt + actualWidth = gifSummaryWidth summary + actualHeight = gifSummaryHeight summary + expectedFrameCount = roseAnimationFrameCount receipt + actualFrameCount = gifSummaryFrameCount summary + actualFrameDelayCount = gifSummaryFrameDelayCount summary + actualDurationCentiseconds = gifSummaryDurationCentiseconds summary + +gifLittleEndianWord16 :: ByteString -> Int -> Either PersistenceRoseError Int +gifLittleEndianWord16 gifBytes offset = do + low <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset) + high <- maybe (Left (RoseGifTruncated (offset + 1))) (Right . fromIntegral) (gifByteAt gifBytes (offset + 1)) + pure (low + 256 * high) + +gifByteAt :: ByteString -> Int -> Maybe Word8 +gifByteAt gifBytes offset = fst <$> ByteString.uncons (ByteString.drop offset gifBytes) + +gifSlice :: ByteString -> Int -> Int -> Maybe ByteString +gifSlice gifBytes offset width = + let selected = ByteString.take width (ByteString.drop offset gifBytes) + in if ByteString.length selected == width then Just selected else Nothing + +fingerprintSections :: [String] -> Word64 +fingerprintSections = + foldl' + (\fingerprint section -> fingerprintByte (fingerprintText fingerprint section) 0) + fnvOffsetBasis + +fingerprintText :: Word64 -> String -> Word64 +fingerprintText fingerprint = + ByteString.foldl' fingerprintByte fingerprint + . Text.Encoding.encodeUtf8 + . Text.pack + +fingerprintByte :: Word64 -> Word8 -> Word64 +fingerprintByte fingerprint byte = + (fingerprint `xor` fromIntegral byte) * fnvPrime + +renderWord64Hex :: Word64 -> String +renderWord64Hex value = + let rendered = showHex value "" + in replicate (16 - length rendered) '0' <> rendered + +gifMarkerPrefix :: ByteString +gifMarkerPrefix = ByteString.Char8.pack "MOONLIGHT_PERSISTENCE_ROSE " + +canonicalAnimationFrameCount :: Int +canonicalAnimationFrameCount = 65 + +canonicalAnimationFramesPerSecond :: Int +canonicalAnimationFramesPerSecond = 8 + +canonicalAnimationWidth :: Int +canonicalAnimationWidth = 960 + +canonicalAnimationHeight :: Int +canonicalAnimationHeight = 540 + +canonicalAnimationDurationCentiseconds :: Int +canonicalAnimationDurationCentiseconds = 813 + +fnvOffsetBasis :: Word64 +fnvOffsetBasis = 14695981039346656037 + +fnvPrime :: Word64 +fnvPrime = 1099511628211 + +frameProgressAt :: Int -> Int -> Double +frameProgressAt frameCount frameIndex + | frameIndex <= 0 || frameIndex >= frameCount - 1 = 0 + | otherwise = + let phase = fromIntegral frameIndex / fromIntegral (frameCount - 1) + in 0.5 - 0.5 * cos (twoPi * phase) + +renderScene :: PersistenceRoseScene -> Int -> Double -> Bool -> String +renderScene scene selectedRank progress poster = + let selectedState = criticalStateAt selectedRank (sceneCriticalStates scene) + finalRank = max 1 (criticalRank (NonEmpty.last (sceneCriticalStates scene))) + activation = if poster then fromIntegral selectedRank / fromIntegral finalRank else progress + in concat + [ "\n", + "Moonlight Triangulation Persistence Rose\n", + "Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose.\n", + renderDefinitions (sceneMaskComponents scene), + "\n", + renderAmbientOrbits activation, + renderPersistenceHalo finalRank selectedRank (scenePersistenceArcs scene), + "\n", + "\n", + "", concatMap renderFieldSample (sceneFieldSamples scene), "\n", + "", concatMap renderVoronoiSegment (sceneVoronoiSegments scene), "\n", + concatMap (renderRankedTriangle finalRank activation) (sceneFaces scene), + concatMap (renderRankedSegment finalRank activation) (sceneEdges scene), + "", concatMap renderHoleComponent (criticalHoles selectedState), "\n", + concatMap (renderSite activation) (sceneSites scene), + "\n", + "\n", + renderTitle selectedState, + "\n" + ] + +criticalStateAt :: Int -> NonEmpty CriticalState -> CriticalState +criticalStateAt target (firstState :| remainingStates) = + foldl' + (\chosen candidate -> if criticalRank candidate <= target then candidate else chosen) + firstState + remainingStates + +renderDefinitions :: [MaskComponent] -> String +renderDefinitions maskComponents = + concat + [ "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n" + ] + +renderAmbientOrbits :: Double -> String +renderAmbientOrbits activation = + concatMap + ( \orbit -> + let radius = 322 + fromIntegral orbit * 34 + opacity = 0.055 + activation * 0.025 + in " formatDouble radius + <> "\" fill=\"none\" stroke=\"#8ba5ff\" stroke-width=\"0.8\" stroke-dasharray=\"2 12\" opacity=\"" + <> formatDouble opacity + <> "\"/>\n" + ) + [0 .. 5 :: Int] + +renderPersistenceHalo :: Int -> Int -> [PersistenceArc] -> String +renderPersistenceHalo finalRank selectedRank arcs = + "\n" + <> concatMap renderArc (zip ([0 :: Int ..]) arcs) + <> "\n" + where + renderArc :: (Int, PersistenceArc) -> String + renderArc (index, arc) = + let active = persistenceArcBirthRank arc <= selectedRank && selectedRank < persistenceArcDeathRank arc + radius = 414 + fromIntegral (index `mod` 7) * 7.5 + start = rankAngle finalRank (persistenceArcBirthRank arc) + finish = rankAngle finalRank (persistenceArcDeathRank arc) + points = arcPolyline radius start finish 42 + hue = 188 + (index * 17 `mod` 122) + opacity = if active then 0.72 else 0.16 + width = if active then 2.6 else 1.1 + in " renderScreenPoints points + <> "\" stroke=\"hsl(" + <> show hue + <> " 92% 72%)\" stroke-width=\"" + <> formatDouble width + <> "\" opacity=\"" + <> formatDouble opacity + <> "\"/>\n" + +rankAngle :: Int -> Int -> Double +rankAngle finalRank rankValue = + -pi / 2 + twoPi * fromIntegral rankValue / fromIntegral (max 1 finalRank) + +arcPolyline :: Double -> Double -> Double -> Int -> [Point] +arcPolyline radius start finish sampleCount = + fmap + ( \sampleIndex -> + let fraction = fromIntegral sampleIndex / fromIntegral sampleCount + angle = start + fraction * (finish - start) + in screenPointFromPolar radius angle + ) + [0 .. sampleCount] + +screenPointFromPolar :: Double -> Double -> Point +screenPointFromPolar radius angle = + Point (960 + radius * cos angle) (552 + radius * sin angle) + +renderFieldSample :: FieldSample -> String +renderFieldSample FieldSample{fieldSamplePoint, fieldSampleValue, fieldSampleNeighborCount} = + let Point x y = toScreen fieldSamplePoint + hue = round (186 + 126 * fieldSampleValue) :: Int + radius = 30 + min 5 (fromIntegral fieldSampleNeighborCount) + opacity = 0.16 + 0.16 * fieldSampleValue + in " formatDouble x + <> "\" cy=\"" + <> formatDouble y + <> "\" r=\"" + <> formatDouble radius + <> "\" fill=\"hsl(" + <> show hue + <> " 94% 61%)\" opacity=\"" + <> formatDouble opacity + <> "\"/>\n" + +renderVoronoiSegment :: Segment -> String +renderVoronoiSegment segment = + renderLine segment "#61efff" 1.15 0.5 "" + +renderRankedTriangle :: Int -> Double -> RankedTriangle -> String +renderRankedTriangle finalRank activation RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint), rankedTriangleBirthRank} = + let opacity = activationOpacity finalRank activation rankedTriangleBirthRank + hue :: Int + hue = 282 - round (94 * fromIntegral rankedTriangleBirthRank / fromIntegral (max 1 finalRank) :: Double) + in if opacity <= 0.001 + then "" + else + " renderWorldPoints [firstPoint, secondPoint, thirdPoint] + <> "\" fill=\"hsl(" + <> show hue + <> " 88% 60%)\" opacity=\"" + <> formatDouble (0.06 + 0.17 * opacity) + <> "\"/>\n" + +renderRankedSegment :: Int -> Double -> RankedSegment -> String +renderRankedSegment finalRank activation RankedSegment{rankedSegmentGeometry, rankedSegmentBirthRank} = + let opacity = activationOpacity finalRank activation rankedSegmentBirthRank + width = 0.75 + 1.25 * opacity + color = if opacity > 0.72 then "#ffd56a" else "#dd78ff" + in renderLine rankedSegmentGeometry color width (0.06 + 0.82 * opacity) "filter=\"url(#edge-glow)\"" + +activationOpacity :: Int -> Double -> Int -> Double +activationOpacity finalRank activation birthRank = + let level = activation * fromIntegral finalRank + distance = level - fromIntegral birthRank + in smoothstep (distance + 0.6) + +smoothstep :: Double -> Double +smoothstep value = + let bounded = clamp 0 1 value + in bounded * bounded * (3 - 2 * bounded) + +renderHoleComponent :: HoleComponent -> String +renderHoleComponent (HoleComponent loops) = + concatMap + ( \points -> + " renderClosedWorldPath points + <> "\" fill=\"none\" stroke=\"url(#hole-stroke)\" stroke-width=\"5.4\" stroke-linejoin=\"round\" opacity=\"0.98\"/>\n" + ) + loops + +renderSite :: Double -> Point -> String +renderSite activation point = + let Point x y = toScreen point + radius = 2.5 + 1.5 * activation + in " formatDouble x + <> "\" cy=\"" + <> formatDouble y + <> "\" r=\"" + <> formatDouble radius + <> "\" fill=\"#fff8d9\" stroke=\"#ff9ad7\" stroke-width=\"1.2\" opacity=\"0.95\"/>\n" + +renderLine :: Segment -> String -> Double -> Double -> String -> String +renderLine (Segment fromPoint toPoint) color width opacity extraAttributes = + let Point fromX fromY = toScreen fromPoint + Point toX toY = toScreen toPoint + in " formatDouble fromX + <> "\" y1=\"" + <> formatDouble fromY + <> "\" x2=\"" + <> formatDouble toX + <> "\" y2=\"" + <> formatDouble toY + <> "\" stroke=\"" + <> color + <> "\" stroke-width=\"" + <> formatDouble width + <> "\" stroke-linecap=\"round\" opacity=\"" + <> formatDouble opacity + <> "\" " + <> extraAttributes + <> "/>\n" + +renderTitle :: CriticalState -> String +renderTitle state = + let alphaFraction = exactFractionSummary (criticalBirth state) + alphaDecimal = formatDouble (alphaBirthToDouble (criticalBirth state)) + bettiMeaning = bettiOneMeaning (criticalBettiOne state) + in concat + [ "\n", + "MOONLIGHT TRIANGULATION\n", + "PERSISTENCE ROSE\n", + "\n", + "TOPOLOGICAL HOLES AT THIS SCALE\n", + "β₁ = ", + show (criticalBettiOne state), + "\n", + "", + bettiMeaning, + "\n", + "in the exact alpha complex\n", + "critical rank ", + show (criticalRank state), + " · α² = ", + alphaDecimal, + "\n", + "", + alphaFraction, + "\n", + "\n", + "\n" + ] + +bettiOneMeaning :: Int -> String +bettiOneMeaning holeCount = + case holeCount of + 0 -> "no independent one-dimensional holes" + 1 -> "1 independent one-dimensional hole" + _ -> show holeCount <> " independent one-dimensional holes" + +exactFractionSummary :: AlphaBirth -> String +exactFractionSummary birth = + let numeratorDigits = length (show (abs (alphaBirthNumerator birth))) + denominatorDigits = length (show (alphaBirthDenominator birth)) + in "exact " <> show numeratorDigits <> "-digit / " <> show denominatorDigits <> "-digit rational" + +renderMaskPath :: [MaskComponent] -> String +renderMaskPath = + intercalate " " + . concatMap + (\MaskComponent{maskOuterLoop, maskHoleLoops} -> renderClosedScreenPath maskOuterLoop : fmap renderClosedScreenPath maskHoleLoops) + +renderClosedWorldPath :: [Point] -> String +renderClosedWorldPath = renderClosedPath . fmap toScreen + +renderClosedScreenPath :: [Point] -> String +renderClosedScreenPath = renderClosedPath . fmap toScreen + +renderClosedPath :: [Point] -> String +renderClosedPath points = + case points of + [] -> "" + firstPoint : remainingPoints -> + "M " <> renderPoint firstPoint <> concatMap (" L " <>) (fmap renderPoint remainingPoints) <> " Z" + +renderWorldPoints :: [Point] -> String +renderWorldPoints = renderScreenPoints . fmap toScreen + +renderScreenPoints :: [Point] -> String +renderScreenPoints = unwords . fmap renderPoint + +renderPoint :: Point -> String +renderPoint (Point x y) = formatDouble x <> "," <> formatDouble y + +toScreen :: Point -> Point +toScreen (Point x y) = Point (960 + x * 101) (552 + y * 101) + +formatDouble :: Double -> String +formatDouble value = showFFloat (Just 3) value "" + +clamp :: Double -> Double -> Double -> Double +clamp lower upper = min upper . max lower + +clampInt :: Int -> Int -> Int -> Int +clampInt lower upper = min upper . max lower + +twoPi :: Double +twoPi = 2 * pi diff --git a/docs/persistence-rose/README.md b/docs/persistence-rose/README.md new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/README.md @@ -0,0 +1,110 @@ +# Moonlight persistence rose + +![Animated Moonlight persistence rose](./moonlight-triangulation-persistence-rose.gif) + +[Browse all exhibits.](../README.md) +· [Open the animation directly.](./moonlight-triangulation-persistence-rose.gif) +· [Open the static vector poster.](./moonlight-triangulation-persistence-rose.svg) +· [Open the alpha eclipse.](./alpha-eclipse.md) +· [Read the package overview.](../../README.md#persistence-rose) + +## Exact alpha filtration and persistent topology + +The full alpha path is a different observation of the same resident Delaunay +DCEL. `alphaFiltration` computes exact squared-radius births once: vertices at +zero, Gabriel edges at one quarter of their squared length, other edges at their +least incident-face witness, and faces at their circumradius squared. +`filteredAlphaComplex` lowers that section to the one Homology persistence +owner. `AlphaBirth` is an opaque reduced rational; equality and ordering never +round through `Double`. + +This is the planar alpha-complex shortcut to the Cech filtration: the Delaunay +subcomplex has the same homotopy type as the corresponding union of discs, but +has only the resident planar cells. One reduction therefore yields the barcode +for every critical radius. `persistentBettiAtCriticalValues` sweeps all of +those sublevels through dense complex-relative ranks without rebuilding +geometry, reducing another boundary matrix, or rescanning the barcode per +radius. + +The external component path uses the main facade for Delaunay construction and +exact alpha births, then adds only the opt-in cell-complex lowering and +Homology. + +```cabal +build-depends: + base >= 4.22 && < 5, + moonlight-triangulation >= 1.4 && < 1.5, + moonlight-triangulation:cell-complex >= 1.4 && < 1.5, + moonlight-homology >= 0.1 && < 0.2, + vector >= 0.13 && < 0.14 +``` + +```haskell +import Data.Foldable (traverse_) +import qualified Data.Vector as Vector +import Moonlight.Homology.Persistence + ( filteredCriticalValues + , mod2PersistentPairs + , persistentBettiAtCriticalValues + ) +import Moonlight.Triangulation + ( Point (..) + , alphaFiltration + , delaunayGeometry + ) +import Moonlight.Triangulation.CellComplex (filteredAlphaComplex) + +main :: IO () +main = do + mesh <- requireRight (delaunayGeometry (Vector.fromList [Point (-1) (-1), Point 1 (-1), Point 1 1, Point (-1) 1])) + filtration <- requireRight (alphaFiltration mesh) + filtered <- requireRight (filteredAlphaComplex filtration) + pairs <- requireRight (mod2PersistentPairs filtered) + profiles <- requireRight (persistentBettiAtCriticalValues filtered pairs) + traverse_ print (zip (filteredCriticalValues filtered) profiles) + +requireRight :: Show failure => Either failure value -> IO value +requireRight = either (fail . show) pure +``` + +The focused `moonlight-triangulation-alpha-bench` measures exact preparation, +one persistence reduction plus all critical-radius queries, and repeated +threshold homology as separate lanes over the same prebuilt Delaunay mesh. + +## Source SVG generation + +On GHC 9.14, the package-owned generator reproduces the poster or the canonical +65-frame seamless SVG sweep: + +```console +cabal run moonlight-triangulation-persistence-rose -- poster persistence-rose.svg +cabal run moonlight-triangulation-persistence-rose -- frames 65 persistence-rose-frames +``` + +## Retained GIF reproduction + +The retained GIF is the 960×540, 8 fps projection of those 65 source frames. +Its exact encoding boundary is deliberately outside geometry and Homology: +rasterize the SVG section, encode it, then let the exhibit owner stamp the GIF +with the deterministic source-frame fingerprint it computed itself. + +```console +mkdir -p persistence-rose-png +sips -s format png persistence-rose-frames/frame-*.svg --out persistence-rose-png +ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \ + -vf "scale=960:-2:flags=lanczos,palettegen=max_colors=96:stats_mode=diff" \ + -y persistence-rose-palette.png +ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \ + -i persistence-rose-palette.png \ + -lavfi "[0:v]scale=960:-2:flags=lanczos[x];[x][1:v]paletteuse=dither=bayer:bayer_scale=4:diff_mode=rectangle" \ + -loop 0 -y persistence-rose-raw.gif +cabal run moonlight-triangulation-persistence-rose -- \ + stamp-gif persistence-rose-raw.gif docs/persistence-rose/moonlight-triangulation-persistence-rose.gif +cabal run moonlight-triangulation-persistence-rose -- verify-artifacts . +``` + +`verify-artifacts` compares both retained SVGs byte-for-byte with their pure +renderers, checks the GIF dimensions, timing, and image-frame inventory, and +requires the GIF's embedded source fingerprint to equal the freshly rendered +canonical frame section. A plausible binary can no longer wander in wearing a +nice hat. diff --git a/docs/persistence-rose/alpha-eclipse.md b/docs/persistence-rose/alpha-eclipse.md new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/alpha-eclipse.md @@ -0,0 +1,23 @@ +# Moonlight alpha eclipse + +![Alpha eclipse: a fixed Delaunay site set closes one hole and later fills it across exact critical radii](./moonlight-triangulation-alpha-eclipse.svg) + +[Open the full-size vector.](./moonlight-triangulation-alpha-eclipse.svg) +· [Browse all exhibits.](../README.md) +· [Read the exact-filtration API semantics.](./README.md#exact-alpha-filtration-and-persistent-topology) + +The eclipse uses the package's canonical four-site square witness and isolates +its one finite `H₁` interval. The four sites, five resident Delaunay edges, and +two resident faces remain fixed: the four hull edges close one hole at exact +`α² = 1`; the resident diagonal and both resident faces enter at exact +`α² = 2`, making that cycle a boundary. Only the alpha sublevel changes. Every +visible cell is projected from the resident DCEL, and the `β₁ = 0 → 1 → 0` +profile comes from Moonlight Homology rather than a hand-authored diagram. + +## Reproduce + +On GHC 9.14, the package-owned generator reproduces the retained vector: + +```console +cabal run moonlight-triangulation-persistence-rose -- eclipse alpha-eclipse.svg +``` diff --git a/docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg b/docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg @@ -0,0 +1,91 @@ + +Moonlight Triangulation alpha eclipse +One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius 1, and its resident diagonal and faces kill that hole at squared radius 2. + + + + + + + + + +MOONLIGHT TRIANGULATION +ALPHA ECLIPSE +ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS + + +BEFORE BIRTH + + + + + + + + + + +four isolated sites +β₁ = 0 +α² = 0 + + + +LOOP BORN + + + + + + + + + + + + + + + +resident boundary closes +β₁ = 1 +α² = 1 + + + +CYCLE KILLED + + + + + + + + + + + + + + + + + +resident faces fill it +β₁ = 0 +α² = 2 + + +ONE EXACT H₁ INTERVAL + + + + +α² = 0 +birth α² = 1 +the eclipse hole persists +death α² = 2 +exact α² increases → + + diff --git a/docs/persistence-rose/moonlight-triangulation-persistence-rose.gif b/docs/persistence-rose/moonlight-triangulation-persistence-rose.gif new file mode 100644 Binary files /dev/null and b/docs/persistence-rose/moonlight-triangulation-persistence-rose.gif differ diff --git a/docs/persistence-rose/moonlight-triangulation-persistence-rose.svg b/docs/persistence-rose/moonlight-triangulation-persistence-rose.svg new file mode 100644 --- /dev/null +++ b/docs/persistence-rose/moonlight-triangulation-persistence-rose.svg @@ -0,0 +1,1895 @@ + +Moonlight Triangulation Persistence Rose +Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +MOONLIGHT TRIANGULATION +PERSISTENCE ROSE + +TOPOLOGICAL HOLES AT THIS SCALE +β₁ = 7 +7 independent one-dimensional holes +in the exact alpha complex +critical rank 538 · α² = 0.358 +exact 94-digit / 94-digit rational + + + diff --git a/docs/social/moonlight-triangulation-persistence-rose.gif b/docs/social/moonlight-triangulation-persistence-rose.gif deleted file mode 100644 Binary files a/docs/social/moonlight-triangulation-persistence-rose.gif and /dev/null differ diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Boundary.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Boundary.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Boundary.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Triangulation.Foreign.Boundary + ( GeometryMesh + , HandleValue + , checkedCount + , dereferenceHandle + , freeHandle + , prepareHandleOutput + , produceHandle + , publishHandle + , readPoints + , requireOutputCapacity + , requirePointer + , runBoundary + ) where + +import Control.Exception (SomeException, try) +import Foreign.C.Types (CDouble (..), CSize, CUInt) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.StablePtr + ( StablePtr + , castPtrToStablePtr + , castStablePtrToPtr + , deRefStablePtr + , freeStablePtr + , newStablePtr + ) +import Foreign.Storable (peekElemOff, poke) +import qualified Data.Vector as V +import qualified Moonlight.Triangulation as T +import Moonlight.Triangulation.Foreign.Contract + ( CMesh + , CObstruction + , CRegion + , CStructuringElement + ) +import Moonlight.Triangulation.Foreign.Obstruction + ( AbiFailure (..) + , bufferTooSmallFailure + , countOverflowFailure + , emptyObstruction + , nullPointerFailure + , runtimeFailure + , statusOk + ) + +type GeometryMesh = T.DelaunayTriangulation () + +type family HandleValue carrier where + HandleValue CMesh = GeometryMesh + HandleValue CRegion = T.PlanarRegion + HandleValue CStructuringElement = T.StructuringElement + +runBoundary :: Ptr CObstruction -> IO (Either AbiFailure ()) -> IO CUInt +runBoundary obstructionPointer action = do + writeObstruction obstructionPointer emptyObstruction + outcome <- try action :: IO (Either SomeException (Either AbiFailure ())) + case outcome of + Left exception -> finishFailure obstructionPointer (runtimeFailure exception) + Right (Left failure) -> finishFailure obstructionPointer failure + Right (Right ()) -> pure statusOk + +finishFailure :: Ptr CObstruction -> AbiFailure -> IO CUInt +finishFailure obstructionPointer (AbiFailure status obstruction) = do + writeObstruction obstructionPointer obstruction + pure status + +writeObstruction :: Ptr CObstruction -> CObstruction -> IO () +writeObstruction pointer obstruction + | pointer == nullPtr = pure () + | otherwise = poke pointer obstruction + +requirePointer :: String -> Ptr value -> Either AbiFailure () +requirePointer label pointer + | pointer == nullPtr = Left (nullPointerFailure label) + | otherwise = Right () + +checkedCount :: Int -> CSize -> Either AbiFailure Int +checkedCount elementsPerItem rawCount + | toInteger rawCount * toInteger elementsPerItem > toInteger (maxBound :: Int) = + Left (countOverflowFailure (fromIntegral rawCount)) + | otherwise = Right (fromIntegral rawCount) + +readPoints :: Ptr CDouble -> Int -> IO (Either AbiFailure (V.Vector T.Point)) +readPoints pointer count + | count == 0 = pure (Right V.empty) + | pointer == nullPtr = pure (Left (nullPointerFailure "coordinates")) + | otherwise = + Right + <$> V.generateM + count + ( \index -> do + CDouble x <- peekElemOff pointer (index * 2) + CDouble y <- peekElemOff pointer (index * 2 + 1) + pure (T.Point x y) + ) + +prepareHandleOutput :: Ptr (Ptr carrier) -> IO (Either AbiFailure ()) +prepareHandleOutput pointer = + case requirePointer "result" pointer of + Left failure -> pure (Left failure) + Right () -> poke pointer nullPtr >> pure (Right ()) + +publishHandle :: Ptr (Ptr carrier) -> HandleValue carrier -> IO () +publishHandle output value = do + stable <- newStablePtr value + poke output (castPtr (castStablePtrToPtr stable)) + +produceHandle + :: Ptr (Ptr carrier) + -> IO (Either AbiFailure (HandleValue carrier)) + -> IO (Either AbiFailure ()) +produceHandle output obtain = do + prepared <- prepareHandleOutput output + case prepared of + Left failure -> pure (Left failure) + Right () -> do + outcome <- obtain + case outcome of + Left failure -> pure (Left failure) + Right value -> publishHandle output value >> pure (Right ()) + +dereferenceHandle :: Ptr carrier -> IO (HandleValue carrier) +dereferenceHandle pointer = deRefStablePtr (castPtrToStablePtr (castPtr pointer)) + +freeHandle :: Ptr carrier -> IO () +freeHandle pointer + | pointer == nullPtr = pure () + | otherwise = freeStablePtr (castPtrToStablePtr (castPtr pointer) :: StablePtr ()) + +requireOutputCapacity :: String -> Ptr value -> Int -> Int -> Either AbiFailure () +requireOutputCapacity label output required capacity + | capacity < required = Left (bufferTooSmallFailure required capacity) + | required > 0 = requirePointer label output + | otherwise = Right () diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Contract.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Contract.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Contract.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module Moonlight.Triangulation.Foreign.Contract + ( AbiField (..) + , AbiFieldType (..) + , AbiFunction + , AbiFunctionFamily (..) + , AbiFunctionImplementation (..) + , AbiFunctionName (..) + , AbiHandle (..) + , AbiParameter (..) + , AbiParameterKind (..) + , AbiResult (..) + , AbiStatus (..) + , AbiStruct (..) + , CMesh + , CMinkowskiReceipt (..) + , CObstruction (..) + , CRegion + , CStructuringElement + , CoordinateErrorCode (..) + , MinkowskiOperationCode (..) + , ObstructionCode (..) + , RegionLocationCode (..) + , abiFunction + , abiFunctionImplementation + , abiFunctionParameters + , abiFunctionResult + , abiFunctionSymbol + , abiHandleSymbol + , abiStatusId + , abiStatusSymbol + , abiStructFields + , abiStructSymbol + , abiVersion + , allAbiFunctionNames + , allAbiFunctions + , allAbiHandles + , allAbiStatuses + , allAbiStructs + , allCoordinateErrorCodes + , allMinkowskiOperationCodes + , allObstructionCodes + , allRegionLocationCodes + , coordinateErrorCodeId + , coordinateErrorCodeSymbol + , minkowskiOperationCodeId + , minkowskiOperationCodeSymbol + , obstructionCodeId + , obstructionCodeSymbol + , regionLocationCodeId + , regionLocationCodeSymbol + ) where + +import Data.Word (Word32, Word64) +import Foreign.C.String (peekCString, withCStringLen) +import Foreign.C.Types (CChar) +import Foreign.Marshal.Utils (copyBytes, fillBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (..)) +import GHC.Generics (Generic) + +abiVersion :: Word32 +abiVersion = 2 + +data AbiStatus + = AbiStatusOk + | AbiStatusNullPointer + | AbiStatusCountOverflow + | AbiStatusBufferTooSmall + | AbiStatusGeometryObstruction + | AbiStatusRuntimeFailure + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allAbiStatuses :: [AbiStatus] +allAbiStatuses = [minBound .. maxBound] + +abiStatusId :: AbiStatus -> Word32 +abiStatusId status = + case status of + AbiStatusOk -> 0 + AbiStatusNullPointer -> 1 + AbiStatusCountOverflow -> 2 + AbiStatusBufferTooSmall -> 3 + AbiStatusGeometryObstruction -> 4 + AbiStatusRuntimeFailure -> 5 + +abiStatusSymbol :: AbiStatus -> String +abiStatusSymbol status = + case status of + AbiStatusOk -> "ML_STATUS_OK" + AbiStatusNullPointer -> "ML_STATUS_NULL_POINTER" + AbiStatusCountOverflow -> "ML_STATUS_COUNT_OVERFLOW" + AbiStatusBufferTooSmall -> "ML_STATUS_BUFFER_TOO_SMALL" + AbiStatusGeometryObstruction -> "ML_STATUS_GEOMETRY_OBSTRUCTION" + AbiStatusRuntimeFailure -> "ML_STATUS_RUNTIME_FAILURE" + +data ObstructionCode + = ObstructionNone + | ObstructionInvalidCoordinate + | ObstructionPointLocationFailed + | ObstructionLocationWalkExhausted + | ObstructionRefinementInputTopologyInvalid + | ObstructionFreshInsertionMatchedExistingVertex + | ObstructionDegenerateLineEndpointMissingOutgoing + | ObstructionDegenerateLineEndpointTurnMissing + | ObstructionDegenerateLineConnectedVertexMissing + | ObstructionHullStartNotVisible + | ObstructionOuterRangeDidNotTerminate + | ObstructionOuterRangeContainsInnerEdge + | ObstructionConstrainedEdgeFlipRefused + | ObstructionRemovalVertexOutOfRange + | ObstructionRemovalEdgeOutOfRange + | ObstructionRemovalFaceOutOfRange + | ObstructionRemovalFaceCycleDidNotTerminate + | ObstructionRemovalEmptyTriangulation + | ObstructionRemovalTwoPointDegreeMismatch + | ObstructionRemovalCollinearDegreeMismatch + | ObstructionRemovalBorderTooShort + | ObstructionRemovalBorderArityMismatch + | ObstructionRemovalOutgoingCycleDidNotTerminate + | ObstructionCircleSweepHullEmpty + | ObstructionOuterCycleDidNotTerminate + | ObstructionHierarchyLevelPopulationMismatch + | ObstructionHierarchyInsertionHandleMismatch + | ObstructionPointIndexCapacityExhausted + | ObstructionRefinementMinimumAngleNotFinite + | ObstructionRefinementMinimumAngleOutOfRange + | ObstructionRefinementMinimumAngleDerivedRatioNotFinite + | ObstructionRefinementMaximumAdditionalVerticesNegative + | ObstructionRefinementMinimumAreaNotFinite + | ObstructionRefinementMinimumAreaNegative + | ObstructionRefinementMaximumAreaNotFinite + | ObstructionRefinementMaximumAreaNotPositive + | ObstructionRefinementMaximumRadiusEdgeRatioNotFinite + | ObstructionRefinementMaximumRadiusEdgeRatioNotPositive + | ObstructionRefinementMinimumAreaExceedsMaximum + | ObstructionRefinementSeedFaceNotActive + | ObstructionRefinementDomainInterfaceEdgeNotActive + | ObstructionRefinementDomainInterfaceMissing + | ObstructionRefinementDomainInterfaceExtraneous + | ObstructionRefinementDomainTopologyChanged + | ObstructionRefinementDomainRequiresConvexHullPreservation + | ObstructionRefinementDomainRequiresConstraintPreservation + | ObstructionRefinementDomainForbidsOuterFaceExclusion + | ObstructionRefinementDomainWouldCrossInterface + | ObstructionRefinementDomainWouldRewriteProtectedFace + | ObstructionRefinementDomainProtectedFaceChanged + | ObstructionCapacityExceeded + | ObstructionHalfEdgeCapacityExceeded + | ObstructionFaceCapacityExceeded + | ObstructionPayloadStorageFailure + | ObstructionCoordinatePayloadCountMismatch + | ObstructionCircleSweepRequiresDenseStorage + | ObstructionSeamFrontierUnavailable + | ObstructionRefinementDomainRequiresFiniteVertexBudget + | ObstructionSeamSourceEdgeRequiresFlip + | ObstructionSeamProtectedSourceFaceChanged + | ObstructionRefinementMaximumEdgeLengthNotFinite + | ObstructionRefinementMaximumEdgeLengthNotPositive + | ObstructionRefinementOversizedEdge + | ObstructionRefinementSeamBridgeBudgetExceeded + | ObstructionRefinementSeamBridgeMidpointCollapsed + | ObstructionBoundarySplitRequiresBoundaryEdge + | ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted + | ObstructionNullPointer + | ObstructionCountOverflow + | ObstructionBufferTooSmall + | ObstructionRuntimeFailure + | ObstructionRegionLayoutInvalid + | ObstructionRegionValidationFailed + | ObstructionOverlayFailed + | ObstructionRegionPublicationFailed + | ObstructionValuationFailed + | ObstructionMinkowskiFailed + | ObstructionRegionProjectionFailed + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allObstructionCodes :: [ObstructionCode] +allObstructionCodes = [minBound .. maxBound] + +obstructionCodeId :: ObstructionCode -> Word32 +obstructionCodeId code = fst (obstructionCodeMetadata code) + +obstructionCodeSymbol :: ObstructionCode -> String +obstructionCodeSymbol code = snd (obstructionCodeMetadata code) + +obstructionCodeMetadata :: ObstructionCode -> (Word32, String) +obstructionCodeMetadata code = + case code of + ObstructionNone -> (0, "ML_OBSTRUCTION_NONE") + ObstructionInvalidCoordinate -> (1, "ML_OBSTRUCTION_INVALID_COORDINATE") + ObstructionPointLocationFailed -> (2, "ML_OBSTRUCTION_POINT_LOCATION_FAILED") + ObstructionLocationWalkExhausted -> (3, "ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED") + ObstructionRefinementInputTopologyInvalid -> (4, "ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID") + ObstructionFreshInsertionMatchedExistingVertex -> (5, "ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX") + ObstructionDegenerateLineEndpointMissingOutgoing -> (6, "ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING") + ObstructionDegenerateLineEndpointTurnMissing -> (7, "ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING") + ObstructionDegenerateLineConnectedVertexMissing -> (8, "ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING") + ObstructionHullStartNotVisible -> (9, "ML_OBSTRUCTION_HULL_START_NOT_VISIBLE") + ObstructionOuterRangeDidNotTerminate -> (10, "ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE") + ObstructionOuterRangeContainsInnerEdge -> (11, "ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE") + ObstructionConstrainedEdgeFlipRefused -> (12, "ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED") + ObstructionRemovalVertexOutOfRange -> (13, "ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE") + ObstructionRemovalEdgeOutOfRange -> (14, "ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE") + ObstructionRemovalFaceOutOfRange -> (15, "ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE") + ObstructionRemovalFaceCycleDidNotTerminate -> (16, "ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE") + ObstructionRemovalEmptyTriangulation -> (17, "ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION") + ObstructionRemovalTwoPointDegreeMismatch -> (18, "ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH") + ObstructionRemovalCollinearDegreeMismatch -> (19, "ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH") + ObstructionRemovalBorderTooShort -> (20, "ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT") + ObstructionRemovalBorderArityMismatch -> (21, "ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH") + ObstructionRemovalOutgoingCycleDidNotTerminate -> (22, "ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE") + ObstructionCircleSweepHullEmpty -> (23, "ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY") + ObstructionOuterCycleDidNotTerminate -> (24, "ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE") + ObstructionHierarchyLevelPopulationMismatch -> (25, "ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH") + ObstructionHierarchyInsertionHandleMismatch -> (26, "ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH") + ObstructionPointIndexCapacityExhausted -> (27, "ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED") + ObstructionRefinementMinimumAngleNotFinite -> (28, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE") + ObstructionRefinementMinimumAngleOutOfRange -> (29, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE") + ObstructionRefinementMinimumAngleDerivedRatioNotFinite -> (30, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE") + ObstructionRefinementMaximumAdditionalVerticesNegative -> (31, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE") + ObstructionRefinementMinimumAreaNotFinite -> (32, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE") + ObstructionRefinementMinimumAreaNegative -> (33, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE") + ObstructionRefinementMaximumAreaNotFinite -> (34, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE") + ObstructionRefinementMaximumAreaNotPositive -> (35, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE") + ObstructionRefinementMaximumRadiusEdgeRatioNotFinite -> (36, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE") + ObstructionRefinementMaximumRadiusEdgeRatioNotPositive -> (37, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE") + ObstructionRefinementMinimumAreaExceedsMaximum -> (38, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM") + ObstructionRefinementSeedFaceNotActive -> (39, "ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE") + ObstructionRefinementDomainInterfaceEdgeNotActive -> (40, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE") + ObstructionRefinementDomainInterfaceMissing -> (41, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING") + ObstructionRefinementDomainInterfaceExtraneous -> (42, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS") + ObstructionRefinementDomainTopologyChanged -> (43, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED") + ObstructionRefinementDomainRequiresConvexHullPreservation -> (44, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION") + ObstructionRefinementDomainRequiresConstraintPreservation -> (45, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION") + ObstructionRefinementDomainForbidsOuterFaceExclusion -> (46, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION") + ObstructionRefinementDomainWouldCrossInterface -> (47, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE") + ObstructionRefinementDomainWouldRewriteProtectedFace -> (48, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE") + ObstructionRefinementDomainProtectedFaceChanged -> (49, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED") + ObstructionCapacityExceeded -> (50, "ML_OBSTRUCTION_CAPACITY_EXCEEDED") + ObstructionHalfEdgeCapacityExceeded -> (51, "ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED") + ObstructionFaceCapacityExceeded -> (52, "ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED") + ObstructionPayloadStorageFailure -> (53, "ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE") + ObstructionCoordinatePayloadCountMismatch -> (54, "ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH") + ObstructionCircleSweepRequiresDenseStorage -> (55, "ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE") + ObstructionSeamFrontierUnavailable -> (56, "ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE") + ObstructionRefinementDomainRequiresFiniteVertexBudget -> (57, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET") + ObstructionSeamSourceEdgeRequiresFlip -> (58, "ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP") + ObstructionSeamProtectedSourceFaceChanged -> (59, "ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED") + ObstructionRefinementMaximumEdgeLengthNotFinite -> (60, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE") + ObstructionRefinementMaximumEdgeLengthNotPositive -> (61, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE") + ObstructionRefinementOversizedEdge -> (62, "ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE") + ObstructionRefinementSeamBridgeBudgetExceeded -> (63, "ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED") + ObstructionRefinementSeamBridgeMidpointCollapsed -> (64, "ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED") + ObstructionBoundarySplitRequiresBoundaryEdge -> (65, "ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE") + ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted -> (66, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED") + ObstructionNullPointer -> (100, "ML_OBSTRUCTION_NULL_POINTER") + ObstructionCountOverflow -> (101, "ML_OBSTRUCTION_COUNT_OVERFLOW") + ObstructionBufferTooSmall -> (102, "ML_OBSTRUCTION_BUFFER_TOO_SMALL") + ObstructionRuntimeFailure -> (103, "ML_OBSTRUCTION_RUNTIME_FAILURE") + ObstructionRegionLayoutInvalid -> (200, "ML_OBSTRUCTION_REGION_LAYOUT_INVALID") + ObstructionRegionValidationFailed -> (201, "ML_OBSTRUCTION_REGION_VALIDATION_FAILED") + ObstructionOverlayFailed -> (202, "ML_OBSTRUCTION_OVERLAY_FAILED") + ObstructionRegionPublicationFailed -> (203, "ML_OBSTRUCTION_REGION_PUBLICATION_FAILED") + ObstructionValuationFailed -> (204, "ML_OBSTRUCTION_VALUATION_FAILED") + ObstructionMinkowskiFailed -> (205, "ML_OBSTRUCTION_MINKOWSKI_FAILED") + ObstructionRegionProjectionFailed -> (206, "ML_OBSTRUCTION_REGION_PROJECTION_FAILED") + +data CoordinateErrorCode + = CoordinateErrorNone + | CoordinateErrorNaN + | CoordinateErrorInfinite + | CoordinateErrorTooSmall + | CoordinateErrorTooLarge + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allCoordinateErrorCodes :: [CoordinateErrorCode] +allCoordinateErrorCodes = [minBound .. maxBound] + +coordinateErrorCodeId :: CoordinateErrorCode -> Word32 +coordinateErrorCodeId code = + case code of + CoordinateErrorNone -> 0 + CoordinateErrorNaN -> 1 + CoordinateErrorInfinite -> 2 + CoordinateErrorTooSmall -> 3 + CoordinateErrorTooLarge -> 4 + +coordinateErrorCodeSymbol :: CoordinateErrorCode -> String +coordinateErrorCodeSymbol code = + case code of + CoordinateErrorNone -> "ML_COORDINATE_ERROR_NONE" + CoordinateErrorNaN -> "ML_COORDINATE_ERROR_NAN" + CoordinateErrorInfinite -> "ML_COORDINATE_ERROR_INFINITE" + CoordinateErrorTooSmall -> "ML_COORDINATE_ERROR_TOO_SMALL" + CoordinateErrorTooLarge -> "ML_COORDINATE_ERROR_TOO_LARGE" + +data RegionLocationCode + = RegionLocationExterior + | RegionLocationBoundary + | RegionLocationInterior + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allRegionLocationCodes :: [RegionLocationCode] +allRegionLocationCodes = [minBound .. maxBound] + +regionLocationCodeId :: RegionLocationCode -> Word32 +regionLocationCodeId code = + case code of + RegionLocationExterior -> 0 + RegionLocationBoundary -> 1 + RegionLocationInterior -> 2 + +regionLocationCodeSymbol :: RegionLocationCode -> String +regionLocationCodeSymbol code = + case code of + RegionLocationExterior -> "ML_REGION_EXTERIOR" + RegionLocationBoundary -> "ML_REGION_BOUNDARY" + RegionLocationInterior -> "ML_REGION_INTERIOR" + +data MinkowskiOperationCode + = MinkowskiOperationAddition + | MinkowskiOperationErosion + | MinkowskiOperationOpening + | MinkowskiOperationClosing + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allMinkowskiOperationCodes :: [MinkowskiOperationCode] +allMinkowskiOperationCodes = [minBound .. maxBound] + +minkowskiOperationCodeId :: MinkowskiOperationCode -> Word32 +minkowskiOperationCodeId code = + case code of + MinkowskiOperationAddition -> 0 + MinkowskiOperationErosion -> 1 + MinkowskiOperationOpening -> 2 + MinkowskiOperationClosing -> 3 + +minkowskiOperationCodeSymbol :: MinkowskiOperationCode -> String +minkowskiOperationCodeSymbol code = + case code of + MinkowskiOperationAddition -> "ML_MINKOWSKI_ADDITION" + MinkowskiOperationErosion -> "ML_MINKOWSKI_EROSION" + MinkowskiOperationOpening -> "ML_MINKOWSKI_OPENING" + MinkowskiOperationClosing -> "ML_MINKOWSKI_CLOSING" + +data CMesh +data CRegion +data CStructuringElement + +data CObstruction = CObstruction + { obstructionCode :: !Word32 + , obstructionCoordinateError :: !Word32 + , obstructionInputIndex :: !Word64 + , obstructionFirstIndex :: !Word64 + , obstructionSecondIndex :: !Word64 + , obstructionFirstValue :: !Double + , obstructionSecondValue :: !Double + , obstructionPointX :: !Double + , obstructionPointY :: !Double + , obstructionMessage :: !String + } + deriving stock (Eq, Show, Generic) + +instance Storable CObstruction where + sizeOf _ = 320 + alignment _ = alignment (0 :: Word64) + peek pointer = do + obstructionCode <- peekByteOff pointer 0 + obstructionCoordinateError <- peekByteOff pointer 4 + obstructionInputIndex <- peekByteOff pointer 8 + obstructionFirstIndex <- peekByteOff pointer 16 + obstructionSecondIndex <- peekByteOff pointer 24 + obstructionFirstValue <- peekByteOff pointer 32 + obstructionSecondValue <- peekByteOff pointer 40 + obstructionPointX <- peekByteOff pointer 48 + obstructionPointY <- peekByteOff pointer 56 + obstructionMessage <- peekCString (castPtr pointer `plusPtr` 64) + pure CObstruction {..} + poke pointer CObstruction {..} = do + pokeByteOff pointer 0 obstructionCode + pokeByteOff pointer 4 obstructionCoordinateError + pokeByteOff pointer 8 obstructionInputIndex + pokeByteOff pointer 16 obstructionFirstIndex + pokeByteOff pointer 24 obstructionSecondIndex + pokeByteOff pointer 32 obstructionFirstValue + pokeByteOff pointer 40 obstructionSecondValue + pokeByteOff pointer 48 obstructionPointX + pokeByteOff pointer 56 obstructionPointY + let messagePointer = castPtr pointer `plusPtr` 64 :: Ptr CChar + fillBytes messagePointer 0 256 + withCStringLen obstructionMessage $ \(source, lengthInBytes) -> + copyBytes messagePointer source (min 255 lengthInBytes) + +data CMinkowskiReceipt = CMinkowskiReceipt + { receiptOperation :: !Word32 + , receiptInputComponents :: !Word64 + , receiptConvexPieces :: !Word64 + , receiptGeneratedPieces :: !Word64 + , receiptGeneratedConvolutionEdges :: !Word64 + , receiptOverlayPasses :: !Word64 + , receiptExactCrossings :: !Word64 + , receiptOutputCells :: !Word64 + , receiptExactCoordinateBitGrowth :: !Word64 + } + deriving stock (Eq, Show, Generic) + +instance Storable CMinkowskiReceipt where + sizeOf _ = 72 + alignment _ = alignment (0 :: Word64) + peek pointer = do + receiptOperation <- peekByteOff pointer 0 + receiptInputComponents <- peekByteOff pointer 8 + receiptConvexPieces <- peekByteOff pointer 16 + receiptGeneratedPieces <- peekByteOff pointer 24 + receiptGeneratedConvolutionEdges <- peekByteOff pointer 32 + receiptOverlayPasses <- peekByteOff pointer 40 + receiptExactCrossings <- peekByteOff pointer 48 + receiptOutputCells <- peekByteOff pointer 56 + receiptExactCoordinateBitGrowth <- peekByteOff pointer 64 + pure CMinkowskiReceipt {..} + poke pointer CMinkowskiReceipt {..} = do + pokeByteOff pointer 0 receiptOperation + pokeByteOff pointer 4 (0 :: Word32) + pokeByteOff pointer 8 receiptInputComponents + pokeByteOff pointer 16 receiptConvexPieces + pokeByteOff pointer 24 receiptGeneratedPieces + pokeByteOff pointer 32 receiptGeneratedConvolutionEdges + pokeByteOff pointer 40 receiptOverlayPasses + pokeByteOff pointer 48 receiptExactCrossings + pokeByteOff pointer 56 receiptOutputCells + pokeByteOff pointer 64 receiptExactCoordinateBitGrowth + +data AbiFieldType + = AbiFieldUInt32 + | AbiFieldUInt64 + | AbiFieldDouble + | AbiFieldCharArray !Int + deriving stock (Eq, Show, Generic) + +data AbiField = AbiField + { abiFieldName :: !String + , abiFieldType :: !AbiFieldType + } + deriving stock (Eq, Show, Generic) + +data AbiStruct + = AbiStructObstruction + | AbiStructMinkowskiReceipt + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allAbiStructs :: [AbiStruct] +allAbiStructs = [minBound .. maxBound] + +abiStructSymbol :: AbiStruct -> String +abiStructSymbol structure = + case structure of + AbiStructObstruction -> "ml_obstruction" + AbiStructMinkowskiReceipt -> "ml_minkowski_receipt" + +abiStructFields :: AbiStruct -> [AbiField] +abiStructFields structure = + case structure of + AbiStructObstruction -> + [ AbiField "code" AbiFieldUInt32 + , AbiField "coordinate_error" AbiFieldUInt32 + , AbiField "input_index" AbiFieldUInt64 + , AbiField "first_index" AbiFieldUInt64 + , AbiField "second_index" AbiFieldUInt64 + , AbiField "first_value" AbiFieldDouble + , AbiField "second_value" AbiFieldDouble + , AbiField "point_x" AbiFieldDouble + , AbiField "point_y" AbiFieldDouble + , AbiField "message" (AbiFieldCharArray 256) + ] + AbiStructMinkowskiReceipt -> + [ AbiField "operation" AbiFieldUInt32 + , AbiField "reserved" AbiFieldUInt32 + , AbiField "input_components" AbiFieldUInt64 + , AbiField "convex_pieces" AbiFieldUInt64 + , AbiField "generated_pieces" AbiFieldUInt64 + , AbiField "generated_convolution_edges" AbiFieldUInt64 + , AbiField "overlay_passes" AbiFieldUInt64 + , AbiField "exact_crossings" AbiFieldUInt64 + , AbiField "output_cells" AbiFieldUInt64 + , AbiField "exact_coordinate_bit_growth" AbiFieldUInt64 + ] + +data AbiHandle + = AbiMesh + | AbiRegion + | AbiStructuringElement + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +allAbiHandles :: [AbiHandle] +allAbiHandles = [minBound .. maxBound] + +abiHandleSymbol :: AbiHandle -> String +abiHandleSymbol handle = + case handle of + AbiMesh -> "ml_mesh" + AbiRegion -> "ml_region" + AbiStructuringElement -> "ml_structuring_element" + +data AbiParameterKind + = AbiValueSize + | AbiValueDouble + | AbiHandleInput !AbiHandle + | AbiHandleRelease !AbiHandle + | AbiHandleOutput !AbiHandle + | AbiBufferInputDouble + | AbiBufferInputSize + | AbiBufferOutputChar + | AbiBufferOutputDouble + | AbiBufferOutputUInt32 + | AbiBufferOutputSize + | AbiScalarOutputRegionLocation + | AbiScalarOutputInt64 + | AbiScalarOutputSize + | AbiScalarOutputDouble + | AbiStructOutput !AbiStruct + deriving stock (Eq, Show, Generic) + +data AbiParameter = AbiParameter + { abiParameterName :: !String + , abiParameterKind :: !AbiParameterKind + } + deriving stock (Eq, Show, Generic) + +data AbiResult + = AbiResultVoid + | AbiResultUInt32 + | AbiResultStatus + deriving stock (Eq, Show, Generic) + +data AbiFunctionFamily + = AbiFunctionMesh + | AbiFunctionRegion + | AbiFunctionMorphology + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +data AbiFunctionImplementation + = AbiFunctionRuntime + | AbiFunctionHaskell !AbiFunctionFamily !String + deriving stock (Eq, Show, Generic) + +data AbiFunctionName + = AbiVersion + | RuntimeInitialize + | DelaunayF64 + | MeshInsertManyF64 + | MeshSiteUnion + | MeshSiteIntersection + | MeshSiteDifference + | MeshSiteSymmetricDifference + | MeshVertexCount + | MeshTriangleCount + | MeshCopyVerticesF64 + | MeshCopyTrianglesU32 + | MeshFree + | RegionCreateF64 + | RegionCounts + | RegionCopyF64 + | RegionUnion + | RegionIntersection + | RegionDifference + | RegionSymmetricDifference + | RegionLocatePointF64 + | RegionMeasure + | RegionFree + | StructuringElementCreateF64 + | StructuringElementFree + | RegionMinkowskiSum + | RegionOffset + | RegionInset + | RegionOpen + | RegionClose + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +data AbiFunction = AbiFunction + { abiFunctionImplementation :: !AbiFunctionImplementation + , abiFunctionSymbol :: !String + , abiFunctionResult :: !AbiResult + , abiFunctionParameters :: ![AbiParameter] + } + deriving stock (Eq, Show, Generic) + +allAbiFunctionNames :: [AbiFunctionName] +allAbiFunctionNames = [minBound .. maxBound] + +allAbiFunctions :: [AbiFunction] +allAbiFunctions = fmap abiFunction allAbiFunctionNames + +abiFunction :: AbiFunctionName -> AbiFunction +abiFunction name = + case name of + AbiVersion -> runtime "ml_abi_version" AbiResultUInt32 [] + RuntimeInitialize -> runtime "ml_runtime_initialize" AbiResultStatus [] + DelaunayF64 -> mesh "ml_delaunay_f64" "delaunayF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiMesh, obstruction] + MeshInsertManyF64 -> mesh "ml_mesh_insert_many_f64" "meshInsertManyF64" AbiResultStatus [inputHandle "mesh" AbiMesh, inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiMesh, obstruction] + MeshSiteUnion -> binaryMesh "ml_mesh_site_union" "meshSiteUnion" + MeshSiteIntersection -> binaryMesh "ml_mesh_site_intersection" "meshSiteIntersection" + MeshSiteDifference -> binaryMesh "ml_mesh_site_difference" "meshSiteDifference" + MeshSiteSymmetricDifference -> binaryMesh "ml_mesh_site_symmetric_difference" "meshSiteSymmetricDifference" + MeshVertexCount -> meshCount "ml_mesh_vertex_count" "meshVertexCount" + MeshTriangleCount -> meshCount "ml_mesh_triangle_count" "meshTriangleCount" + MeshCopyVerticesF64 -> mesh "ml_mesh_copy_vertices_f64" "meshCopyVerticesF64" AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "coordinates" AbiBufferOutputDouble, valueSize "point_capacity", AbiParameter "points_written" AbiScalarOutputSize, obstruction] + MeshCopyTrianglesU32 -> mesh "ml_mesh_copy_triangles_u32" "meshCopyTrianglesU32" AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "triangles" AbiBufferOutputUInt32, valueSize "triangle_capacity", AbiParameter "triangles_written" AbiScalarOutputSize, obstruction] + MeshFree -> mesh "ml_mesh_free" "meshFree" AbiResultVoid [releaseHandle "mesh" AbiMesh] + RegionCreateF64 -> region "ml_region_create_f64" "regionCreateF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", AbiParameter "loop_point_counts" AbiBufferInputSize, valueSize "loop_count", AbiParameter "component_loop_counts" AbiBufferInputSize, valueSize "component_count", outputHandle "result" AbiRegion, obstruction] + RegionCounts -> region "ml_region_counts" "regionCounts" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "component_count" AbiScalarOutputSize, AbiParameter "loop_count" AbiScalarOutputSize, AbiParameter "point_count" AbiScalarOutputSize, obstruction] + RegionCopyF64 -> region "ml_region_copy_f64" "regionCopyF64" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "coordinates" AbiBufferOutputDouble, valueSize "point_capacity", AbiParameter "loop_point_offsets" AbiBufferOutputSize, valueSize "loop_offset_capacity", AbiParameter "component_loop_offsets" AbiBufferOutputSize, valueSize "component_offset_capacity", obstruction] + RegionUnion -> binaryRegion "ml_region_union" "regionUnion" + RegionIntersection -> binaryRegion "ml_region_intersection" "regionIntersection" + RegionDifference -> binaryRegion "ml_region_difference" "regionDifference" + RegionSymmetricDifference -> binaryRegion "ml_region_symmetric_difference" "regionSymmetricDifference" + RegionLocatePointF64 -> region "ml_region_locate_point_f64" "regionLocatePointF64" AbiResultStatus [inputHandle "region" AbiRegion, valueDouble "x", valueDouble "y", AbiParameter "location" AbiScalarOutputRegionLocation, obstruction] + RegionMeasure -> region "ml_region_measure" "regionMeasure" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "euler_characteristic" AbiScalarOutputInt64, AbiParameter "area_ratio_utf8" AbiBufferOutputChar, valueSize "area_capacity", AbiParameter "area_bytes_written" AbiScalarOutputSize, AbiParameter "perimeter_lower" AbiScalarOutputDouble, AbiParameter "perimeter_upper" AbiScalarOutputDouble, obstruction] + RegionFree -> region "ml_region_free" "regionFree" AbiResultVoid [releaseHandle "region" AbiRegion] + StructuringElementCreateF64 -> morphology "ml_structuring_element_create_f64" "structuringElementCreateF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiStructuringElement, obstruction] + StructuringElementFree -> morphology "ml_structuring_element_free" "structuringElementFree" AbiResultVoid [releaseHandle "element" AbiStructuringElement] + RegionMinkowskiSum -> morphologyOperation "ml_region_minkowski_sum" "regionMinkowskiSum" (inputHandle "left" AbiRegion) (inputHandle "right" AbiRegion) + RegionOffset -> morphologyOperation "ml_region_offset" "regionOffset" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion) + RegionInset -> morphologyOperation "ml_region_inset" "regionInset" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion) + RegionOpen -> morphologyOperation "ml_region_open" "regionOpen" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion) + RegionClose -> morphologyOperation "ml_region_close" "regionClose" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion) + where + runtime = AbiFunction AbiFunctionRuntime + implemented family symbol haskellName = + AbiFunction (AbiFunctionHaskell family haskellName) symbol + mesh = implemented AbiFunctionMesh + region = implemented AbiFunctionRegion + morphology = implemented AbiFunctionMorphology + binaryMesh symbol haskellName = + mesh symbol haskellName AbiResultStatus [inputHandle "left" AbiMesh, inputHandle "right" AbiMesh, outputHandle "result" AbiMesh, obstruction] + meshCount symbol haskellName = + mesh symbol haskellName AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "count" AbiScalarOutputSize, obstruction] + binaryRegion symbol haskellName = + region symbol haskellName AbiResultStatus [inputHandle "left" AbiRegion, inputHandle "right" AbiRegion, outputHandle "result" AbiRegion, obstruction] + morphologyOperation symbol haskellName first second = + morphology symbol haskellName AbiResultStatus [first, second, outputHandle "result" AbiRegion, AbiParameter "receipt" (AbiStructOutput AbiStructMinkowskiReceipt), obstruction] + valueSize parameterName = AbiParameter parameterName AbiValueSize + valueDouble parameterName = AbiParameter parameterName AbiValueDouble + inputHandle parameterName handle = AbiParameter parameterName (AbiHandleInput handle) + releaseHandle parameterName handle = AbiParameter parameterName (AbiHandleRelease handle) + outputHandle parameterName handle = AbiParameter parameterName (AbiHandleOutput handle) + inputDoubles parameterName = AbiParameter parameterName AbiBufferInputDouble + obstruction = AbiParameter "obstruction" (AbiStructOutput AbiStructObstruction) diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Contract/Render.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Contract/Render.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Contract/Render.hs @@ -0,0 +1,763 @@ +module Moonlight.Triangulation.Foreign.Contract.Render + ( GeneratedFile (..) + , generatedFiles + , renderCHeader + , renderDefinitionFile + , renderHaskellExports + , renderPythonRaw + , renderRustRaw + , renderTypeScriptWire + , renderTypeScriptRaw + ) where + +import Data.Char (toLower, toUpper) +import Data.List (intercalate) +import Data.Maybe (mapMaybe) +import Data.Word (Word32) +import Moonlight.Triangulation.Foreign.Contract + +data GeneratedFile = GeneratedFile + { generatedFilePath :: !FilePath + , generatedFileContents :: !String + } + deriving stock (Eq, Show) + +generatedFiles :: [GeneratedFile] +generatedFiles = + [ GeneratedFile "ffi/include/moonlight_triangulation.h" renderCHeader + , GeneratedFile "ffi/cbits/moonlight-triangulation.def" renderDefinitionFile + , GeneratedFile "ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs" renderHaskellExports + , GeneratedFile "ffi/bindings/typescript/src/wire.generated.ts" renderTypeScriptWire + , GeneratedFile "ffi/bindings/typescript/src/internal/native.generated.ts" renderTypeScriptRaw + , GeneratedFile "ffi/bindings/python/src/moonlight_triangulation/_native_generated.py" renderPythonRaw + , GeneratedFile "ffi/bindings/rust/src/raw_generated.rs" renderRustRaw + ] + +generatedNotice :: String -> String +generatedNotice comment = + comment + <> " Generated from Moonlight.Triangulation.Foreign.Contract.\n" + <> comment + <> " Run moonlight-triangulation-ffi-contract write; do not edit this file.\n\n" + +renderCHeader :: String +renderCHeader = + generatedNotice "//" + <> unlines + [ "#ifndef MOONLIGHT_TRIANGULATION_H" + , "#define MOONLIGHT_TRIANGULATION_H" + , "" + , "#include " + , "#include " + , "" + , "#if defined(_WIN32)" + , "#define ML_API __declspec(dllexport)" + , "#else" + , "#define ML_API __attribute__((visibility(\"default\")))" + , "#endif" + , "" + , "#ifdef __cplusplus" + , "extern \"C\" {" + , "#endif" + , "" + , "#define ML_ABI_VERSION " <> show abiVersion <> "u" + , "" + , concatMap renderCOpaqueHandle allAbiHandles + , "typedef uint32_t ml_status;" + , "typedef uint32_t ml_obstruction_code;" + , "typedef uint32_t ml_coordinate_error;" + , "typedef uint32_t ml_region_location;" + , "typedef uint32_t ml_minkowski_operation;" + , "" + ] + <> renderCEnum (fmap (wireEntry abiStatusSymbol abiStatusId) allAbiStatuses) + <> renderCEnum (fmap (wireEntry obstructionCodeSymbol obstructionCodeId) allObstructionCodes) + <> renderCEnum (fmap (wireEntry coordinateErrorCodeSymbol coordinateErrorCodeId) allCoordinateErrorCodes) + <> renderCEnum (fmap (wireEntry regionLocationCodeSymbol regionLocationCodeId) allRegionLocationCodes) + <> renderCEnum (fmap (wireEntry minkowskiOperationCodeSymbol minkowskiOperationCodeId) allMinkowskiOperationCodes) + <> concatMap renderCStruct allAbiStructs + <> concatMap renderCFunction allAbiFunctions + <> unlines + [ "" + , "#ifdef __cplusplus" + , "}" + , "#endif" + , "" + , "#endif" + ] + +wireEntry :: (value -> String) -> (value -> Word32) -> value -> (String, Word32) +wireEntry symbol identifier value = (symbol value, identifier value) + +renderCEnum :: [(String, Word32)] -> String +renderCEnum entries = + "enum {\n" + <> intercalate ",\n" (fmap (\(symbol, identifier) -> " " <> symbol <> " = " <> show identifier) entries) + <> "\n};\n\n" + +renderCOpaqueHandle :: AbiHandle -> String +renderCOpaqueHandle handle = + "typedef struct " <> abiHandleSymbol handle <> " " <> abiHandleSymbol handle <> ";\n" + +renderCStruct :: AbiStruct -> String +renderCStruct structure = + "typedef struct " + <> abiStructSymbol structure + <> " {\n" + <> concatMap renderField (abiStructFields structure) + <> "} " + <> abiStructSymbol structure + <> ";\n\n" + where + renderField (AbiField name fieldType) = + " " <> cFieldType fieldType <> " " <> name <> cFieldSuffix fieldType <> ";\n" + +renderCFunction :: AbiFunction -> String +renderCFunction function = + "ML_API " + <> cResultType (abiFunctionResult function) + <> " " + <> abiFunctionSymbol function + <> "(" + <> renderParameters + <> ");\n" + where + parameters = abiFunctionParameters function + renderParameters = + if null parameters + then "void" + else intercalate ", " (fmap renderParameter parameters) + renderParameter (AbiParameter name kind) = cParameterType kind <> " " <> name + +cFieldType :: AbiFieldType -> String +cFieldType fieldType = + case fieldType of + AbiFieldUInt32 -> "uint32_t" + AbiFieldUInt64 -> "uint64_t" + AbiFieldDouble -> "double" + AbiFieldCharArray _ -> "char" + +cFieldSuffix :: AbiFieldType -> String +cFieldSuffix fieldType = + case fieldType of + AbiFieldCharArray lengthInBytes -> "[" <> show lengthInBytes <> "]" + _ -> "" + +cParameterType :: AbiParameterKind -> String +cParameterType kind = + case kind of + AbiValueSize -> "size_t" + AbiValueDouble -> "double" + AbiHandleInput handle -> "const " <> abiHandleSymbol handle <> " *" + AbiHandleRelease handle -> abiHandleSymbol handle <> " *" + AbiHandleOutput handle -> abiHandleSymbol handle <> " **" + AbiBufferInputDouble -> "const double *" + AbiBufferInputSize -> "const size_t *" + AbiBufferOutputChar -> "char *" + AbiBufferOutputDouble -> "double *" + AbiBufferOutputUInt32 -> "uint32_t *" + AbiBufferOutputSize -> "size_t *" + AbiScalarOutputRegionLocation -> "ml_region_location *" + AbiScalarOutputInt64 -> "int64_t *" + AbiScalarOutputSize -> "size_t *" + AbiScalarOutputDouble -> "double *" + AbiStructOutput structure -> abiStructSymbol structure <> " *" + +cResultType :: AbiResult -> String +cResultType result = + case result of + AbiResultVoid -> "void" + AbiResultUInt32 -> "uint32_t" + AbiResultStatus -> "ml_status" + +renderDefinitionFile :: String +renderDefinitionFile = + generatedNotice ";" + <> "LIBRARY moonlight-triangulation-c\nEXPORTS\n" + <> concatMap (\function -> " " <> abiFunctionSymbol function <> "\n") allAbiFunctions + +renderHaskellExports :: String +renderHaskellExports = + generatedNotice "--" + <> unlines + [ "{-# LANGUAGE ForeignFunctionInterface #-}" + , "{-# OPTIONS_GHC -Wno-missing-signatures #-}" + , "" + , "module Moonlight.Triangulation.Foreign.Exports where" + , "" + , "import Data.Int (Int64)" + , "import Data.Word (Word32)" + , "import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..))" + , "import Foreign.Ptr (Ptr)" + , "import Moonlight.Triangulation.Foreign.Contract" + , " ( CMesh" + , " , CMinkowskiReceipt" + , " , CObstruction" + , " , CRegion" + , " , CStructuringElement" + , " )" + , "import qualified Moonlight.Triangulation.Foreign.Mesh as Mesh" + , "import qualified Moonlight.Triangulation.Foreign.Morphology as Morphology" + , "import qualified Moonlight.Triangulation.Foreign.Region as Region" + , "" + ] + <> concatMap renderHaskellAlias implementedFunctions + <> "\n" + <> concatMap renderHaskellExport implementedFunctions + where + implementedFunctions :: [(AbiFunction, String, AbiFunctionFamily)] + implementedFunctions = mapMaybe implemented allAbiFunctions + + implemented :: AbiFunction -> Maybe (AbiFunction, String, AbiFunctionFamily) + implemented function = + case abiFunctionImplementation function of + AbiFunctionRuntime -> Nothing + AbiFunctionHaskell family haskellName -> Just (function, haskellName, family) + + renderHaskellAlias :: (AbiFunction, String, AbiFunctionFamily) -> String + renderHaskellAlias (_, haskellName, family) = + haskellName <> " = " <> familyQualifier family <> "." <> haskellName <> "\n" + + renderHaskellExport :: (AbiFunction, String, AbiFunctionFamily) -> String + renderHaskellExport (function, haskellName, _) = + "foreign export ccall \"" + <> abiFunctionSymbol function + <> "\" " + <> haskellName + <> " :: " + <> haskellFunctionType function + <> "\n" + +familyQualifier :: AbiFunctionFamily -> String +familyQualifier family = + case family of + AbiFunctionMesh -> "Mesh" + AbiFunctionRegion -> "Region" + AbiFunctionMorphology -> "Morphology" + +renderTypeScriptWire :: String +renderTypeScriptWire = + generatedNotice "//" + <> intercalate + "\n" + [ renderTypeScriptVocabulary "AbiStatus" "ML_STATUS_" abiStatusSymbol abiStatusId allAbiStatuses + , renderTypeScriptVocabulary "ObstructionCode" "ML_OBSTRUCTION_" obstructionCodeSymbol obstructionCodeId allObstructionCodes + , renderTypeScriptVocabulary "CoordinateError" "ML_COORDINATE_ERROR_" coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes + , renderTypeScriptVocabulary "RegionLocation" "ML_REGION_" regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes + , renderTypeScriptVocabulary "MinkowskiOperation" "ML_MINKOWSKI_" minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes + ] + +renderTypeScriptVocabulary + :: String + -> String + -> (value -> String) + -> (value -> Word32) + -> [value] + -> String +renderTypeScriptVocabulary typeName prefix symbol identifier values = + "export const " + <> typeName + <> " = {\n" + <> concatMap renderValue values + <> "} as const;\n" + <> "export type " + <> typeName + <> " = (typeof " + <> typeName + <> ")[keyof typeof " + <> typeName + <> "];\n" + <> "const " + <> lowerInitial typeName + <> "ByWire: Readonly typeName + <> ">> = {\n" + <> concatMap renderWireEntry values + <> "};\n" + <> "export function decode" + <> typeName + <> "(value: number): " + <> typeName + <> " | undefined {\n" + <> " return " + <> lowerInitial typeName + <> "ByWire[value];\n" + <> "}\n" + where + renderValue value = + " " <> wireKey prefix (symbol value) <> ": \"" <> wireValue prefix (symbol value) <> "\",\n" + renderWireEntry value = + " " <> show (identifier value) <> ": " <> typeName <> "." <> wireKey prefix (symbol value) <> ",\n" + +wireKey :: String -> String -> String +wireKey prefix = concatMap capitalize . underscoreWords . drop (length prefix) + +wireValue :: String -> String -> String +wireValue prefix = intercalate "-" . fmap (fmap toLower) . underscoreWords . drop (length prefix) + +underscoreWords :: String -> [String] +underscoreWords value = + case break (== '_') value of + (word, []) -> [word] + (word, _ : rest) -> word : underscoreWords rest + +capitalize :: String -> String +capitalize value = + case value of + [] -> [] + firstCharacter : rest -> toUpper firstCharacter : fmap toLower rest + +lowerInitial :: String -> String +lowerInitial value = + case value of + [] -> [] + firstCharacter : rest -> toLower firstCharacter : rest + +haskellFunctionType :: AbiFunction -> String +haskellFunctionType function = + intercalate " -> " (fmap (haskellParameterType . abiParameterKind) (abiFunctionParameters function) <> [haskellResultType (abiFunctionResult function)]) + +haskellParameterType :: AbiParameterKind -> String +haskellParameterType kind = + case kind of + AbiValueSize -> "CSize" + AbiValueDouble -> "CDouble" + AbiHandleInput handle -> "Ptr " <> haskellHandleName handle + AbiHandleRelease handle -> "Ptr " <> haskellHandleName handle + AbiHandleOutput handle -> "Ptr (Ptr " <> haskellHandleName handle <> ")" + AbiBufferInputDouble -> "Ptr CDouble" + AbiBufferInputSize -> "Ptr CSize" + AbiBufferOutputChar -> "Ptr CChar" + AbiBufferOutputDouble -> "Ptr CDouble" + AbiBufferOutputUInt32 -> "Ptr Word32" + AbiBufferOutputSize -> "Ptr CSize" + AbiScalarOutputRegionLocation -> "Ptr CUInt" + AbiScalarOutputInt64 -> "Ptr Int64" + AbiScalarOutputSize -> "Ptr CSize" + AbiScalarOutputDouble -> "Ptr CDouble" + AbiStructOutput structure -> "Ptr " <> haskellStructName structure + +haskellResultType :: AbiResult -> String +haskellResultType result = + case result of + AbiResultVoid -> "IO ()" + AbiResultUInt32 -> "IO CUInt" + AbiResultStatus -> "IO CUInt" + +haskellHandleName :: AbiHandle -> String +haskellHandleName handle = + case handle of + AbiMesh -> "CMesh" + AbiRegion -> "CRegion" + AbiStructuringElement -> "CStructuringElement" + +haskellStructName :: AbiStruct -> String +haskellStructName structure = + case structure of + AbiStructObstruction -> "CObstruction" + AbiStructMinkowskiReceipt -> "CMinkowskiReceipt" + +renderTypeScriptRaw :: String +renderTypeScriptRaw = + generatedNotice "//" + <> "import koffi from \"koffi\";\n\n" + <> "export const ABI_VERSION = " <> show abiVersion <> ";\n" + <> renderTypeScriptConstants abiStatusSymbol abiStatusId allAbiStatuses + <> renderTypeScriptConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes + <> renderTypeScriptConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes + <> renderTypeScriptConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes + <> renderTypeScriptConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes + <> "\nexport type NativeHandle = object;\n" + <> "export type NativeInteger = number | bigint;\n" + <> "export type HandleOutput = Array;\n\n" + <> renderTypeScriptStruct "NativeObstruction" AbiStructObstruction + <> renderTypeScriptStruct "NativeMinkowskiReceipt" AbiStructMinkowskiReceipt + <> "export interface NativeApi {\n" + <> concatMap renderTypeScriptFunctionType allAbiFunctions + <> "}\n\n" + <> unlines + [ "export function loadNativeApi(libraryPath: string): NativeApi {" + , " const library = koffi.load(libraryPath);" + , concatMap renderTypeScriptKoffiHandleDeclarations allAbiHandles + , renderTypeScriptKoffiStruct "obstruction" AbiStructObstruction + , renderTypeScriptKoffiStruct "receipt" AbiStructMinkowskiReceipt + , " const obstructionOutput = koffi.out(koffi.pointer(obstruction));" + , " const receiptOutput = koffi.out(koffi.pointer(receipt));" + , " const sizeOutput = koffi.out(koffi.pointer(\"size_t\"));" + , " const uint32Output = koffi.out(koffi.pointer(\"uint32_t\"));" + , " const int64Output = koffi.out(koffi.pointer(\"int64_t\"));" + , " const doubleOutput = koffi.out(koffi.pointer(\"double\"));" + , " const sizeArray = koffi.pointer(\"size_t\");" + , " return {" + ] + <> concatMap renderTypeScriptFunctionBinding allAbiFunctions + <> " };\n}\n" + +renderTypeScriptConstants :: (value -> String) -> (value -> Word32) -> [value] -> String +renderTypeScriptConstants symbol identifier = + concatMap (\value -> "export const " <> symbol value <> " = " <> show (identifier value) <> ";\n") + +renderTypeScriptStruct :: String -> AbiStruct -> String +renderTypeScriptStruct name structure = + "export interface " + <> name + <> " {\n" + <> concatMap renderField (abiStructFields structure) + <> "}\n\n" + where + renderField (AbiField fieldName fieldType) = + " " <> fieldName <> "?: " <> typeScriptFieldType fieldType <> ";\n" + +typeScriptFieldType :: AbiFieldType -> String +typeScriptFieldType fieldType = + case fieldType of + AbiFieldUInt32 -> "number" + AbiFieldUInt64 -> "NativeInteger" + AbiFieldDouble -> "number" + AbiFieldCharArray _ -> "string | readonly number[]" + +renderTypeScriptFunctionType :: AbiFunction -> String +renderTypeScriptFunctionType function = + " readonly " + <> abiFunctionSymbol function + <> ": (" + <> intercalate ", " (fmap renderParameter (abiFunctionParameters function)) + <> ") => " + <> typeScriptResultType (abiFunctionResult function) + <> ";\n" + where + renderParameter (AbiParameter name kind) = name <> ": " <> typeScriptParameterType kind + +typeScriptParameterType :: AbiParameterKind -> String +typeScriptParameterType kind = + case kind of + AbiValueSize -> "number" + AbiValueDouble -> "number" + AbiHandleInput _ -> "NativeHandle" + AbiHandleRelease _ -> "NativeHandle" + AbiHandleOutput _ -> "HandleOutput" + AbiBufferInputDouble -> "Float64Array" + AbiBufferInputSize -> "BigUint64Array" + AbiBufferOutputChar -> "Buffer" + AbiBufferOutputDouble -> "Float64Array" + AbiBufferOutputUInt32 -> "Uint32Array" + AbiBufferOutputSize -> "BigUint64Array" + AbiScalarOutputRegionLocation -> "number[]" + AbiScalarOutputInt64 -> "NativeInteger[]" + AbiScalarOutputSize -> "NativeInteger[]" + AbiScalarOutputDouble -> "number[]" + AbiStructOutput AbiStructObstruction -> "NativeObstruction" + AbiStructOutput AbiStructMinkowskiReceipt -> "NativeMinkowskiReceipt" + +typeScriptResultType :: AbiResult -> String +typeScriptResultType result = + case result of + AbiResultVoid -> "void" + AbiResultUInt32 -> "number" + AbiResultStatus -> "number" + +renderTypeScriptKoffiStruct :: String -> AbiStruct -> String +renderTypeScriptKoffiStruct variableName structure = + " const " + <> variableName + <> " = koffi.struct({\n" + <> concatMap renderField (abiStructFields structure) + <> " });" + where + renderField (AbiField name fieldType) = + " " <> name <> ": " <> typeScriptKoffiFieldType fieldType <> ",\n" + +typeScriptKoffiFieldType :: AbiFieldType -> String +typeScriptKoffiFieldType fieldType = + case fieldType of + AbiFieldUInt32 -> "\"uint32_t\"" + AbiFieldUInt64 -> "\"uint64_t\"" + AbiFieldDouble -> "\"double\"" + AbiFieldCharArray lengthInBytes -> "koffi.array(\"char\", " <> show lengthInBytes <> ")" + +renderTypeScriptFunctionBinding :: AbiFunction -> String +renderTypeScriptFunctionBinding function = + " " + <> abiFunctionSymbol function + <> ": library.func(\"" + <> abiFunctionSymbol function + <> "\", \"" + <> typeScriptKoffiResultType (abiFunctionResult function) + <> "\", [" + <> intercalate ", " (fmap (typeScriptKoffiParameterType . abiParameterKind) (abiFunctionParameters function)) + <> "]),\n" + +typeScriptKoffiResultType :: AbiResult -> String +typeScriptKoffiResultType result = + case result of + AbiResultVoid -> "void" + AbiResultUInt32 -> "uint32_t" + AbiResultStatus -> "uint32_t" + +typeScriptKoffiParameterType :: AbiParameterKind -> String +typeScriptKoffiParameterType kind = + case kind of + AbiValueSize -> "\"size_t\"" + AbiValueDouble -> "\"double\"" + AbiHandleInput handle -> typeScriptHandleVariable handle <> "Pointer" + AbiHandleRelease handle -> typeScriptHandleVariable handle <> "Pointer" + AbiHandleOutput handle -> typeScriptHandleVariable handle <> "Output" + AbiBufferInputDouble -> "koffi.pointer(\"double\")" + AbiBufferInputSize -> "sizeArray" + AbiBufferOutputChar -> "koffi.out(koffi.pointer(\"char\"))" + AbiBufferOutputDouble -> "koffi.out(koffi.pointer(\"double\"))" + AbiBufferOutputUInt32 -> "koffi.out(koffi.pointer(\"uint32_t\"))" + AbiBufferOutputSize -> "koffi.out(sizeArray)" + AbiScalarOutputRegionLocation -> "uint32Output" + AbiScalarOutputInt64 -> "int64Output" + AbiScalarOutputSize -> "sizeOutput" + AbiScalarOutputDouble -> "doubleOutput" + AbiStructOutput AbiStructObstruction -> "obstructionOutput" + AbiStructOutput AbiStructMinkowskiReceipt -> "receiptOutput" + +typeScriptHandleVariable :: AbiHandle -> String +typeScriptHandleVariable handle = + case handle of + AbiMesh -> "mesh" + AbiRegion -> "region" + AbiStructuringElement -> "structuringElement" + +renderTypeScriptKoffiHandleDeclarations :: AbiHandle -> String +renderTypeScriptKoffiHandleDeclarations handle = + let variableName = typeScriptHandleVariable handle + in unlines + [ " const " <> variableName <> " = koffi.opaque();" + , " const " <> variableName <> "Pointer = koffi.pointer(" <> variableName <> ");" + , " const " <> variableName <> "Output = koffi.out(koffi.pointer(" <> variableName <> ", 2));" + ] + +renderPythonRaw :: String +renderPythonRaw = + generatedNotice "#" + <> unlines + [ "from __future__ import annotations" + , "" + , "import ctypes" + , "from collections.abc import Sequence" + , "from pathlib import Path" + , "from typing import Final" + , "" + , "ABI_VERSION: Final = " <> show abiVersion + ] + <> renderPythonConstants abiStatusSymbol abiStatusId allAbiStatuses + <> renderPythonConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes + <> renderPythonConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes + <> renderPythonConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes + <> renderPythonConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes + <> "\n" + <> renderPythonStruct "_Obstruction" AbiStructObstruction + <> renderPythonStruct "_NativeMinkowskiReceipt" AbiStructMinkowskiReceipt + <> unlines + [ "class _NativeApi:" + , " def __init__(self, library_path: Path) -> None:" + , " library = ctypes.CDLL(str(library_path))" + ] + <> concatMap renderPythonConfiguration allAbiFunctions + <> unlines + [ " self.library = library" + , "" + , "" + , "def _configure(" + , " library: ctypes.CDLL," + , " name: str," + , " parameters: Sequence[object]," + , " result: object = ctypes.c_uint32," + , ") -> None:" + , " function = getattr(library, name)" + , " setattr(function, \"argtypes\", list(parameters))" + , " setattr(function, \"restype\", result)" + ] + +renderPythonConstants :: (value -> String) -> (value -> Word32) -> [value] -> String +renderPythonConstants symbol identifier = + concatMap (\value -> symbol value <> ": Final = " <> show (identifier value) <> "\n") + +renderPythonStruct :: String -> AbiStruct -> String +renderPythonStruct name structure = + "class " + <> name + <> "(ctypes.Structure):\n" + <> " _fields_ = [\n" + <> concatMap renderField (abiStructFields structure) + <> " ]\n\n\n" + where + renderField (AbiField fieldName fieldType) = + " (\"" <> fieldName <> "\", " <> pythonFieldType fieldType <> "),\n" + +pythonFieldType :: AbiFieldType -> String +pythonFieldType fieldType = + case fieldType of + AbiFieldUInt32 -> "ctypes.c_uint32" + AbiFieldUInt64 -> "ctypes.c_uint64" + AbiFieldDouble -> "ctypes.c_double" + AbiFieldCharArray lengthInBytes -> "ctypes.c_char * " <> show lengthInBytes + +renderPythonConfiguration :: AbiFunction -> String +renderPythonConfiguration function = + " _configure(library, \"" + <> abiFunctionSymbol function + <> "\", " + <> pythonTuple (fmap (pythonParameterType . abiParameterKind) (abiFunctionParameters function)) + <> ", " + <> pythonResultType (abiFunctionResult function) + <> ")\n" + +pythonTuple :: [String] -> String +pythonTuple values = + case values of + [] -> "()" + [value] -> "(" <> value <> ",)" + _ -> "(" <> intercalate ", " values <> ")" + +pythonParameterType :: AbiParameterKind -> String +pythonParameterType kind = + case kind of + AbiValueSize -> "ctypes.c_size_t" + AbiValueDouble -> "ctypes.c_double" + AbiHandleInput _ -> "ctypes.c_void_p" + AbiHandleRelease _ -> "ctypes.c_void_p" + AbiHandleOutput _ -> "ctypes.POINTER(ctypes.c_void_p)" + AbiBufferInputDouble -> "ctypes.POINTER(ctypes.c_double)" + AbiBufferInputSize -> "ctypes.POINTER(ctypes.c_size_t)" + AbiBufferOutputChar -> "ctypes.POINTER(ctypes.c_char)" + AbiBufferOutputDouble -> "ctypes.POINTER(ctypes.c_double)" + AbiBufferOutputUInt32 -> "ctypes.POINTER(ctypes.c_uint32)" + AbiBufferOutputSize -> "ctypes.POINTER(ctypes.c_size_t)" + AbiScalarOutputRegionLocation -> "ctypes.POINTER(ctypes.c_uint32)" + AbiScalarOutputInt64 -> "ctypes.POINTER(ctypes.c_int64)" + AbiScalarOutputSize -> "ctypes.POINTER(ctypes.c_size_t)" + AbiScalarOutputDouble -> "ctypes.POINTER(ctypes.c_double)" + AbiStructOutput AbiStructObstruction -> "ctypes.POINTER(_Obstruction)" + AbiStructOutput AbiStructMinkowskiReceipt -> "ctypes.POINTER(_NativeMinkowskiReceipt)" + +pythonResultType :: AbiResult -> String +pythonResultType result = + case result of + AbiResultVoid -> "None" + AbiResultUInt32 -> "ctypes.c_uint32" + AbiResultStatus -> "ctypes.c_uint32" + +renderRustRaw :: String +renderRustRaw = + generatedNotice "//" + <> "// This private module is the complete wire projection; wrappers consume a subset.\n" + <> "#![allow(dead_code)]\n\n" + <> "use std::ffi::{c_char, c_double, c_uint};\n\n" + <> "pub(crate) const ABI_VERSION: u32 = " <> show abiVersion <> ";\n" + <> renderRustConstants abiStatusSymbol abiStatusId allAbiStatuses + <> renderRustConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes + <> renderRustConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes + <> renderRustConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes + <> renderRustConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes + <> "\n" + <> concatMap renderRustHandle allAbiHandles + <> renderRustStruct "NativeObstruction" AbiStructObstruction + <> renderRustStruct "NativeMinkowskiReceipt" AbiStructMinkowskiReceipt + <> "#[link(name = \"moonlight-triangulation-c\")]\nunsafe extern \"C\" {\n" + <> concatMap renderRustFunction allAbiFunctions + <> "}\n" + +renderRustConstants :: (value -> String) -> (value -> Word32) -> [value] -> String +renderRustConstants symbol identifier = + concatMap (\value -> "pub(crate) const " <> symbol value <> ": u32 = " <> show (identifier value) <> ";\n") + +renderRustHandle :: AbiHandle -> String +renderRustHandle handle = + "#[repr(C)]\npub(crate) struct " + <> rustHandleName handle + <> " {\n _private: [u8; 0],\n}\n\n" + +renderRustStruct :: String -> AbiStruct -> String +renderRustStruct name structure = + "#[repr(C)]\npub(crate) struct " + <> name + <> " {\n" + <> concatMap renderField (abiStructFields structure) + <> "}\n\n" + <> "impl Default for " + <> name + <> " {\n" + <> " fn default() -> Self {\n" + <> " Self {\n" + <> concatMap renderDefaultField (abiStructFields structure) + <> " }\n" + <> " }\n" + <> "}\n\n" + where + renderField (AbiField fieldName fieldType) = + " pub(crate) " <> fieldName <> ": " <> rustFieldType fieldType <> ",\n" + renderDefaultField (AbiField fieldName fieldType) = + " " <> fieldName <> ": " <> rustFieldDefault fieldType <> ",\n" + +rustFieldType :: AbiFieldType -> String +rustFieldType fieldType = + case fieldType of + AbiFieldUInt32 -> "u32" + AbiFieldUInt64 -> "u64" + AbiFieldDouble -> "f64" + AbiFieldCharArray lengthInBytes -> "[c_char; " <> show lengthInBytes <> "]" + +rustFieldDefault :: AbiFieldType -> String +rustFieldDefault fieldType = + case fieldType of + AbiFieldUInt32 -> "0" + AbiFieldUInt64 -> "0" + AbiFieldDouble -> "0.0" + AbiFieldCharArray lengthInBytes -> "[0; " <> show lengthInBytes <> "]" + +renderRustFunction :: AbiFunction -> String +renderRustFunction function = + case abiFunctionParameters function of + [] -> declarationPrefix <> "()" <> resultSuffix <> ";\n" + [parameter] -> declarationPrefix <> "(" <> renderParameter parameter <> ")" <> resultSuffix <> ";\n" + parameters -> + declarationPrefix + <> "(\n" + <> concatMap (\parameter -> " " <> renderParameter parameter <> ",\n") parameters + <> " )" + <> resultSuffix + <> ";\n" + where + declarationPrefix = " pub(crate) fn " <> abiFunctionSymbol function + resultSuffix = rustResultSuffix (abiFunctionResult function) + renderParameter (AbiParameter name kind) = name <> ": " <> rustParameterType kind + +rustParameterType :: AbiParameterKind -> String +rustParameterType kind = + case kind of + AbiValueSize -> "usize" + AbiValueDouble -> "c_double" + AbiHandleInput handle -> "*const " <> rustHandleName handle + AbiHandleRelease handle -> "*mut " <> rustHandleName handle + AbiHandleOutput handle -> "*mut *mut " <> rustHandleName handle + AbiBufferInputDouble -> "*const c_double" + AbiBufferInputSize -> "*const usize" + AbiBufferOutputChar -> "*mut c_char" + AbiBufferOutputDouble -> "*mut c_double" + AbiBufferOutputUInt32 -> "*mut u32" + AbiBufferOutputSize -> "*mut usize" + AbiScalarOutputRegionLocation -> "*mut u32" + AbiScalarOutputInt64 -> "*mut i64" + AbiScalarOutputSize -> "*mut usize" + AbiScalarOutputDouble -> "*mut c_double" + AbiStructOutput AbiStructObstruction -> "*mut NativeObstruction" + AbiStructOutput AbiStructMinkowskiReceipt -> "*mut NativeMinkowskiReceipt" + +rustResultSuffix :: AbiResult -> String +rustResultSuffix result = + case result of + AbiResultVoid -> "" + AbiResultUInt32 -> " -> c_uint" + AbiResultStatus -> " -> c_uint" + +rustHandleName :: AbiHandle -> String +rustHandleName handle = + case handle of + AbiMesh -> "NativeMesh" + AbiRegion -> "NativeRegion" + AbiStructuringElement -> "NativeStructuringElement" diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Mesh.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Mesh.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Mesh.hs @@ -0,0 +1,178 @@ +module Moonlight.Triangulation.Foreign.Mesh + ( delaunayF64 + , insertGeometryBatch + , meshCopyTrianglesU32 + , meshCopyVerticesF64 + , meshFree + , meshInsertManyF64 + , meshSiteDifference + , meshSiteIntersection + , meshSiteSymmetricDifference + , meshSiteUnion + , meshTriangleCount + , meshVertexCount + ) where + +import Control.Monad (void) +import Data.Bifunctor (first) +import Data.Word (Word32) +import Foreign.C.Types (CDouble (..), CSize, CUInt) +import Foreign.Ptr (Ptr) +import Foreign.Storable (poke, pokeElemOff) +import qualified Data.Vector as V +import qualified Moonlight.Triangulation as T +import Moonlight.Triangulation.Foreign.Boundary + ( GeometryMesh + , HandleValue + , checkedCount + , dereferenceHandle + , freeHandle + , produceHandle + , readPoints + , requireOutputCapacity + , requirePointer + , runBoundary + ) +import Moonlight.Triangulation.Foreign.Contract (CMesh, CObstruction) +import Moonlight.Triangulation.Foreign.Obstruction (buildFailure) +import Moonlight.Triangulation.Math (validatePoint) +import qualified Moonlight.Triangulation.Session as Session + +delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +delaunayF64 coordinates rawCount output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case checkedCount 2 rawCount of + Left failure -> pure (Left failure) + Right count -> do + points <- readPoints coordinates count + pure (points >>= first buildFailure . T.delaunayGeometry) + +meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +meshInsertManyF64 meshPointer coordinates rawCount output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "mesh" meshPointer >> checkedCount 2 rawCount of + Left failure -> pure (Left failure) + Right count -> do + points <- readPoints coordinates count + case points of + Left failure -> pure (Left failure) + Right admitted -> do + mesh <- dereferenceHandle meshPointer + pure (first buildFailure (insertGeometryBatch mesh admitted)) + +-- | Admit the complete batch before opening the immutable insertion session. +insertGeometryBatch :: GeometryMesh -> V.Vector T.Point -> Either T.BuildError GeometryMesh +insertGeometryBatch mesh points = do + admittedPoints <- V.imapM (\index point -> validatePoint (Just index) point) points + (_, revised, _) <- + Session.withSession + mesh + (V.length points) + ( V.mapM_ + ( \point -> + void + ( Session.insertAdmittedVertexAtCombining + (\_ replacement -> replacement) + point + () + ) + ) + admittedPoints + ) + pure revised + +meshSiteUnion, meshSiteIntersection, meshSiteDifference, meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +meshSiteUnion = binaryMeshOperation T.union +meshSiteIntersection = binaryMeshOperation T.intersection +meshSiteDifference = binaryMeshOperation T.difference +meshSiteSymmetricDifference = binaryMeshOperation T.symmetricDifference + +binaryMeshOperation + :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh) + -> Ptr CMesh + -> Ptr CMesh + -> Ptr (Ptr CMesh) + -> Ptr CObstruction + -> IO CUInt +binaryMeshOperation operation leftPointer rightPointer output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "left mesh" leftPointer >> requirePointer "right mesh" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (first buildFailure (operation left right)) + +meshVertexCount, meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshVertexCount = handleCount "mesh" T.numVertices +meshTriangleCount = handleCount "mesh" (V.length . T.innerFaceVertexTriples) + +handleCount + :: String + -> (HandleValue carrier -> Int) + -> Ptr carrier + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +handleCount handleLabel observe handlePointer output obstructionPointer = + runBoundary obstructionPointer $ + case requirePointer handleLabel handlePointer >> requirePointer "count" output of + Left failure -> pure (Left failure) + Right () -> do + value <- dereferenceHandle handlePointer + poke output (fromIntegral (observe value)) + pure (Right ()) + +meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshCopyVerticesF64 = + copyHandleProjection + "mesh" + "points_written" + "coordinates" + T.vertexPoints + ( \output index (T.Point x y) -> do + pokeElemOff output (index * 2) (CDouble x) + pokeElemOff output (index * 2 + 1) (CDouble y) + ) + +meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshCopyTrianglesU32 = + copyHandleProjection + "mesh" + "triangles_written" + "triangles" + T.innerFaceVertexTriples + ( \output index (firstVertex, secondVertex, thirdVertex) -> do + pokeElemOff output (index * 3) (T.unVertexId firstVertex) + pokeElemOff output (index * 3 + 1) (T.unVertexId secondVertex) + pokeElemOff output (index * 3 + 2) (T.unVertexId thirdVertex) + ) + +copyHandleProjection + :: String + -> String + -> String + -> (HandleValue carrier -> V.Vector item) + -> (Ptr element -> Int -> item -> IO ()) + -> Ptr carrier + -> Ptr element + -> CSize + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +{-# INLINE copyHandleProjection #-} +copyHandleProjection handleLabel writtenLabel outputLabel project writeItem handlePointer output rawCapacity written obstructionPointer = + runBoundary obstructionPointer $ + case requirePointer handleLabel handlePointer >> requirePointer writtenLabel written >> checkedCount 1 rawCapacity of + Left failure -> pure (Left failure) + Right capacity -> do + value <- dereferenceHandle handlePointer + let items = project value + required = V.length items + poke written (fromIntegral required) + case requireOutputCapacity outputLabel output required capacity of + Left failure -> pure (Left failure) + Right () -> V.imapM_ (writeItem output) items >> pure (Right ()) + +meshFree :: Ptr CMesh -> IO () +meshFree = freeHandle diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Morphology.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Morphology.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Morphology.hs @@ -0,0 +1,160 @@ +module Moonlight.Triangulation.Foreign.Morphology + ( regionClose + , regionInset + , regionMinkowskiSum + , regionOffset + , regionOpen + , structuringElementCreateF64 + , structuringElementFree + ) where + +import Data.Bifunctor (first) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Word (Word32) +import Foreign.C.Types (CDouble, CSize, CUInt) +import Foreign.Ptr (Ptr) +import Foreign.Storable (poke) +import qualified Data.Vector as V +import qualified Moonlight.Triangulation as T +import Moonlight.Triangulation.Foreign.Boundary + ( checkedCount + , dereferenceHandle + , freeHandle + , prepareHandleOutput + , produceHandle + , publishHandle + , readPoints + , requirePointer + , runBoundary + ) +import Moonlight.Triangulation.Foreign.Contract + ( CMinkowskiReceipt (..) + , CObstruction + , CRegion + , CStructuringElement + , MinkowskiOperationCode (..) + , minkowskiOperationCodeId + ) +import Moonlight.Triangulation.Foreign.Obstruction + ( AbiFailure + , minkowskiFailure + , pointInputFailure + , structuringElementEmptyFailure + ) + +structuringElementCreateF64 + :: Ptr CDouble + -> CSize + -> Ptr (Ptr CStructuringElement) + -> Ptr CObstruction + -> IO CUInt +structuringElementCreateF64 coordinates rawPointCount output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case checkedCount 2 rawPointCount of + Left failure -> pure (Left failure) + Right pointCount -> do + points <- readPoints coordinates pointCount + pure (points >>= buildStructuringElement) + +buildStructuringElement + :: V.Vector T.Point + -> Either AbiFailure T.StructuringElement +buildStructuringElement points = do + exactPoints <- + V.imapM + (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point)) + points + submitted <- + maybe + (Left structuringElementEmptyFailure) + Right + (NonEmpty.nonEmpty (V.toList exactPoints)) + polygon <- first minkowskiFailure (T.convexPolygon submitted) + first minkowskiFailure (T.structuringElement polygon) + +structuringElementFree :: Ptr CStructuringElement -> IO () +structuringElementFree = freeHandle + +regionMinkowskiSum + :: Ptr CRegion + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> Ptr CObstruction + -> IO CUInt +regionMinkowskiSum leftPointer rightPointer output receiptOutput obstructionPointer = + runBoundary obstructionPointer $ + produceRegionWithReceipt output receiptOutput $ do + case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (first minkowskiFailure (T.minkowskiSum left right)) + +regionOffset, regionInset, regionOpen, regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +regionOffset = structuringElementOperation T.polygonOffset +regionInset = structuringElementOperation T.polygonInset +regionOpen = structuringElementOperation T.openWith +regionClose = structuringElementOperation T.closeWith + +structuringElementOperation + :: (T.StructuringElement -> T.PlanarRegion -> Either T.MinkowskiError (T.PlanarRegion, T.MinkowskiReceipt)) + -> Ptr CStructuringElement + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> Ptr CObstruction + -> IO CUInt +structuringElementOperation operation elementPointer regionPointer output receiptOutput obstructionPointer = + runBoundary obstructionPointer $ + produceRegionWithReceipt output receiptOutput $ do + case requirePointer "structuring element" elementPointer >> requirePointer "region" regionPointer of + Left failure -> pure (Left failure) + Right () -> do + element <- dereferenceHandle elementPointer + region <- dereferenceHandle regionPointer + pure (first minkowskiFailure (operation element region)) + +produceRegionWithReceipt + :: Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> IO (Either AbiFailure (T.PlanarRegion, T.MinkowskiReceipt)) + -> IO (Either AbiFailure ()) +produceRegionWithReceipt output receiptOutput obtain = do + prepared <- prepareHandleOutput output + case (prepared, requirePointer "receipt" receiptOutput) of + (Left failure, _) -> pure (Left failure) + (_, Left failure) -> pure (Left failure) + (Right (), Right ()) -> do + outcome <- obtain + case outcome of + Left failure -> pure (Left failure) + Right (region, receipt) -> do + poke receiptOutput (minkowskiReceiptProjection receipt) + publishHandle output region + pure (Right ()) + +minkowskiReceiptProjection :: T.MinkowskiReceipt -> CMinkowskiReceipt +minkowskiReceiptProjection receipt = + CMinkowskiReceipt + { receiptOperation = minkowskiOperationCode (T.minkowskiOperation receipt) + , receiptInputComponents = fromIntegral (T.minkowskiInputComponents receipt) + , receiptConvexPieces = fromIntegral (T.minkowskiConvexPieces receipt) + , receiptGeneratedPieces = fromIntegral (T.minkowskiGeneratedPieces receipt) + , receiptGeneratedConvolutionEdges = fromIntegral (T.minkowskiGeneratedConvolutionEdges receipt) + , receiptOverlayPasses = fromIntegral (T.minkowskiOverlayPasses receipt) + , receiptExactCrossings = fromIntegral (T.minkowskiExactCrossings receipt) + , receiptOutputCells = fromIntegral (T.minkowskiOutputCells receipt) + , receiptExactCoordinateBitGrowth = fromIntegral (T.minkowskiExactCoordinateBitGrowth receipt) + } + +minkowskiOperationCode :: T.MinkowskiOperation -> Word32 +minkowskiOperationCode operation = + minkowskiOperationCodeId + ( case operation of + T.MinkowskiAddition -> MinkowskiOperationAddition + T.MinkowskiErosion -> MinkowskiOperationErosion + T.MinkowskiOpening -> MinkowskiOperationOpening + T.MinkowskiClosing -> MinkowskiOperationClosing + ) diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Obstruction.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Obstruction.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Obstruction.hs @@ -0,0 +1,313 @@ +module Moonlight.Triangulation.Foreign.Obstruction + ( AbiFailure (..) + , RegionCountKind (..) + , RegionLayoutError (..) + , bufferTooSmallFailure + , buildFailure + , countOverflowFailure + , emptyObstruction + , minkowskiFailure + , nullPointerFailure + , overlayFailure + , pointInputFailure + , projectionFailure + , regionLayoutFailure + , regionPublicationFailure + , regionValidationFailure + , runtimeFailure + , statusOk + , structuringElementEmptyFailure + , valuationFailure + ) where + +import Control.Exception (SomeException, displayException) +import Data.Word (Word32, Word64) +import Foreign.C.Types (CUInt) +import Moonlight.Triangulation.Foreign.Contract +import qualified Moonlight.Triangulation as T + +data AbiFailure = AbiFailure !CUInt !CObstruction + +statusCode :: AbiStatus -> CUInt +statusCode = fromIntegral . abiStatusId + +statusOk :: CUInt +statusOk = statusCode AbiStatusOk + +emptyObstruction :: CObstruction +emptyObstruction = + CObstruction + { obstructionCode = obstructionCodeId ObstructionNone + , obstructionCoordinateError = coordinateErrorCodeId CoordinateErrorNone + , obstructionInputIndex = maxBound + , obstructionFirstIndex = 0 + , obstructionSecondIndex = 0 + , obstructionFirstValue = 0 + , obstructionSecondValue = 0 + , obstructionPointX = 0 + , obstructionPointY = 0 + , obstructionMessage = "" + } + +apiFailure :: AbiStatus -> ObstructionCode -> String -> AbiFailure +apiFailure status code message = + AbiFailure + (statusCode status) + emptyObstruction + { obstructionCode = obstructionCodeId code + , obstructionMessage = message + } + +geometryFailure :: Show obstruction => ObstructionCode -> obstruction -> AbiFailure +geometryFailure code obstruction = + apiFailure AbiStatusGeometryObstruction code (show obstruction) + +nullPointerFailure :: String -> AbiFailure +nullPointerFailure label = + apiFailure AbiStatusNullPointer ObstructionNullPointer (label <> " must not be null") + +countOverflowFailure :: Word64 -> AbiFailure +countOverflowFailure count = + AbiFailure + (statusCode AbiStatusCountOverflow) + emptyObstruction + { obstructionCode = obstructionCodeId ObstructionCountOverflow + , obstructionFirstIndex = count + , obstructionMessage = "count exceeds the host Int range" + } + +bufferTooSmallFailure :: Int -> Int -> AbiFailure +bufferTooSmallFailure required capacity = + AbiFailure + (statusCode AbiStatusBufferTooSmall) + emptyObstruction + { obstructionCode = obstructionCodeId ObstructionBufferTooSmall + , obstructionFirstIndex = fromIntegral required + , obstructionSecondIndex = fromIntegral capacity + , obstructionMessage = "output buffer is smaller than the required element count" + } + +runtimeFailure :: SomeException -> AbiFailure +runtimeFailure = apiFailure AbiStatusRuntimeFailure ObstructionRuntimeFailure . displayException + +buildFailure :: T.BuildError -> AbiFailure +buildFailure obstruction = + AbiFailure (statusCode AbiStatusGeometryObstruction) (buildErrorObstruction obstruction) + +data RegionCountKind + = LoopPointCounts + | ComponentLoopCounts + deriving stock (Eq, Show) + +data RegionLayoutError + = RegionGroupEmpty !RegionCountKind !Int + | RegionCountTotalMismatch !RegionCountKind !Integer !Integer + deriving stock (Eq, Show) + +regionLayoutFailure :: RegionLayoutError -> AbiFailure +regionLayoutFailure layoutError = + AbiFailure (statusCode AbiStatusGeometryObstruction) (layoutObstruction layoutError) + +layoutObstruction :: RegionLayoutError -> CObstruction +layoutObstruction layoutError = + ( case layoutError of + RegionCountTotalMismatch _ actual expected -> + base + { obstructionFirstIndex = fromIntegral actual + , obstructionSecondIndex = fromIntegral expected + } + RegionGroupEmpty _ index -> base {obstructionInputIndex = fromIntegral index} + ) + {obstructionMessage = show layoutError} + where + base = emptyObstruction {obstructionCode = obstructionCodeId ObstructionRegionLayoutInvalid} + +regionValidationFailure :: T.RegionValidationError -> AbiFailure +regionValidationFailure = geometryFailure ObstructionRegionValidationFailed + +overlayFailure :: T.OverlayError Bool Bool -> AbiFailure +overlayFailure = geometryFailure ObstructionOverlayFailed + +regionPublicationFailure :: T.RegionPublicationError -> AbiFailure +regionPublicationFailure = geometryFailure ObstructionRegionPublicationFailed + +valuationFailure :: T.ValuationError -> AbiFailure +valuationFailure = geometryFailure ObstructionValuationFailed + +minkowskiFailure :: T.MinkowskiError -> AbiFailure +minkowskiFailure = geometryFailure ObstructionMinkowskiFailed + +structuringElementEmptyFailure :: AbiFailure +structuringElementEmptyFailure = + apiFailure + AbiStatusGeometryObstruction + ObstructionRegionLayoutInvalid + "structuring element requires at least one point" + +pointInputFailure :: Int -> T.Point -> T.PointValidationError -> AbiFailure +pointInputFailure index (T.Point x y) pointError = + AbiFailure + (statusCode AbiStatusGeometryObstruction) + emptyObstruction + { obstructionCode = obstructionCodeId ObstructionInvalidCoordinate + , obstructionCoordinateError = coordinateErrorCode reason + , obstructionInputIndex = fromIntegral index + , obstructionFirstValue = invalidValue + , obstructionPointX = x + , obstructionPointY = y + , obstructionMessage = show pointError + } + where + (invalidValue, reason) = + case pointError of + T.InvalidPointX coordinateError -> (x, coordinateError) + T.InvalidPointY coordinateError -> (y, coordinateError) + +projectionFailure :: Int -> T.PointValidationError -> AbiFailure +projectionFailure index pointError = + AbiFailure + (statusCode AbiStatusGeometryObstruction) + emptyObstruction + { obstructionCode = obstructionCodeId ObstructionRegionProjectionFailed + , obstructionCoordinateError = + coordinateErrorCode + ( case pointError of + T.InvalidPointX coordinateError -> coordinateError + T.InvalidPointY coordinateError -> coordinateError + ) + , obstructionInputIndex = fromIntegral index + , obstructionMessage = show pointError + } + +buildErrorObstruction :: T.BuildError -> CObstruction +buildErrorObstruction failure = + ( case failure of + T.InvalidCoordinate inputIndex value reason -> + emptyObstruction + { obstructionCode = obstructionCodeId ObstructionInvalidCoordinate + , obstructionCoordinateError = coordinateErrorCode reason + , obstructionInputIndex = maybe maxBound fromIntegral inputIndex + , obstructionFirstValue = value + } + T.PointLocationFailed (T.Point x y) -> pointObstruction ObstructionPointLocationFailed x y + T.LocationWalkExhausted (T.Point x y) steps -> + (pointObstruction ObstructionLocationWalkExhausted x y) {obstructionFirstIndex = fromIntegral steps} + T.RefinementInputTopologyInvalid _ -> codeOnly ObstructionRefinementInputTopologyInvalid + T.FreshInsertionMatchedExistingVertex firstVertex secondVertex -> indices ObstructionFreshInsertionMatchedExistingVertex (T.unVertexId firstVertex) (T.unVertexId secondVertex) + T.DegenerateLineEndpointMissingOutgoing vertex -> firstIndex ObstructionDegenerateLineEndpointMissingOutgoing (T.unVertexId vertex) + T.DegenerateLineEndpointTurnMissing index -> firstIndex ObstructionDegenerateLineEndpointTurnMissing index + T.DegenerateLineConnectedVertexMissing index -> firstIndex ObstructionDegenerateLineConnectedVertexMissing index + T.HullStartNotVisible edge -> firstIndex ObstructionHullStartNotVisible (T.unDirectedEdgeId edge) + T.OuterRangeDidNotTerminate firstEdge secondEdge steps -> + (indices ObstructionOuterRangeDidNotTerminate (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge)) + {obstructionFirstValue = fromIntegral steps} + T.OuterRangeContainsInnerEdge edge face -> indices ObstructionOuterRangeContainsInnerEdge (T.unDirectedEdgeId edge) (T.unFaceId face) + T.ConstrainedEdgeFlipRefused edge -> firstIndex ObstructionConstrainedEdgeFlipRefused (T.unUndirectedEdgeId edge) + T.RemovalVertexOutOfRange vertex count -> indices ObstructionRemovalVertexOutOfRange (T.unVertexId vertex) count + T.RemovalEdgeOutOfRange edge count -> indices ObstructionRemovalEdgeOutOfRange (T.unUndirectedEdgeId edge) count + T.RemovalFaceOutOfRange face count -> indices ObstructionRemovalFaceOutOfRange (T.unFaceId face) count + T.RemovalFaceCycleDidNotTerminate face edge steps -> + (indices ObstructionRemovalFaceCycleDidNotTerminate (T.unFaceId face) (T.unDirectedEdgeId edge)) + {obstructionFirstValue = fromIntegral steps} + T.RemovalEmptyTriangulation vertex -> firstIndex ObstructionRemovalEmptyTriangulation (T.unVertexId vertex) + T.RemovalTwoPointDegreeMismatch vertex degree -> indices ObstructionRemovalTwoPointDegreeMismatch (T.unVertexId vertex) degree + T.RemovalCollinearDegreeMismatch vertex degree -> indices ObstructionRemovalCollinearDegreeMismatch (T.unVertexId vertex) degree + T.RemovalBorderTooShort count -> firstIndex ObstructionRemovalBorderTooShort count + T.RemovalBorderArityMismatch count -> firstIndex ObstructionRemovalBorderArityMismatch count + T.RemovalOutgoingCycleDidNotTerminate vertex edge steps -> + (indices ObstructionRemovalOutgoingCycleDidNotTerminate (T.unVertexId vertex) (T.unDirectedEdgeId edge)) + {obstructionFirstValue = fromIntegral steps} + T.CircleSweepHullEmpty -> codeOnly ObstructionCircleSweepHullEmpty + T.OuterCycleDidNotTerminate firstEdge secondEdge steps -> + (indices ObstructionOuterCycleDidNotTerminate (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge)) + {obstructionFirstValue = fromIntegral steps} + T.HierarchyLevelPopulationMismatch level expected observed -> + (indices ObstructionHierarchyLevelPopulationMismatch expected observed) {obstructionFirstValue = fromIntegral level} + T.HierarchyInsertionHandleMismatch expected observed -> indices ObstructionHierarchyInsertionHandleMismatch (T.unVertexId expected) (T.unVertexId observed) + T.PointIndexCapacityExhausted count -> firstIndex ObstructionPointIndexCapacityExhausted count + T.RefinementMinimumAngleNotFinite value -> nonFinite ObstructionRefinementMinimumAngleNotFinite value + T.RefinementMinimumAngleOutOfRange value -> firstValue ObstructionRefinementMinimumAngleOutOfRange value + T.RefinementMinimumAngleDerivedRatioNotFinite value -> nonFinite ObstructionRefinementMinimumAngleDerivedRatioNotFinite value + T.RefinementMaximumAdditionalVerticesNegative value -> firstValue ObstructionRefinementMaximumAdditionalVerticesNegative (fromIntegral value) + T.RefinementMinimumAreaNotFinite value -> nonFinite ObstructionRefinementMinimumAreaNotFinite value + T.RefinementMinimumAreaNegative value -> firstValue ObstructionRefinementMinimumAreaNegative value + T.RefinementMaximumAreaNotFinite value -> nonFinite ObstructionRefinementMaximumAreaNotFinite value + T.RefinementMaximumAreaNotPositive value -> firstValue ObstructionRefinementMaximumAreaNotPositive value + T.RefinementMaximumRadiusEdgeRatioNotFinite value -> nonFinite ObstructionRefinementMaximumRadiusEdgeRatioNotFinite value + T.RefinementMaximumRadiusEdgeRatioNotPositive value -> firstValue ObstructionRefinementMaximumRadiusEdgeRatioNotPositive value + T.RefinementMaximumEdgeLengthNotFinite value -> nonFinite ObstructionRefinementMaximumEdgeLengthNotFinite value + T.RefinementMaximumEdgeLengthNotPositive value -> firstValue ObstructionRefinementMaximumEdgeLengthNotPositive value + T.RefinementMinimumAreaExceedsMaximum minimumArea maximumArea -> values ObstructionRefinementMinimumAreaExceedsMaximum minimumArea maximumArea + T.RefinementSeedFaceNotActive face count -> indices ObstructionRefinementSeedFaceNotActive (T.unFaceId face) count + T.RefinementDomainTopologyChanged -> codeOnly ObstructionRefinementDomainTopologyChanged + T.RefinementDomainRequiresConvexHullPreservation -> codeOnly ObstructionRefinementDomainRequiresConvexHullPreservation + T.RefinementDomainRequiresConstraintPreservation -> codeOnly ObstructionRefinementDomainRequiresConstraintPreservation + T.RefinementDomainForbidsOuterFaceExclusion -> codeOnly ObstructionRefinementDomainForbidsOuterFaceExclusion + T.RefinementDomainWouldCrossInterface edge face -> indices ObstructionRefinementDomainWouldCrossInterface (T.unUndirectedEdgeId edge) (T.unFaceId face) + T.RefinementDomainWouldRewriteProtectedFace face -> firstIndex ObstructionRefinementDomainWouldRewriteProtectedFace (T.unFaceId face) + T.RefinementDomainProtectedFaceChanged face -> firstIndex ObstructionRefinementDomainProtectedFaceChanged (T.unFaceId face) + T.RefinementDomainInterfaceOppositeFaceNotPermitted edge face -> + indices ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted (T.unUndirectedEdgeId edge) (T.unFaceId face) + T.RefinementOversizedEdge face edge actual bound -> + (indices ObstructionRefinementOversizedEdge (T.unFaceId face) (T.unUndirectedEdgeId edge)) + { obstructionFirstValue = actual + , obstructionSecondValue = bound + } + T.CapacityExceeded count -> firstIndex ObstructionCapacityExceeded count + T.HalfEdgeCapacityExceeded requested capacity -> indices ObstructionHalfEdgeCapacityExceeded requested capacity + T.FaceCapacityExceeded requested capacity -> indices ObstructionFaceCapacityExceeded requested capacity + T.PayloadStorageFailure _ -> codeOnly ObstructionPayloadStorageFailure + T.CoordinatePayloadCountMismatch coordinates payloads -> indices ObstructionCoordinatePayloadCountMismatch coordinates payloads + T.CircleSweepRequiresDenseStorage -> codeOnly ObstructionCircleSweepRequiresDenseStorage + T.SeamFrontierUnavailable -> codeOnly ObstructionSeamFrontierUnavailable + T.RefinementDomainRequiresFiniteVertexBudget -> codeOnly ObstructionRefinementDomainRequiresFiniteVertexBudget + T.SeamSourceEdgeRequiresFlip edge -> firstIndex ObstructionSeamSourceEdgeRequiresFlip (T.unUndirectedEdgeId edge) + T.RefinementSeamBridgeBudgetExceeded required available -> indices ObstructionRefinementSeamBridgeBudgetExceeded required available + T.RefinementSeamBridgeMidpointCollapsed edge -> firstIndex ObstructionRefinementSeamBridgeMidpointCollapsed (T.unUndirectedEdgeId edge) + T.BoundarySplitRequiresBoundaryEdge edge -> firstIndex ObstructionBoundarySplitRequiresBoundaryEdge (T.unUndirectedEdgeId edge) + ) + {obstructionMessage = show failure} + where + codeOnly :: ObstructionCode -> CObstruction + codeOnly code = emptyObstruction {obstructionCode = obstructionCodeId code} + firstIndex :: Integral index => ObstructionCode -> index -> CObstruction + firstIndex code index = (codeOnly code) {obstructionFirstIndex = fromIntegral index} + indices :: (Integral first, Integral second) => ObstructionCode -> first -> second -> CObstruction + indices code firstIndexValue secondIndexValue = + (codeOnly code) + { obstructionFirstIndex = fromIntegral firstIndexValue + , obstructionSecondIndex = fromIntegral secondIndexValue + } + firstValue :: ObstructionCode -> Double -> CObstruction + firstValue code value = (codeOnly code) {obstructionFirstValue = value} + values :: ObstructionCode -> Double -> Double -> CObstruction + values code firstCoordinateValue secondCoordinateValue = + (codeOnly code) + { obstructionFirstValue = firstCoordinateValue + , obstructionSecondValue = secondCoordinateValue + } + pointObstruction :: ObstructionCode -> Double -> Double -> CObstruction + pointObstruction code x y = + (codeOnly code) + { obstructionPointX = x + , obstructionPointY = y + } + nonFinite :: ObstructionCode -> T.NonFiniteValue -> CObstruction + nonFinite code value = firstIndex code (nonFiniteCode value) + +coordinateErrorCode :: T.CoordinateError -> Word32 +coordinateErrorCode reason = + coordinateErrorCodeId + ( case reason of + T.CoordinateNaN -> CoordinateErrorNaN + T.CoordinateInfinite -> CoordinateErrorInfinite + T.CoordinateTooSmall -> CoordinateErrorTooSmall + T.CoordinateTooLarge -> CoordinateErrorTooLarge + ) + +nonFiniteCode :: T.NonFiniteValue -> Word32 +nonFiniteCode value = + case value of + T.ValueNaN -> 1 + T.ValuePositiveInfinity -> 2 + T.ValueNegativeInfinity -> 3 diff --git a/ffi/abi/Moonlight/Triangulation/Foreign/Region.hs b/ffi/abi/Moonlight/Triangulation/Foreign/Region.hs new file mode 100644 --- /dev/null +++ b/ffi/abi/Moonlight/Triangulation/Foreign/Region.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE RecordWildCards #-} + +module Moonlight.Triangulation.Foreign.Region + ( regionCopyF64 + , regionCounts + , regionCreateF64 + , regionDifference + , regionFree + , regionIntersection + , regionLocatePointF64 + , regionMeasure + , regionSymmetricDifference + , regionUnion + ) where + +import Data.Bifunctor (first) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Foreign.C.String (withCStringLen) +import Foreign.C.Types (CChar, CDouble (..), CSize, CUInt) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peekElemOff, poke, pokeElemOff) +import qualified Data.Vector as V +import qualified Moonlight.Triangulation as T +import Moonlight.Triangulation.Foreign.Boundary + ( checkedCount + , dereferenceHandle + , freeHandle + , produceHandle + , readPoints + , requireOutputCapacity + , requirePointer + , runBoundary + ) +import Moonlight.Triangulation.Foreign.Contract + ( CObstruction + , CRegion + , RegionLocationCode (..) + , regionLocationCodeId + ) +import Moonlight.Triangulation.Foreign.Obstruction + ( AbiFailure + , RegionCountKind (..) + , RegionLayoutError (..) + , nullPointerFailure + , overlayFailure + , pointInputFailure + , projectionFailure + , regionLayoutFailure + , regionPublicationFailure + , regionValidationFailure + , valuationFailure + ) + +readCounts + :: String + -> Ptr CSize + -> Int + -> IO (Either AbiFailure (V.Vector Int)) +readCounts _ _ 0 = pure (Right V.empty) +readCounts label pointer count + | pointer == nullPtr = pure (Left (nullPointerFailure label)) + | otherwise = do + rawCounts <- V.generateM count (peekElemOff pointer) + pure (V.mapM (checkedCount 1) rawCounts) + +validateCounts + :: RegionCountKind + -> Int + -> V.Vector Int + -> Either RegionLayoutError () +validateCounts kind expectedTotal counts = + case V.findIndex (== 0) counts of + Just index -> Left (RegionGroupEmpty kind index) + Nothing + | observedTotal /= toInteger expectedTotal -> + Left (RegionCountTotalMismatch kind observedTotal (toInteger expectedTotal)) + | otherwise -> Right () + where + observedTotal = V.foldl' (\total count -> total + toInteger count) 0 counts + +regionCreateF64 + :: Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> Ptr (Ptr CRegion) + -> Ptr CObstruction + -> IO CUInt +regionCreateF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount output obstructionPointer = + runBoundary obstructionPointer $ + produceHandle output $ + readRegionF64 + coordinates + rawPointCount + loopPointCounts + rawLoopCount + componentLoopCounts + rawComponentCount + +readRegionF64 + :: Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> IO (Either AbiFailure T.PlanarRegion) +readRegionF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount = + case checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount of + Left failure -> pure (Left failure) + Right (pointCount, loopCount, componentCount) -> do + points <- readPoints coordinates pointCount + loopCounts <- readCounts "loop_point_counts" loopPointCounts loopCount + componentCounts <- readCounts "component_loop_counts" componentLoopCounts componentCount + pure $ do + admittedPoints <- points + admittedLoopCounts <- loopCounts + admittedComponentCounts <- componentCounts + first regionLayoutFailure (validateCounts LoopPointCounts pointCount admittedLoopCounts) + first regionLayoutFailure (validateCounts ComponentLoopCounts loopCount admittedComponentCounts) + buildRegion admittedPoints admittedLoopCounts admittedComponentCounts + +checkedRegionInputCounts + :: CSize + -> CSize + -> CSize + -> Either AbiFailure (Int, Int, Int) +checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount = do + pointCount <- checkedCount 2 rawPointCount + loopCount <- checkedCount 1 rawLoopCount + componentCount <- checkedCount 1 rawComponentCount + pure (pointCount, loopCount, componentCount) + +buildRegion + :: V.Vector T.Point + -> V.Vector Int + -> V.Vector Int + -> Either AbiFailure T.PlanarRegion +buildRegion points loopCounts componentCounts = do + exactPoints <- + V.imapM + (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point)) + points + loops <- V.imapM (buildLoop exactPoints) (adjacentOffsets loopCounts) + components <- V.imapM (buildComponent loops) (adjacentOffsets componentCounts) + first regionValidationFailure (T.planarRegion (V.toList components)) + +adjacentOffsets :: V.Vector Int -> V.Vector (Int, Int) +adjacentOffsets counts = + let offsets = V.scanl' (+) 0 counts + in V.zip offsets (V.drop 1 offsets) + +buildLoop + :: V.Vector T.ExactPoint + -> Int + -> (Int, Int) + -> Either AbiFailure T.ExactLoop +buildLoop points loopIndex (start, end) = + case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) points)) of + Nothing -> Left (regionLayoutFailure (RegionGroupEmpty LoopPointCounts loopIndex)) + Just submitted -> first regionValidationFailure (T.exactLoop submitted) + +buildComponent + :: V.Vector T.ExactLoop + -> Int + -> (Int, Int) + -> Either AbiFailure T.PolygonComponent +buildComponent loops componentIndex (start, end) = + case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) loops)) of + Nothing -> Left (regionLayoutFailure (RegionGroupEmpty ComponentLoopCounts componentIndex)) + Just (outer :| holes) -> first regionValidationFailure (T.polygonComponent outer holes) + +regionShape + :: T.PlanarRegion + -> ([T.PolygonComponent], [[T.ExactLoop]], [T.ExactLoop]) +regionShape region = + let components = T.planarRegionComponents region + componentLoops component = T.polygonOuterLoop component : T.polygonHoleLoops component + loopsByComponent = map componentLoops components + in (components, loopsByComponent, concat loopsByComponent) + +regionCounts + :: Ptr CRegion + -> Ptr CSize + -> Ptr CSize + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +regionCounts regionPointer componentCountOutput loopCountOutput pointCountOutput obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "component_count" componentCountOutput + >> requirePointer "loop_count" loopCountOutput + >> requirePointer "point_count" pointCountOutput + of + Left failure -> pure (Left failure) + Right () -> do + region <- dereferenceHandle regionPointer + let (components, _, loops) = regionShape region + pointCount = sum (map (NonEmpty.length . T.exactLoopPoints) loops) + poke componentCountOutput (fromIntegral (length components)) + poke loopCountOutput (fromIntegral (length loops)) + poke pointCountOutput (fromIntegral pointCount) + pure (Right ()) + +data RegionProjection = RegionProjection + { projectionPoints :: !(V.Vector T.Point) + , projectionLoopPointOffsets :: !(V.Vector CSize) + , projectionComponentLoopOffsets :: !(V.Vector CSize) + } + +regionProjection :: T.PlanarRegion -> Either AbiFailure RegionProjection +regionProjection region = do + let (_, loopsByComponent, loops) = regionShape region + exactPoints = concatMap (NonEmpty.toList . T.exactLoopPoints) loops + loopPointOffsets = scanl (+) 0 (map (NonEmpty.length . T.exactLoopPoints) loops) + componentLoopOffsets = scanl (+) 0 (map length loopsByComponent) + projectedPoints <- + V.fromList + <$> traverse + (uncurry projectPoint) + (zip [0 ..] exactPoints) + pure + RegionProjection + { projectionPoints = projectedPoints + , projectionLoopPointOffsets = V.fromList (map fromIntegral loopPointOffsets) + , projectionComponentLoopOffsets = V.fromList (map fromIntegral componentLoopOffsets) + } + where + projectPoint index point = + T.queryPointValue + <$> first (projectionFailure index) (T.exactPointToEmbeddingCandidate point) + +regionCopyF64 + :: Ptr CRegion + -> Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CObstruction + -> IO CUInt +regionCopyF64 regionPointer coordinates rawPointCapacity loopPointOffsets rawLoopOffsetCapacity componentLoopOffsets rawComponentOffsetCapacity obstructionPointer = + runBoundary obstructionPointer $ + case + (,,) + <$> (requirePointer "region" regionPointer >> checkedCount 2 rawPointCapacity) + <*> checkedCount 1 rawLoopOffsetCapacity + <*> checkedCount 1 rawComponentOffsetCapacity + of + Left failure -> pure (Left failure) + Right (pointCapacity, loopOffsetCapacity, componentOffsetCapacity) -> do + region <- dereferenceHandle regionPointer + case regionProjection region of + Left failure -> pure (Left failure) + Right RegionProjection {..} -> + case + requireOutputCapacity "coordinates" coordinates (V.length projectionPoints) pointCapacity + >> requireOutputCapacity "loop_point_offsets" loopPointOffsets (V.length projectionLoopPointOffsets) loopOffsetCapacity + >> requireOutputCapacity "component_loop_offsets" componentLoopOffsets (V.length projectionComponentLoopOffsets) componentOffsetCapacity + of + Left failure -> pure (Left failure) + Right () -> do + V.imapM_ + ( \index (T.Point x y) -> do + pokeElemOff coordinates (index * 2) (CDouble x) + pokeElemOff coordinates (index * 2 + 1) (CDouble y) + ) + projectionPoints + V.imapM_ (pokeElemOff loopPointOffsets) projectionLoopPointOffsets + V.imapM_ (pokeElemOff componentLoopOffsets) projectionComponentLoopOffsets + pure (Right ()) + +regionUnion, regionIntersection, regionDifference, regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +regionUnion = binaryRegionOperation (\(left, right) -> left || right) +regionIntersection = binaryRegionOperation (\(left, right) -> left && right) +regionDifference = binaryRegionOperation (\(left, right) -> left && not right) +regionSymmetricDifference = binaryRegionOperation (uncurry (/=)) + +binaryRegionOperation + :: ((Bool, Bool) -> Bool) + -> Ptr CRegion + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CObstruction + -> IO CUInt +binaryRegionOperation selected leftPointer rightPointer output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (exactRegionBoolean selected left right) + +exactRegionBoolean + :: ((Bool, Bool) -> Bool) + -> T.PlanarRegion + -> T.PlanarRegion + -> Either AbiFailure T.PlanarRegion +exactRegionBoolean selected left right = do + leftLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True left)) + rightLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True right)) + overlay <- first overlayFailure (T.overlayLayers leftLayer rightLayer) + first regionPublicationFailure (T.overlaySelectedRegion selected overlay) + +regionLocatePointF64 + :: Ptr CRegion + -> CDouble + -> CDouble + -> Ptr CUInt + -> Ptr CObstruction + -> IO CUInt +regionLocatePointF64 regionPointer (CDouble x) (CDouble y) output obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "location" output + >> first (pointInputFailure 0 (T.Point x y)) (T.exactPointFromPoint (T.Point x y)) + of + Left failure -> pure (Left failure) + Right query -> do + region <- dereferenceHandle regionPointer + poke output (regionLocationCode (T.regionPointLocation region query)) + pure (Right ()) + +regionLocationCode :: T.RegionPointLocation -> CUInt +regionLocationCode location = + fromIntegral + ( regionLocationCodeId + ( case location of + T.RegionExterior -> RegionLocationExterior + T.RegionOnBoundary -> RegionLocationBoundary + T.RegionInterior -> RegionLocationInterior + ) + ) + +regionMeasure + :: Ptr CRegion + -> Ptr Int64 + -> Ptr CChar + -> CSize + -> Ptr CSize + -> Ptr CDouble + -> Ptr CDouble + -> Ptr CObstruction + -> IO CUInt +regionMeasure regionPointer eulerOutput areaRatioOutput rawAreaCapacity areaBytesWritten perimeterLowerOutput perimeterUpperOutput obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "euler_characteristic" eulerOutput + >> requirePointer "area_bytes_written" areaBytesWritten + >> requirePointer "perimeter_lower" perimeterLowerOutput + >> requirePointer "perimeter_upper" perimeterUpperOutput + >> checkedCount 1 rawAreaCapacity + of + Left failure -> pure (Left failure) + Right areaCapacity -> do + region <- dereferenceHandle regionPointer + case regionMeasurements region of + Left failure -> pure (Left failure) + Right (valuations, perimeter) -> do + let area = T.exactAreaValue (T.valuationArea valuations) + areaText = + show (T.exactRationalNumerator area) + <> "/" + <> show (T.exactRationalDenominator area) + bounds = T.exactLengthBounds perimeter + poke eulerOutput (fromIntegral (T.eulerCharacteristicValue (T.valuationEuler valuations))) + poke perimeterLowerOutput (CDouble (T.intervalLower bounds)) + poke perimeterUpperOutput (CDouble (T.intervalUpper bounds)) + copyCStringOutput areaText areaRatioOutput areaCapacity areaBytesWritten + +regionMeasurements + :: T.PlanarRegion + -> Either AbiFailure (T.PlanarValuations, T.ExactLengthMeasurement) +regionMeasurements region = do + valuations <- first valuationFailure (T.regionValuations region) + perimeter <- first valuationFailure (T.planarValuationsPerimeter valuations) + pure (valuations, perimeter) + +copyCStringOutput + :: String + -> Ptr CChar + -> Int + -> Ptr CSize + -> IO (Either AbiFailure ()) +copyCStringOutput value output capacity bytesWritten = + withCStringLen value $ \(source, byteCount) -> do + poke bytesWritten (fromIntegral byteCount) + case requireOutputCapacity "area_ratio_utf8" output (byteCount + 1) capacity of + Left failure -> pure (Left failure) + Right () -> do + copyBytes output source byteCount + pokeElemOff output byteCount 0 + pure (Right ()) + +regionFree :: Ptr CRegion -> IO () +regionFree = freeHandle diff --git a/ffi/bindings/README.md b/ffi/bindings/README.md new file mode 100644 --- /dev/null +++ b/ffi/bindings/README.md @@ -0,0 +1,104 @@ +# Foreign bindings + +`moonlight-triangulation.cabal` owns the private Haskell `ffi` sublibrary and +`moonlight-triangulation-c` foreign library. Python, TypeScript, and Rust are +thin lifecycle and bulk-layout leaves over that sole ABI; none implements +triangulation, overlay, publication, valuation, or morphology. + +`Moonlight.Triangulation.Foreign.Contract` is the closed wire authority. Its +pure renderer owns the installed header, Windows export list, Haskell export +module, TypeScript wire vocabulary and raw declarations, Python ctypes +declarations, and Rust extern block. Check or rewrite those derived sections +from `compiler`—never edit them directly: + +```bash +../scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-ffi-contract \ + --project-file=cabal.project.triangulation-dev \ + -- check foundation/moonlight-triangulation +``` + +From `compiler`, build and locate the shared library: + +```bash +../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`. + +## ABI version 2 + +Three opaque immutable carriers cross the boundary: + +- `ml_mesh` retains a binary64 Delaunay mesh. Its `ml_mesh_site_*` algebra + combines sites, not polygon interiors. +- `ml_region` retains the authoritative exact rational `PlanarRegion`. + `ml_region_create_f64` admits every input coordinate exactly as its binary64 + dyadic value in one call, using point counts per loop and loop counts per + component. The inverse bulk projection returns component/loop offsets and + binary64 rendering points; it does not replace the exact retained geometry. +- `ml_structuring_element` retains one admitted origin-containing convex + polygon for repeated offset, inset, opening, and closing calls. + +Region union, intersection, difference, and symmetric difference call the one +Haskell overlay and grouped-publication path. Point location is exact. A single +valuation call returns Euler characteristic, exact reduced area as +`numerator/denominator`, and certified conventional-perimeter bounds. Morphology +returns a new region plus the existing operation/work receipt. + +Every status-returning call accepts an optional `ml_obstruction` distinguishing +pointer/count/buffer failures from region layout, validation, overlay, +publication, valuation, projection, morphology, and runtime failures. Handles +remain valid until explicitly freed; every operation publishes a fresh output +handle. `ml_runtime_initialize` is idempotent and process-lifetime. + +Python and Rust owned handles are thread-affine: create, use, and release each +handle on one thread. Python exposes context management plus `dispose`; Rust +releases through `Drop`. This prevents release from racing a foreign call after +the runtime has received the raw handle. + +Batch related mesh edits into one `insert_many` call. Author a whole region with +one component list; there is deliberately no mutable builder or per-vertex FFI +surface. + +## Python + +```python +from fractions import Fraction +from moonlight_triangulation import Moonlight, PolygonComponent + +moonlight = Moonlight() +with moonlight.region([ + PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2))) +]) as left, moonlight.region([ + PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2))) +]) as right, left.intersection(right) as intersection: + assert intersection.valuations.area == Fraction(2, 1) +``` + +## TypeScript + +The [`@moonlight/triangulation` package guide](./typescript/README.md) owns +installation, native-library loading, typed results, and resource lifetime. + +## Rust + +```rust +use moonlight_triangulation::{Moonlight, PolygonComponent}; + +let moonlight = Moonlight::initialize()?; +let region = moonlight.region(&[PolygonComponent { + outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]], + holes: vec![], +}])?; +println!("{:?}", region.valuations()?.area); +``` + +Rust reports native refusals as `MoonlightError::AbiObstruction` and keeps ABI +version, initialization, malformed projection, and unknown-wire failures as +distinct variants; it never forges a native obstruction for a wrapper defect. diff --git a/ffi/bindings/python/pyproject.toml b/ffi/bindings/python/pyproject.toml new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/pyproject.toml @@ -0,0 +1,13 @@ +[build-system] +requires = ["hatchling>=1.27,<2"] +build-backend = "hatchling.build" + +[project] +name = "moonlight-triangulation" +version = "2.0.0" +description = "Python bindings for Moonlight exact regions and immutable Delaunay meshes." +requires-python = ">=3.11" +license = { text = "MIT" } + +[tool.hatch.build.targets.wheel] +packages = ["src/moonlight_triangulation"] diff --git a/ffi/bindings/python/src/moonlight_triangulation/__init__.py b/ffi/bindings/python/src/moonlight_triangulation/__init__.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/src/moonlight_triangulation/__init__.py @@ -0,0 +1,26 @@ +from ._binding import Mesh, Moonlight, Region, StructuringElement +from .errors import MoonlightError +from .values import ( + MinkowskiOperation, + MinkowskiReceipt, + Point, + PolygonComponent, + RegionLocation, + RegionValuations, + Triangle, +) + +__all__ = [ + "Mesh", + "MinkowskiOperation", + "MinkowskiReceipt", + "Moonlight", + "MoonlightError", + "Point", + "PolygonComponent", + "Region", + "RegionLocation", + "RegionValuations", + "StructuringElement", + "Triangle", +] diff --git a/ffi/bindings/python/src/moonlight_triangulation/_binding.py b/ffi/bindings/python/src/moonlight_triangulation/_binding.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/src/moonlight_triangulation/_binding.py @@ -0,0 +1,450 @@ +from __future__ import annotations + +import ctypes +import os +import weakref +from collections.abc import Callable, Iterable, Sequence +from fractions import Fraction +from pathlib import Path +from threading import get_ident +from typing import Self + +from ._native_generated import ( + ABI_VERSION, + ML_OBSTRUCTION_BUFFER_TOO_SMALL, + ML_STATUS_BUFFER_TOO_SMALL, + ML_STATUS_OK, + _NativeApi, + _NativeMinkowskiReceipt, + _Obstruction, +) +from .errors import MoonlightError +from .values import ( + MinkowskiOperation, + MinkowskiReceipt, + Point, + PolygonComponent, + RegionLocation, + RegionValuations, + Triangle, +) + +_BinaryNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object], int] +_MorphologyNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object, object], int] + +class Moonlight: + def __init__(self, library_path: str | os.PathLike[str] | None = None) -> None: + configured_path = ( + os.environ.get("MOONLIGHT_TRIANGULATION_LIBRARY") + if library_path is None + else library_path + ) + if configured_path is None: + raise ValueError("set MOONLIGHT_TRIANGULATION_LIBRARY or pass library_path") + if os.fspath(configured_path) == "": + raise ValueError("Moonlight native library path must not be empty") + self._native = _NativeApi(Path(configured_path)) + initialization_status = int(self._native.library.ml_runtime_initialize()) + if initialization_status != ML_STATUS_OK: + raise RuntimeError( + f"Moonlight runtime initialization failed with status {initialization_status}" + ) + observed_version = int(self._native.library.ml_abi_version()) + if observed_version != ABI_VERSION: + raise RuntimeError(f"unsupported Moonlight ABI version {observed_version}") + + def delaunay(self, points: Sequence[Point]) -> Mesh: + coordinates, pointer = _coordinate_buffer(points) + handle = _produce_handle( + lambda output, obstruction: self._native.library.ml_delaunay_f64( + pointer, len(coordinates) // 2, output, obstruction + ), + ) + return Mesh(self._native, handle) + + def region(self, components: Sequence[PolygonComponent]) -> Region: + loops, loop_counts, component_counts = _component_layout(components) + coordinates, coordinate_pointer = _coordinate_buffer( + point for loop in loops for point in loop + ) + loop_buffer = _size_buffer(loop_counts) + component_buffer = _size_buffer(component_counts) + handle = _produce_handle( + lambda output, obstruction: self._native.library.ml_region_create_f64( + coordinate_pointer, + len(coordinates) // 2, + loop_buffer, + len(loop_counts), + component_buffer, + len(component_counts), + output, + obstruction, + ), + ) + return Region(self._native, handle) + + def structuring_element(self, points: Sequence[Point]) -> StructuringElement: + coordinates, pointer = _coordinate_buffer(points) + handle = _produce_handle( + lambda output, obstruction: self._native.library.ml_structuring_element_create_f64( + pointer, len(coordinates) // 2, output, obstruction + ), + ) + return StructuringElement(self._native, handle) + + +class _OwnedHandle: + __slots__ = ("_native", "_handle", "_finalizer", "_kind", "_owner_thread", "__weakref__") + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p, free: Callable[[ctypes.c_void_p], None], kind: str) -> None: + self._native = native + self._handle = handle + self._kind = kind + self._owner_thread = get_ident() + self._finalizer = weakref.finalize(self, free, handle) + + def dispose(self) -> None: + self._require_owner_thread() + self._finalizer() + + def __enter__(self) -> Self: + return self + + def __exit__(self, _type: object, _value: object, _traceback: object) -> None: + self.dispose() + + def _live_handle(self) -> ctypes.c_void_p: + self._require_owner_thread() + if not self._finalizer.alive: + raise RuntimeError(f"{self._kind} is disposed") + return self._handle + + def _require_owner_thread(self) -> None: + if get_ident() != self._owner_thread: + raise RuntimeError(f"{self._kind} belongs to another thread") + + def _require_same_runtime(self, other: _OwnedHandle) -> None: + if self._native is not other._native: + raise ValueError("both values must belong to the same Moonlight runtime") + + +class Mesh(_OwnedHandle): + __slots__ = () + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_mesh_free, "mesh") + + @property + def vertex_count(self) -> int: + return self._count(self._native.library.ml_mesh_vertex_count) + + @property + def triangle_count(self) -> int: + return self._count(self._native.library.ml_mesh_triangle_count) + + @property + def vertices(self) -> tuple[Point, ...]: + count = self.vertex_count + output = (ctypes.c_double * (count * 2))() + written = ctypes.c_size_t() + obstruction = _Obstruction() + status = int( + self._native.library.ml_mesh_copy_vertices_f64( + self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) + ) + ) + _check_status(status, obstruction) + return tuple((float(output[index * 2]), float(output[index * 2 + 1])) for index in range(written.value)) + + @property + def triangles(self) -> tuple[Triangle, ...]: + count = self.triangle_count + output = (ctypes.c_uint32 * (count * 3))() + written = ctypes.c_size_t() + obstruction = _Obstruction() + status = int( + self._native.library.ml_mesh_copy_triangles_u32( + self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) + ) + ) + _check_status(status, obstruction) + return tuple( + (int(output[index * 3]), int(output[index * 3 + 1]), int(output[index * 3 + 2])) + for index in range(written.value) + ) + + def insert_many(self, points: Sequence[Point]) -> Mesh: + coordinates, pointer = _coordinate_buffer(points) + handle = _produce_handle( + lambda output, obstruction: self._native.library.ml_mesh_insert_many_f64( + self._live_handle(), pointer, len(coordinates) // 2, output, obstruction + ), + ) + return Mesh(self._native, handle) + + def site_union(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_union) + + def site_intersection(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_intersection) + + def site_difference(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_difference) + + def site_symmetric_difference(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_symmetric_difference) + + def _binary(self, other: Mesh, operation: _BinaryNativeOperation) -> Mesh: + self._require_same_runtime(other) + handle = _produce_handle( + lambda output, obstruction: operation( + self._live_handle(), other._live_handle(), output, obstruction + ), + ) + return Mesh(self._native, handle) + + def _count(self, operation: Callable[[ctypes.c_void_p, object, object], int]) -> int: + output = ctypes.c_size_t() + obstruction = _Obstruction() + status = int(operation(self._live_handle(), ctypes.byref(output), ctypes.byref(obstruction))) + _check_status(status, obstruction) + return int(output.value) + + +class Region(_OwnedHandle): + __slots__ = () + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_region_free, "region") + + @property + def components(self) -> tuple[PolygonComponent, ...]: + component_count, loop_count, point_count = self._counts() + coordinates = (ctypes.c_double * (point_count * 2))() + loop_offsets = (ctypes.c_size_t * (loop_count + 1))() + component_offsets = (ctypes.c_size_t * (component_count + 1))() + obstruction = _Obstruction() + status = int( + self._native.library.ml_region_copy_f64( + self._live_handle(), + coordinates, + point_count, + loop_offsets, + loop_count + 1, + component_offsets, + component_count + 1, + ctypes.byref(obstruction), + ) + ) + _check_status(status, obstruction) + points = tuple((float(coordinates[index * 2]), float(coordinates[index * 2 + 1])) for index in range(point_count)) + loops = tuple( + points[int(loop_offsets[index]) : int(loop_offsets[index + 1])] + for index in range(loop_count) + ) + component_ranges = tuple( + (int(component_offsets[index]), int(component_offsets[index + 1])) + for index in range(component_count) + ) + if any(start >= end for start, end in component_ranges): + raise RuntimeError("Moonlight returned a component without an outer loop") + return tuple( + PolygonComponent(loops[start], loops[start + 1 : end]) + for start, end in component_ranges + ) + + @property + def valuations(self) -> RegionValuations: + return self._measure_with_capacity(128) + + def locate(self, point: Point) -> RegionLocation: + output = ctypes.c_uint32() + obstruction = _Obstruction() + status = int( + self._native.library.ml_region_locate_point_f64( + self._live_handle(), point[0], point[1], ctypes.byref(output), ctypes.byref(obstruction) + ) + ) + _check_status(status, obstruction) + return RegionLocation(output.value) + + def union(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_union) + + def intersection(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_intersection) + + def difference(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_difference) + + def symmetric_difference(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_symmetric_difference) + + def minkowski_sum(self, other: Region) -> tuple[Region, MinkowskiReceipt]: + self._require_same_runtime(other) + return self._morph( + lambda output, receipt, obstruction: self._native.library.ml_region_minkowski_sum( + self._live_handle(), other._live_handle(), output, receipt, obstruction + ) + ) + + def offset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_offset) + + def inset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_inset) + + def open(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_open) + + def close(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_close) + + def _binary(self, other: Region, operation: _BinaryNativeOperation) -> Region: + self._require_same_runtime(other) + handle = _produce_handle( + lambda output, obstruction: operation( + self._live_handle(), other._live_handle(), output, obstruction + ), + ) + return Region(self._native, handle) + + def _with_element( + self, element: StructuringElement, operation: _MorphologyNativeOperation + ) -> tuple[Region, MinkowskiReceipt]: + self._require_same_runtime(element) + return self._morph( + lambda output, receipt, obstruction: operation( + element._live_handle(), self._live_handle(), output, receipt, obstruction + ) + ) + + def _morph( + self, + operation: Callable[[object, object, object], int], + ) -> tuple[Region, MinkowskiReceipt]: + handle, native_receipt = _produce_morphology(operation) + return Region(self._native, handle), _receipt(native_receipt) + + def _counts(self) -> tuple[int, int, int]: + component_count = ctypes.c_size_t() + loop_count = ctypes.c_size_t() + point_count = ctypes.c_size_t() + obstruction = _Obstruction() + status = int( + self._native.library.ml_region_counts( + self._live_handle(), + ctypes.byref(component_count), + ctypes.byref(loop_count), + ctypes.byref(point_count), + ctypes.byref(obstruction), + ) + ) + _check_status(status, obstruction) + return int(component_count.value), int(loop_count.value), int(point_count.value) + + def _measure_with_capacity(self, capacity: int) -> RegionValuations: + euler = ctypes.c_int64() + area = ctypes.create_string_buffer(capacity) + area_bytes = ctypes.c_size_t() + lower = ctypes.c_double() + upper = ctypes.c_double() + obstruction = _Obstruction() + status = int( + self._native.library.ml_region_measure( + self._live_handle(), + ctypes.byref(euler), + area, + capacity, + ctypes.byref(area_bytes), + ctypes.byref(lower), + ctypes.byref(upper), + ctypes.byref(obstruction), + ) + ) + if ( + status == ML_STATUS_BUFFER_TOO_SMALL + and obstruction.code == ML_OBSTRUCTION_BUFFER_TOO_SMALL + ): + return self._measure_with_capacity(int(area_bytes.value) + 1) + _check_status(status, obstruction) + numerator, separator, denominator = area.value.decode("ascii").partition("/") + if separator != "/": + raise RuntimeError("Moonlight returned a malformed exact-area ratio") + return RegionValuations(int(euler.value), Fraction(int(numerator), int(denominator)), (lower.value, upper.value)) + + +class StructuringElement(_OwnedHandle): + __slots__ = () + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_structuring_element_free, "structuring element") + + +def _component_layout( + components: Sequence[PolygonComponent], +) -> tuple[tuple[Sequence[Point], ...], tuple[int, ...], tuple[int, ...]]: + loops = tuple( + loop + for component in components + for loop in (component.outer, *component.holes) + ) + loop_counts = tuple(len(loop) for loop in loops) + component_counts = tuple(len(component.holes) + 1 for component in components) + return loops, loop_counts, component_counts + + +def _coordinate_buffer(points: Iterable[Point]) -> tuple[tuple[float, ...], object]: + coordinates = tuple(component for x, y in points for component in (x, y)) + pointer = None if not coordinates else (ctypes.c_double * len(coordinates))(*coordinates) + return coordinates, pointer + + +def _size_buffer(values: Sequence[int]) -> object: + return (ctypes.c_size_t * len(values))(*values) + + +def _produce_handle( + operation: Callable[[object, object], int], +) -> ctypes.c_void_p: + output = ctypes.c_void_p() + obstruction = _Obstruction() + status = int(operation(ctypes.byref(output), ctypes.byref(obstruction))) + _check_status(status, obstruction) + return _required_handle(output) + + +def _produce_morphology( + operation: Callable[[object, object, object], int], +) -> tuple[ctypes.c_void_p, _NativeMinkowskiReceipt]: + output = ctypes.c_void_p() + receipt = _NativeMinkowskiReceipt() + obstruction = _Obstruction() + status = int(operation(ctypes.byref(output), ctypes.byref(receipt), ctypes.byref(obstruction))) + _check_status(status, obstruction) + return _required_handle(output), receipt + + +def _receipt(native: _NativeMinkowskiReceipt) -> MinkowskiReceipt: + return MinkowskiReceipt( + MinkowskiOperation(native.operation), + int(native.input_components), + int(native.convex_pieces), + int(native.generated_pieces), + int(native.generated_convolution_edges), + int(native.overlay_passes), + int(native.exact_crossings), + int(native.output_cells), + int(native.exact_coordinate_bit_growth), + ) + + +def _check_status(status: int, obstruction: _Obstruction) -> None: + if status != ML_STATUS_OK: + raise MoonlightError(status, obstruction) + + +def _required_handle(handle: ctypes.c_void_p) -> ctypes.c_void_p: + if not handle.value: + raise RuntimeError("Moonlight returned success without a handle") + return handle diff --git a/ffi/bindings/python/src/moonlight_triangulation/_native_generated.py b/ffi/bindings/python/src/moonlight_triangulation/_native_generated.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/src/moonlight_triangulation/_native_generated.py @@ -0,0 +1,183 @@ +# Generated from Moonlight.Triangulation.Foreign.Contract. +# Run moonlight-triangulation-ffi-contract write; do not edit this file. + +from __future__ import annotations + +import ctypes +from collections.abc import Sequence +from pathlib import Path +from typing import Final + +ABI_VERSION: Final = 2 +ML_STATUS_OK: Final = 0 +ML_STATUS_NULL_POINTER: Final = 1 +ML_STATUS_COUNT_OVERFLOW: Final = 2 +ML_STATUS_BUFFER_TOO_SMALL: Final = 3 +ML_STATUS_GEOMETRY_OBSTRUCTION: Final = 4 +ML_STATUS_RUNTIME_FAILURE: Final = 5 +ML_OBSTRUCTION_NONE: Final = 0 +ML_OBSTRUCTION_INVALID_COORDINATE: Final = 1 +ML_OBSTRUCTION_POINT_LOCATION_FAILED: Final = 2 +ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED: Final = 3 +ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID: Final = 4 +ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX: Final = 5 +ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING: Final = 6 +ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING: Final = 7 +ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING: Final = 8 +ML_OBSTRUCTION_HULL_START_NOT_VISIBLE: Final = 9 +ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE: Final = 10 +ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE: Final = 11 +ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED: Final = 12 +ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE: Final = 13 +ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE: Final = 14 +ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE: Final = 15 +ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE: Final = 16 +ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION: Final = 17 +ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH: Final = 18 +ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH: Final = 19 +ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT: Final = 20 +ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH: Final = 21 +ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE: Final = 22 +ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY: Final = 23 +ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE: Final = 24 +ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH: Final = 25 +ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH: Final = 26 +ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED: Final = 27 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE: Final = 28 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE: Final = 29 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE: Final = 30 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE: Final = 31 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE: Final = 32 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE: Final = 33 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE: Final = 34 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE: Final = 35 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE: Final = 36 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE: Final = 37 +ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM: Final = 38 +ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE: Final = 39 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE: Final = 40 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING: Final = 41 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS: Final = 42 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED: Final = 43 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION: Final = 44 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION: Final = 45 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION: Final = 46 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE: Final = 47 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE: Final = 48 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED: Final = 49 +ML_OBSTRUCTION_CAPACITY_EXCEEDED: Final = 50 +ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED: Final = 51 +ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED: Final = 52 +ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE: Final = 53 +ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH: Final = 54 +ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE: Final = 55 +ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE: Final = 56 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET: Final = 57 +ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP: Final = 58 +ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED: Final = 59 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE: Final = 60 +ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE: Final = 61 +ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE: Final = 62 +ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED: Final = 63 +ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED: Final = 64 +ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE: Final = 65 +ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED: Final = 66 +ML_OBSTRUCTION_NULL_POINTER: Final = 100 +ML_OBSTRUCTION_COUNT_OVERFLOW: Final = 101 +ML_OBSTRUCTION_BUFFER_TOO_SMALL: Final = 102 +ML_OBSTRUCTION_RUNTIME_FAILURE: Final = 103 +ML_OBSTRUCTION_REGION_LAYOUT_INVALID: Final = 200 +ML_OBSTRUCTION_REGION_VALIDATION_FAILED: Final = 201 +ML_OBSTRUCTION_OVERLAY_FAILED: Final = 202 +ML_OBSTRUCTION_REGION_PUBLICATION_FAILED: Final = 203 +ML_OBSTRUCTION_VALUATION_FAILED: Final = 204 +ML_OBSTRUCTION_MINKOWSKI_FAILED: Final = 205 +ML_OBSTRUCTION_REGION_PROJECTION_FAILED: Final = 206 +ML_COORDINATE_ERROR_NONE: Final = 0 +ML_COORDINATE_ERROR_NAN: Final = 1 +ML_COORDINATE_ERROR_INFINITE: Final = 2 +ML_COORDINATE_ERROR_TOO_SMALL: Final = 3 +ML_COORDINATE_ERROR_TOO_LARGE: Final = 4 +ML_REGION_EXTERIOR: Final = 0 +ML_REGION_BOUNDARY: Final = 1 +ML_REGION_INTERIOR: Final = 2 +ML_MINKOWSKI_ADDITION: Final = 0 +ML_MINKOWSKI_EROSION: Final = 1 +ML_MINKOWSKI_OPENING: Final = 2 +ML_MINKOWSKI_CLOSING: Final = 3 + +class _Obstruction(ctypes.Structure): + _fields_ = [ + ("code", ctypes.c_uint32), + ("coordinate_error", ctypes.c_uint32), + ("input_index", ctypes.c_uint64), + ("first_index", ctypes.c_uint64), + ("second_index", ctypes.c_uint64), + ("first_value", ctypes.c_double), + ("second_value", ctypes.c_double), + ("point_x", ctypes.c_double), + ("point_y", ctypes.c_double), + ("message", ctypes.c_char * 256), + ] + + +class _NativeMinkowskiReceipt(ctypes.Structure): + _fields_ = [ + ("operation", ctypes.c_uint32), + ("reserved", ctypes.c_uint32), + ("input_components", ctypes.c_uint64), + ("convex_pieces", ctypes.c_uint64), + ("generated_pieces", ctypes.c_uint64), + ("generated_convolution_edges", ctypes.c_uint64), + ("overlay_passes", ctypes.c_uint64), + ("exact_crossings", ctypes.c_uint64), + ("output_cells", ctypes.c_uint64), + ("exact_coordinate_bit_growth", ctypes.c_uint64), + ] + + +class _NativeApi: + def __init__(self, library_path: Path) -> None: + library = ctypes.CDLL(str(library_path)) + _configure(library, "ml_abi_version", (), ctypes.c_uint32) + _configure(library, "ml_runtime_initialize", (), ctypes.c_uint32) + _configure(library, "ml_delaunay_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_insert_many_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_site_union", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_site_intersection", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_site_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_site_symmetric_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_vertex_count", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_triangle_count", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_copy_vertices_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_copy_triangles_u32", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint32), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_mesh_free", (ctypes.c_void_p,), None) + _configure(library, "ml_region_create_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_counts", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_copy_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_union", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_intersection", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_symmetric_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_locate_point_f64", (ctypes.c_void_p, ctypes.c_double, ctypes.c_double, ctypes.POINTER(ctypes.c_uint32), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_measure", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_int64), ctypes.POINTER(ctypes.c_char), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_double), ctypes.POINTER(ctypes.c_double), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_free", (ctypes.c_void_p,), None) + _configure(library, "ml_structuring_element_create_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_structuring_element_free", (ctypes.c_void_p,), None) + _configure(library, "ml_region_minkowski_sum", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_offset", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_inset", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_open", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + _configure(library, "ml_region_close", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32) + self.library = library + + +def _configure( + library: ctypes.CDLL, + name: str, + parameters: Sequence[object], + result: object = ctypes.c_uint32, +) -> None: + function = getattr(library, name) + setattr(function, "argtypes", list(parameters)) + setattr(function, "restype", result) diff --git a/ffi/bindings/python/src/moonlight_triangulation/errors.py b/ffi/bindings/python/src/moonlight_triangulation/errors.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/src/moonlight_triangulation/errors.py @@ -0,0 +1,18 @@ +from __future__ import annotations + +from ._native_generated import _Obstruction + + +class MoonlightError(RuntimeError): + def __init__(self, status: int, obstruction: _Obstruction) -> None: + self.status = status + self.code = obstruction.code + self.coordinate_error = obstruction.coordinate_error + self.input_index = obstruction.input_index + self.first_index = obstruction.first_index + self.second_index = obstruction.second_index + self.first_value = obstruction.first_value + self.second_value = obstruction.second_value + self.point = (obstruction.point_x, obstruction.point_y) + message = bytes(obstruction.message).split(b"\0", 1)[0].decode("utf-8", errors="replace") + super().__init__(message or f"Moonlight ABI failure {status}:{self.code}") diff --git a/ffi/bindings/python/src/moonlight_triangulation/values.py b/ffi/bindings/python/src/moonlight_triangulation/values.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/src/moonlight_triangulation/values.py @@ -0,0 +1,57 @@ +from __future__ import annotations + +from dataclasses import dataclass +from enum import IntEnum +from fractions import Fraction + +from ._native_generated import ( + ML_MINKOWSKI_ADDITION, + ML_MINKOWSKI_CLOSING, + ML_MINKOWSKI_EROSION, + ML_MINKOWSKI_OPENING, + ML_REGION_BOUNDARY, + ML_REGION_EXTERIOR, + ML_REGION_INTERIOR, +) + +Point = tuple[float, float] +Triangle = tuple[int, int, int] + + +@dataclass(frozen=True) +class PolygonComponent: + outer: tuple[Point, ...] + holes: tuple[tuple[Point, ...], ...] = () + + +class RegionLocation(IntEnum): + EXTERIOR = ML_REGION_EXTERIOR + BOUNDARY = ML_REGION_BOUNDARY + INTERIOR = ML_REGION_INTERIOR + + +class MinkowskiOperation(IntEnum): + ADDITION = ML_MINKOWSKI_ADDITION + EROSION = ML_MINKOWSKI_EROSION + OPENING = ML_MINKOWSKI_OPENING + CLOSING = ML_MINKOWSKI_CLOSING + + +@dataclass(frozen=True) +class RegionValuations: + euler_characteristic: int + area: Fraction + perimeter_bounds: tuple[float, float] + + +@dataclass(frozen=True) +class MinkowskiReceipt: + operation: MinkowskiOperation + input_components: int + convex_pieces: int + generated_pieces: int + generated_convolution_edges: int + overlay_passes: int + exact_crossings: int + output_cells: int + exact_coordinate_bit_growth: int diff --git a/ffi/bindings/python/tests/test_binding.py b/ffi/bindings/python/tests/test_binding.py new file mode 100644 --- /dev/null +++ b/ffi/bindings/python/tests/test_binding.py @@ -0,0 +1,119 @@ +from __future__ import annotations + +import math +import os +import unittest +from collections.abc import Sequence +from concurrent.futures import ThreadPoolExecutor +from fractions import Fraction +from typing import ClassVar + +from moonlight_triangulation import ( + MinkowskiOperation, + Moonlight, + MoonlightError, + PolygonComponent, + RegionLocation, +) + + +class LengthInflatingPoints(Sequence[tuple[float, float]]): + def __len__(self) -> int: + return 1_000 + + def __getitem__(self, index: int) -> tuple[float, float]: + if index == 0: + return (0.0, 0.0) + raise IndexError(index) + + +class MoonlightBindingTest(unittest.TestCase): + engine: ClassVar[Moonlight] + + @classmethod + def setUpClass(cls) -> None: + cls.engine = Moonlight(os.environ["MOONLIGHT_TRIANGULATION_LIBRARY"]) + + def test_immutable_site_set_algebra_and_dense_projection(self) -> None: + left = self.engine.delaunay([(0, 0), (2, 0), (0, 2), (2, 2)]) + right = self.engine.delaunay([(2, 0), (4, 0), (2, 2), (4, 2)]) + union = left.site_union(right) + intersection = left.site_intersection(right) + difference = left.site_difference(right) + symmetric = left.site_symmetric_difference(right) + extended = left.insert_many([(1, 1), (3, 1)]) + self.addCleanup(left.dispose) + self.addCleanup(right.dispose) + self.addCleanup(union.dispose) + self.addCleanup(intersection.dispose) + self.addCleanup(difference.dispose) + self.addCleanup(symmetric.dispose) + self.addCleanup(extended.dispose) + + self.assertEqual(left.vertex_count, 4) + self.assertEqual(union.vertex_count, 6) + self.assertEqual(intersection.vertex_count, 2) + self.assertEqual(difference.vertex_count, 2) + self.assertEqual(symmetric.vertex_count, 4) + self.assertEqual(extended.vertex_count, 6) + self.assertEqual(len(left.vertices), left.vertex_count) + self.assertEqual(len(left.triangles), left.triangle_count) + self.assertTrue(all(max(triangle) < left.vertex_count for triangle in left.triangles)) + + def test_exact_region_boolean_valuation_and_morphology(self) -> None: + left = self.engine.region([PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2)))]) + right = self.engine.region([PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2)))]) + intersection = left.intersection(right) + difference = left.difference(right) + symmetric = left.symmetric_difference(right) + kernel = self.engine.structuring_element(((-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5))) + offset, receipt = left.offset(kernel) + self.addCleanup(left.dispose) + self.addCleanup(right.dispose) + self.addCleanup(intersection.dispose) + self.addCleanup(difference.dispose) + self.addCleanup(symmetric.dispose) + self.addCleanup(kernel.dispose) + self.addCleanup(offset.dispose) + + self.assertEqual(len(left.components), 1) + self.assertEqual(len(left.components[0].outer), 4) + self.assertEqual(intersection.valuations.area, Fraction(2, 1)) + self.assertEqual(difference.valuations.euler_characteristic, 1) + self.assertEqual(symmetric.valuations.euler_characteristic, 2) + self.assertEqual(left.locate((1, 1)), RegionLocation.INTERIOR) + self.assertEqual(left.locate((0, 1)), RegionLocation.BOUNDARY) + self.assertEqual(left.locate((3, 1)), RegionLocation.EXTERIOR) + self.assertEqual(offset.valuations.area, Fraction(9, 1)) + self.assertEqual(receipt.operation, MinkowskiOperation.ADDITION) + self.assertGreaterEqual(receipt.generated_pieces, 1) + + def test_invalid_coordinate_preserves_typed_witness(self) -> None: + with self.assertRaises(MoonlightError) as raised: + self.engine.delaunay([(0, 0), (math.nan, 1), (1, 0)]) + self.assertEqual(raised.exception.status, 4) + self.assertEqual(raised.exception.code, 1) + self.assertEqual(raised.exception.coordinate_error, 1) + self.assertEqual(raised.exception.input_index, 1) + + def test_native_count_descends_from_materialized_coordinates(self) -> None: + mesh = self.engine.delaunay(LengthInflatingPoints()) + self.addCleanup(mesh.dispose) + self.assertEqual(mesh.vertex_count, 1) + + def test_explicit_empty_library_path_is_not_an_environment_fallback(self) -> None: + with self.assertRaisesRegex(ValueError, "must not be empty"): + Moonlight("") + + def test_owned_handles_are_thread_affine(self) -> None: + mesh = self.engine.delaunay([(0, 0), (1, 0), (0, 1)]) + self.addCleanup(mesh.dispose) + with ThreadPoolExecutor(max_workers=1) as executor: + foreign_access = executor.submit(lambda: mesh.vertex_count) + with self.assertRaisesRegex(RuntimeError, "belongs to another thread"): + foreign_access.result() + self.assertEqual(mesh.vertex_count, 3) + + +if __name__ == "__main__": + unittest.main() diff --git a/ffi/bindings/rust/Cargo.toml b/ffi/bindings/rust/Cargo.toml new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/Cargo.toml @@ -0,0 +1,14 @@ +[package] +name = "moonlight-triangulation" +version = "2.0.0" +edition = "2024" +license = "MIT" +description = "Rust bindings for Moonlight exact regions and immutable Delaunay meshes." +repository = "https://github.com/PaleRoses/moonlight.git" +build = "build.rs" +links = "moonlight-triangulation-c" + +[lib] +path = "src/lib.rs" + +[workspace] diff --git a/ffi/bindings/rust/build.rs b/ffi/bindings/rust/build.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/build.rs @@ -0,0 +1,11 @@ +use std::env; + +fn main() { + println!("cargo:rerun-if-env-changed=MOONLIGHT_TRIANGULATION_LIB_DIR"); + if let Some(directory) = env::var_os("MOONLIGHT_TRIANGULATION_LIB_DIR") { + println!( + "cargo:rustc-link-search=native={}", + directory.to_string_lossy() + ); + } +} diff --git a/ffi/bindings/rust/src/binding.rs b/ffi/bindings/rust/src/binding.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/src/binding.rs @@ -0,0 +1,646 @@ +use std::marker::PhantomData; +use std::ptr::NonNull; +use std::rc::Rc; + +use crate::error::{ + MoonlightError, WireVocabulary, invalid_native_result, projection_shape_error, status_result, + success_without_handle_error, +}; +use crate::raw_generated::{ + ABI_VERSION, ML_MINKOWSKI_ADDITION, ML_MINKOWSKI_CLOSING, ML_MINKOWSKI_EROSION, + ML_MINKOWSKI_OPENING, ML_OBSTRUCTION_BUFFER_TOO_SMALL, ML_REGION_BOUNDARY, ML_REGION_EXTERIOR, + ML_REGION_INTERIOR, ML_STATUS_BUFFER_TOO_SMALL, ML_STATUS_OK, NativeMesh, + NativeMinkowskiReceipt, NativeObstruction, NativeRegion, NativeStructuringElement, + ml_abi_version, ml_delaunay_f64, ml_mesh_copy_triangles_u32, ml_mesh_copy_vertices_f64, + ml_mesh_free, ml_mesh_insert_many_f64, ml_mesh_site_difference, ml_mesh_site_intersection, + ml_mesh_site_symmetric_difference, ml_mesh_site_union, ml_mesh_triangle_count, + ml_mesh_vertex_count, ml_region_close, ml_region_copy_f64, ml_region_counts, + ml_region_create_f64, ml_region_difference, ml_region_free, ml_region_inset, + ml_region_intersection, ml_region_locate_point_f64, ml_region_measure, ml_region_minkowski_sum, + ml_region_offset, ml_region_open, ml_region_symmetric_difference, ml_region_union, + ml_runtime_initialize, ml_structuring_element_create_f64, ml_structuring_element_free, +}; +use crate::values::{ + ExactRational, MinkowskiOperation, MinkowskiReceipt, PolygonComponent, RegionLocation, + RegionValuations, +}; + +pub struct Moonlight; + +impl Moonlight { + pub fn initialize() -> Result { + let status = unsafe { ml_runtime_initialize() }; + if status != ML_STATUS_OK { + return Err(MoonlightError::RuntimeInitializationRefused { status }); + } + let version = unsafe { ml_abi_version() }; + if version != ABI_VERSION { + return Err(MoonlightError::AbiVersionMismatch { + expected: ABI_VERSION, + observed: version, + }); + } + Ok(Self) + } + + pub fn delaunay(&self, points: &[[f64; 2]]) -> Result { + let coordinates = flatten_points(points); + create_handle(|output, obstruction| unsafe { + ml_delaunay_f64(coordinates.as_ptr(), points.len(), output, obstruction) + }) + .map(Mesh::from_handle) + } + + pub fn region(&self, components: &[PolygonComponent]) -> Result { + 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 { + handle: NonNull, + _thread_affinity: PhantomData>, +} + +impl Mesh { + fn from_handle(handle: NonNull) -> Self { + Self { + handle, + _thread_affinity: PhantomData, + } + } + + pub fn vertex_count(&self) -> Result { + self.count(|count, obstruction| unsafe { + ml_mesh_vertex_count(self.handle.as_ptr(), count, obstruction) + }) + } + + pub fn triangle_count(&self) -> Result { + self.count(|count, obstruction| unsafe { + ml_mesh_triangle_count(self.handle.as_ptr(), count, obstruction) + }) + } + + pub fn vertices(&self) -> Result, MoonlightError> { + let count = self.vertex_count()?; + let mut coordinates = vec![0.0; count * 2]; + let mut written = 0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_mesh_copy_vertices_f64( + self.handle.as_ptr(), + coordinates.as_mut_ptr(), + count, + &mut written, + &mut obstruction, + ) + }; + status_result(status, obstruction)?; + coordinates.truncate(written * 2); + coordinate_pairs(&coordinates) + } + + pub fn triangles(&self) -> Result, MoonlightError> { + let count = self.triangle_count()?; + let mut triangles = vec![0; count * 3]; + let mut written = 0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_mesh_copy_triangles_u32( + self.handle.as_ptr(), + triangles.as_mut_ptr(), + count, + &mut written, + &mut obstruction, + ) + }; + status_result(status, obstruction)?; + triangles.truncate(written * 3); + triangles + .chunks_exact(3) + .map(|triangle| { + Ok([ + *triangle.first().ok_or_else(projection_shape_error)?, + *triangle.get(1).ok_or_else(projection_shape_error)?, + *triangle.get(2).ok_or_else(projection_shape_error)?, + ]) + }) + .collect() + } + + pub fn insert_many(&self, points: &[[f64; 2]]) -> Result { + let coordinates = flatten_points(points); + create_handle(|output, obstruction| unsafe { + ml_mesh_insert_many_f64( + self.handle.as_ptr(), + coordinates.as_ptr(), + points.len(), + output, + obstruction, + ) + }) + .map(Self::from_handle) + } + + pub fn site_union(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_mesh_site_union( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn site_intersection(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_mesh_site_intersection( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn site_difference(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_mesh_site_difference( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn site_symmetric_difference(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_mesh_site_symmetric_difference( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + fn binary( + &self, + operation: impl FnOnce(*mut *mut NativeMesh, *mut NativeObstruction) -> u32, + ) -> Result { + create_handle(operation).map(Self::from_handle) + } + + fn count( + &self, + operation: impl FnOnce(*mut usize, *mut NativeObstruction) -> u32, + ) -> Result { + let mut count = 0; + let mut obstruction = NativeObstruction::default(); + let status = operation(&mut count, &mut obstruction); + status_result(status, obstruction)?; + Ok(count) + } +} + +impl Drop for Mesh { + fn drop(&mut self) { + unsafe { ml_mesh_free(self.handle.as_ptr()) } + } +} + +pub struct Region { + handle: NonNull, + _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(|output, obstruction| unsafe { + ml_region_union( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn intersection(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_region_intersection( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn difference(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_region_difference( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn symmetric_difference(&self, other: &Self) -> Result { + self.binary(|output, obstruction| unsafe { + ml_region_symmetric_difference( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + } + + pub fn minkowski_sum(&self, other: &Self) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + produce_morphology(|output, receipt, obstruction| unsafe { + ml_region_minkowski_sum( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + receipt, + obstruction, + ) + }) + } + + pub fn offset( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element( + element, + |element, region, output, receipt, obstruction| unsafe { + ml_region_offset(element, region, output, receipt, obstruction) + }, + ) + } + + pub fn inset( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element( + element, + |element, region, output, receipt, obstruction| unsafe { + ml_region_inset(element, region, output, receipt, obstruction) + }, + ) + } + + pub fn open( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element( + element, + |element, region, output, receipt, obstruction| unsafe { + ml_region_open(element, region, output, receipt, obstruction) + }, + ) + } + + pub fn close( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element( + element, + |element, region, output, receipt, obstruction| unsafe { + ml_region_close(element, region, output, receipt, obstruction) + }, + ) + } + + fn binary( + &self, + operation: impl FnOnce(*mut *mut NativeRegion, *mut NativeObstruction) -> u32, + ) -> Result { + create_handle(operation).map(Self::from_handle) + } + + fn with_element( + &self, + element: &StructuringElement, + operation: impl FnOnce( + *const NativeStructuringElement, + *const NativeRegion, + *mut *mut NativeRegion, + *mut NativeMinkowskiReceipt, + *mut NativeObstruction, + ) -> u32, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + produce_morphology(|output, receipt, obstruction| { + operation( + element.handle.as_ptr(), + self.handle.as_ptr(), + output, + receipt, + obstruction, + ) + }) + } + + fn counts(&self) -> Result<(usize, usize, usize), MoonlightError> { + let mut component_count = 0; + let mut loop_count = 0; + let mut point_count = 0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_counts( + self.handle.as_ptr(), + &mut component_count, + &mut loop_count, + &mut point_count, + &mut obstruction, + ) + }; + status_result(status, obstruction)?; + Ok((component_count, loop_count, point_count)) + } + + fn measure_with_capacity(&self, capacity: usize) -> Result { + let mut euler_characteristic = 0; + let mut area_ratio = vec![0; capacity]; + let mut area_bytes_written = 0; + let mut perimeter_lower = 0.0; + let mut perimeter_upper = 0.0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_measure( + self.handle.as_ptr(), + &mut euler_characteristic, + area_ratio.as_mut_ptr(), + capacity, + &mut area_bytes_written, + &mut perimeter_lower, + &mut perimeter_upper, + &mut obstruction, + ) + }; + if status == ML_STATUS_BUFFER_TOO_SMALL + && obstruction.code == ML_OBSTRUCTION_BUFFER_TOO_SMALL + { + return self.measure_with_capacity(area_bytes_written + 1); + } + status_result(status, obstruction)?; + let area_bytes = area_ratio + .get(..area_bytes_written) + .ok_or_else(projection_shape_error)? + .iter() + .map(|byte| *byte as u8) + .collect::>(); + let area_text = String::from_utf8(area_bytes).map_err(|failure| { + invalid_native_result(format!( + "Moonlight returned a non-UTF-8 exact-area ratio: {failure}" + )) + })?; + let (numerator, denominator) = area_text.split_once('/').ok_or_else(|| { + invalid_native_result("Moonlight returned a malformed exact-area ratio") + })?; + Ok(RegionValuations { + euler_characteristic, + area: ExactRational { + numerator: numerator.to_owned(), + denominator: denominator.to_owned(), + }, + perimeter_bounds: [perimeter_lower, perimeter_upper], + }) + } +} + +impl Drop for Region { + fn drop(&mut self) { + unsafe { ml_region_free(self.handle.as_ptr()) } + } +} + +pub struct StructuringElement { + handle: NonNull, + _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() +} + +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).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 { + ML_MINKOWSKI_ADDITION => Ok(MinkowskiOperation::Addition), + ML_MINKOWSKI_EROSION => Ok(MinkowskiOperation::Erosion), + ML_MINKOWSKI_OPENING => Ok(MinkowskiOperation::Opening), + ML_MINKOWSKI_CLOSING => Ok(MinkowskiOperation::Closing), + _ => Err(MoonlightError::UnknownWireValue { + vocabulary: WireVocabulary::MinkowskiOperation, + value: code, + }), + } +} + +fn region_location(code: u32) -> Result { + match code { + ML_REGION_EXTERIOR => Ok(RegionLocation::Exterior), + ML_REGION_BOUNDARY => Ok(RegionLocation::Boundary), + ML_REGION_INTERIOR => Ok(RegionLocation::Interior), + _ => Err(MoonlightError::UnknownWireValue { + vocabulary: WireVocabulary::RegionLocation, + value: code, + }), + } +} diff --git a/ffi/bindings/rust/src/error.rs b/ffi/bindings/rust/src/error.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/src/error.rs @@ -0,0 +1,150 @@ +use std::error::Error; +use std::fmt::{Display, Formatter}; + +use crate::raw_generated::{ML_STATUS_OK, NativeObstruction}; + +#[derive(Debug, Clone, PartialEq)] +pub enum MoonlightError { + RuntimeInitializationRefused { + status: u32, + }, + AbiVersionMismatch { + expected: u32, + observed: u32, + }, + AbiObstruction(AbiObstruction), + InvalidNativeResult { + message: String, + }, + UnknownWireValue { + vocabulary: WireVocabulary, + value: u32, + }, +} + +#[derive(Debug, Clone, PartialEq)] +pub struct AbiObstruction { + pub status: u32, + pub code: u32, + pub coordinate_error: u32, + pub input_index: u64, + pub first_index: u64, + pub second_index: u64, + pub first_value: f64, + pub second_value: f64, + pub point: [f64; 2], + pub message: String, +} + +#[derive(Debug, Clone, Copy, PartialEq, Eq)] +pub enum WireVocabulary { + RegionLocation, + MinkowskiOperation, +} + +impl Display for MoonlightError { + fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result { + match self { + Self::RuntimeInitializationRefused { status } => { + write!( + formatter, + "Moonlight runtime initialization refused with status {status}" + ) + } + Self::AbiVersionMismatch { expected, observed } => write!( + formatter, + "Moonlight ABI {observed} is incompatible with expected ABI {expected}" + ), + Self::AbiObstruction(obstruction) => write!(formatter, "{obstruction}"), + Self::InvalidNativeResult { message } => write!(formatter, "{message}"), + Self::UnknownWireValue { vocabulary, value } => { + write!( + formatter, + "Moonlight returned unknown {vocabulary} value {value}" + ) + } + } + } +} + +impl Display for AbiObstruction { + fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result { + if self.message.is_empty() { + write!( + formatter, + "Moonlight ABI failure {}:{}", + self.status, self.code + ) + } else { + write!(formatter, "{}", self.message) + } + } +} + +impl Display for WireVocabulary { + fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result { + match self { + Self::RegionLocation => write!(formatter, "region-location"), + Self::MinkowskiOperation => write!(formatter, "minkowski-operation"), + } + } +} + +impl Error for MoonlightError {} + +pub(crate) fn status_result( + status: u32, + obstruction: NativeObstruction, +) -> Result<(), MoonlightError> { + if status == ML_STATUS_OK { + Ok(()) + } else { + Err(MoonlightError::AbiObstruction(AbiObstruction::from_native( + status, + obstruction, + ))) + } +} + +impl AbiObstruction { + fn from_native(status: u32, obstruction: NativeObstruction) -> Self { + let message_end = obstruction + .message + .iter() + .position(|character| *character == 0) + .unwrap_or(obstruction.message.len()); + let message_bytes = obstruction + .message + .get(..message_end) + .unwrap_or_default() + .iter() + .map(|character| *character as u8) + .collect::>(); + Self { + status, + code: obstruction.code, + coordinate_error: obstruction.coordinate_error, + input_index: obstruction.input_index, + first_index: obstruction.first_index, + second_index: obstruction.second_index, + first_value: obstruction.first_value, + second_value: obstruction.second_value, + point: [obstruction.point_x, obstruction.point_y], + message: String::from_utf8_lossy(&message_bytes).into_owned(), + } + } +} + +pub(crate) fn projection_shape_error() -> MoonlightError { + invalid_native_result("Moonlight returned a malformed bulk projection") +} + +pub(crate) fn success_without_handle_error() -> MoonlightError { + invalid_native_result("Moonlight returned success without a handle") +} + +pub(crate) fn invalid_native_result(message: impl Into) -> MoonlightError { + MoonlightError::InvalidNativeResult { + message: message.into(), + } +} diff --git a/ffi/bindings/rust/src/lib.rs b/ffi/bindings/rust/src/lib.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/src/lib.rs @@ -0,0 +1,11 @@ +mod binding; +mod error; +mod raw_generated; +mod values; + +pub use binding::{Mesh, Moonlight, Region, StructuringElement}; +pub use error::{AbiObstruction, MoonlightError, WireVocabulary}; +pub use values::{ + ExactRational, MinkowskiOperation, MinkowskiReceipt, PolygonComponent, RegionLocation, + RegionValuations, +}; diff --git a/ffi/bindings/rust/src/raw_generated.rs b/ffi/bindings/rust/src/raw_generated.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/src/raw_generated.rs @@ -0,0 +1,361 @@ +// Generated from Moonlight.Triangulation.Foreign.Contract. +// Run moonlight-triangulation-ffi-contract write; do not edit this file. + +// This private module is the complete wire projection; wrappers consume a subset. +#![allow(dead_code)] + +use std::ffi::{c_char, c_double, c_uint}; + +pub(crate) const ABI_VERSION: u32 = 2; +pub(crate) const ML_STATUS_OK: u32 = 0; +pub(crate) const ML_STATUS_NULL_POINTER: u32 = 1; +pub(crate) const ML_STATUS_COUNT_OVERFLOW: u32 = 2; +pub(crate) const ML_STATUS_BUFFER_TOO_SMALL: u32 = 3; +pub(crate) const ML_STATUS_GEOMETRY_OBSTRUCTION: u32 = 4; +pub(crate) const ML_STATUS_RUNTIME_FAILURE: u32 = 5; +pub(crate) const ML_OBSTRUCTION_NONE: u32 = 0; +pub(crate) const ML_OBSTRUCTION_INVALID_COORDINATE: u32 = 1; +pub(crate) const ML_OBSTRUCTION_POINT_LOCATION_FAILED: u32 = 2; +pub(crate) const ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED: u32 = 3; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID: u32 = 4; +pub(crate) const ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX: u32 = 5; +pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING: u32 = 6; +pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING: u32 = 7; +pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING: u32 = 8; +pub(crate) const ML_OBSTRUCTION_HULL_START_NOT_VISIBLE: u32 = 9; +pub(crate) const ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE: u32 = 10; +pub(crate) const ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE: u32 = 11; +pub(crate) const ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED: u32 = 12; +pub(crate) const ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE: u32 = 13; +pub(crate) const ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE: u32 = 14; +pub(crate) const ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE: u32 = 15; +pub(crate) const ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE: u32 = 16; +pub(crate) const ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION: u32 = 17; +pub(crate) const ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH: u32 = 18; +pub(crate) const ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH: u32 = 19; +pub(crate) const ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT: u32 = 20; +pub(crate) const ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH: u32 = 21; +pub(crate) const ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE: u32 = 22; +pub(crate) const ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY: u32 = 23; +pub(crate) const ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE: u32 = 24; +pub(crate) const ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH: u32 = 25; +pub(crate) const ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH: u32 = 26; +pub(crate) const ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED: u32 = 27; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE: u32 = 28; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE: u32 = 29; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE: u32 = 30; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE: u32 = 31; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE: u32 = 32; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE: u32 = 33; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE: u32 = 34; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE: u32 = 35; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE: u32 = 36; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE: u32 = 37; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM: u32 = 38; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE: u32 = 39; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE: u32 = 40; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING: u32 = 41; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS: u32 = 42; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED: u32 = 43; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION: u32 = 44; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION: u32 = 45; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION: u32 = 46; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE: u32 = 47; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE: u32 = 48; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED: u32 = 49; +pub(crate) const ML_OBSTRUCTION_CAPACITY_EXCEEDED: u32 = 50; +pub(crate) const ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED: u32 = 51; +pub(crate) const ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED: u32 = 52; +pub(crate) const ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE: u32 = 53; +pub(crate) const ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH: u32 = 54; +pub(crate) const ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE: u32 = 55; +pub(crate) const ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE: u32 = 56; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET: u32 = 57; +pub(crate) const ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP: u32 = 58; +pub(crate) const ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED: u32 = 59; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE: u32 = 60; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE: u32 = 61; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE: u32 = 62; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED: u32 = 63; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED: u32 = 64; +pub(crate) const ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE: u32 = 65; +pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED: u32 = 66; +pub(crate) const ML_OBSTRUCTION_NULL_POINTER: u32 = 100; +pub(crate) const ML_OBSTRUCTION_COUNT_OVERFLOW: u32 = 101; +pub(crate) const ML_OBSTRUCTION_BUFFER_TOO_SMALL: u32 = 102; +pub(crate) const ML_OBSTRUCTION_RUNTIME_FAILURE: u32 = 103; +pub(crate) const ML_OBSTRUCTION_REGION_LAYOUT_INVALID: u32 = 200; +pub(crate) const ML_OBSTRUCTION_REGION_VALIDATION_FAILED: u32 = 201; +pub(crate) const ML_OBSTRUCTION_OVERLAY_FAILED: u32 = 202; +pub(crate) const ML_OBSTRUCTION_REGION_PUBLICATION_FAILED: u32 = 203; +pub(crate) const ML_OBSTRUCTION_VALUATION_FAILED: u32 = 204; +pub(crate) const ML_OBSTRUCTION_MINKOWSKI_FAILED: u32 = 205; +pub(crate) const ML_OBSTRUCTION_REGION_PROJECTION_FAILED: u32 = 206; +pub(crate) const ML_COORDINATE_ERROR_NONE: u32 = 0; +pub(crate) const ML_COORDINATE_ERROR_NAN: u32 = 1; +pub(crate) const ML_COORDINATE_ERROR_INFINITE: u32 = 2; +pub(crate) const ML_COORDINATE_ERROR_TOO_SMALL: u32 = 3; +pub(crate) const ML_COORDINATE_ERROR_TOO_LARGE: u32 = 4; +pub(crate) const ML_REGION_EXTERIOR: u32 = 0; +pub(crate) const ML_REGION_BOUNDARY: u32 = 1; +pub(crate) const ML_REGION_INTERIOR: u32 = 2; +pub(crate) const ML_MINKOWSKI_ADDITION: u32 = 0; +pub(crate) const ML_MINKOWSKI_EROSION: u32 = 1; +pub(crate) const ML_MINKOWSKI_OPENING: u32 = 2; +pub(crate) const ML_MINKOWSKI_CLOSING: u32 = 3; + +#[repr(C)] +pub(crate) struct NativeMesh { + _private: [u8; 0], +} + +#[repr(C)] +pub(crate) struct NativeRegion { + _private: [u8; 0], +} + +#[repr(C)] +pub(crate) struct NativeStructuringElement { + _private: [u8; 0], +} + +#[repr(C)] +pub(crate) struct NativeObstruction { + pub(crate) code: u32, + pub(crate) coordinate_error: u32, + pub(crate) input_index: u64, + pub(crate) first_index: u64, + pub(crate) second_index: u64, + pub(crate) first_value: f64, + pub(crate) second_value: f64, + pub(crate) point_x: f64, + pub(crate) point_y: f64, + pub(crate) message: [c_char; 256], +} + +impl Default for NativeObstruction { + fn default() -> Self { + Self { + code: 0, + coordinate_error: 0, + input_index: 0, + first_index: 0, + second_index: 0, + first_value: 0.0, + second_value: 0.0, + point_x: 0.0, + point_y: 0.0, + message: [0; 256], + } + } +} + +#[repr(C)] +pub(crate) struct NativeMinkowskiReceipt { + pub(crate) operation: u32, + pub(crate) reserved: u32, + pub(crate) input_components: u64, + pub(crate) convex_pieces: u64, + pub(crate) generated_pieces: u64, + pub(crate) generated_convolution_edges: u64, + pub(crate) overlay_passes: u64, + pub(crate) exact_crossings: u64, + pub(crate) output_cells: u64, + pub(crate) exact_coordinate_bit_growth: u64, +} + +impl Default for NativeMinkowskiReceipt { + fn default() -> Self { + Self { + operation: 0, + reserved: 0, + input_components: 0, + convex_pieces: 0, + generated_pieces: 0, + generated_convolution_edges: 0, + overlay_passes: 0, + exact_crossings: 0, + output_cells: 0, + exact_coordinate_bit_growth: 0, + } + } +} + +#[link(name = "moonlight-triangulation-c")] +unsafe extern "C" { + pub(crate) fn ml_abi_version() -> c_uint; + pub(crate) fn ml_runtime_initialize() -> c_uint; + pub(crate) fn ml_delaunay_f64( + coordinates: *const c_double, + point_count: usize, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_insert_many_f64( + mesh: *const NativeMesh, + coordinates: *const c_double, + point_count: usize, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_site_union( + left: *const NativeMesh, + right: *const NativeMesh, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_site_intersection( + left: *const NativeMesh, + right: *const NativeMesh, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_site_difference( + left: *const NativeMesh, + right: *const NativeMesh, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_site_symmetric_difference( + left: *const NativeMesh, + right: *const NativeMesh, + result: *mut *mut NativeMesh, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_vertex_count( + mesh: *const NativeMesh, + count: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_triangle_count( + mesh: *const NativeMesh, + count: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_copy_vertices_f64( + mesh: *const NativeMesh, + coordinates: *mut c_double, + point_capacity: usize, + points_written: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_copy_triangles_u32( + mesh: *const NativeMesh, + triangles: *mut u32, + triangle_capacity: usize, + triangles_written: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_mesh_free(mesh: *mut NativeMesh); + pub(crate) fn ml_region_create_f64( + coordinates: *const c_double, + point_count: usize, + loop_point_counts: *const usize, + loop_count: usize, + component_loop_counts: *const usize, + component_count: usize, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_counts( + region: *const NativeRegion, + component_count: *mut usize, + loop_count: *mut usize, + point_count: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_copy_f64( + region: *const NativeRegion, + coordinates: *mut c_double, + point_capacity: usize, + loop_point_offsets: *mut usize, + loop_offset_capacity: usize, + component_loop_offsets: *mut usize, + component_offset_capacity: usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_union( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_intersection( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_difference( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_symmetric_difference( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_locate_point_f64( + region: *const NativeRegion, + x: c_double, + y: c_double, + location: *mut u32, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_measure( + region: *const NativeRegion, + euler_characteristic: *mut i64, + area_ratio_utf8: *mut c_char, + area_capacity: usize, + area_bytes_written: *mut usize, + perimeter_lower: *mut c_double, + perimeter_upper: *mut c_double, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_free(region: *mut NativeRegion); + pub(crate) fn ml_structuring_element_create_f64( + coordinates: *const c_double, + point_count: usize, + result: *mut *mut NativeStructuringElement, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_structuring_element_free(element: *mut NativeStructuringElement); + pub(crate) fn ml_region_minkowski_sum( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_offset( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_inset( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_open( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + pub(crate) fn ml_region_close( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; +} diff --git a/ffi/bindings/rust/src/values.rs b/ffi/bindings/rust/src/values.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/src/values.rs @@ -0,0 +1,46 @@ +#[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, +} diff --git a/ffi/bindings/rust/tests/binding.rs b/ffi/bindings/rust/tests/binding.rs new file mode 100644 --- /dev/null +++ b/ffi/bindings/rust/tests/binding.rs @@ -0,0 +1,119 @@ +use moonlight_triangulation::{ + ExactRational, MinkowskiOperation, Moonlight, MoonlightError, PolygonComponent, RegionLocation, +}; + +#[test] +fn immutable_site_set_algebra_and_dense_projection() { + let engine = Moonlight::initialize().expect("runtime"); + let left = engine + .delaunay(&[[0.0, 0.0], [2.0, 0.0], [0.0, 2.0], [2.0, 2.0]]) + .expect("left mesh"); + let right = engine + .delaunay(&[[2.0, 0.0], [4.0, 0.0], [2.0, 2.0], [4.0, 2.0]]) + .expect("right mesh"); + let union = left.site_union(&right).expect("site union"); + let intersection = left.site_intersection(&right).expect("site intersection"); + let difference = left.site_difference(&right).expect("site difference"); + let symmetric = left + .site_symmetric_difference(&right) + .expect("site symmetric difference"); + let extended = left + .insert_many(&[[1.0, 1.0], [3.0, 1.0]]) + .expect("batch insertion"); + + assert_eq!(left.vertex_count().expect("left count"), 4); + assert_eq!(union.vertex_count().expect("union count"), 6); + assert_eq!(intersection.vertex_count().expect("intersection count"), 2); + assert_eq!(difference.vertex_count().expect("difference count"), 2); + assert_eq!(symmetric.vertex_count().expect("symmetric count"), 4); + assert_eq!(extended.vertex_count().expect("extended count"), 6); + assert_eq!( + left.vertices().expect("vertices").len(), + left.vertex_count().expect("vertex count") + ); + assert_eq!( + left.triangles().expect("triangles").len(), + left.triangle_count().expect("triangle count") + ); +} + +#[test] +fn exact_region_boolean_valuation_and_morphology() { + let engine = Moonlight::initialize().expect("runtime"); + let left = engine + .region(&[PolygonComponent { + outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]], + holes: vec![], + }]) + .expect("left region"); + let right = engine + .region(&[PolygonComponent { + outer: vec![[1.0, 0.0], [3.0, 0.0], [3.0, 2.0], [1.0, 2.0]], + holes: vec![], + }]) + .expect("right region"); + let intersection = left.intersection(&right).expect("intersection"); + let symmetric = left + .symmetric_difference(&right) + .expect("symmetric difference"); + let kernel = engine + .structuring_element(&[[-0.5, -0.5], [0.5, -0.5], [0.5, 0.5], [-0.5, 0.5]]) + .expect("structuring element"); + let (offset, receipt) = left.offset(&kernel).expect("offset"); + + assert_eq!(left.components().expect("components").len(), 1); + assert_eq!( + intersection + .valuations() + .expect("intersection valuation") + .area, + ExactRational { + numerator: "2".to_owned(), + denominator: "1".to_owned(), + } + ); + assert_eq!( + symmetric + .valuations() + .expect("symmetric valuation") + .euler_characteristic, + 2 + ); + assert_eq!( + left.locate([1.0, 1.0]).expect("interior"), + RegionLocation::Interior + ); + assert_eq!( + left.locate([0.0, 1.0]).expect("boundary"), + RegionLocation::Boundary + ); + assert_eq!( + left.locate([3.0, 1.0]).expect("exterior"), + RegionLocation::Exterior + ); + assert_eq!( + offset.valuations().expect("offset valuation").area, + ExactRational { + numerator: "9".to_owned(), + denominator: "1".to_owned(), + } + ); + assert_eq!(receipt.operation, MinkowskiOperation::Addition); + assert!(receipt.generated_pieces >= 1); +} + +#[test] +fn invalid_coordinate_preserves_typed_witness() { + let engine = Moonlight::initialize().expect("runtime"); + let failure = engine + .delaunay(&[[0.0, 0.0], [f64::NAN, 1.0], [1.0, 0.0]]) + .err() + .expect("invalid coordinate refusal"); + let MoonlightError::AbiObstruction(obstruction) = failure else { + panic!("expected an ABI obstruction"); + }; + assert_eq!(obstruction.status, 4); + assert_eq!(obstruction.code, 1); + assert_eq!(obstruction.coordinate_error, 1); + assert_eq!(obstruction.input_index, 1); +} diff --git a/ffi/bindings/typescript/README.md b/ffi/bindings/typescript/README.md new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/README.md @@ -0,0 +1,44 @@ +# `@moonlight/triangulation` + +[Read the shared ABI contract.](../README.md#abi-version-2) + +Typed TypeScript access to Moonlight's immutable Delaunay meshes, exact planar +regions, and polygonal morphology. The package owns JavaScript resource +lifetime and error terms; the generated raw declarations descend from the same +Haskell contract as the C header, Python declarations, and Rust declarations. + +This source package does not pretend to contain a native binary. Supply an +explicit path to the ABI-version-2 shared library: + +```typescript +import { + RegionLocation, + formatMoonlightFailure, + loadMoonlight, + type Result, +} from "@moonlight/triangulation"; + +const moonlight = loadMoonlight({ + kind: "path", + path: "/absolute/path/to/libmoonlight-triangulation-c.so", +}); + +if (!moonlight.ok) { + throw new Error(formatMoonlightFailure(moonlight.error)); +} + +const region = moonlight.value.region([ + { outer: [[0, 0], [2, 0], [2, 2], [0, 2]] }, +]); + +if (region.ok) { + const location: Result = region.value.locate([1, 1]); + region.value.dispose(); +} +``` + +Every operation that can be refused returns `Result`. +No raw Koffi handle, constructor capability, or numeric status code crosses the +package entrypoint. Owned meshes, regions, and structuring elements implement +both `dispose()` and `Symbol.dispose`; morphology therefore keeps the honest +domain method `region.close(element)`. diff --git a/ffi/bindings/typescript/package.json b/ffi/bindings/typescript/package.json new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/package.json @@ -0,0 +1,34 @@ +{ + "name": "@moonlight/triangulation", + "version": "2.0.0", + "description": "TypeScript bindings for Moonlight exact regions and immutable Delaunay meshes.", + "type": "module", + "main": "./dist/src/index.js", + "types": "./dist/src/index.d.ts", + "exports": { + ".": { + "types": "./dist/src/index.d.ts", + "import": "./dist/src/index.js" + } + }, + "files": [ + "dist/src", + "README.md" + ], + "scripts": { + "build": "tsc -p tsconfig.json", + "test": "node --test dist/test/binding.test.js" + }, + "engines": { + "node": ">=20" + }, + "dependencies": { + "koffi": "3.1.4" + }, + "devDependencies": { + "@types/node": "26.2.0", + "typescript": "7.0.2" + }, + "license": "MIT", + "packageManager": "pnpm@11.21.0" +} diff --git a/ffi/bindings/typescript/pnpm-workspace.yaml b/ffi/bindings/typescript/pnpm-workspace.yaml new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/pnpm-workspace.yaml @@ -0,0 +1,5 @@ +packages: + - . + +allowBuilds: + koffi: true diff --git a/ffi/bindings/typescript/src/failure.ts b/ffi/bindings/typescript/src/failure.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/failure.ts @@ -0,0 +1,111 @@ +import type { + AbiStatus, + CoordinateError, + ObstructionCode, +} from "./wire.generated.js"; + +import type { Point } from "./values.js"; + +export type Result = + | { readonly ok: true; readonly value: Value } + | { readonly ok: false; readonly error: Failure }; + +export interface Obstruction { + readonly status: AbiStatus; + readonly code: ObstructionCode; + readonly coordinateError: CoordinateError; + readonly inputIndex: bigint; + readonly firstIndex: bigint; + readonly secondIndex: bigint; + readonly firstValue: number; + readonly secondValue: number; + readonly point: Point; + readonly message: string; +} + +export type ResourceKind = "mesh" | "region" | "structuring-element"; + +export type MoonlightFailure = + | { + readonly kind: "native-library-unavailable"; + readonly path: string; + readonly message: string; + } + | { + readonly kind: "runtime-initialization-refused"; + readonly status: AbiStatus; + } + | { + readonly kind: "abi-version-mismatch"; + readonly expected: number; + readonly observed: number; + } + | { + readonly kind: "abi-obstruction"; + readonly obstruction: Obstruction; + } + | { + readonly kind: "disposed-resource"; + readonly resource: ResourceKind; + } + | { + readonly kind: "foreign-runtime"; + readonly resource: ResourceKind; + } + | { + readonly kind: "unsafe-integer"; + readonly value: bigint; + } + | { + readonly kind: "unknown-wire-value"; + readonly vocabulary: "status" | "obstruction" | "coordinate-error" | "region-location" | "minkowski-operation"; + readonly value: number; + } + | { + readonly kind: "invalid-native-result"; + readonly message: string; + } + | { + readonly kind: "native-call-failed"; + readonly message: string; + }; + +export function success(value: Value): Result { + return { ok: true, value }; +} + +export function failure(error: MoonlightFailure): Result { + return { ok: false, error }; +} + +export function collectResults(results: readonly Result[]): Result { + const refused = results.find((result) => !result.ok); + return refused?.ok === false + ? failure(refused.error) + : success(results.flatMap((result) => (result.ok ? [result.value] : []))); +} + +export function formatMoonlightFailure(error: MoonlightFailure): string { + switch (error.kind) { + case "native-library-unavailable": + return `cannot load Moonlight native library at ${error.path}: ${error.message}`; + case "runtime-initialization-refused": + return `Moonlight runtime initialization refused with ${error.status}`; + case "abi-version-mismatch": + return `Moonlight ABI ${error.observed} is incompatible with expected ABI ${error.expected}`; + case "abi-obstruction": + return error.obstruction.message || `${error.obstruction.status}: ${error.obstruction.code}`; + case "disposed-resource": + return `${error.resource} is disposed`; + case "foreign-runtime": + return `${error.resource} belongs to another Moonlight runtime`; + case "unsafe-integer": + return `Moonlight count ${error.value} exceeds JavaScript's safe integer range`; + case "unknown-wire-value": + return `Moonlight returned unknown ${error.vocabulary} value ${error.value}`; + case "invalid-native-result": + return error.message; + case "native-call-failed": + return error.message; + } +} diff --git a/ffi/bindings/typescript/src/index.ts b/ffi/bindings/typescript/src/index.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/index.ts @@ -0,0 +1,28 @@ +export type { + MoonlightFailure, + Obstruction, + ResourceKind, + Result, +} from "./failure.js"; +export { formatMoonlightFailure } from "./failure.js"; +export type { Mesh } from "./mesh.js"; +export type { Moonlight, NativeLibrarySource } from "./moonlight.js"; +export { loadMoonlight } from "./moonlight.js"; +export type { StructuringElement } from "./morphology.js"; +export type { MorphologyResult, Region } from "./region.js"; +export type { OwnedResource } from "./resource.js"; +export type { + ExactRational, + MinkowskiReceipt, + Point, + PolygonComponent, + RegionValuations, + Triangle, +} from "./values.js"; +export { + AbiStatus, + CoordinateError, + MinkowskiOperation, + ObstructionCode, + RegionLocation, +} from "./wire.generated.js"; diff --git a/ffi/bindings/typescript/src/internal/call.ts b/ffi/bindings/typescript/src/internal/call.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/internal/call.ts @@ -0,0 +1,83 @@ +import { failure, success, type Result } from "../failure.js"; +import type { MinkowskiReceipt, Point } from "../values.js"; +import { decodeMinkowskiReceipt, decodeStatus, nativeCallFailure } from "./decode.js"; +import type { + HandleOutput, + NativeHandle, + NativeMinkowskiReceipt, + NativeObstruction, +} from "./native.generated.js"; + +type HandleOperation = (output: HandleOutput, obstruction: NativeObstruction) => number; +type MorphologyOperation = ( + output: HandleOutput, + receipt: NativeMinkowskiReceipt, + obstruction: NativeObstruction, +) => number; + +export interface NativeMorphologyResult { + readonly handle: NativeHandle; + readonly receipt: MinkowskiReceipt; +} + +export function produceHandle(operation: HandleOperation): Result { + return captureNativeCall(() => { + const output: HandleOutput = [null]; + const obstruction: NativeObstruction = {}; + const status = decodeStatus(operation(output, obstruction), obstruction); + if (!status.ok) { + return status; + } + return requireHandle(output, "handle"); + }); +} + +export function produceMorphology(operation: MorphologyOperation): Result { + return captureNativeCall(() => { + const output: HandleOutput = [null]; + const receipt: NativeMinkowskiReceipt = {}; + const obstruction: NativeObstruction = {}; + const status = decodeStatus(operation(output, receipt, obstruction), obstruction); + if (!status.ok) { + return status; + } + const handle = requireHandle(output, "region handle"); + if (!handle.ok) { + return handle; + } + const decodedReceipt = decodeMinkowskiReceipt(receipt); + return decodedReceipt.ok + ? success({ handle: handle.value, receipt: decodedReceipt.value }) + : decodedReceipt; + }); +} + +export function callStatus(operation: (obstruction: NativeObstruction) => number): Result { + return captureNativeCall(() => { + const obstruction: NativeObstruction = {}; + return decodeStatus(operation(obstruction), obstruction); + }); +} + +export function captureNativeCall(operation: () => Result): Result { + try { + return operation(); + } catch (cause: unknown) { + return failure(nativeCallFailure(cause)); + } +} + +export function flattenPoints(points: readonly Point[]): Float64Array { + return Float64Array.from(points.flatMap(([x, y]) => [x, y])); +} + +export function flattenLoops(loops: readonly (readonly Point[])[]): Float64Array { + return Float64Array.from(loops.flatMap((loop) => loop.flatMap(([x, y]) => [x, y]))); +} + +function requireHandle(output: HandleOutput, description: string): Result { + const handle = output[0]; + return handle === null || handle === undefined + ? failure({ kind: "invalid-native-result", message: `Moonlight returned success without a ${description}` }) + : success(handle); +} diff --git a/ffi/bindings/typescript/src/internal/decode.ts b/ffi/bindings/typescript/src/internal/decode.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/internal/decode.ts @@ -0,0 +1,117 @@ +import { failure, success, type MoonlightFailure, type Obstruction, type Result } from "../failure.js"; +import type { MinkowskiReceipt, Point } from "../values.js"; +import { + decodeAbiStatus, + decodeCoordinateError, + decodeMinkowskiOperation, + decodeObstructionCode, + decodeRegionLocation, + type RegionLocation, +} from "../wire.generated.js"; +import { + ML_COORDINATE_ERROR_NONE, + ML_OBSTRUCTION_NONE, + ML_STATUS_OK, + type NativeInteger, + type NativeMinkowskiReceipt, + type NativeObstruction, +} from "./native.generated.js"; + +export function decodeStatus(status: number, obstruction: NativeObstruction): Result { + if (status === ML_STATUS_OK) { + return success(undefined); + } + const decodedStatus = decodeAbiStatus(status); + if (decodedStatus === undefined) { + return failure({ kind: "unknown-wire-value", vocabulary: "status", value: status }); + } + const codeValue = obstruction.code ?? ML_OBSTRUCTION_NONE; + const code = decodeObstructionCode(codeValue); + if (code === undefined) { + return failure({ kind: "unknown-wire-value", vocabulary: "obstruction", value: codeValue }); + } + const coordinateErrorValue = obstruction.coordinate_error ?? ML_COORDINATE_ERROR_NONE; + const coordinateError = decodeCoordinateError(coordinateErrorValue); + if (coordinateError === undefined) { + return failure({ kind: "unknown-wire-value", vocabulary: "coordinate-error", value: coordinateErrorValue }); + } + const decoded: Obstruction = { + status: decodedStatus, + code, + coordinateError, + inputIndex: toBigInt(obstruction.input_index), + firstIndex: toBigInt(obstruction.first_index), + secondIndex: toBigInt(obstruction.second_index), + firstValue: obstruction.first_value ?? 0, + secondValue: obstruction.second_value ?? 0, + point: [obstruction.point_x ?? 0, obstruction.point_y ?? 0], + message: obstructionMessage(obstruction), + }; + return failure({ kind: "abi-obstruction", obstruction: decoded }); +} + +export function decodeLocation(value: number | undefined): Result { + const wireValue = value ?? -1; + const location = decodeRegionLocation(wireValue); + return location === undefined + ? failure({ kind: "unknown-wire-value", vocabulary: "region-location", value: wireValue }) + : success(location); +} + +export function decodeMinkowskiReceipt(receipt: NativeMinkowskiReceipt): Result { + const operationValue = receipt.operation ?? -1; + const operation = decodeMinkowskiOperation(operationValue); + if (operation === undefined) { + return failure({ kind: "unknown-wire-value", vocabulary: "minkowski-operation", value: operationValue }); + } + return success({ + operation, + inputComponents: toBigInt(receipt.input_components), + convexPieces: toBigInt(receipt.convex_pieces), + generatedPieces: toBigInt(receipt.generated_pieces), + generatedConvolutionEdges: toBigInt(receipt.generated_convolution_edges), + overlayPasses: toBigInt(receipt.overlay_passes), + exactCrossings: toBigInt(receipt.exact_crossings), + outputCells: toBigInt(receipt.output_cells), + exactCoordinateBitGrowth: toBigInt(receipt.exact_coordinate_bit_growth), + }); +} + +export function toBigInt(value: NativeInteger | undefined): bigint { + return value === undefined ? 0n : BigInt(value); +} + +export function toSafeNumber(value: NativeInteger | undefined): Result { + const exact = toBigInt(value); + const projected = Number(exact); + return Number.isSafeInteger(projected) + ? success(projected) + : failure({ kind: "unsafe-integer", value: exact }); +} + +export function nativeCallFailure(cause: unknown): MoonlightFailure { + return { + kind: "native-call-failed", + message: cause instanceof Error ? cause.message : String(cause), + }; +} + +export function pointsFromCoordinates(coordinates: Float64Array, count: number): readonly Point[] { + return Array.from({ length: count }, (_unused, index): Point => [ + coordinates[index * 2] ?? 0, + coordinates[index * 2 + 1] ?? 0, + ]); +} + +function obstructionMessage(obstruction: NativeObstruction): string { + const message = obstruction.message; + if (message === undefined) { + return "Moonlight ABI obstruction"; + } + if (typeof message === "string") { + return message.split("\0", 1)[0] ?? ""; + } + const terminator = message.indexOf(0); + const length = terminator === -1 ? message.length : terminator; + return new TextDecoder().decode(Uint8Array.from(message.slice(0, length))); +} diff --git a/ffi/bindings/typescript/src/internal/native.generated.ts b/ffi/bindings/typescript/src/internal/native.generated.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/internal/native.generated.ts @@ -0,0 +1,242 @@ +// Generated from Moonlight.Triangulation.Foreign.Contract. +// Run moonlight-triangulation-ffi-contract write; do not edit this file. + +import koffi from "koffi"; + +export const ABI_VERSION = 2; +export const ML_STATUS_OK = 0; +export const ML_STATUS_NULL_POINTER = 1; +export const ML_STATUS_COUNT_OVERFLOW = 2; +export const ML_STATUS_BUFFER_TOO_SMALL = 3; +export const ML_STATUS_GEOMETRY_OBSTRUCTION = 4; +export const ML_STATUS_RUNTIME_FAILURE = 5; +export const ML_OBSTRUCTION_NONE = 0; +export const ML_OBSTRUCTION_INVALID_COORDINATE = 1; +export const ML_OBSTRUCTION_POINT_LOCATION_FAILED = 2; +export const ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED = 3; +export const ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID = 4; +export const ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX = 5; +export const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING = 6; +export const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING = 7; +export const ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING = 8; +export const ML_OBSTRUCTION_HULL_START_NOT_VISIBLE = 9; +export const ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE = 10; +export const ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE = 11; +export const ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED = 12; +export const ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE = 13; +export const ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE = 14; +export const ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE = 15; +export const ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE = 16; +export const ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION = 17; +export const ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH = 18; +export const ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH = 19; +export const ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT = 20; +export const ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH = 21; +export const ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE = 22; +export const ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY = 23; +export const ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE = 24; +export const ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH = 25; +export const ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH = 26; +export const ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED = 27; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE = 28; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE = 29; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE = 30; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE = 31; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE = 32; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE = 33; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE = 34; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE = 35; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE = 36; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE = 37; +export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM = 38; +export const ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE = 39; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE = 40; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING = 41; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS = 42; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED = 43; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION = 44; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION = 45; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION = 46; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE = 47; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE = 48; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED = 49; +export const ML_OBSTRUCTION_CAPACITY_EXCEEDED = 50; +export const ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED = 51; +export const ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52; +export const ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53; +export const ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54; +export const ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55; +export const ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE = 56; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET = 57; +export const ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP = 58; +export const ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED = 59; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE = 60; +export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE = 61; +export const ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE = 62; +export const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED = 63; +export const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED = 64; +export const ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE = 65; +export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED = 66; +export const ML_OBSTRUCTION_NULL_POINTER = 100; +export const ML_OBSTRUCTION_COUNT_OVERFLOW = 101; +export const ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102; +export const ML_OBSTRUCTION_RUNTIME_FAILURE = 103; +export const ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200; +export const ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201; +export const ML_OBSTRUCTION_OVERLAY_FAILED = 202; +export const ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203; +export const ML_OBSTRUCTION_VALUATION_FAILED = 204; +export const ML_OBSTRUCTION_MINKOWSKI_FAILED = 205; +export const ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206; +export const ML_COORDINATE_ERROR_NONE = 0; +export const ML_COORDINATE_ERROR_NAN = 1; +export const ML_COORDINATE_ERROR_INFINITE = 2; +export const ML_COORDINATE_ERROR_TOO_SMALL = 3; +export const ML_COORDINATE_ERROR_TOO_LARGE = 4; +export const ML_REGION_EXTERIOR = 0; +export const ML_REGION_BOUNDARY = 1; +export const ML_REGION_INTERIOR = 2; +export const ML_MINKOWSKI_ADDITION = 0; +export const ML_MINKOWSKI_EROSION = 1; +export const ML_MINKOWSKI_OPENING = 2; +export const ML_MINKOWSKI_CLOSING = 3; + +export type NativeHandle = object; +export type NativeInteger = number | bigint; +export type HandleOutput = Array; + +export interface NativeObstruction { + code?: number; + coordinate_error?: number; + input_index?: NativeInteger; + first_index?: NativeInteger; + second_index?: NativeInteger; + first_value?: number; + second_value?: number; + point_x?: number; + point_y?: number; + message?: string | readonly number[]; +} + +export interface NativeMinkowskiReceipt { + operation?: number; + reserved?: number; + input_components?: NativeInteger; + convex_pieces?: NativeInteger; + generated_pieces?: NativeInteger; + generated_convolution_edges?: NativeInteger; + overlay_passes?: NativeInteger; + exact_crossings?: NativeInteger; + output_cells?: NativeInteger; + exact_coordinate_bit_growth?: NativeInteger; +} + +export interface NativeApi { + readonly ml_abi_version: () => number; + readonly ml_runtime_initialize: () => number; + readonly ml_delaunay_f64: (coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_insert_many_f64: (mesh: NativeHandle, coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_site_union: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_site_intersection: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_site_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_site_symmetric_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_mesh_vertex_count: (mesh: NativeHandle, count: NativeInteger[], obstruction: NativeObstruction) => number; + readonly ml_mesh_triangle_count: (mesh: NativeHandle, count: NativeInteger[], obstruction: NativeObstruction) => number; + readonly ml_mesh_copy_vertices_f64: (mesh: NativeHandle, coordinates: Float64Array, point_capacity: number, points_written: NativeInteger[], obstruction: NativeObstruction) => number; + readonly ml_mesh_copy_triangles_u32: (mesh: NativeHandle, triangles: Uint32Array, triangle_capacity: number, triangles_written: NativeInteger[], obstruction: NativeObstruction) => number; + readonly ml_mesh_free: (mesh: NativeHandle) => void; + readonly ml_region_create_f64: (coordinates: Float64Array, point_count: number, loop_point_counts: BigUint64Array, loop_count: number, component_loop_counts: BigUint64Array, component_count: number, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_region_counts: (region: NativeHandle, component_count: NativeInteger[], loop_count: NativeInteger[], point_count: NativeInteger[], obstruction: NativeObstruction) => number; + readonly ml_region_copy_f64: (region: NativeHandle, coordinates: Float64Array, point_capacity: number, loop_point_offsets: BigUint64Array, loop_offset_capacity: number, component_loop_offsets: BigUint64Array, component_offset_capacity: number, obstruction: NativeObstruction) => number; + readonly ml_region_union: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_region_intersection: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_region_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_region_symmetric_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_region_locate_point_f64: (region: NativeHandle, x: number, y: number, location: number[], obstruction: NativeObstruction) => number; + readonly ml_region_measure: (region: NativeHandle, euler_characteristic: NativeInteger[], area_ratio_utf8: Buffer, area_capacity: number, area_bytes_written: NativeInteger[], perimeter_lower: number[], perimeter_upper: number[], obstruction: NativeObstruction) => number; + readonly ml_region_free: (region: NativeHandle) => void; + readonly ml_structuring_element_create_f64: (coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number; + readonly ml_structuring_element_free: (element: NativeHandle) => void; + readonly ml_region_minkowski_sum: (left: NativeHandle, right: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number; + readonly ml_region_offset: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number; + readonly ml_region_inset: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number; + readonly ml_region_open: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number; + readonly ml_region_close: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number; +} + +export function loadNativeApi(libraryPath: string): NativeApi { + const library = koffi.load(libraryPath); + const mesh = koffi.opaque(); + const meshPointer = koffi.pointer(mesh); + const meshOutput = koffi.out(koffi.pointer(mesh, 2)); + const region = koffi.opaque(); + const regionPointer = koffi.pointer(region); + const regionOutput = koffi.out(koffi.pointer(region, 2)); + const structuringElement = koffi.opaque(); + const structuringElementPointer = koffi.pointer(structuringElement); + const structuringElementOutput = koffi.out(koffi.pointer(structuringElement, 2)); + + const obstruction = koffi.struct({ + code: "uint32_t", + coordinate_error: "uint32_t", + input_index: "uint64_t", + first_index: "uint64_t", + second_index: "uint64_t", + first_value: "double", + second_value: "double", + point_x: "double", + point_y: "double", + message: koffi.array("char", 256), + }); + const receipt = koffi.struct({ + operation: "uint32_t", + reserved: "uint32_t", + input_components: "uint64_t", + convex_pieces: "uint64_t", + generated_pieces: "uint64_t", + generated_convolution_edges: "uint64_t", + overlay_passes: "uint64_t", + exact_crossings: "uint64_t", + output_cells: "uint64_t", + exact_coordinate_bit_growth: "uint64_t", + }); + const obstructionOutput = koffi.out(koffi.pointer(obstruction)); + const receiptOutput = koffi.out(koffi.pointer(receipt)); + const sizeOutput = koffi.out(koffi.pointer("size_t")); + const uint32Output = koffi.out(koffi.pointer("uint32_t")); + const int64Output = koffi.out(koffi.pointer("int64_t")); + const doubleOutput = koffi.out(koffi.pointer("double")); + const sizeArray = koffi.pointer("size_t"); + return { + ml_abi_version: library.func("ml_abi_version", "uint32_t", []), + ml_runtime_initialize: library.func("ml_runtime_initialize", "uint32_t", []), + ml_delaunay_f64: library.func("ml_delaunay_f64", "uint32_t", [koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]), + ml_mesh_insert_many_f64: library.func("ml_mesh_insert_many_f64", "uint32_t", [meshPointer, koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]), + ml_mesh_site_union: library.func("ml_mesh_site_union", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + ml_mesh_site_intersection: library.func("ml_mesh_site_intersection", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + ml_mesh_site_difference: library.func("ml_mesh_site_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + ml_mesh_site_symmetric_difference: library.func("ml_mesh_site_symmetric_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + ml_mesh_vertex_count: library.func("ml_mesh_vertex_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]), + ml_mesh_triangle_count: library.func("ml_mesh_triangle_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]), + ml_mesh_copy_vertices_f64: library.func("ml_mesh_copy_vertices_f64", "uint32_t", [meshPointer, koffi.out(koffi.pointer("double")), "size_t", sizeOutput, obstructionOutput]), + ml_mesh_copy_triangles_u32: library.func("ml_mesh_copy_triangles_u32", "uint32_t", [meshPointer, koffi.out(koffi.pointer("uint32_t")), "size_t", sizeOutput, obstructionOutput]), + ml_mesh_free: library.func("ml_mesh_free", "void", [meshPointer]), + ml_region_create_f64: library.func("ml_region_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", sizeArray, "size_t", sizeArray, "size_t", regionOutput, obstructionOutput]), + ml_region_counts: library.func("ml_region_counts", "uint32_t", [regionPointer, sizeOutput, sizeOutput, sizeOutput, obstructionOutput]), + ml_region_copy_f64: library.func("ml_region_copy_f64", "uint32_t", [regionPointer, koffi.out(koffi.pointer("double")), "size_t", koffi.out(sizeArray), "size_t", koffi.out(sizeArray), "size_t", obstructionOutput]), + ml_region_union: library.func("ml_region_union", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + ml_region_intersection: library.func("ml_region_intersection", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + ml_region_difference: library.func("ml_region_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + ml_region_symmetric_difference: library.func("ml_region_symmetric_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + ml_region_locate_point_f64: library.func("ml_region_locate_point_f64", "uint32_t", [regionPointer, "double", "double", uint32Output, obstructionOutput]), + ml_region_measure: library.func("ml_region_measure", "uint32_t", [regionPointer, int64Output, koffi.out(koffi.pointer("char")), "size_t", sizeOutput, doubleOutput, doubleOutput, obstructionOutput]), + ml_region_free: library.func("ml_region_free", "void", [regionPointer]), + ml_structuring_element_create_f64: library.func("ml_structuring_element_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", structuringElementOutput, obstructionOutput]), + ml_structuring_element_free: library.func("ml_structuring_element_free", "void", [structuringElementPointer]), + ml_region_minkowski_sum: library.func("ml_region_minkowski_sum", "uint32_t", [regionPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + ml_region_offset: library.func("ml_region_offset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + ml_region_inset: library.func("ml_region_inset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + ml_region_open: library.func("ml_region_open", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + ml_region_close: library.func("ml_region_close", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + }; +} diff --git a/ffi/bindings/typescript/src/internal/resource.ts b/ffi/bindings/typescript/src/internal/resource.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/internal/resource.ts @@ -0,0 +1,113 @@ +import { failure, success, type ResourceKind, type Result } from "../failure.js"; +import type { OwnedResource } from "../resource.js"; +import type { NativeApi, NativeHandle } from "./native.generated.js"; + +export interface RuntimeContext { + readonly native: NativeApi; + readonly identity: symbol; +} + +interface FinalizerState { + readonly free: (handle: NativeHandle) => void; + readonly handle: NativeHandle; +} + +const handleFinalizer = new FinalizationRegistry(({ free, handle }) => free(handle)); +export const resourceAccess: unique symbol = Symbol("moonlight resource access"); + +export interface InternalResource { + readonly [resourceAccess]: () => ResourceProjection; +} + +interface OpenResource { + readonly kind: "open"; + readonly handle: NativeHandle; +} + +interface DisposedResource { + readonly kind: "disposed"; +} + +type ResourceState = OpenResource | DisposedResource; + +export interface ResourceProjection { + readonly context: RuntimeContext; + readonly resource: ResourceKind; + readonly state: ResourceState; +} + +export abstract class OwnedNativeResource implements InternalResource, OwnedResource { + readonly #context: RuntimeContext; + readonly #free: (handle: NativeHandle) => void; + readonly #resource: ResourceKind; + #state: ResourceState; + + protected constructor( + context: RuntimeContext, + handle: NativeHandle, + free: (handle: NativeHandle) => void, + resource: ResourceKind, + ) { + this.#context = context; + this.#free = free; + this.#resource = resource; + this.#state = { kind: "open", handle }; + handleFinalizer.register(this, { free, handle }, this); + } + + get disposed(): boolean { + return this.#state.kind === "disposed"; + } + + dispose(): void { + const state = this.#state; + if (state.kind === "open") { + handleFinalizer.unregister(this); + this.#free(state.handle); + this.#state = { kind: "disposed" }; + } + } + + [Symbol.dispose](): void { + this.dispose(); + } + + [resourceAccess](): ResourceProjection { + return { + context: this.#context, + resource: this.#resource, + state: this.#state, + }; + } + + protected context(): RuntimeContext { + return this.#context; + } + + protected handle(): Result { + return this.#state.kind === "open" + ? success(this.#state.handle) + : failure({ kind: "disposed-resource", resource: this.#resource }); + } +} + +export function borrowResource( + value: unknown, + expectedContext: RuntimeContext, + expectedResource: ResourceKind, +): Result { + if (!isInternalResource(value)) { + return failure({ kind: "foreign-runtime", resource: expectedResource }); + } + const projection = value[resourceAccess](); + if (projection.context.identity !== expectedContext.identity || projection.resource !== expectedResource) { + return failure({ kind: "foreign-runtime", resource: expectedResource }); + } + return projection.state.kind === "open" + ? success(projection.state.handle) + : failure({ kind: "disposed-resource", resource: expectedResource }); +} + +function isInternalResource(value: unknown): value is InternalResource { + return typeof value === "object" && value !== null && resourceAccess in value; +} diff --git a/ffi/bindings/typescript/src/mesh.ts b/ffi/bindings/typescript/src/mesh.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/mesh.ts @@ -0,0 +1,161 @@ +import { success, type Result } from "./failure.js"; +import { callStatus, flattenPoints, produceHandle } from "./internal/call.js"; +import { pointsFromCoordinates, toSafeNumber } from "./internal/decode.js"; +import type { NativeApi, NativeHandle, NativeInteger } from "./internal/native.generated.js"; +import { borrowResource, OwnedNativeResource, type RuntimeContext } from "./internal/resource.js"; +import type { OwnedResource } from "./resource.js"; +import type { Point, Triangle } from "./values.js"; + +export interface Mesh extends OwnedResource { + vertexCount(): Result; + triangleCount(): Result; + vertices(): Result; + triangles(): Result; + insertMany(points: readonly Point[]): Result; + siteUnion(other: Mesh): Result; + siteIntersection(other: Mesh): Result; + siteDifference(other: Mesh): Result; + siteSymmetricDifference(other: Mesh): Result; +} + +/** @internal */ +export function createMesh(context: RuntimeContext, handle: NativeHandle): Mesh { + return new MeshResource(context, handle); +} + +class MeshResource extends OwnedNativeResource implements Mesh { + constructor(context: RuntimeContext, handle: NativeHandle) { + super(context, handle, context.native.ml_mesh_free, "mesh"); + } + + vertexCount(): Result { + return this.count(this.context().native.ml_mesh_vertex_count); + } + + triangleCount(): Result { + return this.count(this.context().native.ml_mesh_triangle_count); + } + + vertices(): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const count = this.vertexCount(); + if (!count.ok) { + return count; + } + const coordinates = new Float64Array(count.value * 2); + const written: NativeInteger[] = [0]; + const copied = callStatus((obstruction) => + this.context().native.ml_mesh_copy_vertices_f64( + handle.value, + coordinates, + count.value, + written, + obstruction, + ), + ); + if (!copied.ok) { + return copied; + } + const writtenCount = toSafeNumber(written[0]); + return writtenCount.ok + ? success(pointsFromCoordinates(coordinates, writtenCount.value)) + : writtenCount; + } + + triangles(): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const count = this.triangleCount(); + if (!count.ok) { + return count; + } + const triangles = new Uint32Array(count.value * 3); + const written: NativeInteger[] = [0]; + const copied = callStatus((obstruction) => + this.context().native.ml_mesh_copy_triangles_u32( + handle.value, + triangles, + count.value, + written, + obstruction, + ), + ); + if (!copied.ok) { + return copied; + } + const writtenCount = toSafeNumber(written[0]); + return writtenCount.ok + ? success( + Array.from({ length: writtenCount.value }, (_unused, index): Triangle => [ + triangles[index * 3] ?? 0, + triangles[index * 3 + 1] ?? 0, + triangles[index * 3 + 2] ?? 0, + ]), + ) + : writtenCount; + } + + insertMany(points: readonly Point[]): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const coordinates = flattenPoints(points); + const produced = produceHandle((output, obstruction) => + this.context().native.ml_mesh_insert_many_f64( + handle.value, + coordinates, + coordinates.length / 2, + output, + obstruction, + ), + ); + return produced.ok ? success(createMesh(this.context(), produced.value)) : produced; + } + + siteUnion(other: Mesh): Result { + return this.binary(other, this.context().native.ml_mesh_site_union); + } + + siteIntersection(other: Mesh): Result { + return this.binary(other, this.context().native.ml_mesh_site_intersection); + } + + siteDifference(other: Mesh): Result { + return this.binary(other, this.context().native.ml_mesh_site_difference); + } + + siteSymmetricDifference(other: Mesh): Result { + return this.binary(other, this.context().native.ml_mesh_site_symmetric_difference); + } + + private binary(other: Mesh, operation: NativeApi["ml_mesh_site_union"]): Result { + const left = this.handle(); + if (!left.ok) { + return left; + } + const right = borrowResource(other, this.context(), "mesh"); + if (!right.ok) { + return right; + } + const produced = produceHandle((output, obstruction) => + operation(left.value, right.value, output, obstruction), + ); + return produced.ok ? success(createMesh(this.context(), produced.value)) : produced; + } + + private count(operation: NativeApi["ml_mesh_vertex_count"]): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const output: NativeInteger[] = [0]; + const counted = callStatus((obstruction) => operation(handle.value, output, obstruction)); + return counted.ok ? toSafeNumber(output[0]) : counted; + } +} diff --git a/ffi/bindings/typescript/src/moonlight.ts b/ffi/bindings/typescript/src/moonlight.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/moonlight.ts @@ -0,0 +1,120 @@ +import { failure, success, type Result } from "./failure.js"; +import { flattenLoops, flattenPoints, produceHandle } from "./internal/call.js"; +import { + ABI_VERSION, + ML_STATUS_OK, + loadNativeApi, +} from "./internal/native.generated.js"; +import type { RuntimeContext } from "./internal/resource.js"; +import { createMesh, type Mesh } from "./mesh.js"; +import { createStructuringElement, type StructuringElement } from "./morphology.js"; +import { createRegion, type Region } from "./region.js"; +import type { Point, PolygonComponent } from "./values.js"; +import { decodeAbiStatus } from "./wire.generated.js"; + +export type NativeLibrarySource = { + readonly kind: "path"; + readonly path: string; +}; + +export interface Moonlight { + readonly abiVersion: number; + delaunay(points: readonly Point[]): Result; + region(components: readonly PolygonComponent[]): Result; + structuringElement(points: readonly Point[]): Result; +} + +export function loadMoonlight(source: NativeLibrarySource): Result { + if (source.path.length === 0) { + return failure({ + kind: "native-library-unavailable", + path: source.path, + message: "native library path must not be empty", + }); + } + try { + const native = loadNativeApi(source.path); + const initializationStatus = native.ml_runtime_initialize(); + if (initializationStatus !== ML_STATUS_OK) { + const status = decodeAbiStatus(initializationStatus); + return status === undefined + ? failure({ kind: "unknown-wire-value", vocabulary: "status", value: initializationStatus }) + : failure({ kind: "runtime-initialization-refused", status }); + } + const observedVersion = native.ml_abi_version(); + if (observedVersion !== ABI_VERSION) { + return failure({ + kind: "abi-version-mismatch", + expected: ABI_VERSION, + observed: observedVersion, + }); + } + const context: RuntimeContext = { native, identity: Symbol("moonlight runtime") }; + return success(new MoonlightRuntime(context)); + } catch (cause: unknown) { + return failure({ + kind: "native-library-unavailable", + path: source.path, + message: cause instanceof Error ? cause.message : String(cause), + }); + } +} + +class MoonlightRuntime implements Moonlight { + readonly abiVersion = ABI_VERSION; + readonly #context: RuntimeContext; + + constructor(context: RuntimeContext) { + this.#context = context; + } + + delaunay(points: readonly Point[]): Result { + const coordinates = flattenPoints(points); + const produced = produceHandle((output, obstruction) => + this.#context.native.ml_delaunay_f64( + coordinates, + coordinates.length / 2, + output, + obstruction, + ), + ); + return produced.ok ? success(createMesh(this.#context, produced.value)) : produced; + } + + region(components: readonly PolygonComponent[]): Result { + const loops = components.flatMap(({ outer, holes = [] }) => [outer, ...holes]); + const loopPointCounts = BigUint64Array.from(loops.map((loop) => BigInt(loop.length))); + const componentLoopCounts = BigUint64Array.from( + components.map(({ holes = [] }) => BigInt(holes.length + 1)), + ); + const coordinates = flattenLoops(loops); + const produced = produceHandle((output, obstruction) => + this.#context.native.ml_region_create_f64( + coordinates, + coordinates.length / 2, + loopPointCounts, + loopPointCounts.length, + componentLoopCounts, + componentLoopCounts.length, + output, + obstruction, + ), + ); + return produced.ok ? success(createRegion(this.#context, produced.value)) : produced; + } + + structuringElement(points: readonly Point[]): Result { + const coordinates = flattenPoints(points); + const produced = produceHandle((output, obstruction) => + this.#context.native.ml_structuring_element_create_f64( + coordinates, + coordinates.length / 2, + output, + obstruction, + ), + ); + return produced.ok + ? success(createStructuringElement(this.#context, produced.value)) + : produced; + } +} diff --git a/ffi/bindings/typescript/src/morphology.ts b/ffi/bindings/typescript/src/morphology.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/morphology.ts @@ -0,0 +1,25 @@ +import type { NativeHandle } from "./internal/native.generated.js"; +import { OwnedNativeResource, type RuntimeContext } from "./internal/resource.js"; +import type { OwnedResource } from "./resource.js"; + +declare const structuringElementBrand: unique symbol; + +export interface StructuringElement extends OwnedResource { + readonly [structuringElementBrand]: "structuring-element"; +} + +/** @internal */ +export function createStructuringElement( + context: RuntimeContext, + handle: NativeHandle, +): StructuringElement { + return new StructuringElementResource(context, handle); +} + +class StructuringElementResource extends OwnedNativeResource implements StructuringElement { + declare readonly [structuringElementBrand]: "structuring-element"; + + constructor(context: RuntimeContext, handle: NativeHandle) { + super(context, handle, context.native.ml_structuring_element_free, "structuring-element"); + } +} diff --git a/ffi/bindings/typescript/src/region.ts b/ffi/bindings/typescript/src/region.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/region.ts @@ -0,0 +1,281 @@ +import { Buffer } from "node:buffer"; + +import { collectResults, failure, success, type Result } from "./failure.js"; +import { captureNativeCall, callStatus, produceHandle, produceMorphology } from "./internal/call.js"; +import { decodeLocation, decodeStatus, pointsFromCoordinates, toBigInt, toSafeNumber } from "./internal/decode.js"; +import { + ML_OBSTRUCTION_BUFFER_TOO_SMALL, + ML_STATUS_BUFFER_TOO_SMALL, + type NativeApi, + type NativeHandle, + type NativeInteger, + type NativeObstruction, +} from "./internal/native.generated.js"; +import { borrowResource, OwnedNativeResource, type RuntimeContext } from "./internal/resource.js"; +import type { StructuringElement } from "./morphology.js"; +import type { OwnedResource } from "./resource.js"; +import type { MinkowskiReceipt, Point, PolygonComponent, RegionValuations } from "./values.js"; +import type { RegionLocation } from "./wire.generated.js"; + +export interface MorphologyResult { + readonly region: Region; + readonly receipt: MinkowskiReceipt; +} + +export interface Region extends OwnedResource { + components(): Result; + valuations(): Result; + locate(point: Point): Result; + union(other: Region): Result; + intersection(other: Region): Result; + difference(other: Region): Result; + symmetricDifference(other: Region): Result; + minkowskiSum(other: Region): Result; + offset(element: StructuringElement): Result; + inset(element: StructuringElement): Result; + open(element: StructuringElement): Result; + close(element: StructuringElement): Result; +} + +/** @internal */ +export function createRegion(context: RuntimeContext, handle: NativeHandle): Region { + return new RegionResource(context, handle); +} + +class RegionResource extends OwnedNativeResource implements Region { + constructor(context: RuntimeContext, handle: NativeHandle) { + super(context, handle, context.native.ml_region_free, "region"); + } + + components(): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const counts = this.counts(handle.value); + if (!counts.ok) { + return counts; + } + const [componentCount, loopCount, pointCount] = counts.value; + const coordinates = new Float64Array(pointCount * 2); + const loopPointOffsets = new BigUint64Array(loopCount + 1); + const componentLoopOffsets = new BigUint64Array(componentCount + 1); + const copied = callStatus((obstruction) => + this.context().native.ml_region_copy_f64( + handle.value, + coordinates, + pointCount, + loopPointOffsets, + loopCount + 1, + componentLoopOffsets, + componentCount + 1, + obstruction, + ), + ); + if (!copied.ok) { + return copied; + } + const points = pointsFromCoordinates(coordinates, pointCount); + const loopOffsets = collectResults( + Array.from({ length: loopCount + 1 }, (_unused, index) => toSafeNumber(loopPointOffsets[index])), + ); + if (!loopOffsets.ok) { + return loopOffsets; + } + const componentOffsets = collectResults( + Array.from({ length: componentCount + 1 }, (_unused, index) => toSafeNumber(componentLoopOffsets[index])), + ); + if (!componentOffsets.ok) { + return componentOffsets; + } + const loops = Array.from({ length: loopCount }, (_unused, index) => + points.slice(loopOffsets.value[index] ?? 0, loopOffsets.value[index + 1] ?? 0), + ); + return collectResults( + Array.from({ length: componentCount }, (_unused, index): Result => { + const start = componentOffsets.value[index] ?? 0; + const end = componentOffsets.value[index + 1] ?? 0; + const outer = loops[start]; + return outer === undefined || start >= end + ? failure({ kind: "invalid-native-result", message: "Moonlight returned a component without an outer loop" }) + : success({ outer, holes: loops.slice(start + 1, end) }); + }), + ); + } + + valuations(): Result { + const handle = this.handle(); + return handle.ok ? this.measureWithCapacity(handle.value, 128) : handle; + } + + locate([x, y]: Point): Result { + const handle = this.handle(); + if (!handle.ok) { + return handle; + } + const location = [0]; + const located = callStatus((obstruction) => + this.context().native.ml_region_locate_point_f64(handle.value, x, y, location, obstruction), + ); + return located.ok ? decodeLocation(location[0]) : located; + } + + union(other: Region): Result { + return this.binary(other, this.context().native.ml_region_union); + } + + intersection(other: Region): Result { + return this.binary(other, this.context().native.ml_region_intersection); + } + + difference(other: Region): Result { + return this.binary(other, this.context().native.ml_region_difference); + } + + symmetricDifference(other: Region): Result { + return this.binary(other, this.context().native.ml_region_symmetric_difference); + } + + minkowskiSum(other: Region): Result { + const left = this.handle(); + if (!left.ok) { + return left; + } + const right = borrowResource(other, this.context(), "region"); + return right.ok + ? this.morphology(this.context().native.ml_region_minkowski_sum, left.value, right.value) + : right; + } + + offset(element: StructuringElement): Result { + return this.withElement(element, this.context().native.ml_region_offset); + } + + inset(element: StructuringElement): Result { + return this.withElement(element, this.context().native.ml_region_inset); + } + + open(element: StructuringElement): Result { + return this.withElement(element, this.context().native.ml_region_open); + } + + close(element: StructuringElement): Result { + return this.withElement(element, this.context().native.ml_region_close); + } + + private binary(other: Region, operation: NativeApi["ml_region_union"]): Result { + const left = this.handle(); + if (!left.ok) { + return left; + } + const right = borrowResource(other, this.context(), "region"); + if (!right.ok) { + return right; + } + const produced = produceHandle((output, obstruction) => + operation(left.value, right.value, output, obstruction), + ); + return produced.ok ? success(createRegion(this.context(), produced.value)) : produced; + } + + private withElement( + element: StructuringElement, + operation: NativeApi["ml_region_offset"], + ): Result { + const region = this.handle(); + if (!region.ok) { + return region; + } + const structuringElement = borrowResource(element, this.context(), "structuring-element"); + return structuringElement.ok + ? this.morphology(operation, structuringElement.value, region.value) + : structuringElement; + } + + private morphology( + operation: NativeApi["ml_region_minkowski_sum"], + first: NativeHandle, + second: NativeHandle, + ): Result { + const produced = produceMorphology((output, receipt, obstruction) => + operation(first, second, output, receipt, obstruction), + ); + return produced.ok + ? success({ region: createRegion(this.context(), produced.value.handle), receipt: produced.value.receipt }) + : produced; + } + + private counts(handle: NativeHandle): Result { + const componentCount: NativeInteger[] = [0]; + const loopCount: NativeInteger[] = [0]; + const pointCount: NativeInteger[] = [0]; + const counted = callStatus((obstruction) => + this.context().native.ml_region_counts( + handle, + componentCount, + loopCount, + pointCount, + obstruction, + ), + ); + if (!counted.ok) { + return counted; + } + const components = toSafeNumber(componentCount[0]); + const loops = toSafeNumber(loopCount[0]); + const points = toSafeNumber(pointCount[0]); + if (!components.ok) { + return failure(components.error); + } + if (!loops.ok) { + return failure(loops.error); + } + if (!points.ok) { + return failure(points.error); + } + return success([components.value, loops.value, points.value]); + } + + private measureWithCapacity(handle: NativeHandle, capacity: number): Result { + return captureNativeCall(() => { + const euler: NativeInteger[] = [0]; + const areaRatio = Buffer.alloc(capacity); + const areaBytes: NativeInteger[] = [0]; + const perimeterLower = [0]; + const perimeterUpper = [0]; + const obstruction: NativeObstruction = {}; + const status = this.context().native.ml_region_measure( + handle, + euler, + areaRatio, + capacity, + areaBytes, + perimeterLower, + perimeterUpper, + obstruction, + ); + if (status === ML_STATUS_BUFFER_TOO_SMALL && obstruction.code === ML_OBSTRUCTION_BUFFER_TOO_SMALL) { + const required = toSafeNumber(areaBytes[0]); + return required.ok ? this.measureWithCapacity(handle, required.value + 1) : required; + } + const measured = decodeStatus(status, obstruction); + if (!measured.ok) { + return measured; + } + const byteCount = toSafeNumber(areaBytes[0]); + if (!byteCount.ok) { + return byteCount; + } + const ratio = areaRatio.subarray(0, byteCount.value).toString("ascii"); + const [numerator, denominator, remainder] = ratio.split("/"); + if (numerator === undefined || denominator === undefined || remainder !== undefined) { + return failure({ kind: "invalid-native-result", message: "Moonlight returned a malformed exact-area ratio" }); + } + return success({ + eulerCharacteristic: toBigInt(euler[0]), + area: { numerator: BigInt(numerator), denominator: BigInt(denominator) }, + perimeterBounds: [perimeterLower[0] ?? 0, perimeterUpper[0] ?? 0], + }); + }); + } +} diff --git a/ffi/bindings/typescript/src/resource.ts b/ffi/bindings/typescript/src/resource.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/resource.ts @@ -0,0 +1,4 @@ +export interface OwnedResource extends Disposable { + readonly disposed: boolean; + dispose(): void; +} diff --git a/ffi/bindings/typescript/src/values.ts b/ffi/bindings/typescript/src/values.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/values.ts @@ -0,0 +1,32 @@ +import type { MinkowskiOperation } from "./wire.generated.js"; + +export type Point = readonly [x: number, y: number]; +export type Triangle = readonly [first: number, second: number, third: number]; + +export interface PolygonComponent { + readonly outer: readonly Point[]; + readonly holes?: readonly (readonly Point[])[]; +} + +export interface ExactRational { + readonly numerator: bigint; + readonly denominator: bigint; +} + +export interface RegionValuations { + readonly eulerCharacteristic: bigint; + readonly area: ExactRational; + readonly perimeterBounds: readonly [lower: number, upper: number]; +} + +export interface MinkowskiReceipt { + readonly operation: MinkowskiOperation; + readonly inputComponents: bigint; + readonly convexPieces: bigint; + readonly generatedPieces: bigint; + readonly generatedConvolutionEdges: bigint; + readonly overlayPasses: bigint; + readonly exactCrossings: bigint; + readonly outputCells: bigint; + readonly exactCoordinateBitGrowth: bigint; +} diff --git a/ffi/bindings/typescript/src/wire.generated.ts b/ffi/bindings/typescript/src/wire.generated.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/src/wire.generated.ts @@ -0,0 +1,239 @@ +// Generated from Moonlight.Triangulation.Foreign.Contract. +// Run moonlight-triangulation-ffi-contract write; do not edit this file. + +export const AbiStatus = { + Ok: "ok", + NullPointer: "null-pointer", + CountOverflow: "count-overflow", + BufferTooSmall: "buffer-too-small", + GeometryObstruction: "geometry-obstruction", + RuntimeFailure: "runtime-failure", +} as const; +export type AbiStatus = (typeof AbiStatus)[keyof typeof AbiStatus]; +const abiStatusByWire: Readonly> = { + 0: AbiStatus.Ok, + 1: AbiStatus.NullPointer, + 2: AbiStatus.CountOverflow, + 3: AbiStatus.BufferTooSmall, + 4: AbiStatus.GeometryObstruction, + 5: AbiStatus.RuntimeFailure, +}; +export function decodeAbiStatus(value: number): AbiStatus | undefined { + return abiStatusByWire[value]; +} + +export const ObstructionCode = { + None: "none", + InvalidCoordinate: "invalid-coordinate", + PointLocationFailed: "point-location-failed", + LocationWalkExhausted: "location-walk-exhausted", + RefinementInputTopologyInvalid: "refinement-input-topology-invalid", + FreshInsertionMatchedExistingVertex: "fresh-insertion-matched-existing-vertex", + DegenerateLineEndpointMissingOutgoing: "degenerate-line-endpoint-missing-outgoing", + DegenerateLineEndpointTurnMissing: "degenerate-line-endpoint-turn-missing", + DegenerateLineConnectedVertexMissing: "degenerate-line-connected-vertex-missing", + HullStartNotVisible: "hull-start-not-visible", + OuterRangeDidNotTerminate: "outer-range-did-not-terminate", + OuterRangeContainsInnerEdge: "outer-range-contains-inner-edge", + ConstrainedEdgeFlipRefused: "constrained-edge-flip-refused", + RemovalVertexOutOfRange: "removal-vertex-out-of-range", + RemovalEdgeOutOfRange: "removal-edge-out-of-range", + RemovalFaceOutOfRange: "removal-face-out-of-range", + RemovalFaceCycleDidNotTerminate: "removal-face-cycle-did-not-terminate", + RemovalEmptyTriangulation: "removal-empty-triangulation", + RemovalTwoPointDegreeMismatch: "removal-two-point-degree-mismatch", + RemovalCollinearDegreeMismatch: "removal-collinear-degree-mismatch", + RemovalBorderTooShort: "removal-border-too-short", + RemovalBorderArityMismatch: "removal-border-arity-mismatch", + RemovalOutgoingCycleDidNotTerminate: "removal-outgoing-cycle-did-not-terminate", + CircleSweepHullEmpty: "circle-sweep-hull-empty", + OuterCycleDidNotTerminate: "outer-cycle-did-not-terminate", + HierarchyLevelPopulationMismatch: "hierarchy-level-population-mismatch", + HierarchyInsertionHandleMismatch: "hierarchy-insertion-handle-mismatch", + PointIndexCapacityExhausted: "point-index-capacity-exhausted", + RefinementMinimumAngleNotFinite: "refinement-minimum-angle-not-finite", + RefinementMinimumAngleOutOfRange: "refinement-minimum-angle-out-of-range", + RefinementMinimumAngleDerivedRatioNotFinite: "refinement-minimum-angle-derived-ratio-not-finite", + RefinementMaximumAdditionalVerticesNegative: "refinement-maximum-additional-vertices-negative", + RefinementMinimumAreaNotFinite: "refinement-minimum-area-not-finite", + RefinementMinimumAreaNegative: "refinement-minimum-area-negative", + RefinementMaximumAreaNotFinite: "refinement-maximum-area-not-finite", + RefinementMaximumAreaNotPositive: "refinement-maximum-area-not-positive", + RefinementMaximumRadiusEdgeRatioNotFinite: "refinement-maximum-radius-edge-ratio-not-finite", + RefinementMaximumRadiusEdgeRatioNotPositive: "refinement-maximum-radius-edge-ratio-not-positive", + RefinementMinimumAreaExceedsMaximum: "refinement-minimum-area-exceeds-maximum", + RefinementSeedFaceNotActive: "refinement-seed-face-not-active", + RefinementDomainInterfaceEdgeNotActive: "refinement-domain-interface-edge-not-active", + RefinementDomainInterfaceMissing: "refinement-domain-interface-missing", + RefinementDomainInterfaceExtraneous: "refinement-domain-interface-extraneous", + RefinementDomainTopologyChanged: "refinement-domain-topology-changed", + RefinementDomainRequiresConvexHullPreservation: "refinement-domain-requires-convex-hull-preservation", + RefinementDomainRequiresConstraintPreservation: "refinement-domain-requires-constraint-preservation", + RefinementDomainForbidsOuterFaceExclusion: "refinement-domain-forbids-outer-face-exclusion", + RefinementDomainWouldCrossInterface: "refinement-domain-would-cross-interface", + RefinementDomainWouldRewriteProtectedFace: "refinement-domain-would-rewrite-protected-face", + RefinementDomainProtectedFaceChanged: "refinement-domain-protected-face-changed", + CapacityExceeded: "capacity-exceeded", + HalfEdgeCapacityExceeded: "half-edge-capacity-exceeded", + FaceCapacityExceeded: "face-capacity-exceeded", + PayloadStorageFailure: "payload-storage-failure", + CoordinatePayloadCountMismatch: "coordinate-payload-count-mismatch", + CircleSweepRequiresDenseStorage: "circle-sweep-requires-dense-storage", + SeamFrontierUnavailable: "seam-frontier-unavailable", + RefinementDomainRequiresFiniteVertexBudget: "refinement-domain-requires-finite-vertex-budget", + SeamSourceEdgeRequiresFlip: "seam-source-edge-requires-flip", + SeamProtectedSourceFaceChanged: "seam-protected-source-face-changed", + RefinementMaximumEdgeLengthNotFinite: "refinement-maximum-edge-length-not-finite", + RefinementMaximumEdgeLengthNotPositive: "refinement-maximum-edge-length-not-positive", + RefinementOversizedEdge: "refinement-oversized-edge", + RefinementSeamBridgeBudgetExceeded: "refinement-seam-bridge-budget-exceeded", + RefinementSeamBridgeMidpointCollapsed: "refinement-seam-bridge-midpoint-collapsed", + BoundarySplitRequiresBoundaryEdge: "boundary-split-requires-boundary-edge", + RefinementDomainInterfaceOppositeFaceNotPermitted: "refinement-domain-interface-opposite-face-not-permitted", + NullPointer: "null-pointer", + CountOverflow: "count-overflow", + BufferTooSmall: "buffer-too-small", + RuntimeFailure: "runtime-failure", + RegionLayoutInvalid: "region-layout-invalid", + RegionValidationFailed: "region-validation-failed", + OverlayFailed: "overlay-failed", + RegionPublicationFailed: "region-publication-failed", + ValuationFailed: "valuation-failed", + MinkowskiFailed: "minkowski-failed", + RegionProjectionFailed: "region-projection-failed", +} as const; +export type ObstructionCode = (typeof ObstructionCode)[keyof typeof ObstructionCode]; +const obstructionCodeByWire: Readonly> = { + 0: ObstructionCode.None, + 1: ObstructionCode.InvalidCoordinate, + 2: ObstructionCode.PointLocationFailed, + 3: ObstructionCode.LocationWalkExhausted, + 4: ObstructionCode.RefinementInputTopologyInvalid, + 5: ObstructionCode.FreshInsertionMatchedExistingVertex, + 6: ObstructionCode.DegenerateLineEndpointMissingOutgoing, + 7: ObstructionCode.DegenerateLineEndpointTurnMissing, + 8: ObstructionCode.DegenerateLineConnectedVertexMissing, + 9: ObstructionCode.HullStartNotVisible, + 10: ObstructionCode.OuterRangeDidNotTerminate, + 11: ObstructionCode.OuterRangeContainsInnerEdge, + 12: ObstructionCode.ConstrainedEdgeFlipRefused, + 13: ObstructionCode.RemovalVertexOutOfRange, + 14: ObstructionCode.RemovalEdgeOutOfRange, + 15: ObstructionCode.RemovalFaceOutOfRange, + 16: ObstructionCode.RemovalFaceCycleDidNotTerminate, + 17: ObstructionCode.RemovalEmptyTriangulation, + 18: ObstructionCode.RemovalTwoPointDegreeMismatch, + 19: ObstructionCode.RemovalCollinearDegreeMismatch, + 20: ObstructionCode.RemovalBorderTooShort, + 21: ObstructionCode.RemovalBorderArityMismatch, + 22: ObstructionCode.RemovalOutgoingCycleDidNotTerminate, + 23: ObstructionCode.CircleSweepHullEmpty, + 24: ObstructionCode.OuterCycleDidNotTerminate, + 25: ObstructionCode.HierarchyLevelPopulationMismatch, + 26: ObstructionCode.HierarchyInsertionHandleMismatch, + 27: ObstructionCode.PointIndexCapacityExhausted, + 28: ObstructionCode.RefinementMinimumAngleNotFinite, + 29: ObstructionCode.RefinementMinimumAngleOutOfRange, + 30: ObstructionCode.RefinementMinimumAngleDerivedRatioNotFinite, + 31: ObstructionCode.RefinementMaximumAdditionalVerticesNegative, + 32: ObstructionCode.RefinementMinimumAreaNotFinite, + 33: ObstructionCode.RefinementMinimumAreaNegative, + 34: ObstructionCode.RefinementMaximumAreaNotFinite, + 35: ObstructionCode.RefinementMaximumAreaNotPositive, + 36: ObstructionCode.RefinementMaximumRadiusEdgeRatioNotFinite, + 37: ObstructionCode.RefinementMaximumRadiusEdgeRatioNotPositive, + 38: ObstructionCode.RefinementMinimumAreaExceedsMaximum, + 39: ObstructionCode.RefinementSeedFaceNotActive, + 40: ObstructionCode.RefinementDomainInterfaceEdgeNotActive, + 41: ObstructionCode.RefinementDomainInterfaceMissing, + 42: ObstructionCode.RefinementDomainInterfaceExtraneous, + 43: ObstructionCode.RefinementDomainTopologyChanged, + 44: ObstructionCode.RefinementDomainRequiresConvexHullPreservation, + 45: ObstructionCode.RefinementDomainRequiresConstraintPreservation, + 46: ObstructionCode.RefinementDomainForbidsOuterFaceExclusion, + 47: ObstructionCode.RefinementDomainWouldCrossInterface, + 48: ObstructionCode.RefinementDomainWouldRewriteProtectedFace, + 49: ObstructionCode.RefinementDomainProtectedFaceChanged, + 50: ObstructionCode.CapacityExceeded, + 51: ObstructionCode.HalfEdgeCapacityExceeded, + 52: ObstructionCode.FaceCapacityExceeded, + 53: ObstructionCode.PayloadStorageFailure, + 54: ObstructionCode.CoordinatePayloadCountMismatch, + 55: ObstructionCode.CircleSweepRequiresDenseStorage, + 56: ObstructionCode.SeamFrontierUnavailable, + 57: ObstructionCode.RefinementDomainRequiresFiniteVertexBudget, + 58: ObstructionCode.SeamSourceEdgeRequiresFlip, + 59: ObstructionCode.SeamProtectedSourceFaceChanged, + 60: ObstructionCode.RefinementMaximumEdgeLengthNotFinite, + 61: ObstructionCode.RefinementMaximumEdgeLengthNotPositive, + 62: ObstructionCode.RefinementOversizedEdge, + 63: ObstructionCode.RefinementSeamBridgeBudgetExceeded, + 64: ObstructionCode.RefinementSeamBridgeMidpointCollapsed, + 65: ObstructionCode.BoundarySplitRequiresBoundaryEdge, + 66: ObstructionCode.RefinementDomainInterfaceOppositeFaceNotPermitted, + 100: ObstructionCode.NullPointer, + 101: ObstructionCode.CountOverflow, + 102: ObstructionCode.BufferTooSmall, + 103: ObstructionCode.RuntimeFailure, + 200: ObstructionCode.RegionLayoutInvalid, + 201: ObstructionCode.RegionValidationFailed, + 202: ObstructionCode.OverlayFailed, + 203: ObstructionCode.RegionPublicationFailed, + 204: ObstructionCode.ValuationFailed, + 205: ObstructionCode.MinkowskiFailed, + 206: ObstructionCode.RegionProjectionFailed, +}; +export function decodeObstructionCode(value: number): ObstructionCode | undefined { + return obstructionCodeByWire[value]; +} + +export const CoordinateError = { + None: "none", + Nan: "nan", + Infinite: "infinite", + TooSmall: "too-small", + TooLarge: "too-large", +} as const; +export type CoordinateError = (typeof CoordinateError)[keyof typeof CoordinateError]; +const coordinateErrorByWire: Readonly> = { + 0: CoordinateError.None, + 1: CoordinateError.Nan, + 2: CoordinateError.Infinite, + 3: CoordinateError.TooSmall, + 4: CoordinateError.TooLarge, +}; +export function decodeCoordinateError(value: number): CoordinateError | undefined { + return coordinateErrorByWire[value]; +} + +export const RegionLocation = { + Exterior: "exterior", + Boundary: "boundary", + Interior: "interior", +} as const; +export type RegionLocation = (typeof RegionLocation)[keyof typeof RegionLocation]; +const regionLocationByWire: Readonly> = { + 0: RegionLocation.Exterior, + 1: RegionLocation.Boundary, + 2: RegionLocation.Interior, +}; +export function decodeRegionLocation(value: number): RegionLocation | undefined { + return regionLocationByWire[value]; +} + +export const MinkowskiOperation = { + Addition: "addition", + Erosion: "erosion", + Opening: "opening", + Closing: "closing", +} as const; +export type MinkowskiOperation = (typeof MinkowskiOperation)[keyof typeof MinkowskiOperation]; +const minkowskiOperationByWire: Readonly> = { + 0: MinkowskiOperation.Addition, + 1: MinkowskiOperation.Erosion, + 2: MinkowskiOperation.Opening, + 3: MinkowskiOperation.Closing, +}; +export function decodeMinkowskiOperation(value: number): MinkowskiOperation | undefined { + return minkowskiOperationByWire[value]; +} diff --git a/ffi/bindings/typescript/test/binding.test.ts b/ffi/bindings/typescript/test/binding.test.ts new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/test/binding.test.ts @@ -0,0 +1,136 @@ +import assert from "node:assert/strict"; +import test from "node:test"; + +import { + AbiStatus, + CoordinateError, + MinkowskiOperation, + ObstructionCode, + RegionLocation, + formatMoonlightFailure, + loadMoonlight, + type Moonlight, + type Result, +} from "../src/index.js"; + +function expectSuccess(result: Result): Value { + if (!result.ok) { + assert.fail(formatMoonlightFailure(result.error)); + } + return result.value; +} + +function libraryPath(): string { + const path = process.env.MOONLIGHT_TRIANGULATION_LIBRARY; + assert.notEqual(path, undefined, "MOONLIGHT_TRIANGULATION_LIBRARY is required"); + return path ?? ""; +} + +function runtime(): Moonlight { + return expectSuccess(loadMoonlight({ kind: "path", path: libraryPath() })); +} + +test("immutable site-set algebra and dense projection", () => { + const engine = runtime(); + using left = expectSuccess(engine.delaunay([[0, 0], [2, 0], [0, 2], [2, 2]])); + using right = expectSuccess(engine.delaunay([[2, 0], [4, 0], [2, 2], [4, 2]])); + using union = expectSuccess(left.siteUnion(right)); + using intersection = expectSuccess(left.siteIntersection(right)); + using difference = expectSuccess(left.siteDifference(right)); + using symmetric = expectSuccess(left.siteSymmetricDifference(right)); + using extended = expectSuccess(left.insertMany([[1, 1], [3, 1]])); + + assert.equal(expectSuccess(left.vertexCount()), 4); + assert.equal(expectSuccess(union.vertexCount()), 6); + assert.equal(expectSuccess(intersection.vertexCount()), 2); + assert.equal(expectSuccess(difference.vertexCount()), 2); + assert.equal(expectSuccess(symmetric.vertexCount()), 4); + assert.equal(expectSuccess(extended.vertexCount()), 6); + assert.equal(expectSuccess(left.vertices()).length, expectSuccess(left.vertexCount())); + assert.equal(expectSuccess(left.triangles()).length, expectSuccess(left.triangleCount())); + +}); + +test("exact regions expose Boolean, valuation, location, and all morphology operations", () => { + const engine = runtime(); + using left = expectSuccess(engine.region([{ outer: [[0, 0], [2, 0], [2, 2], [0, 2]] }])); + using right = expectSuccess(engine.region([{ outer: [[1, 0], [3, 0], [3, 2], [1, 2]] }])); + using intersection = expectSuccess(left.intersection(right)); + using symmetric = expectSuccess(left.symmetricDifference(right)); + using kernel = expectSuccess( + engine.structuringElement([[-0.25, -0.25], [0.25, -0.25], [0.25, 0.25], [-0.25, 0.25]]), + ); + const sum = expectSuccess(left.minkowskiSum(right)); + const offset = expectSuccess(left.offset(kernel)); + const inset = expectSuccess(left.inset(kernel)); + const opened = expectSuccess(left.open(kernel)); + const closed = expectSuccess(left.close(kernel)); + using sumRegion = sum.region; + using offsetRegion = offset.region; + using insetRegion = inset.region; + using openedRegion = opened.region; + using closedRegion = closed.region; + + assert.equal(expectSuccess(left.components()).length, 1); + assert.equal(expectSuccess(left.components())[0]?.outer.length, 4); + assert.deepEqual(expectSuccess(intersection.valuations()).area, { numerator: 2n, denominator: 1n }); + assert.equal(expectSuccess(symmetric.valuations()).eulerCharacteristic, 2n); + assert.equal(expectSuccess(left.locate([1, 1])), RegionLocation.Interior); + assert.equal(expectSuccess(left.locate([0, 1])), RegionLocation.Boundary); + assert.equal(expectSuccess(left.locate([3, 1])), RegionLocation.Exterior); + assert.equal(offset.receipt.operation, MinkowskiOperation.Addition); + assert.equal(inset.receipt.operation, MinkowskiOperation.Erosion); + assert.equal(opened.receipt.operation, MinkowskiOperation.Opening); + assert.equal(closed.receipt.operation, MinkowskiOperation.Closing); + assert(sum.receipt.generatedPieces >= 1n); + +}); + +test("invalid coordinates return a typed obstruction", () => { + const result = runtime().delaunay([[0, 0], [Number.NaN, 1], [1, 0]]); + assert.equal(result.ok, false); + if (result.ok || result.error.kind !== "abi-obstruction") { + throw new Error("expected an ABI obstruction"); + } + assert.equal(result.error.obstruction.status, AbiStatus.GeometryObstruction); + assert.equal(result.error.obstruction.code, ObstructionCode.InvalidCoordinate); + assert.equal(result.error.obstruction.coordinateError, CoordinateError.Nan); + assert.equal(result.error.obstruction.inputIndex, 1n); +}); + +test("materialized coordinates own native counts", () => { + const points = new Proxy([[0, 0]], { + get(target, property, receiver) { + return property === "length" ? 1_000 : Reflect.get(target, property, receiver); + }, + }); + using mesh = expectSuccess(runtime().delaunay(points)); + assert.equal(expectSuccess(mesh.vertexCount()), 1); +}); + +test("loading, runtime descent, and disposal are explicit", () => { + const unavailable = loadMoonlight({ kind: "path", path: "" }); + assert.equal(unavailable.ok, false); + if (!unavailable.ok) { + assert.equal(unavailable.error.kind, "native-library-unavailable"); + } + + const firstRuntime = runtime(); + const secondRuntime = runtime(); + const first = expectSuccess(firstRuntime.delaunay([[0, 0]])); + const second = expectSuccess(secondRuntime.delaunay([[1, 1]])); + const mixed = first.siteUnion(second); + assert.equal(mixed.ok, false); + if (!mixed.ok) { + assert.equal(mixed.error.kind, "foreign-runtime"); + } + + first[Symbol.dispose](); + assert.equal(first.disposed, true); + const afterDispose = first.vertexCount(); + assert.equal(afterDispose.ok, false); + if (!afterDispose.ok) { + assert.equal(afterDispose.error.kind, "disposed-resource"); + } + second.dispose(); +}); diff --git a/ffi/bindings/typescript/tsconfig.json b/ffi/bindings/typescript/tsconfig.json new file mode 100644 --- /dev/null +++ b/ffi/bindings/typescript/tsconfig.json @@ -0,0 +1,28 @@ +{ + "compilerOptions": { + "target": "ES2023", + "lib": [ + "ES2023", + "ESNext.Disposable" + ], + "module": "NodeNext", + "moduleResolution": "NodeNext", + "strict": true, + "noImplicitAny": true, + "strictNullChecks": true, + "noUncheckedIndexedAccess": true, + "exactOptionalPropertyTypes": true, + "types": [ + "node" + ], + "declaration": true, + "stripInternal": true, + "rootDir": ".", + "outDir": "dist", + "skipLibCheck": false + }, + "include": [ + "src/**/*.ts", + "test/**/*.ts" + ] +} diff --git a/ffi/cbits/moonlight-triangulation.def b/ffi/cbits/moonlight-triangulation.def new file mode 100644 --- /dev/null +++ b/ffi/cbits/moonlight-triangulation.def @@ -0,0 +1,35 @@ +; Generated from Moonlight.Triangulation.Foreign.Contract. +; Run moonlight-triangulation-ffi-contract write; do not edit this file. + +LIBRARY moonlight-triangulation-c +EXPORTS + ml_abi_version + ml_runtime_initialize + ml_delaunay_f64 + ml_mesh_insert_many_f64 + ml_mesh_site_union + ml_mesh_site_intersection + ml_mesh_site_difference + ml_mesh_site_symmetric_difference + ml_mesh_vertex_count + ml_mesh_triangle_count + ml_mesh_copy_vertices_f64 + ml_mesh_copy_triangles_u32 + ml_mesh_free + ml_region_create_f64 + ml_region_counts + ml_region_copy_f64 + ml_region_union + ml_region_intersection + ml_region_difference + ml_region_symmetric_difference + ml_region_locate_point_f64 + ml_region_measure + ml_region_free + ml_structuring_element_create_f64 + ml_structuring_element_free + ml_region_minkowski_sum + ml_region_offset + ml_region_inset + ml_region_open + ml_region_close diff --git a/ffi/cbits/moonlight_runtime.c b/ffi/cbits/moonlight_runtime.c new file mode 100644 --- /dev/null +++ b/ffi/cbits/moonlight_runtime.c @@ -0,0 +1,48 @@ +#include "moonlight_triangulation.h" +#include "HsFFI.h" + +#if defined(_WIN32) +#include + +static INIT_ONCE moonlight_runtime_once = INIT_ONCE_STATIC_INIT; + +static BOOL CALLBACK moonlight_initialize_runtime(PINIT_ONCE once, PVOID parameter, PVOID *context) { + int argc = 1; + char program_name[] = "moonlight-triangulation"; + char *argv[] = {program_name, NULL}; + char **argv_pointer = argv; + (void)once; + (void)parameter; + (void)context; + hs_init(&argc, &argv_pointer); + return TRUE; +} + +ML_API ml_status ml_runtime_initialize(void) { + return InitOnceExecuteOnce(&moonlight_runtime_once, moonlight_initialize_runtime, NULL, NULL) + ? ML_STATUS_OK + : ML_STATUS_RUNTIME_FAILURE; +} +#else +#include + +static pthread_once_t moonlight_runtime_once = PTHREAD_ONCE_INIT; + +static void moonlight_initialize_runtime(void) { + int argc = 1; + char program_name[] = "moonlight-triangulation"; + char *argv[] = {program_name, NULL}; + char **argv_pointer = argv; + hs_init(&argc, &argv_pointer); +} + +ML_API ml_status ml_runtime_initialize(void) { + return pthread_once(&moonlight_runtime_once, moonlight_initialize_runtime) == 0 + ? ML_STATUS_OK + : ML_STATUS_RUNTIME_FAILURE; +} +#endif + +ML_API uint32_t ml_abi_version(void) { + return ML_ABI_VERSION; +} diff --git a/ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs b/ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs new file mode 100644 --- /dev/null +++ b/ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs @@ -0,0 +1,80 @@ +-- Generated from Moonlight.Triangulation.Foreign.Contract. +-- Run moonlight-triangulation-ffi-contract write; do not edit this file. + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Moonlight.Triangulation.Foreign.Exports where + +import Data.Int (Int64) +import Data.Word (Word32) +import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..)) +import Foreign.Ptr (Ptr) +import Moonlight.Triangulation.Foreign.Contract + ( CMesh + , CMinkowskiReceipt + , CObstruction + , CRegion + , CStructuringElement + ) +import qualified Moonlight.Triangulation.Foreign.Mesh as Mesh +import qualified Moonlight.Triangulation.Foreign.Morphology as Morphology +import qualified Moonlight.Triangulation.Foreign.Region as Region + +delaunayF64 = Mesh.delaunayF64 +meshInsertManyF64 = Mesh.meshInsertManyF64 +meshSiteUnion = Mesh.meshSiteUnion +meshSiteIntersection = Mesh.meshSiteIntersection +meshSiteDifference = Mesh.meshSiteDifference +meshSiteSymmetricDifference = Mesh.meshSiteSymmetricDifference +meshVertexCount = Mesh.meshVertexCount +meshTriangleCount = Mesh.meshTriangleCount +meshCopyVerticesF64 = Mesh.meshCopyVerticesF64 +meshCopyTrianglesU32 = Mesh.meshCopyTrianglesU32 +meshFree = Mesh.meshFree +regionCreateF64 = Region.regionCreateF64 +regionCounts = Region.regionCounts +regionCopyF64 = Region.regionCopyF64 +regionUnion = Region.regionUnion +regionIntersection = Region.regionIntersection +regionDifference = Region.regionDifference +regionSymmetricDifference = Region.regionSymmetricDifference +regionLocatePointF64 = Region.regionLocatePointF64 +regionMeasure = Region.regionMeasure +regionFree = Region.regionFree +structuringElementCreateF64 = Morphology.structuringElementCreateF64 +structuringElementFree = Morphology.structuringElementFree +regionMinkowskiSum = Morphology.regionMinkowskiSum +regionOffset = Morphology.regionOffset +regionInset = Morphology.regionInset +regionOpen = Morphology.regionOpen +regionClose = Morphology.regionClose + +foreign export ccall "ml_delaunay_f64" delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_insert_many_f64" meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_union" meshSiteUnion :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_intersection" meshSiteIntersection :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_difference" meshSiteDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_symmetric_difference" meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_vertex_count" meshVertexCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_triangle_count" meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_copy_vertices_f64" meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_copy_triangles_u32" meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_free" meshFree :: Ptr CMesh -> IO () +foreign export ccall "ml_region_create_f64" regionCreateF64 :: Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_counts" regionCounts :: Ptr CRegion -> Ptr CSize -> Ptr CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_copy_f64" regionCopyF64 :: Ptr CRegion -> Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_union" regionUnion :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_intersection" regionIntersection :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_difference" regionDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_symmetric_difference" regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_locate_point_f64" regionLocatePointF64 :: Ptr CRegion -> CDouble -> CDouble -> Ptr CUInt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_measure" regionMeasure :: Ptr CRegion -> Ptr Int64 -> Ptr CChar -> CSize -> Ptr CSize -> Ptr CDouble -> Ptr CDouble -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_free" regionFree :: Ptr CRegion -> IO () +foreign export ccall "ml_structuring_element_create_f64" structuringElementCreateF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CStructuringElement) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_structuring_element_free" structuringElementFree :: Ptr CStructuringElement -> IO () +foreign export ccall "ml_region_minkowski_sum" regionMinkowskiSum :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_offset" regionOffset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_inset" regionInset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_open" regionOpen :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_close" regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt diff --git a/ffi/generator/Main.hs b/ffi/generator/Main.hs new file mode 100644 --- /dev/null +++ b/ffi/generator/Main.hs @@ -0,0 +1,116 @@ +module Main (main) where + +import Data.Either (partitionEithers) +import Data.Foldable (traverse_) +import Data.Bifunctor (first) +import Moonlight.Triangulation.Foreign.Contract.Render + ( GeneratedFile (..) + , generatedFiles + ) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.FilePath ((), takeDirectory) +import System.IO (readFile') +import System.IO.Error (ioeGetErrorString, tryIOError) + +data Command + = WriteGenerated !FilePath + | CheckGenerated !FilePath + deriving stock (Eq, Show) + +data GeneratorObstruction + = InvalidArguments + | GeneratedFileMissing !FilePath + | GeneratedFileStale !FilePath + | GeneratedFileReadFailed !FilePath !String + | GeneratedFileWriteFailed !FilePath !String + deriving stock (Eq, Show) + +main :: IO () +main = do + arguments <- getArgs + case parseCommand arguments of + Left obstruction -> reportObstructions [obstruction] + Right command -> runCommand command >>= either reportObstructions (const (pure ())) + +parseCommand :: [String] -> Either GeneratorObstruction Command +parseCommand arguments = + case arguments of + ["write", packageRoot] -> Right (WriteGenerated packageRoot) + ["check", packageRoot] -> Right (CheckGenerated packageRoot) + _ -> Left InvalidArguments + +runCommand :: Command -> IO (Either [GeneratorObstruction] ()) +runCommand command = + case command of + WriteGenerated packageRoot -> do + outcomes <- traverse (writeGeneratedFile packageRoot) generatedFiles + pure (collectObstructions outcomes) + CheckGenerated packageRoot -> do + comparisons <- traverse (checkGeneratedFile packageRoot) generatedFiles + pure (collectObstructions comparisons) + +collectObstructions :: [Either GeneratorObstruction ()] -> Either [GeneratorObstruction] () +collectObstructions outcomes = + case partitionEithers outcomes of + ([], _) -> Right () + (obstructions, _) -> Left obstructions + +writeGeneratedFile :: FilePath -> GeneratedFile -> IO (Either GeneratorObstruction ()) +writeGeneratedFile packageRoot generated@GeneratedFile {generatedFilePath, generatedFileContents} = do + let destination = packageRoot generatedFilePath + comparison <- checkGeneratedFile packageRoot generated + case comparison of + Right () -> putStrLn ("current " <> destination) >> pure (Right ()) + Left (GeneratedFileMissing _) -> replaceGeneratedFile destination generatedFileContents + Left (GeneratedFileStale _) -> replaceGeneratedFile destination generatedFileContents + Left obstruction -> pure (Left obstruction) + +replaceGeneratedFile :: FilePath -> String -> IO (Either GeneratorObstruction ()) +replaceGeneratedFile destination contents = do + outcome <- + captureFileFailure GeneratedFileWriteFailed destination $ do + createDirectoryIfMissing True (takeDirectory destination) + writeFile destination contents + case outcome of + Left obstruction -> pure (Left obstruction) + Right () -> putStrLn ("wrote " <> destination) >> pure (Right ()) + +checkGeneratedFile :: FilePath -> GeneratedFile -> IO (Either GeneratorObstruction ()) +checkGeneratedFile packageRoot GeneratedFile {generatedFilePath, generatedFileContents} = do + let destination = packageRoot generatedFilePath + existence <- captureFileFailure GeneratedFileReadFailed destination (doesFileExist destination) + case existence of + Left obstruction -> pure (Left obstruction) + Right False -> pure (Left (GeneratedFileMissing destination)) + Right True -> do + observed <- captureFileFailure GeneratedFileReadFailed destination (readFile' destination) + pure $ do + contents <- observed + if contents == generatedFileContents + then Right () + else Left (GeneratedFileStale destination) + +captureFileFailure + :: (FilePath -> String -> GeneratorObstruction) + -> FilePath + -> IO value + -> IO (Either GeneratorObstruction value) +captureFileFailure obstruction path action = + first (obstruction path . ioeGetErrorString) <$> tryIOError action + +reportObstructions :: [GeneratorObstruction] -> IO () +reportObstructions obstructions = do + traverse_ (putStrLn . renderObstruction) obstructions + exitFailure + +renderObstruction :: GeneratorObstruction -> String +renderObstruction obstruction = + case obstruction of + InvalidArguments -> + "usage: moonlight-triangulation-ffi-contract (write|check) PACKAGE_ROOT" + GeneratedFileMissing path -> "missing generated file: " <> path + GeneratedFileStale path -> "stale generated file: " <> path + GeneratedFileReadFailed path message -> "cannot read generated file " <> path <> ": " <> message + GeneratedFileWriteFailed path message -> "cannot write generated file " <> path <> ": " <> message diff --git a/ffi/include/moonlight_triangulation.h b/ffi/include/moonlight_triangulation.h new file mode 100644 --- /dev/null +++ b/ffi/include/moonlight_triangulation.h @@ -0,0 +1,204 @@ +// Generated from Moonlight.Triangulation.Foreign.Contract. +// Run moonlight-triangulation-ffi-contract write; do not edit this file. + +#ifndef MOONLIGHT_TRIANGULATION_H +#define MOONLIGHT_TRIANGULATION_H + +#include +#include + +#if defined(_WIN32) +#define ML_API __declspec(dllexport) +#else +#define ML_API __attribute__((visibility("default"))) +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#define ML_ABI_VERSION 2u + +typedef struct ml_mesh ml_mesh; +typedef struct ml_region ml_region; +typedef struct ml_structuring_element ml_structuring_element; + +typedef uint32_t ml_status; +typedef uint32_t ml_obstruction_code; +typedef uint32_t ml_coordinate_error; +typedef uint32_t ml_region_location; +typedef uint32_t ml_minkowski_operation; + +enum { + ML_STATUS_OK = 0, + ML_STATUS_NULL_POINTER = 1, + ML_STATUS_COUNT_OVERFLOW = 2, + ML_STATUS_BUFFER_TOO_SMALL = 3, + ML_STATUS_GEOMETRY_OBSTRUCTION = 4, + ML_STATUS_RUNTIME_FAILURE = 5 +}; + +enum { + ML_OBSTRUCTION_NONE = 0, + ML_OBSTRUCTION_INVALID_COORDINATE = 1, + ML_OBSTRUCTION_POINT_LOCATION_FAILED = 2, + ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED = 3, + ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID = 4, + ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX = 5, + ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING = 6, + ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING = 7, + ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING = 8, + ML_OBSTRUCTION_HULL_START_NOT_VISIBLE = 9, + ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE = 10, + ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE = 11, + ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED = 12, + ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE = 13, + ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE = 14, + ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE = 15, + ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE = 16, + ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION = 17, + ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH = 18, + ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH = 19, + ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT = 20, + ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH = 21, + ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE = 22, + ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY = 23, + ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE = 24, + ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH = 25, + ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH = 26, + ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED = 27, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE = 28, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE = 29, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE = 30, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE = 31, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE = 32, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE = 33, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE = 34, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE = 35, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE = 36, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE = 37, + ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM = 38, + ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE = 39, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE = 40, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING = 41, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS = 42, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED = 43, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION = 44, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION = 45, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION = 46, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE = 47, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE = 48, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED = 49, + ML_OBSTRUCTION_CAPACITY_EXCEEDED = 50, + ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED = 51, + ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52, + ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53, + ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54, + ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55, + ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE = 56, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET = 57, + ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP = 58, + ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED = 59, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE = 60, + ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE = 61, + ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE = 62, + ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED = 63, + ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED = 64, + ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE = 65, + ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED = 66, + ML_OBSTRUCTION_NULL_POINTER = 100, + ML_OBSTRUCTION_COUNT_OVERFLOW = 101, + ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102, + ML_OBSTRUCTION_RUNTIME_FAILURE = 103, + ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200, + ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201, + ML_OBSTRUCTION_OVERLAY_FAILED = 202, + ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203, + ML_OBSTRUCTION_VALUATION_FAILED = 204, + ML_OBSTRUCTION_MINKOWSKI_FAILED = 205, + ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206 +}; + +enum { + ML_COORDINATE_ERROR_NONE = 0, + ML_COORDINATE_ERROR_NAN = 1, + ML_COORDINATE_ERROR_INFINITE = 2, + ML_COORDINATE_ERROR_TOO_SMALL = 3, + ML_COORDINATE_ERROR_TOO_LARGE = 4 +}; + +enum { + ML_REGION_EXTERIOR = 0, + ML_REGION_BOUNDARY = 1, + ML_REGION_INTERIOR = 2 +}; + +enum { + ML_MINKOWSKI_ADDITION = 0, + ML_MINKOWSKI_EROSION = 1, + ML_MINKOWSKI_OPENING = 2, + ML_MINKOWSKI_CLOSING = 3 +}; + +typedef struct ml_obstruction { + uint32_t code; + uint32_t coordinate_error; + uint64_t input_index; + uint64_t first_index; + uint64_t second_index; + double first_value; + double second_value; + double point_x; + double point_y; + char message[256]; +} ml_obstruction; + +typedef struct ml_minkowski_receipt { + uint32_t operation; + uint32_t reserved; + uint64_t input_components; + uint64_t convex_pieces; + uint64_t generated_pieces; + uint64_t generated_convolution_edges; + uint64_t overlay_passes; + uint64_t exact_crossings; + uint64_t output_cells; + uint64_t exact_coordinate_bit_growth; +} ml_minkowski_receipt; + +ML_API uint32_t ml_abi_version(void); +ML_API ml_status ml_runtime_initialize(void); +ML_API ml_status ml_delaunay_f64(const double * coordinates, size_t point_count, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_insert_many_f64(const ml_mesh * mesh, const double * coordinates, size_t point_count, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_site_union(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_site_intersection(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_site_difference(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_site_symmetric_difference(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_vertex_count(const ml_mesh * mesh, size_t * count, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_triangle_count(const ml_mesh * mesh, size_t * count, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_copy_vertices_f64(const ml_mesh * mesh, double * coordinates, size_t point_capacity, size_t * points_written, ml_obstruction * obstruction); +ML_API ml_status ml_mesh_copy_triangles_u32(const ml_mesh * mesh, uint32_t * triangles, size_t triangle_capacity, size_t * triangles_written, ml_obstruction * obstruction); +ML_API void ml_mesh_free(ml_mesh * mesh); +ML_API ml_status ml_region_create_f64(const double * coordinates, size_t point_count, const size_t * loop_point_counts, size_t loop_count, const size_t * component_loop_counts, size_t component_count, ml_region ** result, ml_obstruction * obstruction); +ML_API ml_status ml_region_counts(const ml_region * region, size_t * component_count, size_t * loop_count, size_t * point_count, ml_obstruction * obstruction); +ML_API ml_status ml_region_copy_f64(const ml_region * region, double * coordinates, size_t point_capacity, size_t * loop_point_offsets, size_t loop_offset_capacity, size_t * component_loop_offsets, size_t component_offset_capacity, ml_obstruction * obstruction); +ML_API ml_status ml_region_union(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction); +ML_API ml_status ml_region_intersection(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction); +ML_API ml_status ml_region_difference(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction); +ML_API ml_status ml_region_symmetric_difference(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction); +ML_API ml_status ml_region_locate_point_f64(const ml_region * region, double x, double y, ml_region_location * location, ml_obstruction * obstruction); +ML_API ml_status ml_region_measure(const ml_region * region, int64_t * euler_characteristic, char * area_ratio_utf8, size_t area_capacity, size_t * area_bytes_written, double * perimeter_lower, double * perimeter_upper, ml_obstruction * obstruction); +ML_API void ml_region_free(ml_region * region); +ML_API ml_status ml_structuring_element_create_f64(const double * coordinates, size_t point_count, ml_structuring_element ** result, ml_obstruction * obstruction); +ML_API void ml_structuring_element_free(ml_structuring_element * element); +ML_API ml_status ml_region_minkowski_sum(const ml_region * left, const ml_region * right, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction); +ML_API ml_status ml_region_offset(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction); +ML_API ml_status ml_region_inset(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction); +ML_API ml_status ml_region_open(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction); +ML_API ml_status ml_region_close(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/include/moonlight_triangulation.h b/include/moonlight_triangulation.h deleted file mode 100644 --- a/include/moonlight_triangulation.h +++ /dev/null @@ -1,236 +0,0 @@ -#ifndef MOONLIGHT_TRIANGULATION_H -#define MOONLIGHT_TRIANGULATION_H - -#include -#include - -#if defined(_WIN32) -#define ML_API __declspec(dllexport) -#else -#define ML_API __attribute__((visibility("default"))) -#endif - -#ifdef __cplusplus -extern "C" { -#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_GEOMETRY_OBSTRUCTION = 4, - ML_STATUS_RUNTIME_FAILURE = 5 -}; - -enum { - ML_OBSTRUCTION_NONE = 0, - ML_OBSTRUCTION_INVALID_COORDINATE = 1, - ML_OBSTRUCTION_POINT_LOCATION_FAILED = 2, - ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED = 3, - ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID = 4, - ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX = 5, - ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING = 6, - ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING = 7, - ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING = 8, - ML_OBSTRUCTION_HULL_START_NOT_VISIBLE = 9, - ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE = 10, - ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE = 11, - ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED = 12, - ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE = 13, - ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE = 14, - ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE = 15, - ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE = 16, - ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION = 17, - ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH = 18, - ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH = 19, - ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT = 20, - ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH = 21, - ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE = 22, - ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY = 23, - ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE = 24, - ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH = 25, - ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH = 26, - ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED = 27, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE = 28, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE = 29, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE = 30, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE = 31, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE = 32, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE = 33, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE = 34, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE = 35, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE = 36, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE = 37, - ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM = 38, - ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE = 39, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE = 40, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING = 41, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS = 42, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED = 43, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION = 44, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION = 45, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION = 46, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE = 47, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE = 48, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED = 49, - ML_OBSTRUCTION_CAPACITY_EXCEEDED = 50, - ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED = 51, - ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52, - ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53, - ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54, - ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55, - ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE = 56, - ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET = 57, - ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP = 58, - ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED = 59, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE = 60, - ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE = 61, - ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE = 62, - ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED = 63, - ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED = 64, - ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE = 65, - ML_OBSTRUCTION_NULL_POINTER = 100, - ML_OBSTRUCTION_COUNT_OVERFLOW = 101, - ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102, - ML_OBSTRUCTION_RUNTIME_FAILURE = 103, - ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200, - ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201, - ML_OBSTRUCTION_OVERLAY_FAILED = 202, - ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203, - ML_OBSTRUCTION_VALUATION_FAILED = 204, - ML_OBSTRUCTION_MINKOWSKI_FAILED = 205, - ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206 -}; - -enum { - ML_COORDINATE_ERROR_NONE = 0, - ML_COORDINATE_ERROR_NAN = 1, - ML_COORDINATE_ERROR_INFINITE = 2, - ML_COORDINATE_ERROR_TOO_SMALL = 3, - ML_COORDINATE_ERROR_TOO_LARGE = 4 -}; - -enum { - ML_REGION_EXTERIOR = 0, - ML_REGION_BOUNDARY = 1, - ML_REGION_INTERIOR = 2 -}; - -enum { - ML_MINKOWSKI_ADDITION = 0, - ML_MINKOWSKI_EROSION = 1, - ML_MINKOWSKI_OPENING = 2, - ML_MINKOWSKI_CLOSING = 3 -}; - -typedef struct ml_obstruction { - uint32_t code; - uint32_t coordinate_error; - uint64_t input_index; - uint64_t first_index; - uint64_t second_index; - double first_value; - double second_value; - double point_x; - double point_y; - char message[256]; -} ml_obstruction; - -typedef struct ml_minkowski_receipt { - uint32_t operation; - uint32_t reserved; - uint64_t input_components; - uint64_t convex_pieces; - uint64_t generated_pieces; - uint64_t generated_convolution_edges; - uint64_t overlay_passes; - uint64_t exact_crossings; - uint64_t output_cells; - uint64_t exact_coordinate_bit_growth; -} ml_minkowski_receipt; - -ML_API uint32_t ml_abi_version(void); -ML_API ml_status ml_runtime_initialize(void); - -/* 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_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 -} -#endif - -#endif diff --git a/moonlight-triangulation.cabal b/moonlight-triangulation.cabal --- a/moonlight-triangulation.cabal +++ b/moonlight-triangulation.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: moonlight-triangulation -version: 1.4.0.1 +version: 1.4.0.2 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 @@ -10,15 +10,13 @@ union, intersection and difference return triangulations and refinement composes after them rather than replacing them. One structure-of-arrays half-edge mesh carries the - constrained and unconstrained layers, split into public - sublibraries by role: exact binary64 predicates and paged - storage; the finite DCEL with its handle, - iterator, location and validation surface; circle-sweep bulk - load, incremental insertion, removal, conflict-strip - constraint recovery and Ruppert refinement; the Voronoi dual - with natural-neighbour interpolation and Delaunay hierarchy - hints; a bounded-concurrency interpreter for the join - tournament; and a versioned binary serialization surface. + constrained and unconstrained layers. A private finite-DCEL + and construction tower owns its handles, iterators, + circle-sweep build, incremental edits, constraint recovery, + and refinement. Public opt-in sublibraries expose the exact + scalar core, Voronoi and natural-neighbour dual, bounded + concurrent join interpreter, and versioned serialization + surface beside the main construction facade. On GHC 9.14, a public cell-complex component interprets admitted exact cell selections for Homology and Category and lowers exact Delaunay alpha filtrations into persistent @@ -41,33 +39,61 @@ README.md CHANGELOG.md docs/README.md - docs/moonlight-triangulation-alpha-eclipse.svg - docs/moonlight-triangulation-persistence-rose.svg - docs/social/moonlight-triangulation-persistence-rose.gif - bench/delaunay-compare/results/moonlight-delaunay-compare-small.svg + docs/development.md + docs/examples/README.md + docs/mesh-publication.md + docs/category-observatory/README.md + docs/category-observatory/moonlight-triangulation-category-observatory.svg + docs/delaunay-compare/README.md + docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg + docs/persistence-rose/alpha-eclipse.md + docs/persistence-rose/README.md + docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg + docs/persistence-rose/moonlight-triangulation-persistence-rose.svg + docs/persistence-rose/moonlight-triangulation-persistence-rose.gif extra-source-files: weeder.toml - bench/delaunay-compare/README.md -- The retained CSV, source receipt, and big-point SVG remain beside the - -- benchmark but are not package inputs. The small README projection is the - -- sole published chart and is declared as package documentation above. - 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 - bindings/python/src/moonlight_triangulation/__init__.py - bindings/python/tests/test_binding.py - bindings/rust/Cargo.toml - bindings/rust/build.rs - bindings/rust/src/lib.rs - bindings/rust/tests/binding.rs - bindings/typescript/package.json - bindings/typescript/pnpm-workspace.yaml - bindings/typescript/tsconfig.json - bindings/typescript/src/index.ts - bindings/typescript/test/binding.test.ts + -- benchmark but are not package inputs. The small documentation projection + -- is the sole published chart and is declared above. + docs/delaunay-compare/rust/Cargo.lock + docs/delaunay-compare/rust/Cargo.toml + docs/delaunay-compare/rust/src/lib.rs + ffi/include/moonlight_triangulation.h + ffi/bindings/README.md + ffi/bindings/python/pyproject.toml + ffi/bindings/python/src/moonlight_triangulation/__init__.py + ffi/bindings/python/src/moonlight_triangulation/_binding.py + ffi/bindings/python/src/moonlight_triangulation/_native_generated.py + ffi/bindings/python/src/moonlight_triangulation/errors.py + ffi/bindings/python/src/moonlight_triangulation/values.py + ffi/bindings/python/tests/test_binding.py + ffi/bindings/rust/Cargo.toml + ffi/bindings/rust/build.rs + ffi/bindings/rust/src/binding.rs + ffi/bindings/rust/src/error.rs + ffi/bindings/rust/src/lib.rs + ffi/bindings/rust/src/raw_generated.rs + ffi/bindings/rust/src/values.rs + ffi/bindings/rust/tests/binding.rs + ffi/bindings/typescript/README.md + ffi/bindings/typescript/package.json + ffi/bindings/typescript/pnpm-workspace.yaml + ffi/bindings/typescript/tsconfig.json + ffi/bindings/typescript/src/failure.ts + ffi/bindings/typescript/src/index.ts + ffi/bindings/typescript/src/internal/call.ts + ffi/bindings/typescript/src/internal/decode.ts + ffi/bindings/typescript/src/internal/native.generated.ts + ffi/bindings/typescript/src/internal/resource.ts + ffi/bindings/typescript/src/mesh.ts + ffi/bindings/typescript/src/moonlight.ts + ffi/bindings/typescript/src/morphology.ts + ffi/bindings/typescript/src/region.ts + ffi/bindings/typescript/src/resource.ts + ffi/bindings/typescript/src/values.ts + ffi/bindings/typescript/src/wire.generated.ts + ffi/bindings/typescript/test/binding.test.ts source-repository head type: git @@ -77,7 +103,7 @@ source-repository this type: git location: https://github.com/PaleRoses/moonlight.git - tag: moonlight-triangulation-1.4.0.1 + tag: moonlight-triangulation-1.4.0.2 subdir: moonlight-triangulation flag warnings-as-errors @@ -138,7 +164,7 @@ library dcel import: shared-properties - visibility: public + visibility: private hs-source-dirs: src-dcel exposed-modules: Moonlight.Triangulation.Alpha @@ -223,7 +249,7 @@ library build import: shared-properties - visibility: public + visibility: private hs-source-dirs: src-build exposed-modules: Moonlight.Triangulation.BulkLoad @@ -257,7 +283,6 @@ Moonlight.Triangulation.Internal.Refinement Moonlight.Triangulation.Internal.Transaction Moonlight.Triangulation.Internal.Join.Plan - Moonlight.Triangulation.Internal.Join.Rebuild Moonlight.Triangulation.Internal.Join.SiteSet build-depends: base >= 4.19 && < 5 @@ -333,7 +358,6 @@ import: shared-properties hs-source-dirs: src-public - src-planar exposed-modules: Moonlight.Triangulation Moonlight.Triangulation.HintGenerator @@ -360,9 +384,15 @@ library ffi import: shared-properties visibility: private - hs-source-dirs: src-ffi + hs-source-dirs: ffi/abi exposed-modules: - Moonlight.Triangulation.Foreign.ABI + Moonlight.Triangulation.Foreign.Boundary + Moonlight.Triangulation.Foreign.Contract + Moonlight.Triangulation.Foreign.Contract.Render + Moonlight.Triangulation.Foreign.Mesh + Moonlight.Triangulation.Foreign.Morphology + Moonlight.Triangulation.Foreign.Obstruction + Moonlight.Triangulation.Foreign.Region build-depends: base >= 4.19 && < 5 , containers >= 0.8 && < 0.9 @@ -374,13 +404,13 @@ foreign-library moonlight-triangulation-c import: shared-properties type: native-shared - hs-source-dirs: src-capi + hs-source-dirs: ffi/exports other-modules: Moonlight.Triangulation.Foreign.Exports c-sources: - cbits/moonlight_runtime.c + ffi/cbits/moonlight_runtime.c include-dirs: - include + ffi/include install-includes: moonlight_triangulation.h build-depends: @@ -389,12 +419,22 @@ ghc-options: -threaded if os(windows) options: standalone - mod-def-file: cbits/moonlight-triangulation.def + mod-def-file: ffi/cbits/moonlight-triangulation.def else extra-libraries: pthread if os(linux) lib-version-info: 2:0:0 +executable moonlight-triangulation-ffi-contract + import: shared-properties + hs-source-dirs: ffi/generator + main-is: Main.hs + build-depends: + base >= 4.19 && < 5 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , moonlight-triangulation:ffi >= 1.4 && < 1.5 + -- ── test slices ────────────────────────────────────────────────────────────── -- Each slice is an ATOM: a @common@ stanza binding a spec module to the @@ -513,6 +553,22 @@ , tasty-hunit >= 0.10 && < 0.11 , vector >= 0.13 && < 0.14 +-- Canonical documentation examples compile exclusively against the public +-- facade and retain their expected semantic summaries as executable checks. +test-suite moonlight-triangulation-examples-test + import: triangulation-test-properties + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/examples + docs/examples + other-modules: + Moonlight.Triangulation.Example.AlphaBoundary + Moonlight.Triangulation.Example.ConstrainedRegion + Moonlight.Triangulation.Example.PlanarRegion + Moonlight.Triangulation.Example.SetAlgebra + build-depends: containers >= 0.8 && < 0.9 + -- One pure, source-grounded projection of the alpha, dual, interpolation, -- planar-algebra, and persistence owners. The test shares the internal exhibit -- module; neither component creates a public visualization API. @@ -522,7 +578,7 @@ main-is: Main.hs hs-source-dirs: test/persistence-rose - app/persistence-rose + docs/persistence-rose other-modules: Moonlight.Triangulation.Exhibit.PersistenceRose if impl(ghc < 9.14) @@ -714,7 +770,7 @@ import: triangulation-delaunay-compare-properties ghc-options: -threaded -rtsopts main-is: Main.hs - hs-source-dirs: bench/delaunay-compare + hs-source-dirs: docs/delaunay-compare other-modules: Moonlight.Triangulation.Bench.DelaunayCompare.Domain Moonlight.Triangulation.Bench.DelaunayCompare.Native @@ -731,7 +787,7 @@ executable moonlight-triangulation-delaunay-pictures import: triangulation-delaunay-compare-properties main-is: PictureMain.hs - hs-source-dirs: bench/delaunay-compare + hs-source-dirs: docs/delaunay-compare other-modules: Moonlight.Triangulation.Bench.DelaunayCompare.Domain Moonlight.Triangulation.Bench.DelaunayCompare.Picture @@ -744,7 +800,15 @@ executable moonlight-triangulation-category-observatory-export import: shared-properties main-is: Main.hs - hs-source-dirs: app/category-observatory + hs-source-dirs: docs/category-observatory + other-modules: + Moonlight.Triangulation.Exhibit.CategoryObservatory + Moonlight.Triangulation.Exhibit.CategoryObservatory.Category + Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry + Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier + Moonlight.Triangulation.Exhibit.CategoryObservatory.Model + Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve + Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture ghc-options: -Wall -Wcompat default-extensions: TypeFamilies @@ -755,6 +819,8 @@ , base >= 4.22 && < 5 , bytestring >= 0.12 && < 0.13 , containers >= 0.6 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 , moonlight-category >= 1.1.0.0 && < 1.2 , moonlight-category:simplicial >= 1.1.0.0 && < 1.2 , moonlight-homology:cell-category >= 0.1.0.2 && < 0.2 @@ -762,12 +828,13 @@ , moonlight-triangulation:build , moonlight-triangulation:cell-complex , moonlight-triangulation:dcel + , transformers >= 0.5 && < 0.7 , vector >= 0.13 && < 0.14 executable moonlight-triangulation-persistence-rose import: shared-properties main-is: Main.hs - hs-source-dirs: app/persistence-rose + hs-source-dirs: docs/persistence-rose other-modules: Moonlight.Triangulation.Exhibit.PersistenceRose if impl(ghc < 9.14) @@ -786,6 +853,93 @@ , text >= 2.0 && < 2.2 , transformers >= 0.5 && < 0.7 , vector >= 0.13 && < 0.14 + +-- These referent instruments inspect package-internal handles and thaw/freeze +-- lanes. They belong to the triangulation package rather than reopening its +-- private construction boundary through a second package. +executable moonlight-triangulation-spade-referent + default-language: GHC2024 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -O2 + -rtsopts + default-extensions: + BangPatterns + LambdaCase + NumericUnderscores + hs-source-dirs: bench/spade-compare/hs + main-is: Main.hs + -- Main is the entry and the lane dispatch; every workload, gate and + -- diagnostic sits in the domain module that owns it. The domains depend on + -- SpadeCompare.Support and on nothing else of each other, so they compile in + -- parallel and a lane edit rebuilds one slice. + other-modules: + Moonlight.Triangulation.Bench.SpadeCompare.Lane + Moonlight.Triangulation.Bench.SpadeCompare.Input + Moonlight.Triangulation.Bench.SpadeCompare.Timing + Moonlight.Triangulation.Bench.SpadeCompare.Support + Moonlight.Triangulation.Bench.SpadeCompare.Delaunay + Moonlight.Triangulation.Bench.SpadeCompare.Removal + Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy + Moonlight.Triangulation.Bench.SpadeCompare.Constraint + Moonlight.Triangulation.Bench.SpadeCompare.Interpolation + Moonlight.Triangulation.Bench.SpadeCompare.Voronoi + Moonlight.Triangulation.Bench.SpadeCompare.Dcel + Moonlight.Triangulation.Bench.SpadeCompare.Intersection + Moonlight.Triangulation.Bench.SpadeCompare.Gates + build-depends: + base >= 4.22 && < 5 + , deepseq >= 1.4 && < 1.6 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , vector >= 0.13 && < 0.14 + , primitive >= 0.9 && < 0.10 + , moonlight-triangulation + , moonlight-triangulation:dcel + , moonlight-triangulation:build + , moonlight-triangulation:dual + +-- The alpha comparison is deliberately opt-in: ordinary scorecard listing and +-- replay do not inherit Homology merely because this diagnostic exists beside +-- the canonical board. +executable moonlight-triangulation-alpha-spade-referent + default-language: GHC2024 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -O2 + -rtsopts + default-extensions: + BangPatterns + LambdaCase + NumericUnderscores + hs-source-dirs: + bench/spade-compare/hs-alpha + bench/spade-compare/hs + main-is: Main.hs + other-modules: + Moonlight.Triangulation.Bench.SpadeCompare.Alpha + Moonlight.Triangulation.Bench.SpadeCompare.Input + Moonlight.Triangulation.Bench.SpadeCompare.Lane + Moonlight.Triangulation.Bench.SpadeCompare.Timing + build-depends: + base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + , deepseq >= 1.4 && < 1.6 + , vector >= 0.13 && < 0.14 + , moonlight-homology >= 0.1 && < 0.2 + , moonlight-triangulation:build + , moonlight-triangulation:cell-complex + , moonlight-triangulation:dcel -- One exact Delaunay alpha filtration versus independently restricting and -- reducing the same chain complex at every critical radius. Construction of 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 @@ -14,6 +14,7 @@ , delaunayGeometry , DuplicatePayloadPolicy (..) , delaunayFromCoordinates + , delaunayFromAdmittedDistinctAscending , insert , insertAt , insertMany @@ -49,7 +50,8 @@ , setCounter ) import Moonlight.Triangulation.Internal.CircleSweep - ( circleSweepInsert + ( RadiallyOrderedArena + , circleSweepInsert , radiallyOrderArena , radiallyOrderGeometry ) @@ -107,6 +109,17 @@ = KeepFirstPayload | CombineDuplicatePayload !(vertex -> vertex -> vertex) +-- | The two lawful ingress sections for the one bulk construction engine. +-- Raw callers need coordinate admission and duplicate classification; an exact +-- SiteSet has already established canonical, distinct, lexicographically +-- ascending 'QueryPoint's. The latter remains package-internal through the +-- private build component, rather than becoming a second constructor. +data BulkInput vertex + = RawPossiblyDuplicate + !(Int -> Point) + !(DuplicatePayloadPolicy vertex) + | AdmittedDistinctAscending !(Int -> QueryPoint) + -- | The local identity verdict for one input position. A fresh verdict carries -- the canonical coordinates already admitted to the mutable DCEL, so ingress -- never rereads its own writes merely to accumulate the sweep centre. @@ -127,9 +140,8 @@ buildDelaunayFromSource defaults (V.length input) - (position . (input V.!)) + (RawPossiblyDuplicate (position . (input V.!)) KeepFirstPayload) (input V.!) - KeepFirstPayload -- | Build the geometry-only Delaunay triangulation of a coordinate vector. -- Exact duplicate positions collapse to one site. Use 'delaunay' or @@ -291,60 +303,65 @@ buildDelaunayFromSource defaults coordinateCount - (coordinates V.!) + (RawPossiblyDuplicate (coordinates V.!) duplicatePolicy) (payloads V.!) - duplicatePolicy where !coordinateCount = V.length coordinates !payloadCount = V.length payloads +-- | Construction from an already-admitted exact site section. The caller +-- supplies Map-ascending, distinct 'QueryPoint's; this skips only raw +-- admission, duplicate classification, and unique-site recentering. It still +-- derives the radial execution order and runs the one circle sweep. +delaunayFromAdmittedDistinctAscending + :: forall vertex directed undirected face + . ElementDefaults directed undirected face + -> V.Vector (QueryPoint, vertex) + -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face) +delaunayFromAdmittedDistinctAscending defaults input = + buildDelaunayFromSource + defaults + (V.length input) + (AdmittedDistinctAscending (\index -> fst (input V.! index))) + (\index -> snd (input V.! index)) +{-# INLINE delaunayFromAdmittedDistinctAscending #-} + buildDelaunayFromSource :: forall vertex directed undirected face . ElementDefaults directed undirected face -> Int - -> (Int -> Point) + -> BulkInput vertex -> (Int -> vertex) - -> DuplicatePayloadPolicy vertex -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face) -buildDelaunayFromSource defaults inputCount pointAtInput payloadAtInput duplicatePolicy = do +buildDelaunayFromSource defaults inputCount input payloadAtInput = do ensureCapacity inputCount runST $ do inputArena <- MUV.new inputCount - admitted <- initializeInputArena inputArena 0 0 0 + admitted <- initializeInputArena inputArena case admitted of Left failure -> pure (Left failure) Right (inputSumX, inputSumY) -> do - let !inputScale = if inputCount == 0 then 0 else recip (fromIntegral inputCount) - !inputCenterX = inputSumX * inputScale - !inputCenterY = inputSumY * inputScale - assignRadialDistances inputArena inputCenterX inputCenterY 0 - orderedInputArena <- radiallyOrderArena inputArena mutable <- newMutableDcel defaults (planarDcelCapacity inputCount) operation <- newOperationState (halfEdgeCapacity mutable) - mapping <- newPrimArray inputCount - unique <- classifySortedInputs mapping inputArena - (sumX, sumY) <- appendClassifiedInputs mutable mapping 0 0 0 + (mapping, unique, orderedArena) <- + case input of + RawPossiblyDuplicate pointAtInput duplicatePolicy -> + prepareRawInput + inputArena + mutable + pointAtInput + duplicatePolicy + inputSumX + inputSumY + AdmittedDistinctAscending _ -> + prepareAdmittedDistinctInput inputArena mutable inputSumX inputSumY setCounter operation CounterInputPoints inputCount setCounter operation CounterUniquePoints unique setCounter operation CounterDuplicatePoints (inputCount - unique) inserted <- if unique == 0 then pure (Right 0) - else do - orderedArena <- - if unique == inputCount - then pure orderedInputArena - else do - let !scale = recip (fromIntegral unique) - !uniqueArena = MUV.unsafeSlice 0 unique inputArena - rewriteCompactedArena - mapping - (sumX * scale) - (sumY * scale) - uniqueArena - 0 - radiallyOrderArena uniqueArena - circleSweepInsert mutable operation orderedArena + else circleSweepInsert mutable operation orderedArena case inserted of Left failure -> pure (Left failure) Right seedCount -> do @@ -364,18 +381,29 @@ } ) where - -- Validate, canonicalize, and materialize each source position in one local - -- section. The former validation pass and centre fold both traversed the - -- boxed source before arena generation traversed it a third time; this - -- section returns their only global invariant, the coordinate sum. + -- Raw sources validate and canonicalize at this one ingress. Admitted + -- sources merely project their retained QueryPoint evidence into the sweep + -- arena; neither route reconstructs coordinate identity downstream. initializeInputArena :: forall s . MUV.MVector s (Double, Double, Double, Word32) + -> ST s (Either BuildError (Double, Double)) + initializeInputArena arena = + case input of + RawPossiblyDuplicate pointAtInput _ -> + initializeRawInputArena arena pointAtInput 0 0 0 + AdmittedDistinctAscending pointAtInput -> + initializeAdmittedInputArena arena pointAtInput + + initializeRawInputArena + :: forall s + . MUV.MVector s (Double, Double, Double, Word32) + -> (Int -> Point) -> Int -> Double -> Double -> ST s (Either BuildError (Double, Double)) - initializeInputArena arena !index !sumX !sumY + initializeRawInputArena arena pointAtInput !index !sumX !sumY | index >= inputCount = pure (Right (sumX, sumY)) | otherwise = case validatePoint (Just index) (pointAtInput index) of @@ -384,8 +412,99 @@ case queryPointValue admitted of Point x y -> do MUV.unsafeWrite arena index (0, x, y, fromIntegral index) - initializeInputArena arena (index + 1) (sumX + x) (sumY + y) + initializeRawInputArena + arena + pointAtInput + (index + 1) + (sumX + x) + (sumY + y) + initializeAdmittedInputArena + :: forall s + . MUV.MVector s (Double, Double, Double, Word32) + -> (Int -> QueryPoint) + -> ST s (Either BuildError (Double, Double)) + initializeAdmittedInputArena arena pointAtInput = + Right + <$> MUV.ifoldM' + (\(!sumX, !sumY) index _ -> + case queryPointValue (pointAtInput index) of + Point x y -> do + MUV.unsafeWrite arena index (0, x, y, fromIntegral index) + pure (sumX + x, sumY + y) + ) + (0, 0) + arena + + prepareRawInput + :: forall s + . MUV.MVector s (Double, Double, Double, Word32) + -> MutableDcel s vertex directed undirected face + -> (Int -> Point) + -> DuplicatePayloadPolicy vertex + -> Double + -> Double + -> ST s (MutablePrimArray s Word32, Int, RadiallyOrderedArena s) + prepareRawInput inputArena mutable pointAtInput duplicatePolicy inputSumX inputSumY = do + let !inputScale = if inputCount == 0 then 0 else recip (fromIntegral inputCount) + !inputCenterX = inputSumX * inputScale + !inputCenterY = inputSumY * inputScale + assignRadialDistances inputArena inputCenterX inputCenterY 0 + orderedInputArena <- radiallyOrderArena inputArena + mapping <- newPrimArray inputCount + unique <- classifySortedInputs mapping inputArena + (sumX, sumY) <- + appendClassifiedInputs mutable mapping pointAtInput duplicatePolicy 0 0 0 + orderedArena <- + if unique == inputCount + then pure orderedInputArena + else do + let !scale = recip (fromIntegral unique) + !uniqueArena = MUV.unsafeSlice 0 unique inputArena + rewriteCompactedArena + mapping + (sumX * scale) + (sumY * scale) + uniqueArena + 0 + radiallyOrderArena uniqueArena + pure (mapping, unique, orderedArena) + + prepareAdmittedDistinctInput + :: forall s + . MUV.MVector s (Double, Double, Double, Word32) + -> MutableDcel s vertex directed undirected face + -> Double + -> Double + -> ST s (MutablePrimArray s Word32, Int, RadiallyOrderedArena s) + prepareAdmittedDistinctInput inputArena mutable inputSumX inputSumY = do + mapping <- newPrimArray inputCount + appendAdmittedDistinctInputs mutable mapping inputArena + let !inputScale = if inputCount == 0 then 0 else recip (fromIntegral inputCount) + !inputCenterX = inputSumX * inputScale + !inputCenterY = inputSumY * inputScale + assignRadialDistances inputArena inputCenterX inputCenterY 0 + orderedArena <- radiallyOrderArena inputArena + pure (mapping, inputCount, orderedArena) + + -- An admitted SiteSet is already distinct. Sequential append therefore + -- transports the identity class map directly into authoritative vertex ids, + -- without reopening duplicate policy or recentering a compacted arena. + appendAdmittedDistinctInputs + :: forall s + . MutableDcel s vertex directed undirected face + -> MutablePrimArray s Word32 + -> MUV.MVector s (Double, Double, Double, Word32) + -> ST s () + appendAdmittedDistinctInputs mutable mapping arena = + MUV.imapM_ + (\index (_, x, y, _) -> do + vertex <- appendVertexCoordinates mutable x y (payloadAtInput index) + writePrimArray mapping index (fromIntegral vertex) + MUV.unsafeWrite arena index (0, x, y, fromIntegral vertex) + ) + arena + -- The all-input centre seeds the first radial ordering. Duplicate -- equivalence classes become adjacent in that total order; after descent, -- the compacted section is recentered over unique sites and ordered once @@ -400,10 +519,10 @@ assignRadialDistances arena centerX centerY !index | index >= inputCount = pure () | otherwise = do - (_, x, y, input) <- MUV.unsafeRead arena index + (_, x, y, inputOrdinal) <- MUV.unsafeRead arena index let !deltaX = centerX - x !deltaY = centerY - y - MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, input) + MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, inputOrdinal) assignRadialDistances arena centerX centerY (index + 1) -- Classify the sorted local sections by exact canonical position. The @@ -421,20 +540,28 @@ writePrimArray mapping (fromIntegral firstInput) firstInput classifyFrom first firstX firstY firstInput 1 1 where + classifyFrom + :: (Double, Double, Double, Word32) + -> Double + -> Double + -> Word32 + -> Int + -> Int + -> ST s Int classifyFrom !_ !previousX !previousY !classInput !readIndex !uniqueCount | readIndex >= inputCount = pure uniqueCount | otherwise = do - record@(_, x, y, input) <- MUV.unsafeRead arena readIndex + record@(_, x, y, inputOrdinal) <- MUV.unsafeRead arena readIndex if x == previousX && y == previousY then do - writePrimArray mapping (fromIntegral input) classInput + writePrimArray mapping (fromIntegral inputOrdinal) classInput classifyFrom record previousX previousY classInput (readIndex + 1) uniqueCount else do - writePrimArray mapping (fromIntegral input) input + writePrimArray mapping (fromIntegral inputOrdinal) inputOrdinal if uniqueCount == readIndex then pure () else MUV.unsafeWrite arena uniqueCount record - classifyFrom record x y input (readIndex + 1) (uniqueCount + 1) + classifyFrom record x y inputOrdinal (readIndex + 1) (uniqueCount + 1) -- Materialize in original order, preserving the established handle -- assignment and duplicate-payload law. The equivalence mapping for a @@ -443,11 +570,13 @@ :: forall s . MutableDcel s vertex directed undirected face -> MutablePrimArray s Word32 + -> (Int -> Point) + -> DuplicatePayloadPolicy vertex -> Int -> Double -> Double -> ST s (Double, Double) - appendClassifiedInputs mutable mapping !index !sumX !sumY + appendClassifiedInputs mutable mapping pointAtInput duplicatePolicy !index !sumX !sumY | index >= inputCount = pure (sumX, sumY) | otherwise = do classInput <- readPrimArray mapping index @@ -462,6 +591,8 @@ appendClassifiedInputs mutable mapping + pointAtInput + duplicatePolicy (index + 1) (sumX + canonicalX) (sumY + canonicalY) @@ -473,7 +604,14 @@ CombineDuplicatePayload combine -> do residentData <- vertexDataAt mutable resident writeVertexData mutable resident (combine residentData vertexData) - appendClassifiedInputs mutable mapping (index + 1) sumX sumY + appendClassifiedInputs + mutable + mapping + pointAtInput + duplicatePolicy + (index + 1) + sumX + sumY -- Once duplicates have shortened the vertex arena, translate each compacted -- representative from its input-class name to its authoritative vertex and 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 @@ -17,16 +17,12 @@ , constrainedSeamFaceFirstPoint , constrainedSeamFaceSecondPoint , constrainedSeamFaceThirdPoint - , ConstrainedSeamConstraintEvidence - , constrainedSeamConstraintSegment - , constrainedSeamConstraintRecovery , ConstrainedSeamResult , constrainedSeamResultTriangulation , constrainedSeamLeftFaceCount , constrainedSeamRightFaceEvidence , constrainedSeamJoinFaces , constrainedSeamLeftConstraintCount - , constrainedSeamRightConstraintEvidence , constrainedSeamConstraintStats , constrainedSeamBuildStats , constrainedSeamPublicationStats @@ -102,7 +98,6 @@ , ConstraintBatchStats (..) , ConstrainedExtensionResult (..) , ConstrainedSeamSide (..) - , ConstrainedSeamConstraintEvidence (..) , ConstrainedSeamFaceEvidence (..) , ConstrainedSeamResult (..) , ConstraintConflict (..) 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 @@ -8,6 +8,7 @@ ( insertExistingVertex , insertExistingVertexWithHint , insertPointCombining + , insertAdmittedPointCombining , insertVertexAtPoint , insertExistingVertexAtLocation ) where @@ -37,11 +38,12 @@ import Moonlight.Triangulation.Math import Moonlight.Triangulation.Types --- | The shared exact-site insertion interpreter. Geometry decides whether a --- site is new; callers choose only the annotation law for an occupied site. --- Keeping the validation, location, placement, and counters here prevents --- sessions and constrained extension from drifting into two insertion --- semantics merely because they own different enclosing transactions. +-- | Admit a raw site, then delegate to the shared admitted-site interpreter. +-- Geometry decides whether a site is new; callers choose only the annotation +-- law for an occupied site. Keeping raw admission and the common location, +-- placement, and counters in this one owner prevents sessions and constrained +-- extension from drifting into two insertion semantics merely because they own +-- different enclosing transactions. insertPointCombining :: (vertex -> vertex -> vertex) -> Maybe Int @@ -53,21 +55,43 @@ insertPointCombining combine seed mutable operation point payload = case validatePoint Nothing point of Left failure -> pure (Left failure) - Right _ -> do - addCounter operation CounterInputPoints 1 - outcome <- insertVertexAtPoint @'ProbeOff mutable operation seed point payload - case outcome of - Left failure -> pure (Left failure) - Right resolved@(vertex, disposition) -> do - case disposition of - AlreadyPresent -> do - resident <- vertexDataAt mutable vertex - writeVertexData mutable vertex (combine resident payload) - addCounter operation CounterExistingPoints 1 - addCounter operation CounterDuplicatePoints 1 - Inserted -> addCounter operation CounterUniquePoints 1 - pure (Right resolved) + Right admitted -> + insertAdmittedPointCombining combine seed mutable operation admitted payload {-# INLINE insertPointCombining #-} + +-- | Insert an already admitted site. The caller has retained the canonical +-- coordinate section, so this interpreter only locates and glues the payload; +-- it must not reopen coordinate admission. +insertAdmittedPointCombining + :: (vertex -> vertex -> vertex) + -> Maybe Int + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> QueryPoint + -> vertex + -> ST s (Either BuildError (Int, InsertionDisposition)) +insertAdmittedPointCombining combine seed mutable operation queryPoint payload = do + addCounter operation CounterInputPoints 1 + outcome <- + insertVertexAtPoint + @'ProbeOff + mutable + operation + seed + (queryPointValue queryPoint) + payload + case outcome of + Left failure -> pure (Left failure) + Right resolved@(vertex, disposition) -> do + case disposition of + AlreadyPresent -> do + resident <- vertexDataAt mutable vertex + writeVertexData mutable vertex (combine resident payload) + addCounter operation CounterExistingPoints 1 + addCounter operation CounterDuplicatePoints 1 + Inserted -> addCounter operation CounterUniquePoints 1 + pure (Right resolved) +{-# INLINE insertAdmittedPointCombining #-} insertExistingVertex :: forall p s vertex directed undirected face 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 @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | The singleton segment verbs: glue one segment or a polyline, and retire a -- constraint, each inside one sealed transaction. @@ -43,25 +44,20 @@ import Moonlight.Triangulation.Internal.Representation import Moonlight.Triangulation.Internal.Transaction (runUnmeasuredTransaction) import Moonlight.Triangulation.Internal.Types -import Moonlight.Triangulation.Math -- | Site both endpoints and glue the segment between them, in one transaction. -- A refused request publishes nothing, so the caller's triangulation still -- stands and the endpoints it would have sited are not among its vertices. addConstraintEdge - :: HasPosition vertex + :: forall vertex directed undirected face + . HasPosition vertex => Triangulation 'Constrained vertex directed undirected face -> vertex -> vertex -> Either (CdtError) (ConstraintResult vertex directed undirected face) addConstraintEdge triangulation fromVertex toVertex = do - _ <- first CdtBuildError (validatePoint Nothing fromPoint) - _ <- first CdtBuildError (validatePoint Nothing toPoint) result <- - case - ( lookupExistingConstraintEndpoint triangulation fromPoint - , lookupExistingConstraintEndpoint triangulation toPoint - ) of + case (fromExisting, toExisting) of (Just from, Just to) -> case constraintAdmission triangulation from to of ConstraintBlocked blocking -> Left (ConstraintIntersection blocking) @@ -72,22 +68,48 @@ fromVertex to toVertex - _ -> addConstraintWithEndpointPlacement + _ -> addConstraintWithEndpointPlacement fromExisting toExisting pure result where !fromPoint = position fromVertex !toPoint = position toVertex + !fromExisting = lookupExistingConstraintEndpoint triangulation fromPoint + !toExisting = lookupExistingConstraintEndpoint triangulation toPoint - addConstraintWithEndpointPlacement = do + addConstraintWithEndpointPlacement existingFrom existingTo = do (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 + runUnmeasuredTransaction + CdtBuildError + LocalTransaction + triangulation + (missingEndpointCount existingFrom + missingEndpointCount existingTo) + $ \mutable operation -> do + programWords <- newGrowableWord32 256 + asConstraintStep + (placeOrReuseConstraintEndpoint mutable operation existingFrom fromPoint fromVertex) + `bindMutable` \from -> + asConstraintStep + (placeOrReuseConstraintEndpoint mutable operation existingTo toPoint toVertex) + `bindMutable` \to -> + recoverConstraintRequest programWords mutable operation from to pure (publishConstraintResult frozen request) + + missingEndpointCount :: Maybe VertexId -> Int + missingEndpointCount = maybe 1 (const 0) + + placeOrReuseConstraintEndpoint + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe VertexId + -> Point + -> vertex + -> ST s (Either BuildError VertexId) + placeOrReuseConstraintEndpoint mutable operation existing point payload = + case existing of + Just vertex@(VertexId rawVertex) -> do + writeVertexData mutable (fromIntegral rawVertex) payload + pure (Right vertex) + Nothing -> placeConstraintEndpoint mutable operation Nothing point payload -- | The common singleton case already owns both sites. Resolve them before -- opening topology, then retain the original payload semantics in the 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 @@ -97,22 +97,18 @@ -> VertexId -> Either (CdtError) (ConstraintResult vertex directed undirected face) addConstraintAndSplit makeVertex triangulation from to = do - validateEndpoints triangulation from to - if from == to - then pure (ConstraintRecoveryResult triangulation V.empty 0) - else do - (published, receipts) <- - driveConstraintSplits LocalTransaction makeVertex triangulation (V.singleton (from, to)) - pure - ( case receipts V.!? 0 of - Just receipt -> - ConstraintRecoveryResult - { constraintRecoveryTriangulation = published - , constraintRecoveryPathReceipt = splitReceiptPath receipt - , constraintRecoveryAddedEdges = splitReceiptAdded receipt - } - Nothing -> ConstraintRecoveryResult published V.empty 0 - ) + (published, receipts) <- + driveConstraintSplits LocalTransaction makeVertex triangulation (V.singleton (from, to)) + pure + ( case receipts V.!? 0 of + Just receipt -> + ConstraintRecoveryResult + { constraintRecoveryTriangulation = published + , constraintRecoveryPathReceipt = splitReceiptPath receipt + , constraintRecoveryAddedEdges = splitReceiptAdded receipt + } + Nothing -> ConstraintRecoveryResult published V.empty 0 + ) -- | Divide every requested segment inside as few transactions as the vertex -- reservation allows: usually one, which is the referent semantics for a @@ -179,8 +175,12 @@ ) driveConstraintSplits shape makeVertex base requests = do V.mapM_ (uncurry (validateEndpoints base)) requests - advance base 0 [] Nothing + if V.all (uncurry (==)) requests + then Right (base, V.replicate (V.length requests) emptySplitReceipt) + else advance base 0 [] Nothing where + emptySplitReceipt = SplitReceipt V.empty 0 + advance :: Triangulation 'Constrained vertex directed undirected face -> Int 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 @@ -13,7 +13,6 @@ , ConstrainedUnionError (..) , ConstrainedSeamSide (..) , ConstrainedSeamFaceEvidence (..) - , ConstrainedSeamConstraintEvidence (..) , ConstrainedSeamResult (..) , CorridorObstruction (..) , ConstraintRecoveryResult (..) @@ -152,18 +151,6 @@ deriving stock (Eq, Show, Generic) deriving anyclass (NFData) --- | Exact transport of one source constraint segment. 'Nothing' means its --- copied constraint edge already represented the segment after zippering; --- 'Just' records the corridor outcome when recovery was required. -data ConstrainedSeamConstraintEvidence = ConstrainedSeamConstraintEvidence - { constrainedSeamConstraintSegment :: !(CanonicalSegment) - -- ^ Canonical source segment preserved by the publication. - , constrainedSeamConstraintRecovery :: !(Maybe ConstraintOutcome) - -- ^ Recovery work when copying alone did not preserve the segment. - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - -- | Atomic publication of a source-preserving constrained seam and the proof -- needed to transport solved face-indexed data. The receipt is derived during -- the ordered append/seam interpretation; canonical numbering remains an @@ -183,9 +170,6 @@ -- ^ Exact final J component, including rewritten exterior source filler. , constrainedSeamLeftConstraintCount :: {-# UNPACK #-} !Int -- ^ Stable number of left-source constraints. - , constrainedSeamRightConstraintEvidence - :: !(V.Vector (ConstrainedSeamConstraintEvidence)) - -- ^ Preservation evidence for right-source constraints. , constrainedSeamConstraintStats :: !ConstraintBatchStats -- ^ Constraint recovery work performed by the seam. , constrainedSeamBuildStats :: !BuildStats 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 @@ -29,7 +29,7 @@ import qualified Moonlight.Triangulation.Dcel as Dcel import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Internal.Canonical (canonicalize) -import Moonlight.Triangulation.Insertion (insertPointCombining) +import Moonlight.Triangulation.Insertion (insertAdmittedPointCombining) import Moonlight.Triangulation.Refinement (validateRefinementParameters) import Moonlight.Triangulation.Internal.Cdt.Batch ( finalizeConstraintBatch @@ -41,7 +41,6 @@ import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) import Moonlight.Triangulation.IntersectionIterator (foldCorridorBetweenPoints) import Moonlight.Triangulation.Internal.Cdt.Types -import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) import Moonlight.Triangulation.Internal.Join.Seam ( executeConstrainedSeam , planSeam @@ -55,6 +54,7 @@ ) import Moonlight.Triangulation.Internal.Join.SiteSet ( SiteSet + , delaunayFromSiteSet , siteSetAssocs , siteSetFromTriangulation , siteSetPoints @@ -111,7 +111,7 @@ unconstrained <- Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) - (rebuildCanonicalSiteSet unionSites) + (delaunayFromSiteSet unionSites) requests <- traverse (segmentRequest unconstrained) (V.toList segments) recovered <- Bifunctor.first ConstraintUnionConstructionFailed @@ -183,11 +183,11 @@ (ConstrainedUnionError) (ConstrainedSeamResult annotation) joinSeparatedConstrained sourceFacePreserved parameters left right = do - vertexDefault <- ensureDefaultedPayloads left right Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) (validateRefinementParameters parameters) seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right) + vertexDefault <- ensureDefaultedPayloads left right seamExecution <- Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) @@ -200,8 +200,6 @@ right ) let published = seamExecutionTriangulation seamExecution - rightSegments = constraintSegments right - rightConstraintEvidence <- sourceConstraintEvidence rightSegments Map.empty pure ConstrainedSeamResult { constrainedSeamResultTriangulation = published @@ -209,7 +207,6 @@ , constrainedSeamRightFaceEvidence = seamExecutionRightFaceEvidence seamExecution , constrainedSeamJoinFaces = seamExecutionJoinFaces seamExecution , constrainedSeamLeftConstraintCount = Dcel.numConstraints left - , constrainedSeamRightConstraintEvidence = rightConstraintEvidence , constrainedSeamConstraintStats = ConstraintBatchStats 0 0 0 0 0 0 , constrainedSeamBuildStats = seamExecutionBuildStats seamExecution , constrainedSeamPublicationStats = seamExecutionPublicationStats seamExecution @@ -222,9 +219,7 @@ -> Either ConstrainedUnionError annotation ensureDefaultedPayloads left right = case - ( triSeamFrontier left - , triSeamFrontier right - , boxedFill (triVertexData left) + ( boxedFill (triVertexData left) , boxedFill (triDirectedData left) , boxedFill (triUndirectedData left) , boxedFill (triFaceData left) @@ -233,9 +228,7 @@ , boxedFill (triUndirectedData right) , boxedFill (triFaceData right) ) of - ( Just _ - , Just _ - , Just vertexDefault + ( Just vertexDefault , Just _ , Just _ , Just _ @@ -246,21 +239,6 @@ ) -> Right vertexDefault _ -> Left ConstraintUnionRequiresGeometryOnlyPublication -sourceConstraintEvidence - :: V.Vector (CanonicalSegment) - -> Map.Map (CanonicalSegment) ConstraintOutcome - -> Either (ConstrainedUnionError) (V.Vector (ConstrainedSeamConstraintEvidence)) -sourceConstraintEvidence segments recovered = - traverse - (\segment -> - Right - ConstrainedSeamConstraintEvidence - { constrainedSeamConstraintSegment = segment - , constrainedSeamConstraintRecovery = Map.lookup segment recovered - } - ) - segments - -- | Extend one already-resident constrained triangulation with one new -- constrained section. This is intentionally asymmetric: the base mesh is -- thawed once, extension sites are inserted into it, and only the extension's @@ -306,10 +284,13 @@ , residentCorridorIsEmpty segment -> LocalTransaction _ -> DenseTransaction residentCorridorIsEmpty segment = - case (mkQueryPoint (segmentStart segment), mkQueryPoint (segmentEnd segment)) of - (Right from, Right to) -> - foldCorridorBetweenPoints base from to (\_ _ -> Left ()) () == Just (Right ()) - _ -> False + foldCorridorBetweenPoints + base + (QueryPoint (segmentStart segment)) + (QueryPoint (segmentEnd segment)) + (\_ _ -> Left ()) + () + == Just (Right ()) {-# INLINE extendConstrainedWith #-} insertAndRecoverExtension @@ -363,16 +344,20 @@ where insertOne :: Either (ConstrainedUnionError) [(Point, VertexId)] - -> (Point, annotation) + -> (QueryPoint, annotation) -> ST s (Either (ConstrainedUnionError) [(Point, VertexId)]) insertOne rejected@(Left _) _ = pure rejected - insertOne (Right accumulated) (point, annotation) = + insertOne (Right accumulated) (queryPoint, annotation) = fmap ( Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) . fmap - (\(vertex, _) -> (point, VertexId (fromIntegral vertex)) : accumulated) + ( \(vertex, _) -> + ( queryPointValue queryPoint + , VertexId (fromIntegral vertex) + ) : accumulated + ) ) - (insertPointCombining combine Nothing mutable operation point annotation) + (insertAdmittedPointCombining combine Nothing mutable operation queryPoint annotation) accumulatorOutcomes :: ConstraintBatchAccumulator -> V.Vector ConstraintOutcome accumulatorOutcomes = V.fromList . reverse . accumulatedConstraintOutcomes diff --git a/src-build/Moonlight/Triangulation/Internal/Join.hs b/src-build/Moonlight/Triangulation/Internal/Join.hs --- a/src-build/Moonlight/Triangulation/Internal/Join.hs +++ b/src-build/Moonlight/Triangulation/Internal/Join.hs @@ -22,9 +22,9 @@ , planTournament ) import Moonlight.Triangulation.Internal.Join.Seam (executeSeam) -import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) import Moonlight.Triangulation.Internal.Join.SiteSet ( SiteSet + , rebuildCanonicalSiteSet , siteSetAssocs , siteSetSize ) @@ -32,7 +32,7 @@ ( JoinSemilattice (joinAnnotations) ) import Moonlight.Triangulation.Session - ( insertVertexAtCombining + ( insertAdmittedVertexAtCombining , withLocalSession ) import Moonlight.Triangulation.Types @@ -85,7 +85,7 @@ (siteSetSize sites) ( traverse_ (\(point, annotation) -> - () <$ insertVertexAtCombining joinAnnotations point annotation + () <$ insertAdmittedVertexAtCombining joinAnnotations point annotation ) (siteSetAssocs sites) ) diff --git a/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs b/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Canonical publication of an exact site section through the existing bulk --- loader. Join, finite-set algebra, and constrained union share this boundary; --- none owns a private point/payload carrier or a second constructor. -module Moonlight.Triangulation.Internal.Join.Rebuild - ( rebuildCanonicalSiteSet - ) where - -import qualified Data.Vector as V -import Moonlight.Triangulation.BulkLoad - ( DuplicatePayloadPolicy (KeepFirstPayload) - , delaunayFromCoordinates - ) -import Moonlight.Triangulation.Internal.Canonical (canonicalize) -import Moonlight.Triangulation.Internal.Join.SiteSet (SiteSet, siteSetAssocs) -import Moonlight.Triangulation.Internal.Representation - ( BuildResult (buildTriangulation) - , Triangulation - ) -import Moonlight.Triangulation.Internal.Types - ( BuildError - , ConstraintMode (Unconstrained) - , unitElementDefaults - ) - -rebuildCanonicalSiteSet - :: SiteSet annotation - -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) -rebuildCanonicalSiteSet sites = do - built <- - delaunayFromCoordinates - unitElementDefaults - (V.fromList (fmap fst associations)) - (V.fromList (fmap snd associations)) - KeepFirstPayload - canonicalize (buildTriangulation built) - where - associations = siteSetAssocs sites 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 @@ -44,13 +44,12 @@ , vertexOutEdge , vertexData ) -import Moonlight.Triangulation.FloodFillIterator (floodFillFaces) +import Moonlight.Triangulation.FloodFillIterator (floodFillFacesWithRejectedEdges) import Moonlight.Triangulation.Handles.HandleDefs ( DirectedEdgeId (..) , FaceId (..) , UndirectedEdgeId (..) , VertexId (..) - , asUndirected , directedPair ) import Moonlight.Triangulation.Internal.DcelOperations.Hull (closeOuterTurn) @@ -105,8 +104,12 @@ -- kernel. Constructors stay private so an unseparated pair cannot be handed to -- the executor by accident. data SeamPlan - = SeamLeftBeforeRight !SeamTangents - | SeamRightBeforeLeft !SeamTangents + = -- | The operands are already in geometric left/right order. The two + -- retained frontiers are therefore the exact ones consumed by the zipper. + SeamLeftBeforeRight !SeamTangents !SeamFrontierIndex !SeamFrontierIndex + | -- | The input operands are reversed, but the retained frontiers remain in + -- geometric left/right order rather than input-operand order. + SeamRightBeforeLeft !SeamTangents !SeamFrontierIndex !SeamFrontierIndex -- | Coordinate chart used by the separated seam. The second chart is the -- orientation-preserving quarter turn @(u,v) = (y,-x)@; exact predicates and @@ -130,10 +133,10 @@ planAxis axis leftFrontier rightFrontier = case separatedOrder axis left right leftFrontier rightFrontier of Just LeftBeforeRight -> - SeamLeftBeforeRight + (\tangents -> SeamLeftBeforeRight tangents leftFrontier rightFrontier) <$> seamTangents axis left leftFrontier right rightFrontier Just RightBeforeLeft -> - SeamRightBeforeLeft + (\tangents -> SeamRightBeforeLeft tangents rightFrontier leftFrontier) <$> seamTangents axis right rightFrontier left leftFrontier Nothing -> Nothing @@ -148,9 +151,9 @@ -> Either BuildError (Triangulation 'Unconstrained vertex () () ()) executeSeam plan left right = case plan of - SeamLeftBeforeRight tangents -> + SeamLeftBeforeRight tangents _ _ -> fmap fst (mergeSeparated left right tangents) - SeamRightBeforeLeft tangents -> + SeamRightBeforeLeft tangents _ _ -> fmap fst (mergeSeparated right left tangents) -- | Result of the constrained seam kernel. Constraint flags are copied before @@ -182,12 +185,12 @@ -> Triangulation 'Constrained vertex () () () -> Either BuildError (ConstrainedSeamExecution vertex) executeConstrainedSeam sourceFacePreserved parameters vertexDefault plan left right = do - let (order, tangents) = + let (order, tangents, leftFrontier, rightFrontier) = case plan of - SeamLeftBeforeRight selectedTangents -> - (GeometricBaseLeft, selectedTangents) - SeamRightBeforeLeft selectedTangents -> - (GeometricBaseRight, selectedTangents) + SeamLeftBeforeRight selectedTangents selectedLeftFrontier selectedRightFrontier -> + (GeometricBaseLeft, selectedTangents, selectedLeftFrontier, selectedRightFrontier) + SeamRightBeforeLeft selectedTangents selectedLeftFrontier selectedRightFrontier -> + (GeometricBaseRight, selectedTangents, selectedLeftFrontier, selectedRightFrontier) (triangulation, statistics, publicationStats, joinFaces) <- executeResidentConstrained targetFaceProtected @@ -196,11 +199,12 @@ order left right + leftFrontier + rightFrontier tangents rightEvidence <- seamFaceEvidenceForSource right - triangulation incomingFaceOffset rightEvidenceFaces pure @@ -244,14 +248,14 @@ :: Triangulation 'Constrained vertex () () () -> (Int -> Bool) -> V.Vector FaceId - -> V.Vector FaceId + -> (V.Vector FaceId, [UndirectedEdgeId]) exactJoinFaces triangulation targetFaceProtected seeds = - V.fromList - ( floodFillFaces - triangulation - (V.toList seeds) - canCross - ) + let (faces, rejectedPairs) = + floodFillFacesWithRejectedEdges + triangulation + (V.toList seeds) + canCross + in (V.fromList faces, rejectedPairs) where canCross edge = not (isConstraintEdge triangulation edge) @@ -270,51 +274,16 @@ -- rewrite the solved section. certifyJoinBoundary :: Triangulation 'Constrained vertex () () () - -> (Int -> Bool) - -> V.Vector FaceId + -> [UndirectedEdgeId] -> Either BuildError () -certifyJoinBoundary triangulation targetFaceProtected joinFaces = - traverse_ certifyPair (IntSet.toAscList candidatePairs) +certifyJoinBoundary triangulation = traverse_ certifyPair where - joinFaceSet = - IntSet.fromList - [ fromIntegral raw - | FaceId raw <- V.toList joinFaces - ] - - candidatePairs = - List.foldl' - (\pairs faceHandle -> - List.foldl' - (\acc edge -> - let UndirectedEdgeId raw = asUndirected edge - in IntSet.insert (fromIntegral raw) acc - ) - pairs - (faceDirectedEdges triangulation faceHandle) - ) - IntSet.empty - (V.toList joinFaces) - - certifyPair rawPair = - let edge = UndirectedEdgeId (fromIntegral rawPair) - in if not (selectedJoinOverlap edge) - || isConstraintEdge triangulation edge + certifyPair edge = + if isConstraintEdge triangulation edge || not (immutableEdgeRequiresFlip triangulation edge) then Right () else Left (SeamSourceEdgeRequiresFlip edge) - selectedJoinOverlap edge = - case directedPair edge of - (forward, backward) -> - let forwardFace = incidentFace triangulation forward - backwardFace = incidentFace triangulation backward - in (joinFace forwardFace && protectedFace backwardFace) - || (joinFace backwardFace && protectedFace forwardFace) - - joinFace (FaceId raw) = IntSet.member (fromIntegral raw) joinFaceSet - protectedFace (FaceId raw) = targetFaceProtected (fromIntegral raw) - incidentInnerFaces :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId @@ -498,6 +467,8 @@ -> GeometricBaseOrder -> Triangulation 'Constrained vertex () () () -> Triangulation 'Constrained vertex () () () + -> SeamFrontierIndex + -> SeamFrontierIndex -> SeamTangents -> Either BuildError ( Triangulation 'Constrained vertex () () () @@ -505,7 +476,7 @@ , PublicationStats , V.Vector FaceId ) -executeResidentConstrained targetFaceProtected parameters vertexDefault order base extension tangents = do +executeResidentConstrained targetFaceProtected parameters vertexDefault order base extension leftFrontier rightFrontier tangents = do let !baseDirected = numDirectedEdges base !extensionDirected = numDirectedEdges extension !baseVertices = numVertices base @@ -521,8 +492,6 @@ , seamUpperLeft = SeamTangent _ upperLeft , seamUpperRight = SeamTangent _ upperRight } = tangents - leftFrontier <- maybe (Left SeamFrontierUnavailable) Right (triSeamFrontier leftSource) - rightFrontier <- maybe (Left SeamFrontierUnavailable) Right (triSeamFrontier rightSource) bridgePlan <- planSeamBridgeSubdivision parameters @@ -569,9 +538,9 @@ mutable operation (Seq.length (seamFrontierEdges leftFrontier)) - (seamTangentIndex (seamLowerLeft tangents)) + (tangentIndex (seamLowerLeft tangents)) (Seq.length (seamFrontierEdges rightFrontier)) - (seamTangentIndex (seamLowerRight tangents)) + (tangentIndex (seamLowerRight tangents)) seamBase (leftVertexOffset + topologyAt leftSource (4 * upperLeft)) (rightVertexOffset + topologyAt rightSource (4 * upperRight)) @@ -605,8 +574,9 @@ ) ) let newFaceSeeds = V.fromList (fmap (FaceId . fromIntegral) newFaces) - joinFaces = exactJoinFaces triangulation targetFaceProtected newFaceSeeds - certifyJoinBoundary triangulation targetFaceProtected joinFaces + (joinFaces, rejectedBoundaryPairs) = + exactJoinFaces triangulation targetFaceProtected newFaceSeeds + certifyJoinBoundary triangulation rejectedBoundaryPairs frontier <- combineSeamFrontier triangulation @@ -628,38 +598,38 @@ seamFaceEvidenceForSource :: Triangulation 'Constrained vertex () () () - -> Triangulation 'Constrained vertex () () () -> Int -> [FaceId] -> Either BuildError (V.Vector ConstrainedSeamFaceEvidence) -seamFaceEvidenceForSource source target targetOffset sourceFaces = +seamFaceEvidenceForSource source targetOffset sourceFaces = V.fromList <$> traverse evidenceFor sourceFaces where evidenceFor sourceFace = do - sourcePoints <- facePoints source sourceFace + (first, second, third) <- facePoints source sourceFace let targetFace = FaceId (unFaceId sourceFace + fromIntegral targetOffset) - targetPoints <- facePoints target targetFace - if sourcePoints == targetPoints - then - case sourcePoints of - [first, second, third] -> - Right - ConstrainedSeamFaceEvidence - { constrainedSeamSourceFace = sourceFace - , constrainedSeamTargetFace = targetFace - , constrainedSeamFaceFirstPoint = first - , constrainedSeamFaceSecondPoint = second - , constrainedSeamFaceThirdPoint = third - } - points -> Left (faceCardinalityFailure source sourceFace points) - else Left (SeamProtectedSourceFaceChanged sourceFace) + Right + ConstrainedSeamFaceEvidence + { constrainedSeamSourceFace = sourceFace + , constrainedSeamTargetFace = targetFace + , constrainedSeamFaceFirstPoint = first + , constrainedSeamFaceSecondPoint = second + , constrainedSeamFaceThirdPoint = third + } + facePoints + :: Triangulation mode sourceVertex directed undirected face + -> FaceId + -> Either BuildError (Point, Point, Point) facePoints triangulation faceHandle = case List.sort (fmap (vertexPointAt triangulation) (faceVertices triangulation faceHandle)) of - [first, second, third] -> Right [first, second, third] - points -> Left (faceCardinalityFailure triangulation faceHandle points) + [first, second, third] -> Right (first, second, third) + _ -> Left (faceCardinalityFailure triangulation faceHandle) - faceCardinalityFailure triangulation faceHandle _points = + faceCardinalityFailure + :: Triangulation mode sourceVertex directed undirected face + -> FaceId + -> BuildError + faceCardinalityFailure triangulation faceHandle = case faceDirectedEdges triangulation faceHandle of edge : _ -> RefinementInputTopologyInvalid (InnerFaceNotTriangularAtEdge edge) [] -> RefinementInputTopologyInvalid (FaceMissingAdjacentEdge faceHandle) @@ -698,10 +668,13 @@ -- The opposite-sign branch cannot overflow in its sum. The same-sign branch -- cannot overflow in its difference. data SeamTangent = SeamTangent - { seamTangentIndex :: {-# UNPACK #-} !Int - , seamTangentEdge :: {-# UNPACK #-} !Int - } + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int +tangentIndex :: SeamTangent -> Int +tangentIndex (SeamTangent index _) = index +{-# INLINE tangentIndex #-} + data SeamTangents = SeamTangents { seamLowerLeft :: !SeamTangent , seamLowerRight :: !SeamTangent @@ -760,12 +733,12 @@ leftSize = Seq.length (seamFrontierEdges leftFrontier) rightSize = Seq.length (seamFrontierEdges rightFrontier) - walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !reads = do + walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !frontierReads = do nextLeftIndex <- pure (nextIndex leftSize leftIndex) previousRightIndex <- pure (previousIndex rightSize rightIndex) (nextLeftX, nextLeftY) <- frontierPointAt axis left leftFrontier nextLeftIndex (previousRightX, previousRightY) <- frontierPointAt axis right rightFrontier previousRightIndex - let !nextReads = reads + 2 + let !nextReads = frontierReads + 2 !leftBelow = orient2dCoordinates leftX leftY rightX rightY nextLeftX nextLeftY == LT !rightBelow = @@ -812,12 +785,12 @@ leftSize = Seq.length (seamFrontierEdges leftFrontier) rightSize = Seq.length (seamFrontierEdges rightFrontier) - walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !reads = do + walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !frontierReads = do previousLeftIndex <- pure (previousIndex leftSize leftIndex) nextRightIndex <- pure (nextIndex rightSize rightIndex) (previousLeftX, previousLeftY) <- frontierPointAt axis left leftFrontier previousLeftIndex (nextRightX, nextRightY) <- frontierPointAt axis right rightFrontier nextRightIndex - let !nextReads = reads + 2 + let !nextReads = frontierReads + 2 !leftAbove = orient2dCoordinates leftX leftY rightX rightY previousLeftX previousLeftY == GT !rightAbove = diff --git a/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs b/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs --- a/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs +++ b/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Exact transient site sections derived from the authoritative coordinate @@ -18,6 +19,8 @@ , siteSetSymmetricDifferenceFromTriangulations , siteSetAssocs , siteSetPoints + , delaunayFromSiteSet + , rebuildCanonicalSiteSet ) where import Control.Monad.ST (ST, runST) @@ -28,8 +31,10 @@ import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.BulkLoad (delaunayFromAdmittedDistinctAscending) import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint) import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Internal.Canonical (canonicalizeKnownAscending) import Moonlight.Triangulation.Handles.Iterators.FixedIterators ( foldVertices' ) @@ -44,14 +49,20 @@ , newMutablePointIndex , seedMutablePointIndex ) -import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Representation + ( BuildResult (buildTriangulation) + , Triangulation (..) + ) import Moonlight.Triangulation.Internal.Types ( BuildError + , ConstraintMode (Unconstrained) , Point (..) + , QueryPoint (..) , SiteRelation (..) + , unitElementDefaults ) -newtype SiteSet annotation = SiteSet (Map.Map (Point) annotation) +newtype SiteSet annotation = SiteSet (Map.Map QueryPoint annotation) -- Strict sufficient statistics for the one-pass ordered-map descent used by -- 'siteSetRelation'. Keeping the census strict prevents a relation query from @@ -74,9 +85,11 @@ siteSetFromTriangulation triangulation = SiteSet ( Map.fromList - [ ( Point - (triPointX triangulation `pagedUnsafeIndex` vertex) - (triPointY triangulation `pagedUnsafeIndex` vertex) + [ ( QueryPoint + ( Point + (triPointX triangulation `pagedUnsafeIndex` vertex) + (triPointY triangulation `pagedUnsafeIndex` vertex) + ) , vertexData triangulation (VertexId (fromIntegral vertex)) ) | vertex <- [0 .. numVertices triangulation - 1] @@ -93,9 +106,11 @@ siteSupportFromTriangulation triangulation = SiteSet ( Map.fromList - [ ( Point - (triPointX triangulation `pagedUnsafeIndex` vertex) - (triPointY triangulation `pagedUnsafeIndex` vertex) + [ ( QueryPoint + ( Point + (triPointX triangulation `pagedUnsafeIndex` vertex) + (triPointY triangulation `pagedUnsafeIndex` vertex) + ) , () ) | vertex <- [0 .. numVertices triangulation - 1] @@ -254,7 +269,7 @@ fmap (SiteSet . Map.fromList) (runST collectExclusiveAssociations) where collectExclusiveAssociations - :: forall state. ST state (Either BuildError [(Point, annotation)]) + :: forall state. ST state (Either BuildError [(QueryPoint, annotation)]) collectExclusiveAssociations = do pointIndex <- newMutablePointIndex (numVertices indexed) seeded <- @@ -282,14 +297,14 @@ collectSourceExclusive :: MutablePointIndex state -> MUV.MVector state Bool - -> [(Point, annotation)] + -> [(QueryPoint, annotation)] -> Int -> Double - -> ST state [(Point, annotation)] + -> ST state [(QueryPoint, annotation)] collectSourceExclusive pointIndex matchedIndexedVertices associations rawVertex x = do let vertex = VertexId (fromIntegral rawVertex) y = triPointY source `pagedUnsafeIndex` rawVertex - point = Point x y + point = QueryPoint (Point x y) match <- lookupMutablePoint pointIndex @@ -305,13 +320,13 @@ collectIndexedExclusive :: MUV.MVector state Bool - -> [(Point, annotation)] + -> [(QueryPoint, annotation)] -> Int -> Double - -> ST state [(Point, annotation)] + -> ST state [(QueryPoint, annotation)] collectIndexedExclusive matchedIndexedVertices associations rawVertex x = do let vertex = VertexId (fromIntegral rawVertex) - point = Point x (triPointY indexed `pagedUnsafeIndex` rawVertex) + point = QueryPoint (Point x (triPointY indexed `pagedUnsafeIndex` rawVertex)) matched <- MUV.unsafeRead matchedIndexedVertices rawVertex pure ( if matched @@ -354,10 +369,32 @@ (triPointIndex triangulation) {-# INLINE lookupPointIn #-} -siteSetAssocs :: SiteSet annotation -> [(Point, annotation)] +siteSetAssocs :: SiteSet annotation -> [(QueryPoint, annotation)] siteSetAssocs (SiteSet sites) = Map.toAscList sites {-# INLINE siteSetAssocs #-} siteSetPoints :: SiteSet annotation -> V.Vector (Point) -siteSetPoints (SiteSet sites) = V.fromList (Map.keys sites) +siteSetPoints (SiteSet sites) = V.fromList (fmap queryPointValue (Map.keys sites)) {-# INLINE siteSetPoints #-} + +-- | Publish an admitted exact site section through the one bulk-construction +-- engine. Its Map order is the trusted strict lexicographic vertex order; the +-- circle sweep still establishes the algorithm's radial execution order. +delaunayFromSiteSet + :: SiteSet annotation + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +delaunayFromSiteSet sites = + buildTriangulation + <$> delaunayFromAdmittedDistinctAscending + unitElementDefaults + (V.fromList (siteSetAssocs sites)) +{-# INLINE delaunayFromSiteSet #-} + +-- | Canonical finite-set publication. The preceding SiteSet build preserves +-- lexicographic vertex order, so Canonical need not rediscover that fact. +rebuildCanonicalSiteSet + :: SiteSet annotation + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +rebuildCanonicalSiteSet sites = + delaunayFromSiteSet sites >>= canonicalizeKnownAscending +{-# INLINE rebuildCanonicalSiteSet #-} 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 @@ -23,7 +23,7 @@ import Data.List (find) import qualified Data.List as List import qualified Data.IntMap.Strict as IntMap -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef) import qualified Data.Vector.Unboxed.Mutable as MUV import Data.Word (Word32) @@ -258,7 +258,9 @@ data FaceHint = FaceAcceptable - | FaceMustSplitLongestEdge {-# UNPACK #-} !Int + | FaceMustSplitLongestEdge + {-# UNPACK #-} !Int + {-# UNPACK #-} !Double | FaceMustRefine | FaceShouldRefine @@ -344,7 +346,7 @@ wsCavityWork <- newGrowableWord32 16 let workspace = Workspace{wsQueue, wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts, wsForcedSplits, wsEncroachment, wsEncroachmentSlot, wsSegmentOrigin, wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityChain, wsCavityWork} seedInitialWork workspace initialSeed - loop workspace 0 + loop workspace IntMap.empty 0 where !limit = max 0 budget @@ -412,9 +414,13 @@ writeSTRef wsCavityEpoch next pure next - loop :: Workspace s -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int)) - loop workspace@Workspace{wsQueue, wsForcedSplits} !added - | added >= limit = finish workspace False added + loop + :: Workspace s + -> IntMap.IntMap Double + -> Int + -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int)) + loop workspace@Workspace{wsQueue, wsForcedSplits} pendingOversizedEdges !added + | added >= limit = finish workspace pendingOversizedEdges False added | otherwise = do forced <- popGrowableOr noIndex wsForcedSplits if forced /= noIndex @@ -424,14 +430,14 @@ Left obstruction -> pure (Left obstruction) Right split -> if split - then loop workspace (added + 1) + then loop workspace pendingOversizedEdges (added + 1) else do -- The split refused (degenerate position or a kept -- constraint). Retrying the face that forced it would loop, -- so one queued face is sacrificed, exactly the face whose -- requeue sits on top. _ <- popFace wsQueue - loop workspace added + loop workspace pendingOversizedEdges added else do candidate <- popEncroachment workspace if candidate /= noIndex @@ -439,26 +445,126 @@ splitOutcome <- checkEncroachment workspace (fromIntegral candidate) case splitOutcome of Left obstruction -> pure (Left obstruction) - Right split -> loop workspace (if split then added + 1 else added) + Right split -> + loop + workspace + pendingOversizedEdges + (if split then added + 1 else added) else do next <- popFace wsQueue case next of - Nothing -> finish workspace True added + Nothing -> finish workspace pendingOversizedEdges True added Just face -> do outcome <- handleFace workspace face case outcome of Left failure -> pure (Left failure) - Right gained -> loop workspace (added + gained) + Right (gained, pendingEdge) -> + loop + workspace + ( maybe + pendingOversizedEdges + (\(pair, actualSquaredLength) -> + IntMap.insertWith + max + pair + actualSquaredLength + pendingOversizedEdges + ) + pendingEdge + ) + (added + gained) - finish :: Workspace s -> Bool -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int)) - finish Workspace{wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts} complete added = do - excludedFaces <- markedIndices wsExcluded - visitedFaces <- maybe (pure []) markedIndices wsVisited - permittedFaces <- maybe (pure []) markedIndices wsPermitted - interfaceBoundaryReads <- readSTRef wsInterfaceBoundaryReads - boundaryCrossingAttempts <- readSTRef wsBoundaryCrossingAttempts - pure (Right (complete, added, excludedFaces, visitedFaces, permittedFaces, interfaceBoundaryReads, boundaryCrossingAttempts)) + finish + :: Workspace s + -> IntMap.IntMap Double + -> Bool + -> Int + -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int)) + finish workspace@Workspace{wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts} pendingOversizedEdges complete added = do + pendingObstruction <- + if complete + then completedMaximumEdgeObstruction workspace pendingOversizedEdges + else pure (Right Nothing) + case pendingObstruction of + Left failure -> pure (Left failure) + Right (Just failure) -> pure (Left failure) + Right Nothing -> do + excludedFaces <- markedIndices wsExcluded + visitedFaces <- maybe (pure []) markedIndices wsVisited + permittedFaces <- maybe (pure []) markedIndices wsPermitted + interfaceBoundaryReads <- readSTRef wsInterfaceBoundaryReads + boundaryCrossingAttempts <- readSTRef wsBoundaryCrossingAttempts + pure (Right (complete, added, excludedFaces, visitedFaces, permittedFaces, interfaceBoundaryReads, boundaryCrossingAttempts)) + -- A quality edge that cannot be split is remembered at the point where the + -- worklist discovers it. Only a drained run discharges the pending section; + -- a budget-limited run remains an ordinary resumable publication. The + -- final face is read from the constant-degree live edge neighbourhood so the + -- reported obstruction retains the former face/edge ordering without an + -- all-face audit. + completedMaximumEdgeObstruction + :: Workspace s + -> IntMap.IntMap Double + -> ST s (Either BuildError (Maybe BuildError)) + completedMaximumEdgeObstruction workspace pendingOversizedEdges = + case refineMaxEdgeLength parameters of + Nothing -> pure (Right Nothing) + Just maximumLength -> do + candidateResults <- + traverse + (liveOversizedEdgeCandidate workspace) + (IntMap.toAscList pendingOversizedEdges) + pure $ do + candidates <- catMaybes <$> sequence candidateResults + Right + ( case List.sortOn (\(face, pair, _) -> (face, pair)) candidates of + [] -> Nothing + (face, pair, actualSquaredLength) : _ -> + Just + ( RefinementOversizedEdge + (FaceId (fromIntegral face)) + (UndirectedEdgeId (fromIntegral pair)) + (sqrt actualSquaredLength) + maximumLength + ) + ) + + liveOversizedEdgeCandidate + :: Workspace s + -> (Int, Double) + -> ST s (Either BuildError (Maybe (Int, Int, Double))) + liveOversizedEdgeCandidate workspace (pair, actualSquaredLength) = do + directedTotal <- directedEdgeCount mutable + let directed = 2 * pair + if directed < 0 || directed + 1 >= directedTotal + then pure (Left RefinementDomainTopologyChanged) + else do + forwardFace <- readFace mutable directed + backwardFace <- readFace mutable (reverseIndex directed) + eligibleFaces <- + filterM + (maximumEdgeFaceEligible workspace) + [forwardFace, backwardFace] + pure + ( Right + ( case eligibleFaces of + [] -> Nothing + _ -> Just (minimum eligibleFaces, pair, actualSquaredLength) + ) + ) + + maximumEdgeFaceEligible :: Workspace s -> Int -> ST s Bool + maximumEdgeFaceEligible Workspace{wsExcluded, wsPermitted} face + | face <= 0 = pure False + | otherwise = do + excluded <- readBoolMark wsExcluded face + permitted <- + maybe + (pure True) + (\membership -> readBoolMark membership face) + wsPermitted + pure (not excluded && permitted) + markedIndices :: BoolMarks s -> ST s [Int] markedIndices marks = case marks of @@ -576,7 +682,10 @@ let (!longestEdge, !longestSquaredLength, !side01, !side12, !side20) = faceEdgeMetrics e0 e1 e2 p0 p1 p2 in if exceeds longestSquaredLength maximumSquaredLength - then FaceMustSplitLongestEdge (longestEdge `quot` 2) + then + FaceMustSplitLongestEdge + (longestEdge `quot` 2) + longestSquaredLength else nonEdgeHint ( ratioBad @@ -604,7 +713,10 @@ | angleBad = FaceShouldRefine | otherwise = FaceAcceptable - handleFace :: Workspace s -> Int -> ST s (Either BuildError Int) + handleFace + :: Workspace s + -> Int + -> ST s (Either BuildError (Int, Maybe (Int, Double))) handleFace workspace@Workspace{wsExcluded, wsPermitted, wsVisited} face = do addCounter operation CounterRefinementQueuePops 1 permitted <- @@ -618,7 +730,7 @@ traverse_ (\visited -> writeBoolMark visited face True) wsVisited skip <- readBoolMark wsExcluded face if skip - then pure (Right 0) + then pure (Right (0, Nothing)) else do addCounter operation CounterRefinementFaceChecks 1 (e0, e1, e2) <- faceEdges mutable face @@ -626,14 +738,21 @@ p1 <- edgeOriginPoint mutable e1 p2 <- edgeOriginPoint mutable e2 case faceHint e0 e1 e2 p0 p1 p2 of - FaceAcceptable -> pure (Right 0) - FaceMustSplitLongestEdge pair -> qualitySplit workspace pair - FaceMustRefine -> attemptCandidate workspace face p0 p1 p2 + FaceAcceptable -> pure (Right (0, Nothing)) + FaceMustSplitLongestEdge pair actualSquaredLength -> + qualitySplit workspace pair actualSquaredLength + FaceMustRefine -> + fmap + (fmap (\gained -> (gained, Nothing))) + (attemptCandidate workspace face p0 p1 p2) FaceShouldRefine -> do blocked <- inputAngleBlocks workspace e0 e1 e2 p0 p1 p2 if blocked - then pure (Right 0) - else attemptCandidate workspace face p0 p1 p2 + then pure (Right (0, Nothing)) + else + fmap + (fmap (\gained -> (gained, Nothing))) + (attemptCandidate workspace face p0 p1 p2) faceEdgeMetrics :: Int @@ -654,17 +773,21 @@ result :: Int -> Double -> (Int, Double, Double, Double, Double) result edge longest = (edge, longest, side01, side12, side20) - -- An overlong edge on a local interface is a publish-time quality - -- obstruction, not a permission to cross the frozen section. Let the - -- completed-domain audit report that exact edge; a budget-limited run stays - -- resumable and returns its ordinary incomplete result. - qualitySplit :: Workspace s -> Int -> ST s (Either BuildError Int) - qualitySplit workspace pair = do + -- An unsplittable quality edge is a pending law obstruction, not permission + -- to cross a frozen interface and not immediate failure of a resumable run. + qualitySplit + :: Workspace s + -> Int + -> Double + -> ST s (Either BuildError (Int, Maybe (Int, Double))) + qualitySplit workspace pair actualSquaredLength = do outcome <- resolveSplit SplitQualityEdge workspace pair case outcome of - Left (RefinementDomainWouldCrossInterface _ _) -> pure (Right 0) + Left (RefinementDomainWouldCrossInterface _ _) -> + pure (Right (0, Just (pair, actualSquaredLength))) Left failure -> pure (Left failure) - Right split -> pure (Right (if split then 1 else 0)) + Right True -> pure (Right (1, Nothing)) + Right False -> pure (Right (0, Just (pair, actualSquaredLength))) -- Two subsegments of one original segment meeting at a small input angle -- cannot be refined apart: the angle is fixed by the input geometry. When 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 @@ -34,13 +34,11 @@ import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth) import Moonlight.Triangulation.Handles.HandleDefs ( FaceId (..) - , DirectedEdgeId , UndirectedEdgeId (..) , asUndirected , directedPair , reverseEdge ) -import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.Paged ( PublicationStats @@ -49,7 +47,6 @@ import Moonlight.Triangulation.Internal.Refinement import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) import Moonlight.Triangulation.Internal.Transaction (runTransactionWithPublication) -import Moonlight.Triangulation.Math (squaredDistanceWide) import Moonlight.Triangulation.Types import Moonlight.Triangulation.Validation ( validateTopology @@ -100,38 +97,22 @@ fmap refinementExecutionResult . refineWithInitialSeed RefineEveryFace Nothing makeVertex parameters --- | Prove that a set of active faces is separated from every protected inner --- face by exactly the supplied immutable edge section. The witness is tied to --- the input arena cardinalities and is revalidated before interpretation. +-- | Derive the exact immutable interface separating a checked active face +-- section from every protected inner face. A permitted face set determines +-- this cut uniquely, so callers cannot supply a second claim about Gamma. mkRefinementDomain :: Set.Set FaceId - -> Set.Set UndirectedEdgeId -> Triangulation mode vertex directed undirected face -> Either BuildError RefinementDomain -mkRefinementDomain permittedFaces interfaceEdges triangulation = do +mkRefinementDomain permittedFaces triangulation = do permitted <- validateSeedFaces triangulation permittedFaces - interface <- IntSet.fromList <$> traverse validateInterfaceEdge (Set.toAscList interfaceEdges) - let expected = expectedInterface permitted - case IntSet.lookupMin (expected IntSet.\\ interface) of - Just pair -> Left (RefinementDomainInterfaceMissing (UndirectedEdgeId (fromIntegral pair))) - Nothing -> - case IntSet.lookupMin (interface IntSet.\\ expected) of - Just pair -> Left (RefinementDomainInterfaceExtraneous (UndirectedEdgeId (fromIntegral pair))) - Nothing -> - Right - RefinementDomain - { refinementDomainPermittedFaces = permitted - , refinementDomainInterfacePairs = interface - , refinementDomainInputFaceCount = numFaces triangulation - } + Right + RefinementDomain + { refinementDomainPermittedFaces = permitted + , refinementDomainInterfacePairs = expectedInterface permitted + , refinementDomainInputFaceCount = numFaces triangulation + } where - totalEdges = numUndirectedEdges triangulation - validateInterfaceEdge :: UndirectedEdgeId -> Either BuildError Int - validateInterfaceEdge edge@(UndirectedEdgeId raw) - | toInteger raw >= toInteger totalEdges = - Left (RefinementDomainInterfaceEdgeNotActive edge totalEdges) - | otherwise = Right (fromIntegral raw) - expectedInterface permitted = IntSet.fromList [ pair @@ -154,12 +135,11 @@ (Point -> vertex) -> RefinementParameters -> Set.Set FaceId - -> Set.Set UndirectedEdgeId -> Triangulation mode vertex directed undirected face -> Either BuildError (RefinementDomainResult mode vertex directed undirected face) -refineWithinDomain makeVertex parameters permittedFaces interfaceEdges triangulation = do +refineWithinDomain makeVertex parameters permittedFaces triangulation = do validateDomainParameters parameters - domain <- mkRefinementDomain permittedFaces interfaceEdges triangulation + domain <- mkRefinementDomain permittedFaces triangulation execution <- refineWithInitialSeed (RefineSeededFaces (refinementDomainPermittedFaces domain)) @@ -168,7 +148,7 @@ parameters triangulation let result = refinementExecutionResult execution - validationStats <- validateDomainClosure + (validationStats, finalInterfaceIncidence) <- validateDomainClosure domain triangulation (refinedTriangulation result) @@ -180,6 +160,7 @@ (refinedTriangulation result) (refinementExecutionVisitedFaces execution) (refinementExecutionPermittedFaces execution) + finalInterfaceIncidence (refinementExecutionInterfaceBoundaryReads execution) (refinementExecutionBoundaryCrossingAttempts execution) (refinementExecutionPublicationStats execution) @@ -226,11 +207,6 @@ refineWithInitialSeed initialSeed domain makeVertex parameters triangulation = do validateRefinementParameters parameters case domain of - Just _ - | refineMaxAdditionalVertices parameters == Nothing -> - Left RefinementDomainRequiresFiniteVertexBudget - _ -> Right () - case domain of Just _ -> pure () Nothing -> case validateTopology triangulation of @@ -272,18 +248,6 @@ removeInterfaceBarriers mutable triangulation domain pure refinement let (complete, added, excluded, visited, permittedFaces, interfaceBoundaryReads, boundaryCrossingAttempts) = outcome - excludedFaceSet = IntSet.fromList excluded - finalAuditFaces = - case domain of - Nothing -> - [ face - | face@(FaceId raw) <- innerFaces frozen - , IntSet.notMember (fromIntegral raw) excludedFaceSet - ] - Just _ -> fmap (FaceId . fromIntegral) permittedFaces - if complete - then validateMaximumEdgeLength parameters frozen finalAuditFaces - else Right () pure RefinementExecution { refinementExecutionResult = @@ -334,17 +298,19 @@ -> Triangulation mode vertex directed undirected face -> [Int] -> [Int] + -> V.Vector (UndirectedEdgeId, FaceId, FaceId) -> Int -> Int -> PublicationStats -> ValidationClosureStats -> RefinementReceipt -buildRefinementReceipt domain before after visited permittedFaces interfaceBoundaryReads boundaryCrossingAttempts publicationStats validationStats = +buildRefinementReceipt domain before after visited permittedFaces finalInterfaceIncidence interfaceBoundaryReads boundaryCrossingAttempts publicationStats validationStats = RefinementReceipt { refinementVisitedJoinFaces = V.fromList (fmap toFace visitedJoin) , refinementVisitedProtectedFaces = V.fromList (fmap toFace visitedProtected) , refinementCreatedFaces = V.fromList (fmap toFace createdFaces) , refinementFinalPermittedFaces = V.fromList (fmap toFace permittedFaces) + , refinementFinalInterfaceIncidence = finalInterfaceIncidence , refinementTouchedEdges = V.fromList (fmap toEdge touchedEdges) , refinementRemovedEdges = V.fromList (fmap toEdge removedEdges) , refinementInterfaceBoundaryReads = interfaceBoundaryReads @@ -438,13 +404,14 @@ -> Triangulation mode vertex directed undirected face -> Triangulation mode vertex directed undirected face -> [Int] - -> Either BuildError ValidationClosureStats + -> Either BuildError (ValidationClosureStats, V.Vector (UndirectedEdgeId, FaceId, FaceId)) validateDomainClosure domain before after finalPermittedFaces = do - let (closureStats, closureViolations) = + let finalPermitted = IntSet.fromList finalPermittedFaces + (closureStats, closureViolations) = validateTopologyClosureWithStats ( IntSet.union (refinementDomainPermittedFaces domain) - (IntSet.fromList finalPermittedFaces) + finalPermitted ) (refinementDomainInterfacePairs domain) after @@ -452,8 +419,12 @@ violation : _ -> Left (RefinementInputTopologyInvalid violation) [] -> pure () traverse_ validateProtectedFace (IntSet.toAscList protectedFaces) - traverse_ validateInterfaceEdge (IntSet.toAscList (refinementDomainInterfacePairs domain)) - pure closureStats + finalInterfaceIncidence <- + V.fromList + <$> traverse + (validateInterfaceEdge finalPermitted) + (IntSet.toAscList (refinementDomainInterfacePairs domain)) + pure (closureStats, finalInterfaceIncidence) where permitted = refinementDomainPermittedFaces domain protectedFaces = @@ -475,67 +446,38 @@ then Right () else Left (RefinementDomainProtectedFaceChanged (FaceId (fromIntegral rawFace))) - validateInterfaceEdge rawPair = - if interfaceEdgePreserved rawPair - then Right () - else Left RefinementDomainTopologyChanged - - interfaceEdgePreserved rawPair = - case (localEdgeSignature before rawPair, localEdgeSignature after rawPair) of + validateInterfaceEdge finalPermitted rawPair = + let edge = UndirectedEdgeId (fromIntegral rawPair) + in case (localEdgeSignature before rawPair, localEdgeSignature after rawPair) of ( Just (beforeFrom, beforeTo, beforeFaces) , Just (afterFrom, afterTo, afterFaces) - ) -> - beforeFrom == afterFrom - && beforeTo == afterTo - && all (`elem` afterFaces) (filter protected beforeFaces) - _ -> False + ) + | beforeFrom == afterFrom && beforeTo == afterTo -> + validateInterfaceFaces finalPermitted edge beforeFaces afterFaces + _ -> Left RefinementDomainTopologyChanged + validateInterfaceFaces finalPermitted edge beforeFaces afterFaces = + case filter protected beforeFaces of + [protectedFace] + | protectedFace `elem` afterFaces -> + case filter (/= protectedFace) afterFaces of + [oppositeFace] + | IntSet.member (fromIntegral (unFace oppositeFace)) finalPermitted -> + Right (edge, protectedFace, oppositeFace) + | otherwise -> + Left + ( RefinementDomainInterfaceOppositeFaceNotPermitted + edge + oppositeFace + ) + _ -> Left RefinementDomainTopologyChanged + _ -> Left RefinementDomainTopologyChanged + protected face = let raw = fromIntegral (unFace face) in raw > 0 && IntSet.notMember raw permitted unFace (FaceId raw) = raw - --- | A drained worklist is publishable only when its final active face section --- satisfies the optional edge-length law. Global refinement checks every --- active inner face; local refinement checks only its exact dynamic permitted --- witness, never the retired handles from the input cover. -validateMaximumEdgeLength - :: RefinementParameters - -> Triangulation mode vertex directed undirected face - -> [FaceId] - -> Either BuildError () -validateMaximumEdgeLength parameters triangulation finalPermittedFaces = - case refineMaxEdgeLength parameters of - Nothing -> Right () - Just maximumLength -> - traverse_ - (validateFace maximumLength (maximumLength * maximumLength)) - finalPermittedFaces - where - validateFace :: Double -> Double -> FaceId -> Either BuildError () - validateFace maximumLength maximumSquaredLength face = - traverse_ (validateEdge maximumLength maximumSquaredLength face) - (faceDirectedEdges triangulation face) - - validateEdge :: Double -> Double -> FaceId -> DirectedEdgeId -> Either BuildError () - validateEdge maximumLength maximumSquaredLength face edge = - let undirected = asUndirected edge - (fromVertex, toVertex) = undirectedEndpoints triangulation undirected - actualSquaredLength = - squaredDistanceWide - (vertexPoint triangulation fromVertex) - (vertexPoint triangulation toVertex) - in if actualSquaredLength > maximumSquaredLength - then - Left - ( RefinementOversizedEdge - face - undirected - (sqrt actualSquaredLength) - maximumLength - ) - else Right () -- | Refuse outer or absent faces rather than silently treating an invalid -- topology witness as an empty repair. Face zero is the outer face and has no diff --git a/src-build/Moonlight/Triangulation/Session.hs b/src-build/Moonlight/Triangulation/Session.hs --- a/src-build/Moonlight/Triangulation/Session.hs +++ b/src-build/Moonlight/Triangulation/Session.hs @@ -12,7 +12,7 @@ , insertVertex , insertVertexAt , insertVertexAtNear - , insertVertexAtCombining + , insertAdmittedVertexAtCombining , removeAt , removeAtNear , removeManyAt @@ -26,7 +26,10 @@ import Data.Bits (xor) import qualified Data.Vector as V import Moonlight.Triangulation.Handles.HandleDefs -import Moonlight.Triangulation.Insertion (insertPointCombining) +import Moonlight.Triangulation.Insertion + ( insertAdmittedPointCombining + , insertPointCombining + ) import Moonlight.Triangulation.Internal.Excision (removeMutable) import Moonlight.Triangulation.Internal.Location (MutableLocation (..), locateMutable) import Moonlight.Triangulation.Internal.Mutable @@ -147,18 +150,18 @@ payload ) --- | Insert at a site while combining an occupied site's resident annotation --- with the incoming one. Geometry still owns identity; this supplies only the --- overlap law used by annotated joins. -insertVertexAtCombining +-- | Insert an admitted site while combining an occupied annotation. This is +-- package-internal descent from a boundary that already owns coordinate +-- admission; only location and annotation gluing remain here. +insertAdmittedVertexAtCombining :: (vertex -> vertex -> vertex) - -> Point + -> QueryPoint -> vertex -> Session s vertex directed undirected face (VertexId, InsertionDisposition) -insertVertexAtCombining combine point payload = Session $ \mesh operation -> +insertAdmittedVertexAtCombining combine queryPoint payload = Session $ \mesh operation -> fmap (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition))) - (insertPointCombining combine Nothing mesh operation point payload) + (insertAdmittedPointCombining combine Nothing mesh operation queryPoint payload) -- | Remove the vertex standing at a point, answering 'Nothing' when no vertex -- stands there. diff --git a/src-build/Moonlight/Triangulation/SetAlgebra.hs b/src-build/Moonlight/Triangulation/SetAlgebra.hs --- a/src-build/Moonlight/Triangulation/SetAlgebra.hs +++ b/src-build/Moonlight/Triangulation/SetAlgebra.hs @@ -20,9 +20,9 @@ import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint, vertexPoints) import Moonlight.Triangulation.Handles.Iterators.FixedIterators (vertices) import Moonlight.Triangulation.Internal.Join (joinBalanced, joinNormalForm) -import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) import Moonlight.Triangulation.Internal.Join.SiteSet - ( siteSetDifference + ( rebuildCanonicalSiteSet + , siteSetDifference , siteSetFromTriangulation , siteSetIntersectionWith , siteSetPoints diff --git a/src-capi/Moonlight/Triangulation/Foreign/Exports.hs b/src-capi/Moonlight/Triangulation/Foreign/Exports.hs deleted file mode 100644 --- a/src-capi/Moonlight/Triangulation/Foreign/Exports.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Moonlight.Triangulation.Foreign.Exports where - -import Data.Int (Int64) -import Data.Word (Word32) -import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..)) -import Foreign.Ptr (Ptr) -import Moonlight.Triangulation.Foreign.ABI - ( CMesh - , CMinkowskiReceipt - , CObstruction - , CRegion - , CStructuringElement - ) -import qualified Moonlight.Triangulation.Foreign.ABI as ABI - -delaunayF64 = ABI.delaunayF64 -meshInsertManyF64 = ABI.meshInsertManyF64 -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 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-dcel/Moonlight/Triangulation/Exact.hs b/src-dcel/Moonlight/Triangulation/Exact.hs --- a/src-dcel/Moonlight/Triangulation/Exact.hs +++ b/src-dcel/Moonlight/Triangulation/Exact.hs @@ -131,14 +131,13 @@ -- callers must certify the candidate projection before relying on it. exactPointToEmbeddingCandidate :: ExactPoint - -> Either PointValidationError Point + -> Either PointValidationError QueryPoint exactPointToEmbeddingCandidate (ExactPoint x y) = - queryPointValue - <$> mkQueryPoint - ( Point - (integerRatioToDouble (exactRationalNumerator x) (exactRationalDenominator x)) - (integerRatioToDouble (exactRationalNumerator y) (exactRationalDenominator y)) - ) + mkQueryPoint + ( Point + (integerRatioToDouble (exactRationalNumerator x) (exactRationalDenominator x)) + (integerRatioToDouble (exactRationalNumerator y) (exactRationalDenominator y)) + ) -- | Exact orientation of an ordered triple. 'GT' is a positive determinant -- and counter-clockwise turn, 'EQ' is collinear, and 'LT' is clockwise. 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 @@ -19,6 +19,7 @@ , edgesInRectangle , verticesInRectangle , floodFillFaces + , floodFillFacesWithRejectedEdges , outerFaceFloodFill , facesAtEvenBarrierDepth , FaceComponent @@ -214,7 +215,7 @@ [edge | edge <- undirectedEdges triangulation, edgeInside edge] | otherwise = let starts = shapeStartFaces triangulation metric - (_, accepted) = floodFillFacesWithEdges triangulation starts edgeInside + (_, accepted, _) = floodFillFacesWithEdges triangulation starts edgeInside in map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList accepted) where edgeInside edge = @@ -244,15 +245,27 @@ -> (UndirectedEdgeId -> Bool) -> [FaceId] floodFillFaces triangulation starts canCross = - fst (floodFillFacesWithEdges triangulation starts canCross) + let (faces, _, _) = floodFillFacesWithEdges triangulation starts canCross + in faces +-- | The reached section and the edge pairs whose crossing was rejected while +-- descending it. This package-internal observation retains the boundary +-- witness instead of requiring a later face-wide rediscovery. +floodFillFacesWithRejectedEdges + :: Triangulation mode vertex directed undirected face -> [FaceId] + -> (UndirectedEdgeId -> Bool) + -> ([FaceId], [UndirectedEdgeId]) +floodFillFacesWithRejectedEdges triangulation starts canCross = + let (faces, _, rejected) = floodFillFacesWithEdges triangulation starts canCross + in (faces, fmap (UndirectedEdgeId . fromIntegral) (IntSet.toAscList rejected)) + floodFillFacesWithEdges :: Triangulation mode vertex directed undirected face -> [FaceId] -> (UndirectedEdgeId -> Bool) - -> ([FaceId], IntSet.IntSet) + -> ([FaceId], IntSet.IntSet, IntSet.IntSet) floodFillFacesWithEdges triangulation starts canCross = - let (faces, accepted, _) = go initialStack initialVisited IntSet.empty IntSet.empty [] - in (reverse faces, accepted) + let (faces, accepted, rejected) = go initialStack initialVisited IntSet.empty IntSet.empty [] + in (reverse faces, accepted, rejected) where valid face@(FaceId value) = face /= outerFace && fromIntegral value < numFaces triangulation (initialStack, initialVisited) = List.foldl' enqueueStart ([], IntSet.empty) starts diff --git a/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs b/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs --- a/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs @@ -6,6 +6,7 @@ -- representation is a function of its geometry alone. module Moonlight.Triangulation.Internal.Canonical ( canonicalize + , canonicalizeKnownAscending ) where import Control.Monad (when) @@ -20,6 +21,14 @@ import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) import Moonlight.Triangulation.Internal.Types (BuildError) +-- | Whether the caller has already established the authoritative vertex-order +-- section. The canonicalizer still owns every edge, directed-edge, face, +-- anchor, and constraint normalization; this witness affects only its vertex +-- rank entrance. +data VertexOrderAdmission + = VertexOrderUnknown + | VertexOrderKnownAscending + -- | Renumber a triangulation into its canonical representation. -- -- Two triangulations of the same sites are the same triangulation — Delaunay @@ -56,7 +65,21 @@ canonicalize :: Triangulation mode vertex () () () -> Either BuildError (Triangulation mode vertex () () ()) -canonicalize source = runST $ do +canonicalize = canonicalizeWithVertexOrder VertexOrderUnknown + +-- | Canonicalize a triangulation whose vertices were appended in strict +-- lexicographic coordinate order by the admitted SiteSet bulk entrance. +-- This is an execution witness, not a second numbering implementation. +canonicalizeKnownAscending + :: Triangulation mode vertex () () () + -> Either BuildError (Triangulation mode vertex () () ()) +canonicalizeKnownAscending = canonicalizeWithVertexOrder VertexOrderKnownAscending + +canonicalizeWithVertexOrder + :: VertexOrderAdmission + -> Triangulation mode vertex () () () + -> Either BuildError (Triangulation mode vertex () () ()) +canonicalizeWithVertexOrder vertexOrderAdmission source = runST $ do mutable <- newMutableDcel (triElementDefaults source) @@ -118,7 +141,10 @@ -- the schedule is assumed here — the coordinates are simply read and -- believed, so a mesh that arrives sorted for any other reason is served just -- as well. - !alreadyRanked = coordinatesAscend vertexTotal coordinateX coordinateY + !alreadyRanked = + case vertexOrderAdmission of + VertexOrderUnknown -> coordinatesAscend vertexTotal coordinateX coordinateY + VertexOrderKnownAscending -> True !vertexOrder | alreadyRanked = U.enumFromN 0 vertexTotal | otherwise = diff --git a/src-dcel/Moonlight/Triangulation/Internal/Representation.hs b/src-dcel/Moonlight/Triangulation/Internal/Representation.hs --- a/src-dcel/Moonlight/Triangulation/Internal/Representation.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/Representation.hs @@ -602,6 +602,7 @@ -- ^ Face slots whose published triangle changed or was appended. , refinementFinalPermittedFaces :: !(V.Vector FaceId) -- ^ Exact final face lineage admitted by a checked local domain. + , refinementFinalInterfaceIncidence :: !(V.Vector (UndirectedEdgeId, FaceId, FaceId)) , refinementTouchedEdges :: !(V.Vector UndirectedEdgeId) , refinementRemovedEdges :: !(V.Vector UndirectedEdgeId) , refinementInterfaceBoundaryReads :: {-# UNPACK #-} !Int diff --git a/src-dcel/Moonlight/Triangulation/Internal/Types.hs b/src-dcel/Moonlight/Triangulation/Internal/Types.hs --- a/src-dcel/Moonlight/Triangulation/Internal/Types.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/Types.hs @@ -283,7 +283,6 @@ | RefinementInputTopologyInvalid !InvariantViolation | SeamFrontierUnavailable | SeamSourceEdgeRequiresFlip !UndirectedEdgeId - | SeamProtectedSourceFaceChanged !FaceId | FreshInsertionMatchedExistingVertex !VertexId !VertexId | DegenerateLineEndpointMissingOutgoing !VertexId | DegenerateLineEndpointTurnMissing {-# UNPACK #-} !Int @@ -336,9 +335,6 @@ {-# UNPACK #-} !Double {-# UNPACK #-} !Double | RefinementSeedFaceNotActive !FaceId {-# UNPACK #-} !Int - | RefinementDomainInterfaceEdgeNotActive !UndirectedEdgeId {-# UNPACK #-} !Int - | RefinementDomainInterfaceMissing !UndirectedEdgeId - | RefinementDomainInterfaceExtraneous !UndirectedEdgeId | RefinementDomainTopologyChanged | RefinementDomainRequiresConvexHullPreservation | RefinementDomainRequiresConstraintPreservation @@ -352,6 +348,7 @@ | RefinementDomainWouldCrossInterface !UndirectedEdgeId !FaceId | RefinementDomainWouldRewriteProtectedFace !FaceId | RefinementDomainProtectedFaceChanged !FaceId + | RefinementDomainInterfaceOppositeFaceNotPermitted !UndirectedEdgeId !FaceId | RefinementOversizedEdge !FaceId !UndirectedEdgeId diff --git a/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs b/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs deleted file mode 100644 --- a/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs +++ /dev/null @@ -1,1117 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - -module Moonlight.Triangulation.Foreign.ABI - ( CObstruction (..) - , CMinkowskiReceipt (..) - , CMesh - , CRegion - , CStructuringElement - , delaunayF64 - , meshInsertManyF64 - , -- | 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.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 (CChar, CDouble (..), CSize (..), CUInt (..)) -import Foreign.Marshal.Utils (copyBytes, fillBytes) -import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) -import Foreign.StablePtr - ( StablePtr - , castPtrToStablePtr - , castStablePtrToPtr - , deRefStablePtr - , freeStablePtr - , newStablePtr - ) -import Foreign.Storable (Storable (..)) -import qualified Data.Vector as V -import qualified Moonlight.Triangulation as T -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 - , obstructionInputIndex :: !Word64 - , obstructionFirstIndex :: !Word64 - , obstructionSecondIndex :: !Word64 - , obstructionFirstValue :: !Double - , obstructionSecondValue :: !Double - , obstructionPointX :: !Double - , obstructionPointY :: !Double - , obstructionMessage :: !String - } - deriving stock (Eq, Show) - -instance Storable CObstruction where - sizeOf _ = 320 - alignment _ = alignment (0 :: Word64) - peek pointer = do - obstructionCode <- peekByteOff pointer 0 - obstructionCoordinateError <- peekByteOff pointer 4 - obstructionInputIndex <- peekByteOff pointer 8 - obstructionFirstIndex <- peekByteOff pointer 16 - obstructionSecondIndex <- peekByteOff pointer 24 - obstructionFirstValue <- peekByteOff pointer 32 - obstructionSecondValue <- peekByteOff pointer 40 - obstructionPointX <- peekByteOff pointer 48 - obstructionPointY <- peekByteOff pointer 56 - obstructionMessage <- peekCString (castPtr pointer `plusPtr` 64) - pure CObstruction {..} - poke pointer CObstruction {..} = do - pokeByteOff pointer 0 obstructionCode - pokeByteOff pointer 4 obstructionCoordinateError - pokeByteOff pointer 8 obstructionInputIndex - pokeByteOff pointer 16 obstructionFirstIndex - pokeByteOff pointer 24 obstructionSecondIndex - pokeByteOff pointer 32 obstructionFirstValue - pokeByteOff pointer 40 obstructionSecondValue - pokeByteOff pointer 48 obstructionPointX - pokeByteOff pointer 56 obstructionPointY - let messagePointer = castPtr pointer `plusPtr` 64 :: Ptr CChar - fillBytes messagePointer 0 256 - withCStringLen obstructionMessage $ \(source, lengthInBytes) -> - copyBytes messagePointer source (min 255 lengthInBytes) - --- | 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, statusGeometryObstruction, statusRuntimeFailure :: CUInt -statusOk = 0 -statusNullPointer = 1 -statusCountOverflow = 2 -statusBufferTooSmall = 3 -statusGeometryObstruction = 4 -statusRuntimeFailure = 5 - -emptyObstruction :: CObstruction -emptyObstruction = - CObstruction - { obstructionCode = 0 - , obstructionCoordinateError = 0 - , obstructionInputIndex = maxBound - , obstructionFirstIndex = 0 - , obstructionSecondIndex = 0 - , obstructionFirstValue = 0 - , obstructionSecondValue = 0 - , obstructionPointX = 0 - , obstructionPointY = 0 - , obstructionMessage = "" - } - -apiFailure :: CUInt -> Word32 -> String -> AbiFailure -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") - -countOverflowFailure :: Word64 -> AbiFailure -countOverflowFailure count = - AbiFailure statusCountOverflow emptyObstruction - { obstructionCode = 101 - , obstructionFirstIndex = count - , obstructionMessage = "count exceeds the host Int range" - } - -bufferTooSmallFailure :: Int -> Int -> AbiFailure -bufferTooSmallFailure required capacity = - AbiFailure statusBufferTooSmall emptyObstruction - { obstructionCode = 102 - , obstructionFirstIndex = fromIntegral required - , obstructionSecondIndex = fromIntegral capacity - , obstructionMessage = "output buffer is smaller than the required element count" - } - -runtimeFailure :: SomeException -> AbiFailure -runtimeFailure = apiFailure statusRuntimeFailure 103 . displayException - -runBoundary :: Ptr CObstruction -> IO (Either AbiFailure ()) -> IO CUInt -runBoundary obstructionPointer action = do - writeObstruction obstructionPointer emptyObstruction - outcome <- try action :: IO (Either SomeException (Either AbiFailure ())) - case outcome of - Left exception -> finishFailure obstructionPointer (runtimeFailure exception) - Right (Left failure) -> finishFailure obstructionPointer failure - Right (Right ()) -> pure statusOk - -finishFailure :: Ptr CObstruction -> AbiFailure -> IO CUInt -finishFailure obstructionPointer (AbiFailure status obstruction) = do - writeObstruction obstructionPointer obstruction - pure status - -writeObstruction :: Ptr CObstruction -> CObstruction -> IO () -writeObstruction pointer obstruction - | pointer == nullPtr = pure () - | otherwise = poke pointer obstruction - -requirePointer :: String -> Ptr value -> Either AbiFailure () -requirePointer label pointer - | pointer == nullPtr = Left (nullPointerFailure label) - | otherwise = Right () - -checkedCount :: Int -> CSize -> Either AbiFailure Int -checkedCount elementsPerItem rawCount - | toInteger rawCount * toInteger elementsPerItem > toInteger (maxBound :: Int) = - Left (countOverflowFailure (fromIntegral rawCount)) - | otherwise = Right (fromIntegral rawCount) - -readPoints :: Ptr CDouble -> Int -> IO (Either AbiFailure (V.Vector T.Point)) -readPoints pointer count - | count == 0 = pure (Right V.empty) - | pointer == nullPtr = pure (Left (nullPointerFailure "coordinates")) - | otherwise = - Right - <$> V.generateM - count - ( \index -> do - CDouble x <- peekElemOff pointer (index * 2) - CDouble y <- peekElemOff pointer (index * 2 + 1) - pure (T.Point x y) - ) - -prepareHandleOutput :: Ptr (Ptr carrier) -> IO (Either AbiFailure ()) -prepareHandleOutput pointer = - case requirePointer "result" pointer of - Left failure -> pure (Left failure) - Right () -> poke pointer nullPtr >> pure (Right ()) - -publishHandle :: Ptr (Ptr carrier) -> HandleValue carrier -> IO () -publishHandle output value = do - stable <- newStablePtr value - poke output (castPtr (castStablePtrToPtr stable)) - -produceHandle - :: Ptr (Ptr carrier) - -> IO (Either AbiFailure (HandleValue carrier)) - -> IO (Either AbiFailure ()) -produceHandle output obtain = do - prepared <- prepareHandleOutput output - case prepared of - Left failure -> pure (Left failure) - Right () -> do - outcome <- obtain - case outcome of - Left failure -> pure (Left failure) - Right value -> publishHandle output value >> pure (Right ()) - -dereferenceHandle :: Ptr carrier -> IO (HandleValue carrier) -dereferenceHandle pointer = deRefStablePtr (castPtrToStablePtr (castPtr pointer)) - -freeHandle :: Ptr carrier -> IO () -freeHandle pointer - | pointer == nullPtr = pure () - | otherwise = freeStablePtr (castPtrToStablePtr (castPtr pointer) :: StablePtr ()) - -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 $ produceHandle output $ do - case checkedCount 2 rawCount of - Left failure -> pure (Left failure) - Right count -> do - points <- readPoints coordinates count - pure (points >>= first buildFailure . T.delaunayGeometry) - -meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt -meshInsertManyF64 meshPointer coordinates rawCount output obstructionPointer = - runBoundary obstructionPointer $ produceHandle output $ do - case requirePointer "mesh" meshPointer >> checkedCount 2 rawCount of - Left failure -> pure (Left failure) - Right count -> do - points <- readPoints coordinates count - case points of - Left failure -> pure (Left failure) - Right admitted -> do - mesh <- dereferenceHandle meshPointer - pure (first buildFailure (insertGeometryBatch mesh admitted)) - --- | 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 - V.imapM_ (\index point -> () <$ validatePoint (Just index) point) points - (_, revised, _) <- - Session.withSession - mesh - (V.length points) - (V.mapM_ (\point -> void (Session.insertVertexAt (canonicalPoint point) ())) points) - pure revised - -meshSiteUnion, meshSiteIntersection, meshSiteDifference, meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt -meshSiteUnion = binaryMeshOperation T.union -meshSiteIntersection = binaryMeshOperation T.intersection -meshSiteDifference = binaryMeshOperation T.difference -meshSiteSymmetricDifference = binaryMeshOperation T.symmetricDifference - -binaryMeshOperation - :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh) - -> Ptr CMesh - -> Ptr CMesh - -> Ptr (Ptr CMesh) - -> Ptr CObstruction - -> IO CUInt -binaryMeshOperation operation leftPointer rightPointer output obstructionPointer = - runBoundary obstructionPointer $ produceHandle output $ do - case requirePointer "left mesh" leftPointer >> requirePointer "right mesh" rightPointer of - Left failure -> pure (Left failure) - Right () -> do - left <- dereferenceHandle leftPointer - right <- dereferenceHandle rightPointer - pure (first buildFailure (operation left right)) - -meshVertexCount, meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt -meshVertexCount = handleCount "mesh" T.numVertices -meshTriangleCount = handleCount "mesh" (V.length . T.innerFaceVertexTriples) - -handleCount - :: String - -> (HandleValue carrier -> Int) - -> Ptr carrier - -> Ptr CSize - -> Ptr CObstruction - -> IO CUInt -handleCount handleLabel observe handlePointer output obstructionPointer = - runBoundary obstructionPointer $ - case requirePointer handleLabel handlePointer >> requirePointer "count" output of - Left failure -> pure (Left failure) - Right () -> do - value <- dereferenceHandle handlePointer - poke output (fromIntegral (observe value)) - pure (Right ()) - -meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt -meshCopyVerticesF64 = - copyHandleProjection - "mesh" - "points_written" - "coordinates" - T.vertexPoints - ( \output index (T.Point x y) -> do - pokeElemOff output (index * 2) (CDouble x) - pokeElemOff output (index * 2 + 1) (CDouble y) - ) - -meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt -meshCopyTrianglesU32 = - copyHandleProjection - "mesh" - "triangles_written" - "triangles" - T.innerFaceVertexTriples - ( \output index (firstVertex, secondVertex, thirdVertex) -> do - pokeElemOff output (index * 3) (T.unVertexId firstVertex) - pokeElemOff output (index * 3 + 1) (T.unVertexId secondVertex) - pokeElemOff output (index * 3 + 2) (T.unVertexId thirdVertex) - ) - -copyHandleProjection - :: String - -> String - -> String - -> (HandleValue carrier -> V.Vector item) - -> (Ptr element -> Int -> item -> IO ()) - -> Ptr carrier - -> Ptr element - -> CSize - -> Ptr CSize - -> Ptr CObstruction - -> IO CUInt -{-# INLINE copyHandleProjection #-} -copyHandleProjection handleLabel writtenLabel outputLabel project writeItem handlePointer output rawCapacity written obstructionPointer = - runBoundary obstructionPointer $ - case requirePointer handleLabel handlePointer >> requirePointer writtenLabel written >> checkedCount 1 rawCapacity of - Left failure -> pure (Left failure) - Right capacity -> do - value <- dereferenceHandle handlePointer - let items = project value - required = V.length items - poke written (fromIntegral required) - case requireOutputCapacity outputLabel output required capacity of - Left failure -> pure (Left failure) - Right () -> V.imapM_ (writeItem output) items >> pure (Right ()) - -requireOutputCapacity :: String -> Ptr value -> Int -> Int -> Either AbiFailure () -requireOutputCapacity label output required capacity - | capacity < required = Left (bufferTooSmallFailure required capacity) - | required > 0 = requirePointer label output - | otherwise = Right () - -meshFree :: Ptr CMesh -> IO () -meshFree = freeHandle - -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 - T.InvalidCoordinate inputIndex value reason -> - emptyObstruction - { obstructionCode = 1 - , obstructionCoordinateError = coordinateErrorCode reason - , obstructionInputIndex = maybe maxBound fromIntegral inputIndex - , obstructionFirstValue = value - } - T.PointLocationFailed (T.Point x y) -> pointObstruction 2 x y - T.LocationWalkExhausted (T.Point x y) steps -> - (pointObstruction 3 x y) {obstructionFirstIndex = fromIntegral steps} - T.RefinementInputTopologyInvalid _ -> codeOnly 4 - 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 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) - T.RemovalVertexOutOfRange vertex count -> indices 13 (T.unVertexId vertex) count - T.RemovalEdgeOutOfRange edge count -> indices 14 (T.unUndirectedEdgeId edge) count - T.RemovalFaceOutOfRange face count -> indices 15 (T.unFaceId face) count - T.RemovalFaceCycleDidNotTerminate face edge steps -> - (indices 16 (T.unFaceId face) (T.unDirectedEdgeId edge)) - {obstructionFirstValue = fromIntegral steps} - T.RemovalEmptyTriangulation vertex -> firstIndex 17 (T.unVertexId vertex) - T.RemovalTwoPointDegreeMismatch vertex degree -> indices 18 (T.unVertexId vertex) degree - T.RemovalCollinearDegreeMismatch vertex degree -> indices 19 (T.unVertexId vertex) degree - T.RemovalBorderTooShort count -> firstIndex 20 count - T.RemovalBorderArityMismatch count -> firstIndex 21 count - T.RemovalOutgoingCycleDidNotTerminate vertex edge steps -> - (indices 22 (T.unVertexId vertex) (T.unDirectedEdgeId edge)) - {obstructionFirstValue = fromIntegral steps} - T.CircleSweepHullEmpty -> codeOnly 23 - 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} - T.HierarchyInsertionHandleMismatch expected observed -> indices 26 (T.unVertexId expected) (T.unVertexId observed) - T.PointIndexCapacityExhausted count -> firstIndex 27 count - T.RefinementMinimumAngleNotFinite value -> nonFinite 28 value - T.RefinementMinimumAngleOutOfRange value -> firstValue 29 value - T.RefinementMinimumAngleDerivedRatioNotFinite value -> nonFinite 30 value - T.RefinementMaximumAdditionalVerticesNegative value -> firstValue 31 (fromIntegral value) - T.RefinementMinimumAreaNotFinite value -> nonFinite 32 value - T.RefinementMinimumAreaNegative value -> firstValue 33 value - T.RefinementMaximumAreaNotFinite value -> nonFinite 34 value - T.RefinementMaximumAreaNotPositive value -> firstValue 35 value - T.RefinementMaximumRadiusEdgeRatioNotFinite value -> nonFinite 36 value - T.RefinementMaximumRadiusEdgeRatioNotPositive value -> firstValue 37 value - T.RefinementMaximumEdgeLengthNotFinite value -> nonFinite 60 value - T.RefinementMaximumEdgeLengthNotPositive value -> firstValue 61 value - T.RefinementMinimumAreaExceedsMaximum minimumArea maximumArea -> values 38 minimumArea maximumArea - T.RefinementSeedFaceNotActive face count -> indices 39 (T.unFaceId face) count - T.RefinementDomainInterfaceEdgeNotActive edge count -> indices 40 (T.unUndirectedEdgeId edge) count - T.RefinementDomainInterfaceMissing edge -> firstIndex 41 (T.unUndirectedEdgeId edge) - T.RefinementDomainInterfaceExtraneous edge -> firstIndex 42 (T.unUndirectedEdgeId edge) - T.RefinementDomainTopologyChanged -> codeOnly 43 - T.RefinementDomainRequiresConvexHullPreservation -> codeOnly 44 - T.RefinementDomainRequiresConstraintPreservation -> codeOnly 45 - T.RefinementDomainForbidsOuterFaceExclusion -> codeOnly 46 - T.RefinementDomainWouldCrossInterface edge face -> indices 47 (T.unUndirectedEdgeId edge) (T.unFaceId face) - T.RefinementDomainWouldRewriteProtectedFace face -> firstIndex 48 (T.unFaceId face) - T.RefinementDomainProtectedFaceChanged face -> firstIndex 49 (T.unFaceId face) - T.RefinementOversizedEdge face edge actual bound -> - (indices 62 (T.unFaceId face) (T.unUndirectedEdgeId edge)) - { obstructionFirstValue = actual - , obstructionSecondValue = bound - } - T.CapacityExceeded count -> firstIndex 50 count - T.HalfEdgeCapacityExceeded requested capacity -> indices 51 requested capacity - T.FaceCapacityExceeded requested capacity -> indices 52 requested capacity - T.PayloadStorageFailure _ -> codeOnly 53 - T.CoordinatePayloadCountMismatch coordinates payloads -> indices 54 coordinates payloads - T.CircleSweepRequiresDenseStorage -> codeOnly 55 - T.SeamFrontierUnavailable -> codeOnly 56 - T.RefinementDomainRequiresFiniteVertexBudget -> codeOnly 57 - T.SeamSourceEdgeRequiresFlip edge -> firstIndex 58 (T.unUndirectedEdgeId edge) - T.SeamProtectedSourceFaceChanged face -> firstIndex 59 (T.unFaceId face) - T.RefinementSeamBridgeBudgetExceeded required available -> indices 63 required available - T.RefinementSeamBridgeMidpointCollapsed edge -> firstIndex 64 (T.unUndirectedEdgeId edge) - T.BoundarySplitRequiresBoundaryEdge edge -> firstIndex 65 (T.unUndirectedEdgeId edge) - ) - {obstructionMessage = show failure} - where - codeOnly :: Word32 -> CObstruction - codeOnly code = emptyObstruction {obstructionCode = code} - 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 firstIndexValue secondIndexValue = - (codeOnly code) - { obstructionFirstIndex = fromIntegral firstIndexValue - , obstructionSecondIndex = fromIntegral secondIndexValue - } - firstValue :: Word32 -> Double -> CObstruction - firstValue code value = (codeOnly code) {obstructionFirstValue = value} - values :: Word32 -> Double -> Double -> CObstruction - values code firstCoordinateValue secondCoordinateValue = - (codeOnly code) - { obstructionFirstValue = firstCoordinateValue - , obstructionSecondValue = secondCoordinateValue - } - pointObstruction :: Word32 -> Double -> Double -> CObstruction - pointObstruction code x y = - (codeOnly code) - { obstructionPointX = x - , obstructionPointY = y - } - nonFinite :: Word32 -> T.NonFiniteValue -> CObstruction - nonFinite code value = firstIndex code (nonFiniteCode value) - -coordinateErrorCode :: T.CoordinateError -> Word32 -coordinateErrorCode reason = - case reason of - T.CoordinateNaN -> 1 - T.CoordinateInfinite -> 2 - T.CoordinateTooSmall -> 3 - T.CoordinateTooLarge -> 4 - -nonFiniteCode :: T.NonFiniteValue -> Word32 -nonFiniteCode value = - case value of - T.ValueNaN -> 1 - T.ValuePositiveInfinity -> 2 - T.ValueNegativeInfinity -> 3 diff --git a/src-planar/Moonlight/Triangulation/Internal/Minkowski/Convex.hs b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Convex.hs deleted file mode 100644 --- a/src-planar/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-planar/Moonlight/Triangulation/Internal/Minkowski/Types.hs b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Types.hs deleted file mode 100644 --- a/src-planar/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-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs +++ /dev/null @@ -1,814 +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 - ( 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 deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Internal/Overlay/Embedding.hs +++ /dev/null @@ -1,533 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - --- | Bounded certification of local binary64 embedding obligations for a --- declared exact arrangement draft. -module Moonlight.Triangulation.Internal.Overlay.Embedding - ( DraftId (..) - , DraftVertexId - , DraftSegmentId - , DraftSourceId - , DraftIncidence (..) - , DraftNeighborhood (..) - , ExactArrangementDraft (..) - , DraftReference (..) - , OverlayEmbeddingObstruction (..) - , EmbeddingObligation (..) - , EmbeddingResidual - , residualUndischargedObligations - , milestoneOneResidual - , LocalEmbeddingCertificate (..) - , certifyLocalEmbedding - ) where - -import Control.DeepSeq (NFData) -import Data.List (sort, tails) -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import GHC.Generics (Generic) -import Moonlight.Triangulation.Exact - ( ExactPoint - , SegmentRelation - , exactPointToEmbeddingCandidate - , exactSegmentRelation - ) -import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) -import Moonlight.Triangulation.Internal.ExactRational (ExactRational) -import qualified Moonlight.Triangulation.Math as Math - ( orient2d - , segmentRelation - ) -import Moonlight.Triangulation.Types - ( Point (..) - , PointValidationError - ) - --- | 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 deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Internal/Overlay/Resident.hs +++ /dev/null @@ -1,923 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Resident DCEL descent and exact-cell gluing. The certified arrangement is --- authoritative at this seam; diagonal schedules may change only its resident --- triangulation, never its exact cell descriptors. -module Moonlight.Triangulation.Internal.Overlay.Resident - ( OverlayDiagonalSchedule (..) - , residentOverlay - , faceLabels - , faceCarriesExactArea - , regionFaceLabels - , vertexSupport - , edgeSupport - ) where - -import Control.Monad (foldM) -import Data.Bifunctor (first) -import Data.Foldable (traverse_) -import Data.List (partition, sort, sortBy) -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Maybe (listToMaybe, mapMaybe) -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Vector as V -import qualified Moonlight.Triangulation.Dcel as Dcel -import Moonlight.Triangulation.Dcel - ( faceData - , faceDirectedEdges - , faceVertices - , imapUndirectedEdges - , incidentFace - , isConstraintEdge - , numInnerFaces - , numVertices - , outerFace - , undirectedEndpoints - , vertexData - , vertexOutgoingEdges - ) -import Moonlight.Triangulation.Exact (ExactPoint, exactOrient2d) -import Moonlight.Triangulation.FloodFillIterator - ( FaceComponent - , componentBoundary - , faceComponentFaces - , faceComponentsBy - ) -import Moonlight.Triangulation.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 deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Internal/Overlay/Types.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE KindSignatures #-} - --- | Closed vocabulary and opaque carrier representation for exact labelled --- overlay. Construction lives in the public build-tier module; this module --- exists so every invariant-bearing payload shares one owner. -module Moonlight.Triangulation.Internal.Overlay.Types - ( BoundaryLoopRef (..) - , OverlayOperand (..) - , BoundaryRef (..) - , BoundaryVertexRef - , BoundaryEdgeRef - , OverlayVertexOrigin (..) - , OverlayEdgeOrigin (..) - , OverlaySupport (..) - , overlaySupportLabels - , OverlayCellSupport (..) - , OverlayCellId (..) - , OverlayCellGeometry (..) - , OverlayCell (..) - , OverlayFace (..) - , OverlayVertex (..) - , OverlayEdge (..) - , OverlayReceipt (..) - , OverlayArrangementObstruction (..) - , OverlayCellWitness (..) - , OverlayError (..) - , OverlayResult (..) - , OverlaySelectionKind (..) - , OverlaySelectionError (..) - ) where - -import Control.DeepSeq (NFData) -import Data.List.NonEmpty (NonEmpty) -import Data.Vector (Vector) -import GHC.Generics (Generic) -import Moonlight.Triangulation.CellSet (CellSelectionError) -import Moonlight.Triangulation.Exact - ( ExactPoint - ) -import Moonlight.Triangulation.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 deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Minkowski.hs +++ /dev/null @@ -1,595 +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 - ( 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 deleted file mode 100644 --- a/src-planar/Moonlight/Triangulation/Overlay.hs +++ /dev/null @@ -1,296 +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 - , 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 @@ -116,16 +116,12 @@ , constrainedSeamFaceFirstPoint , constrainedSeamFaceSecondPoint , constrainedSeamFaceThirdPoint - , ConstrainedSeamConstraintEvidence - , constrainedSeamConstraintSegment - , constrainedSeamConstraintRecovery , ConstrainedSeamResult , constrainedSeamResultTriangulation , constrainedSeamLeftFaceCount , constrainedSeamRightFaceEvidence , constrainedSeamJoinFaces , constrainedSeamLeftConstraintCount - , constrainedSeamRightConstraintEvidence , constrainedSeamConstraintStats , constrainedSeamBuildStats , constrainedSeamPublicationStats @@ -154,6 +150,7 @@ , refinementVisitedProtectedFaces , refinementCreatedFaces , refinementFinalPermittedFaces + , refinementFinalInterfaceIncidence , refinementTouchedEdges , refinementRemovedEdges , refinementInterfaceBoundaryReads @@ -471,7 +468,6 @@ , ConstrainedUnionError (..) , ConstrainedExtensionResult , ConstrainedSeamSide (..) - , ConstrainedSeamConstraintEvidence , ConstrainedSeamFaceEvidence , ConstrainedSeamResult , ConstraintBatchResult @@ -483,8 +479,6 @@ , constraintBatchStats , constraintBatchTriangulation , constrainedSeamBuildStats - , constrainedSeamConstraintRecovery - , constrainedSeamConstraintSegment , constrainedSeamConstraintStats , constrainedSeamCachedFrontierPointReads , constrainedSeamFaceFirstPoint @@ -495,7 +489,6 @@ , constrainedSeamJoinFaces , constrainedSeamPublicationStats , constrainedSeamResultTriangulation - , constrainedSeamRightConstraintEvidence , constrainedSeamRightFaceEvidence , constrainedSeamSourceFace , constrainedSeamTargetFace @@ -541,6 +534,7 @@ , refinementComplete , refinementCreatedFaces , refinementFinalPermittedFaces + , refinementFinalInterfaceIncidence , refinementExcludedFaces , refinementRemovedEdges , refinementTouchedEdges diff --git a/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs b/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs new file mode 100644 --- /dev/null +++ b/src-public/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-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs b/src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs new file mode 100644 --- /dev/null +++ b/src-public/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-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs @@ -0,0 +1,811 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Exact source normalization and binary64 embedding certification. This +-- module ends at the arrangement/resident seam: no DCEL face state crosses it. +module Moonlight.Triangulation.Internal.Overlay.Arrangement + ( ExactEdgeKey + , AtomicEdge (..) + , atomicEdgeFrom + , atomicEdgeTo + , OverlayVertexSeed (..) + , ArrangementMetrics (..) + , CertifiedArrangement (..) + , certifyArrangement + , canonicalEdgeKey + , atomicKey + , compareAround + ) where + +import Data.Bifunctor (first) +import Data.List (sortBy) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Moonlight.Triangulation.Exact + ( ExactGeometryError + , ExactPoint + , ExactSegment + , SegmentRelation (SegmentsShareEndpoint) + , compareExactVectorAngle + , exactPointCoordinates + , exactPointFromQueryPoint + , exactSegment + , exactSegmentEndpoints + , exactVectorFromPoints + ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( consecutivePairs + , orderedPair + , unorderedPairs + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactDivide + , exactRationalIsZero + ) +import Moonlight.Triangulation.Internal.ExactSegmentEvents + ( ExactSegmentEvent (..) + , ExactSegmentEventPlan + , ExactSweepSegmentId (..) + , exactSegmentEventPlan + , exactSegmentEvents + , exactSegmentPairChecks + , exactSegmentRelationMap + , exactSegmentSplitPoints + , exactSegmentSweepMaximumHeight + ) +import Moonlight.Triangulation.Internal.Overlay.Embedding + ( DraftId (..) + , DraftIncidence (..) + , DraftNeighborhood (..) + , DraftReference (..) + , DraftVertexId + , ExactArrangementDraft (..) + , LocalEmbeddingCertificate (..) + , OverlayEmbeddingObstruction (..) + , certifyLocalEmbedding + ) +import Moonlight.Triangulation.Internal.Overlay.Types +import Moonlight.Triangulation.Internal.Types + ( HasPosition (..) + , Point + , queryPointValue + ) +import Moonlight.Triangulation.Region + ( ExactLoop + , PlanarLayer + , PolygonComponent + , exactLoopPoints + , planarLayerOutsideLabel + , planarLayerRegions + , planarRegionComponents + , polygonHoleLoops + , polygonOuterLoop + ) + +type ExactEdgeKey = (ExactPoint, ExactPoint) + +data SourceBoundary leftLabel rightLabel + = LeftSourceBoundary + !ExactSegment + !leftLabel + !(BoundaryVertexRef 'LeftOverlayOperand) + !(BoundaryVertexRef 'LeftOverlayOperand) + !(BoundaryEdgeRef 'LeftOverlayOperand) + | RightSourceBoundary + !ExactSegment + !rightLabel + !(BoundaryVertexRef 'RightOverlayOperand) + !(BoundaryVertexRef 'RightOverlayOperand) + !(BoundaryEdgeRef 'RightOverlayOperand) + +type SourceBoundaryConstructor operand label leftLabel rightLabel = + ExactSegment + -> label + -> BoundaryVertexRef operand + -> BoundaryVertexRef operand + -> BoundaryEdgeRef operand + -> SourceBoundary leftLabel rightLabel + +data AtomicContribution leftLabel rightLabel = + AtomicContribution !(SourceBoundary leftLabel rightLabel) !Bool + +data AtomicEdge leftLabel rightLabel = AtomicEdge + { atomicEdgeSegment :: !ExactSegment + , atomicEdgeOrigin :: !OverlayEdgeOrigin + , atomicEdgeLeftTransition :: !(Maybe (leftLabel, leftLabel)) + , atomicEdgeRightTransition :: !(Maybe (rightLabel, rightLabel)) + } + +data OriginAccumulation = OriginAccumulation + { accumulatedLeftVertices :: !(Set (BoundaryVertexRef 'LeftOverlayOperand)) + , accumulatedRightVertices :: !(Set (BoundaryVertexRef 'RightOverlayOperand)) + , accumulatedLeftEdges :: !(Set (BoundaryEdgeRef 'LeftOverlayOperand)) + , accumulatedRightEdges :: !(Set (BoundaryEdgeRef 'RightOverlayOperand)) + } + +data OverlayVertexSeed = OverlayVertexSeed + { seedExactPoint :: !ExactPoint + , seedEmbeddedPoint :: !Point + , seedOrigin :: !OverlayVertexOrigin + } + deriving stock (Eq, Ord, Show, Generic) + +instance HasPosition OverlayVertexSeed where + position = seedEmbeddedPoint + +data ArrangementMetrics = ArrangementMetrics + { arrangementInputSegments :: !Int + , arrangementRelationEvents :: !Int + , arrangementExactCrossings :: !Int + , arrangementOverlapIntervals :: !Int + , arrangementEmbeddingCandidates :: !Int + , arrangementTotalRelationChecks :: !Int + , arrangementSweepMaximumHeight :: !Int + } + +data CertifiedArrangement leftLabel rightLabel = CertifiedArrangement + { certifiedAtomicEdges :: !(V.Vector (AtomicEdge leftLabel rightLabel)) + , certifiedVertexSeeds :: !(V.Vector OverlayVertexSeed) + , certifiedConstraints :: !(V.Vector (Int, Int)) + , certifiedInexactEmbeddingPoints :: !(Set ExactPoint) + , certifiedMetrics :: !ArrangementMetrics + } + +certifyArrangement + :: (Ord leftLabel, Ord rightLabel) + => PlanarLayer leftLabel + -> PlanarLayer rightLabel + -> Either + (OverlayError leftLabel rightLabel) + (CertifiedArrangement leftLabel rightLabel) +certifyArrangement leftLayer rightLayer = do + sources <- flattenLayers leftLayer rightLayer + sourcePlan <- + first OverlaySegmentEventsInvalid + (exactSegmentEventPlan (V.map sourceExactSegment sources)) + atomicEdges <- normalizeAtomicEdges leftLayer rightLayer sources sourcePlan + let atomicVector = V.fromList atomicEdges + pointIds = exactPointIds atomicVector + origins = vertexOrigins sources atomicVector + atomicRelations = atomicEndpointRelations atomicVector + draft <- exactArrangementDraft sources sourcePlan atomicVector pointIds atomicRelations + localCertificate <- first OverlayEmbeddingRefused (certifyLocalEmbedding draft) + let projectedPoints = projectedExactPoints localCertificate + inexactEmbeddingPoints = + Set.fromList + [ exactPoint + | (exactPoint, vertexId) <- Map.toAscList pointIds + , Map.lookup vertexId projectedPoints /= Just exactPoint + ] + projectedSegments <- projectedAtomicSegments atomicVector pointIds projectedPoints + projectedPlan <- + first OverlaySegmentEventsInvalid + (exactSegmentEventPlan projectedSegments) + dischargeGlobalRelations atomicRelations projectedPlan + seeds <- overlayVertexSeeds pointIds origins localCertificate + constraints <- atomicConstraints pointIds atomicVector + let events = exactSegmentEvents sourcePlan + pure + CertifiedArrangement + { certifiedAtomicEdges = atomicVector + , certifiedVertexSeeds = seeds + , certifiedConstraints = constraints + , certifiedInexactEmbeddingPoints = inexactEmbeddingPoints + , certifiedMetrics = + ArrangementMetrics + { arrangementInputSegments = V.length sources + , arrangementRelationEvents = length events + , arrangementExactCrossings = + length [() | ExactProperCrossing {} <- events] + , arrangementOverlapIntervals = + length [() | ExactCollinearOverlap {} <- events] + , arrangementEmbeddingCandidates = Map.size pointIds + , arrangementTotalRelationChecks = + exactSegmentPairChecks sourcePlan + + exactSegmentPairChecks projectedPlan + , arrangementSweepMaximumHeight = + max + (exactSegmentSweepMaximumHeight sourcePlan) + (exactSegmentSweepMaximumHeight projectedPlan) + } + } +flattenLayers + :: PlanarLayer leftLabel + -> PlanarLayer rightLabel + -> Either (OverlayError leftLabel rightLabel) (V.Vector (SourceBoundary leftLabel rightLabel)) +flattenLayers leftLayer rightLayer = do + leftSources <- flattenLayer LeftSourceBoundary leftLayer + rightSources <- flattenLayer RightSourceBoundary rightLayer + pure (V.fromList (leftSources <> rightSources)) + +flattenLayer + :: SourceBoundaryConstructor operand label leftLabel rightLabel + -> PlanarLayer label + -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] +flattenLayer makeBoundary layer = + fmap concat + ( traverse + (\(componentIndex, (label, component)) -> + flattenComponent makeBoundary componentIndex label component) + (zip [0 ..] (labelledComponents layer)) + ) +{-# INLINE flattenLayer #-} + +labelledComponents :: PlanarLayer label -> [(label, PolygonComponent)] +labelledComponents layer = + [ (label, component) + | (label, region) <- Map.toAscList (planarLayerRegions layer) + , component <- planarRegionComponents region + ] + +flattenComponent + :: SourceBoundaryConstructor operand label leftLabel rightLabel + -> Int + -> label + -> PolygonComponent + -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] +flattenComponent makeBoundary componentIndex label component = do + outer <- + flattenLoop + makeBoundary + componentIndex + BoundaryOuterLoop + label + (polygonOuterLoop component) + holes <- + fmap concat + ( traverse + (\(holeIndex, loop) -> + flattenLoop + makeBoundary + componentIndex + (BoundaryHoleLoop holeIndex) + label + loop) + (zip [0 ..] (polygonHoleLoops component)) + ) + pure (outer <> holes) +{-# INLINE flattenComponent #-} + +flattenLoop + :: SourceBoundaryConstructor operand label leftLabel rightLabel + -> Int + -> BoundaryLoopRef + -> label + -> ExactLoop + -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] +flattenLoop makeBoundary componentIndex loopRef label loop = + traverse constructSource (indexedCycle (exactLoopPoints loop)) + where + constructSource (edgeIndex, fromIndex, from, toIndex, to) = do + segment <- first (sourceGeometryError from) (exactSegment from to) + pure + ( makeBoundary + segment + label + (BoundaryRef componentIndex loopRef fromIndex) + (BoundaryRef componentIndex loopRef toIndex) + (BoundaryRef componentIndex loopRef edgeIndex) + ) +{-# INLINE flattenLoop #-} + +sourceGeometryError + :: ExactPoint + -> ExactGeometryError + -> OverlayError leftLabel rightLabel +sourceGeometryError point _ = OverlayArrangementInvalid (OverlayRotationDegenerate point) + +indexedCycle :: NonEmpty value -> [(Int, Int, value, Int, value)] +indexedCycle (firstValue :| remaining) = + let values = firstValue : remaining + count = length values + in [ (index, index, from, (index + 1) `mod` count, to) + | (index, (from, to)) <- zip [0 ..] (zip values (remaining <> [firstValue])) + ] + +sourceExactSegment :: SourceBoundary leftLabel rightLabel -> ExactSegment +sourceExactSegment (LeftSourceBoundary segment _ _ _ _) = segment +sourceExactSegment (RightSourceBoundary segment _ _ _ _) = segment + +normalizeAtomicEdges + :: (Ord leftLabel, Ord rightLabel) + => PlanarLayer leftLabel + -> PlanarLayer rightLabel + -> V.Vector (SourceBoundary leftLabel rightLabel) + -> ExactSegmentEventPlan + -> Either (OverlayError leftLabel rightLabel) [AtomicEdge leftLabel rightLabel] +normalizeAtomicEdges leftLayer rightLayer sources plan = + fmap concat + ( traverse + (resolveAtomicContributions leftOutside rightOutside) + (Map.toAscList grouped) + ) + where + leftOutside = planarLayerOutsideLabel leftLayer + rightOutside = planarLayerOutsideLabel rightLayer + grouped = + V.ifoldl' + (\groups sourceIndex source -> + List.foldl' + (insertAtomic source) + groups + (consecutivePairs (exactSegmentSplitPoints plan (ExactSweepSegmentId sourceIndex)))) + Map.empty + sources + insertAtomic + :: SourceBoundary leftLabel' rightLabel' + -> Map ExactEdgeKey [AtomicContribution leftLabel' rightLabel'] + -> (ExactPoint, ExactPoint) + -> Map ExactEdgeKey [AtomicContribution leftLabel' rightLabel'] + insertAtomic source groups (from, to) + | from == to = groups + | otherwise = + let key@(canonicalFrom, _) = canonicalEdgeKey from to + contribution = AtomicContribution source (from == canonicalFrom) + in Map.insertWith (<>) key [contribution] groups + +resolveAtomicContributions + :: (Ord leftLabel, Ord rightLabel) + => leftLabel + -> rightLabel + -> (ExactEdgeKey, [AtomicContribution leftLabel rightLabel]) + -> Either (OverlayError leftLabel rightLabel) [AtomicEdge leftLabel rightLabel] +resolveAtomicContributions leftOutside rightOutside ((from, to), contributions) = do + let + ( leftLabelsOnLeft + , leftLabelsOnRight + , rightLabelsOnLeft + , rightLabelsOnRight + , leftSources + , rightSources + ) = + List.foldl' + collectContribution + (Set.empty, Set.empty, Set.empty, Set.empty, Set.empty, Set.empty) + contributions + origin = + OverlayEdgeOrigin + (Set.toAscList leftSources) + (Set.toAscList rightSources) + leftTransition <- + resolveTransition + OverlayLeftSourceSideConflict + origin + leftOutside + leftLabelsOnLeft + leftLabelsOnRight + rightTransition <- + resolveTransition + OverlayRightSourceSideConflict + origin + rightOutside + rightLabelsOnLeft + rightLabelsOnRight + if transitionIsIdentity leftTransition && transitionIsIdentity rightTransition + then Right [] + else do + segment <- first (sourceGeometryError from) (exactSegment from to) + Right + [ AtomicEdge + { atomicEdgeSegment = segment + , atomicEdgeOrigin = origin + , atomicEdgeLeftTransition = leftTransition + , atomicEdgeRightTransition = rightTransition + } + ] + where + collectContribution + :: (Ord leftLabel', Ord rightLabel') + => ( Set leftLabel' + , Set leftLabel' + , Set rightLabel' + , Set rightLabel' + , Set (BoundaryEdgeRef 'LeftOverlayOperand) + , Set (BoundaryEdgeRef 'RightOverlayOperand) + ) + -> AtomicContribution leftLabel' rightLabel' + -> ( Set leftLabel' + , Set leftLabel' + , Set rightLabel' + , Set rightLabel' + , Set (BoundaryEdgeRef 'LeftOverlayOperand) + , Set (BoundaryEdgeRef 'RightOverlayOperand) + ) + collectContribution + ( !leftLeft + , !leftRight + , !rightLeft + , !rightRight + , !leftSources + , !rightSources + ) + contribution = + case contribution of + AtomicContribution (LeftSourceBoundary _ label _ _ reference) follows -> + ( if follows then Set.insert label leftLeft else leftLeft + , if follows then leftRight else Set.insert label leftRight + , rightLeft + , rightRight + , Set.insert reference leftSources + , rightSources + ) + AtomicContribution (RightSourceBoundary _ label _ _ reference) follows -> + ( leftLeft + , leftRight + , if follows then Set.insert label rightLeft else rightLeft + , if follows then rightRight else Set.insert label rightRight + , leftSources + , Set.insert reference rightSources + ) + +resolveTransition + :: (OverlayEdgeOrigin -> NonEmpty label -> OverlayArrangementObstruction leftLabel rightLabel) + -> OverlayEdgeOrigin + -> label + -> Set label + -> Set label + -> Either (OverlayError leftLabel rightLabel) (Maybe (label, label)) +resolveTransition sideConflict origin outside labelsOnLeft labelsOnRight + | Set.null labelsOnLeft && Set.null labelsOnRight = Right Nothing + | otherwise = + Just + <$> ((,) + <$> resolveSide sideConflict origin outside labelsOnLeft + <*> resolveSide sideConflict origin outside labelsOnRight) +{-# INLINE resolveTransition #-} + +transitionIsIdentity :: Eq label => Maybe (label, label) -> Bool +transitionIsIdentity Nothing = True +transitionIsIdentity (Just (leftLabel, rightLabel)) = leftLabel == rightLabel + +resolveSide + :: (OverlayEdgeOrigin -> NonEmpty label -> OverlayArrangementObstruction leftLabel rightLabel) + -> OverlayEdgeOrigin + -> label + -> Set label + -> Either (OverlayError leftLabel rightLabel) label +resolveSide sideConflict origin outside labels = + case Set.toAscList labels of + [] -> Right outside + [label] -> Right label + firstLabel : remaining -> + Left + ( OverlayArrangementInvalid + (sideConflict origin (firstLabel :| remaining)) + ) +{-# INLINE resolveSide #-} + +exactPointIds + :: V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint DraftVertexId +exactPointIds edges = + Map.fromAscList + ( zip + (Set.toAscList (V.foldl' collect Set.empty edges)) + (map DraftId [0 ..]) + ) + where + collect + :: Set ExactPoint + -> AtomicEdge leftLabel rightLabel + -> Set ExactPoint + collect points edge = Set.insert (atomicEdgeFrom edge) (Set.insert (atomicEdgeTo edge) points) + +vertexOrigins + :: V.Vector (SourceBoundary leftLabel rightLabel) + -> V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint OverlayVertexOrigin +vertexOrigins sources atomicEdges = + Map.map finalizeOrigin + ( V.foldl' + addAtomicOrigin + (V.foldl' addSourceEndpoints Map.empty sources) + atomicEdges + ) + +emptyOrigin :: OriginAccumulation +emptyOrigin = OriginAccumulation Set.empty Set.empty Set.empty Set.empty + +mergeOrigin :: OriginAccumulation -> OriginAccumulation -> OriginAccumulation +mergeOrigin left right = + OriginAccumulation + { accumulatedLeftVertices = accumulatedLeftVertices left <> accumulatedLeftVertices right + , accumulatedRightVertices = accumulatedRightVertices left <> accumulatedRightVertices right + , accumulatedLeftEdges = accumulatedLeftEdges left <> accumulatedLeftEdges right + , accumulatedRightEdges = accumulatedRightEdges left <> accumulatedRightEdges right + } + +addSourceEndpoints + :: Map ExactPoint OriginAccumulation + -> SourceBoundary leftLabel rightLabel + -> Map ExactPoint OriginAccumulation +addSourceEndpoints origins source = + case source of + LeftSourceBoundary segment _ fromReference toReference _ -> + let (from, to) = exactSegmentEndpoints segment + in insertOrigin to (emptyOrigin{accumulatedLeftVertices = Set.singleton toReference}) + (insertOrigin from (emptyOrigin{accumulatedLeftVertices = Set.singleton fromReference}) origins) + RightSourceBoundary segment _ fromReference toReference _ -> + let (from, to) = exactSegmentEndpoints segment + in insertOrigin to (emptyOrigin{accumulatedRightVertices = Set.singleton toReference}) + (insertOrigin from (emptyOrigin{accumulatedRightVertices = Set.singleton fromReference}) origins) + +addAtomicOrigin + :: Map ExactPoint OriginAccumulation + -> AtomicEdge leftLabel rightLabel + -> Map ExactPoint OriginAccumulation +addAtomicOrigin origins edge = + let origin = atomicEdgeOrigin edge + accumulation = + emptyOrigin + { accumulatedLeftEdges = Set.fromList (overlayEdgeLeftSources origin) + , accumulatedRightEdges = Set.fromList (overlayEdgeRightSources origin) + } + in insertOrigin (atomicEdgeTo edge) accumulation + (insertOrigin (atomicEdgeFrom edge) accumulation origins) + +insertOrigin + :: ExactPoint + -> OriginAccumulation + -> Map ExactPoint OriginAccumulation + -> Map ExactPoint OriginAccumulation +insertOrigin = Map.insertWith mergeOrigin + +finalizeOrigin :: OriginAccumulation -> OverlayVertexOrigin +finalizeOrigin accumulated = + OverlayVertexOrigin + { overlayOriginLeftVertices = Set.toAscList (accumulatedLeftVertices accumulated) + , overlayOriginRightVertices = Set.toAscList (accumulatedRightVertices accumulated) + , overlayOriginLeftEdges = Set.toAscList (accumulatedLeftEdges accumulated) + , overlayOriginRightEdges = Set.toAscList (accumulatedRightEdges accumulated) + } + +exactArrangementDraft + :: V.Vector (SourceBoundary leftLabel rightLabel) + -> ExactSegmentEventPlan + -> V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint DraftVertexId + -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation + -> Either (OverlayError leftLabel rightLabel) ExactArrangementDraft +exactArrangementDraft sources sourcePlan atomicEdges pointIds atomicRelations = do + draftSegmentsMap <- + Map.fromList + <$> traverse + (\(segmentIndex, edge) -> do + from <- requireDraftVertex pointIds (atomicEdgeFrom edge) + to <- requireDraftVertex pointIds (atomicEdgeTo edge) + pure (DraftId segmentIndex, (from, to))) + (V.toList (V.indexed atomicEdges)) + memberships <- + Map.fromList + <$> traverse + (\(sourceIndex, source) -> do + values <- + traverse + (\point -> do + parameter <- exactSourceParameter source point + vertex <- requireDraftVertex pointIds point + pure (parameter, vertex)) + (exactSegmentSplitPoints sourcePlan (ExactSweepSegmentId sourceIndex)) + pure (DraftId sourceIndex, values)) + (V.toList (V.indexed sources)) + neighborhoods <- buildDraftNeighborhoods atomicEdges pointIds + let incidences = + [ DraftIncidence + (DraftId leftIndex) + (DraftId rightIndex) + relation + | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <- + Map.toAscList atomicRelations + ] + pure + ExactArrangementDraft + { draftVertices = Map.fromList [(vertexId, point) | (point, vertexId) <- Map.toAscList pointIds] + , draftSegments = draftSegmentsMap + , draftSourceMemberships = memberships + , draftIncidences = incidences + , draftNeighborhoods = neighborhoods + } + +requireDraftVertex + :: Map ExactPoint DraftVertexId + -> ExactPoint + -> Either (OverlayError leftLabel rightLabel) DraftVertexId +requireDraftVertex pointIds point = + case Map.lookup point pointIds of + Just vertex -> Right vertex + Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point)) + +exactSourceParameter + :: SourceBoundary leftLabel rightLabel + -> ExactPoint + -> Either (OverlayError leftLabel rightLabel) ExactRational +exactSourceParameter source point = + let (from, to) = exactSegmentEndpoints (sourceExactSegment source) + (fromX, fromY) = exactPointCoordinates from + (toX, toY) = exactPointCoordinates to + (pointX, pointY) = exactPointCoordinates point + (numerator, denominator) = + if exactRationalIsZero (toX - fromX) + then (pointY - fromY, toY - fromY) + else (pointX - fromX, toX - fromX) + in first OverlayExactArithmetic (exactDivide numerator denominator) + +buildDraftNeighborhoods + :: V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint DraftVertexId + -> Either (OverlayError leftLabel rightLabel) [DraftNeighborhood] +buildDraftNeighborhoods edges pointIds = + traverse neighborhood (Map.toAscList pointIds) + where + neighborhood (centerPoint, centerId) = do + let neighbors = Map.findWithDefault Set.empty centerPoint adjacency + orderedPoints <- + case NonEmpty.nonEmpty (sortBy (compareAround centerPoint) (Set.toList neighbors)) of + Just points -> Right points + Nothing -> Left (OverlayArrangementInvalid (OverlayRotationDegenerate centerPoint)) + orderedIds <- traverse (requireDraftVertex pointIds) orderedPoints + pure (DraftNeighborhood centerId orderedIds) + adjacency = + V.foldl' + (\graph edge -> + Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton (atomicEdgeFrom edge)) + (Map.insertWith Set.union (atomicEdgeFrom edge) (Set.singleton (atomicEdgeTo edge)) graph)) + Map.empty + edges + +compareAround :: ExactPoint -> ExactPoint -> ExactPoint -> Ordering +compareAround center left right = + case + compareExactVectorAngle + (exactVectorFromPoints center left) + (exactVectorFromPoints center right) of + EQ -> compare left right + ordering -> ordering + +-- | Normalization splits every source at every exact event and coalesces +-- duplicate intervals. Distinct atomics can therefore meet only at a stored +-- endpoint; their entire relation section is the endpoint-incidence index. +atomicEndpointRelations + :: V.Vector (AtomicEdge leftLabel rightLabel) + -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation +atomicEndpointRelations edges = + Map.fromList + [ ( orderedPair + (ExactSweepSegmentId leftIndex) + (ExactSweepSegmentId rightIndex) + , SegmentsShareEndpoint + ) + | incident <- Map.elems incidenceByPoint + , (leftIndex, rightIndex) <- unorderedPairs (Set.toAscList incident) + ] + where + incidenceByPoint = + V.ifoldl' + (\incidence index edge -> + Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton index) + ( Map.insertWith Set.union + (atomicEdgeFrom edge) + (Set.singleton index) + incidence + )) + Map.empty + edges +projectedExactPoints + :: LocalEmbeddingCertificate + -> Map DraftVertexId ExactPoint +projectedExactPoints = + Map.map exactPointFromQueryPoint . certificateRoundedVertices + +projectedAtomicSegments + :: V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint DraftVertexId + -> Map DraftVertexId ExactPoint + -> Either (OverlayError leftLabel rightLabel) (V.Vector ExactSegment) +projectedAtomicSegments edges pointIds projected = + V.imapM project edges + where + project segmentIndex edge = do + fromId <- requireDraftVertex pointIds (atomicEdgeFrom edge) + toId <- requireDraftVertex pointIds (atomicEdgeTo edge) + from <- requireProjected fromId + to <- requireProjected toId + first + (\_ -> + OverlayEmbeddingRefused + ( ProjectedSegmentCollapsed + (DraftId segmentIndex) + fromId + toId + :| [] + )) + (exactSegment from to) + requireProjected vertex = + case Map.lookup vertex projected of + Just point -> Right point + Nothing -> + Left + ( OverlayEmbeddingRefused + (DraftReferenceMissing (DraftVertexReference vertex) :| []) + ) + +dischargeGlobalRelations + :: Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation + -> ExactSegmentEventPlan + -> Either (OverlayError leftLabel rightLabel) () +dischargeGlobalRelations exactRelations projectedPlan = + case NonEmpty.nonEmpty obstructions of + Nothing -> Right () + Just failures -> Left (OverlayEmbeddingRefused failures) + where + projectedRelations = exactSegmentRelationMap projectedPlan + keys = Set.toAscList (Map.keysSet exactRelations <> Map.keysSet projectedRelations) + obstructions = concatMap compareRelation keys + compareRelation key@(ExactSweepSegmentId leftId, ExactSweepSegmentId rightId) = + case (Map.lookup key exactRelations, Map.lookup key projectedRelations) of + (Nothing, Just projected) -> + [GlobalRelationAdded (DraftId leftId) (DraftId rightId) projected] + (Just exact, Nothing) -> + [GlobalRelationRemoved (DraftId leftId) (DraftId rightId) exact] + (Just exact, Just projected) + | exact /= projected -> + [GlobalRelationChanged (DraftId leftId) (DraftId rightId) exact projected] + _ -> [] + +overlayVertexSeeds + :: Map ExactPoint DraftVertexId + -> Map ExactPoint OverlayVertexOrigin + -> LocalEmbeddingCertificate + -> Either (OverlayError leftLabel rightLabel) (V.Vector OverlayVertexSeed) +overlayVertexSeeds pointIds origins certificate = + V.fromList + <$> traverse + (\(point, vertexId) -> do + embedded <- + case Map.lookup vertexId (certificateRoundedVertices certificate) of + Just value -> Right value + Nothing -> + Left + ( OverlayEmbeddingRefused + (DraftReferenceMissing (DraftVertexReference vertexId) :| []) + ) + origin <- + case Map.lookup point origins of + Just value -> Right value + Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point)) + pure (OverlayVertexSeed point (queryPointValue embedded) origin)) + (Map.toAscList pointIds) + +atomicConstraints + :: Map ExactPoint DraftVertexId + -> V.Vector (AtomicEdge leftLabel rightLabel) + -> Either (OverlayError leftLabel rightLabel) (V.Vector (Int, Int)) +atomicConstraints pointIds = + V.mapM + (\edge -> do + DraftId from <- requireDraftVertex pointIds (atomicEdgeFrom edge) + DraftId to <- requireDraftVertex pointIds (atomicEdgeTo edge) + pure (from, to)) + + +canonicalEdgeKey :: ExactPoint -> ExactPoint -> ExactEdgeKey +canonicalEdgeKey = orderedPair + +atomicEdgeFrom :: AtomicEdge leftLabel rightLabel -> ExactPoint +atomicEdgeFrom = fst . exactSegmentEndpoints . atomicEdgeSegment + +atomicEdgeTo :: AtomicEdge leftLabel rightLabel -> ExactPoint +atomicEdgeTo = snd . exactSegmentEndpoints . atomicEdgeSegment + +atomicKey :: AtomicEdge leftLabel rightLabel -> ExactEdgeKey +atomicKey edge = (atomicEdgeFrom edge, atomicEdgeTo edge) diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Bounded certification of local binary64 embedding obligations for a +-- declared exact arrangement draft. +module Moonlight.Triangulation.Internal.Overlay.Embedding + ( DraftId (..) + , DraftVertexId + , DraftSegmentId + , DraftSourceId + , DraftIncidence (..) + , DraftNeighborhood (..) + , ExactArrangementDraft (..) + , DraftReference (..) + , OverlayEmbeddingObstruction (..) + , EmbeddingObligation (..) + , EmbeddingResidual + , residualUndischargedObligations + , milestoneOneResidual + , LocalEmbeddingCertificate (..) + , certifyLocalEmbedding + ) where + +import Control.DeepSeq (NFData) +import Data.List (sort, tails) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import Moonlight.Triangulation.Exact + ( ExactPoint + , SegmentRelation + , exactPointToEmbeddingCandidate + , exactSegmentRelation + ) +import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) +import Moonlight.Triangulation.Internal.ExactRational (ExactRational) +import qualified Moonlight.Triangulation.Math as Math + ( orient2d + , segmentRelation + ) +import Moonlight.Triangulation.Types + ( Point (..) + , PointValidationError + , QueryPoint + , queryPointValue + ) + +-- | Phantom draft kind; three incompatible identifiers share one scalar owner. +data DraftEntity = DraftVertexEntity | DraftSegmentEntity | DraftSourceEntity + +newtype DraftId (entity :: DraftEntity) = DraftId Int + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +type DraftVertexId = DraftId 'DraftVertexEntity +type DraftSegmentId = DraftId 'DraftSegmentEntity +type DraftSourceId = DraftId 'DraftSourceEntity + +-- | A declared relation between two atomic draft segments. +data DraftIncidence = DraftIncidence + { -- | First declared atomic segment. + draftIncidenceFirstSegment :: !DraftSegmentId + , -- | Second declared atomic segment. + draftIncidenceSecondSegment :: !DraftSegmentId + , -- | Relation declared to hold in both exact and rounded geometry. + draftIncidenceRelation :: !SegmentRelation + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | One exact vertex and the cyclic neighbor order declared around it. +data DraftNeighborhood = DraftNeighborhood + { -- | Center of the declared local rotation. + draftNeighborhoodCenter :: !DraftVertexId + , -- | Neighbors in cyclic rotation order. + draftNeighborhoodNeighbors :: !(NonEmpty DraftVertexId) + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | A hand-built exact arrangement draft. It contains only declared local +-- structure; no arrangement or global crossing search is derived here. +data ExactArrangementDraft = ExactArrangementDraft + { -- | Exact coordinates keyed by draft-local vertex identity. + draftVertices :: !(Map DraftVertexId ExactPoint) + , -- | Atomic segment endpoint identities. + draftSegments :: !(Map DraftSegmentId (DraftVertexId, DraftVertexId)) + , -- | Exact split parameters and vertices in source-segment order. + draftSourceMemberships :: !(Map DraftSourceId [(ExactRational, DraftVertexId)]) + , -- | Segment relations declared to remain invariant under projection. + draftIncidences :: ![DraftIncidence] + , -- | Cyclic local rotations declared to retain their neighbor order. + draftNeighborhoods :: ![DraftNeighborhood] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The typed identity of a missing draft reference. +data DraftReference + = DraftVertexReference !DraftVertexId + | DraftSegmentReference !DraftSegmentId + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | A witness that prevents local embedding certification. +data OverlayEmbeddingObstruction + = DraftReferenceMissing !DraftReference + | VertexProjectionRefused !DraftVertexId !PointValidationError + | RoundedVerticesCollide !DraftVertexId !DraftVertexId !Point + | SplitOrderNotPreserved !DraftSourceId !DraftVertexId !DraftVertexId + | IncidenceRelationChanged + !DraftSegmentId + !DraftSegmentId + !SegmentRelation + !SegmentRelation + !SegmentRelation + | NeighborhoodRotationChanged + !DraftVertexId + !(NonEmpty DraftVertexId) + !(NonEmpty DraftVertexId) + | GlobalRelationAdded + !DraftSegmentId + !DraftSegmentId + !SegmentRelation + | GlobalRelationRemoved + !DraftSegmentId + !DraftSegmentId + !SegmentRelation + | GlobalRelationChanged + !DraftSegmentId + !DraftSegmentId + !SegmentRelation + !SegmentRelation + | ProjectedSegmentCollapsed + !DraftSegmentId + !DraftVertexId + !DraftVertexId + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | An embedding obligation not discharged by the bounded local certifier. +data EmbeddingObligation + = GlobalNoNewCrossing + deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | A nonempty collection of obligations deferred to a later owner. +newtype EmbeddingResidual = EmbeddingResidual (NonEmpty EmbeddingObligation) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Read the obligations that remain explicitly undischarged. +residualUndischargedObligations + :: EmbeddingResidual + -> NonEmpty EmbeddingObligation +residualUndischargedObligations (EmbeddingResidual obligations) = obligations + +-- | The Milestone 1 residual: the arrangement sweep has not yet proved global +-- absence of new crossings. +milestoneOneResidual :: EmbeddingResidual +milestoneOneResidual = EmbeddingResidual (GlobalNoNewCrossing :| []) + +-- | A certificate for exactly four local obligations on a declared draft: +-- vertex distinctness, source split order, declared incidences, and local +-- neighborhood rotation. Global absence of new crossings is unproved until +-- the Milestone 2 arrangement sweep supplies the complete obligation set. +data LocalEmbeddingCertificate = LocalEmbeddingCertificate + { -- | Number of rounded vertex-pair distinctness checks discharged. + certificateRoundedVertexDistinctnessCount :: !Int + , -- | Number of adjacent source split-order checks discharged. + certificateSplitOrderPreservationCount :: !Int + , -- | Number of declared incidence checks discharged. + certificateIncidenceRelationPreservationCount :: !Int + , -- | Number of neighborhood rotation entries certified. + certificateNeighborhoodRotationPreservationCount :: !Int + , -- | The admitted candidate projection certified by the four local obligations. + certificateRoundedVertices :: !(Map DraftVertexId QueryPoint) + , -- | The necessarily nonempty global obligation residual. + certificateResidual :: !EmbeddingResidual + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Certify the four bounded local embedding obligations, collecting every +-- witness within each obligation and preserving obligation order. +certifyLocalEmbedding + :: ExactArrangementDraft + -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate +certifyLocalEmbedding draft = + case NonEmpty.nonEmpty (structuralObstructions draft) of + Just obstructions -> Left obstructions + Nothing -> + case projectVertices (draftVertices draft) of + Invalid obstructions -> Left obstructions + Valid projectedVertices -> + certifyProjectedDraft draft projectedVertices + +data Validation value + = Invalid !(NonEmpty OverlayEmbeddingObstruction) + | Valid value + +instance Functor Validation where + fmap _ (Invalid obstructions) = Invalid obstructions + fmap transform (Valid value) = Valid (transform value) + +instance Applicative Validation where + pure = Valid + Invalid left <*> Invalid right = Invalid (left <> right) + Invalid obstructions <*> Valid _ = Invalid obstructions + Valid _ <*> Invalid obstructions = Invalid obstructions + Valid transform <*> Valid value = Valid (transform value) + +invalid :: OverlayEmbeddingObstruction -> Validation value +invalid obstruction = Invalid (obstruction :| []) + +data ProjectedVertex = ProjectedVertex + { projectedExactPoint :: !ExactPoint + , projectedRoundedPoint :: !QueryPoint + } + +data ResolvedSegment = ResolvedSegment + { resolvedSegmentId :: !DraftSegmentId + , resolvedSegmentFrom :: !ResolvedVertex + , resolvedSegmentTo :: !ResolvedVertex + } + +data ResolvedVertex = ResolvedVertex + { resolvedVertexId :: !DraftVertexId + , resolvedProjectedVertex :: !ProjectedVertex + } + +data ResolvedMembership = ResolvedMembership + { resolvedMembershipParameter :: !ExactRational + , resolvedMembershipVertex :: !ResolvedVertex + } + +structuralObstructions + :: ExactArrangementDraft + -> [OverlayEmbeddingObstruction] +structuralObstructions draft = + segmentEndpointObstructions + <> sourceMembershipObstructions + <> incidenceObstructions + <> neighborhoodObstructions + where + vertices = draftVertices draft + segments = draftSegments draft + missingVertex vertexId = + [ DraftReferenceMissing (DraftVertexReference vertexId) + | Map.notMember vertexId vertices + ] + missingSegment segmentId = + [ DraftReferenceMissing (DraftSegmentReference segmentId) + | Map.notMember segmentId segments + ] + segmentEndpointObstructions = + concatMap + (\(_, (from, to)) -> missingVertex from <> missingVertex to) + (Map.toAscList segments) + sourceMembershipObstructions = + concatMap + (concatMap (missingVertex . snd) . snd) + (Map.toAscList (draftSourceMemberships draft)) + incidenceObstructions = + concatMap + ( \incidence -> + missingSegment (draftIncidenceFirstSegment incidence) + <> missingSegment (draftIncidenceSecondSegment incidence) + ) + (draftIncidences draft) + neighborhoodObstructions = + concatMap + ( \neighborhood -> + missingVertex (draftNeighborhoodCenter neighborhood) + <> concatMap missingVertex (draftNeighborhoodNeighbors neighborhood) + ) + (draftNeighborhoods draft) + +projectVertices + :: Map DraftVertexId ExactPoint + -> Validation (Map DraftVertexId ProjectedVertex) +projectVertices = + Map.traverseWithKey + ( \vertexId point -> + case exactPointToEmbeddingCandidate point of + Left projectionError -> + invalid (VertexProjectionRefused vertexId projectionError) + Right roundedPoint -> Valid (ProjectedVertex point roundedPoint) + ) + +certifyProjectedDraft + :: ExactArrangementDraft + -> Map DraftVertexId ProjectedVertex + -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate +certifyProjectedDraft draft projectedVertices = + case resolvedFailures of + Left obstruction -> Left (obstruction :| []) + Right localFailures -> + case NonEmpty.nonEmpty (collisionFailures <> localFailures) of + Just obstructions -> Left obstructions + Nothing -> + Right + LocalEmbeddingCertificate + { certificateRoundedVertexDistinctnessCount = distinctnessCount + , certificateSplitOrderPreservationCount = splitOrderCount + , certificateIncidenceRelationPreservationCount = incidenceCount + , certificateNeighborhoodRotationPreservationCount = neighborhoodCount + , certificateRoundedVertices = Map.map projectedRoundedPoint projectedVertices + , certificateResidual = milestoneOneResidual + } + where + collisionFailures = roundedVertexCollisionObstructions projectedVertices + resolvedFailures = do + splitFailures <- traverse (uncurry resolveSource) (Map.toAscList (draftSourceMemberships draft)) + incidenceFailures <- traverse resolveIncidence (draftIncidences draft) + neighborhoodFailures <- traverse resolveNeighborhood (draftNeighborhoods draft) + pure (concat splitFailures <> concat incidenceFailures <> concat neighborhoodFailures) + resolveVertex vertexId = + case Map.lookup vertexId projectedVertices of + Nothing -> Left (DraftReferenceMissing (DraftVertexReference vertexId)) + Just projectedVertex -> Right (ResolvedVertex vertexId projectedVertex) + resolveSegment segmentId = + case Map.lookup segmentId (draftSegments draft) of + Nothing -> Left (DraftReferenceMissing (DraftSegmentReference segmentId)) + Just (from, to) -> + ResolvedSegment segmentId + <$> resolveVertex from + <*> resolveVertex to + resolveSource sourceId memberships = + splitOrderObstructions sourceId + <$> traverse + ( \(parameter, vertexId) -> + ResolvedMembership parameter <$> resolveVertex vertexId + ) + memberships + resolveIncidence incidence = + incidenceRelationObstructions + (draftIncidenceRelation incidence) + <$> resolveSegment (draftIncidenceFirstSegment incidence) + <*> resolveSegment (draftIncidenceSecondSegment incidence) + resolveNeighborhood neighborhood = + neighborhoodRotationObstructions + <$> resolveVertex (draftNeighborhoodCenter neighborhood) + <*> traverse resolveVertex (draftNeighborhoodNeighbors neighborhood) + vertexCount = Map.size projectedVertices + distinctnessCount = vertexCount * (vertexCount - 1) `quot` 2 + splitOrderCount = + sum + ( map + (max 0 . subtract 1 . length) + (Map.elems (draftSourceMemberships draft)) + ) + incidenceCount = length (draftIncidences draft) + neighborhoodCount = + sum + ( map + (length . draftNeighborhoodNeighbors) + (draftNeighborhoods draft) + ) + +roundedVertexCollisionObstructions + :: Map DraftVertexId ProjectedVertex + -> [OverlayEmbeddingObstruction] +roundedVertexCollisionObstructions projectedVertices = + [ RoundedVerticesCollide leftId rightId (queryPointValue roundedPoint) + | (roundedPoint, vertexIds) <- Map.toAscList verticesByRoundedPoint + , (leftId : remainingIds) <- tails (sort vertexIds) + , rightId <- remainingIds + ] + where + verticesByRoundedPoint = + Map.fromListWith (<>) + [ (projectedRoundedPoint projectedVertex, [vertexId]) + | (vertexId, projectedVertex) <- Map.toAscList projectedVertices + ] + +splitOrderObstructions + :: DraftSourceId + -> [ResolvedMembership] + -> [OverlayEmbeddingObstruction] +splitOrderObstructions sourceId memberships = + case memberships of + firstMembership : secondMembership : remainingMemberships -> + let finalMembership = + List.foldl' (\_ current -> current) secondMembership remainingMemberships + sourceFrom = roundedMembershipPoint firstMembership + sourceTo = roundedMembershipPoint finalMembership + in [ SplitOrderNotPreserved + sourceId + (resolvedVertexId (resolvedMembershipVertex leftMembership)) + (resolvedVertexId (resolvedMembershipVertex rightMembership)) + | (leftMembership, rightMembership) <- + zip + memberships + (drop 1 memberships) + , compare + (resolvedMembershipParameter leftMembership) + (resolvedMembershipParameter rightMembership) + /= roundedOrderAlong + sourceFrom + sourceTo + (roundedMembershipPoint leftMembership) + (roundedMembershipPoint rightMembership) + ] + _ -> [] + +roundedMembershipPoint :: ResolvedMembership -> Point +roundedMembershipPoint = + queryPointValue + . projectedRoundedPoint + . resolvedProjectedVertex + . resolvedMembershipVertex + +roundedOrderAlong :: Point -> Point -> Point -> Point -> Ordering +roundedOrderAlong + (Point sourceFromX sourceFromY) + (Point sourceToX sourceToY) + (Point leftX leftY) + (Point rightX rightY) = + let directionX = sourceToX - sourceFromX + directionY = sourceToY - sourceFromY + in if abs directionX >= abs directionY + then + if directionX >= 0 + then compare leftX rightX + else compare rightX leftX + else + if directionY >= 0 + then compare leftY rightY + else compare rightY leftY + +incidenceRelationObstructions + :: SegmentRelation + -> ResolvedSegment + -> ResolvedSegment + -> [OverlayEmbeddingObstruction] +incidenceRelationObstructions declaredRelation firstSegment secondSegment = + [ IncidenceRelationChanged + (resolvedSegmentId firstSegment) + (resolvedSegmentId secondSegment) + declaredRelation + exactRelation + roundedRelation + | exactRelation /= declaredRelation || roundedRelation /= declaredRelation + ] + where + exactRelation = + relationFor exactSegmentRelation projectedExactPoint firstSegment secondSegment + roundedRelation = + relationFor Math.segmentRelation roundedProjectedPoint firstSegment secondSegment + +relationFor + :: (point -> point -> point -> point -> SegmentRelation) + -> (ProjectedVertex -> point) + -> ResolvedSegment + -> ResolvedSegment + -> SegmentRelation +relationFor relation project firstSegment secondSegment = + relation + (project (resolvedProjectedVertex (resolvedSegmentFrom firstSegment))) + (project (resolvedProjectedVertex (resolvedSegmentTo firstSegment))) + (project (resolvedProjectedVertex (resolvedSegmentFrom secondSegment))) + (project (resolvedProjectedVertex (resolvedSegmentTo secondSegment))) + +neighborhoodRotationObstructions + :: ResolvedVertex + -> NonEmpty ResolvedVertex + -> [OverlayEmbeddingObstruction] +neighborhoodRotationObstructions center exactRotation = + [ NeighborhoodRotationChanged + (resolvedVertexId center) + exactVertexRotation + roundedVertexRotation + | roundedRotationDescents > 1 + ] + where + exactVertexRotation = fmap resolvedVertexId exactRotation + roundedRotationDescents = + List.foldl' + (\descentCount (left, right) -> + descentCount + + if compareRoundedAround center left right == GT + then 1 + else 0) + (0 :: Int) + (cyclePairs exactRotation) + roundedVertexRotation = + fmap resolvedVertexId + (NonEmpty.sortBy (compareRoundedAround center) exactRotation) + +compareRoundedAround + :: ResolvedVertex + -> ResolvedVertex + -> ResolvedVertex + -> Ordering +compareRoundedAround center left right = + compareRoundedAroundWith + ( Math.orient2d + (roundedVertexPoint center) + (roundedVertexPoint left) + (roundedVertexPoint right) + ) + center + left + right + +compareRoundedAroundWith + :: Ordering + -> ResolvedVertex + -> ResolvedVertex + -> ResolvedVertex + -> Ordering +compareRoundedAroundWith roundedOrientation center left right = + case compare (roundedVectorHalf center left) (roundedVectorHalf center right) of + EQ -> + case roundedOrientation of + GT -> LT + LT -> GT + EQ -> compare (roundedVertexPoint left) (roundedVertexPoint right) + ordering -> ordering + +roundedVectorHalf :: ResolvedVertex -> ResolvedVertex -> Bool +roundedVectorHalf center neighbor = + let Point centerX centerY = roundedVertexPoint center + Point neighborX neighborY = roundedVertexPoint neighbor + deltaX = neighborX - centerX + deltaY = neighborY - centerY + in deltaY < 0 || (deltaY == 0 && deltaX < 0) + +roundedVertexPoint :: ResolvedVertex -> Point +roundedVertexPoint = roundedProjectedPoint . resolvedProjectedVertex + +roundedProjectedPoint :: ProjectedVertex -> Point +roundedProjectedPoint = queryPointValue . projectedRoundedPoint diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs new file mode 100644 --- /dev/null +++ b/src-public/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-public/Moonlight/Triangulation/Internal/Overlay/Types.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Types.hs new file mode 100644 --- /dev/null +++ b/src-public/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-public/Moonlight/Triangulation/Minkowski.hs b/src-public/Moonlight/Triangulation/Minkowski.hs new file mode 100644 --- /dev/null +++ b/src-public/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-public/Moonlight/Triangulation/Overlay.hs b/src-public/Moonlight/Triangulation/Overlay.hs new file mode 100644 --- /dev/null +++ b/src-public/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/test/examples/Main.hs b/test/examples/Main.hs new file mode 100644 --- /dev/null +++ b/test/examples/Main.hs @@ -0,0 +1,53 @@ +module Main (main) where + +import Moonlight.Triangulation.Example.AlphaBoundary +import Moonlight.Triangulation.Example.ConstrainedRegion +import Moonlight.Triangulation.Example.PlanarRegion +import Moonlight.Triangulation.Example.SetAlgebra +import System.Exit (die) + +main :: IO () +main = do + assertRight "set algebra" (6, 2) siteCounts + assertRight "constrained region" (11, 8) constrainedRegionCounts + assertRight "alpha boundary" [BoundaryShape 4 0] alphaBoundaryShapes + assertRight + "planar region" + expectedPlanarSummary + planarExample + putStrLn "examples: ok" + +expectedPlanarSummary :: PlanarExampleSummary +expectedPlanarSummary = + PlanarExampleSummary + { booleanValuations = + [ CellValuationSummary 1 (ExactFractionSummary 20 1) + , CellValuationSummary 1 (ExactFractionSummary 4 1) + , CellValuationSummary 1 (ExactFractionSummary 12 1) + ] + , morphologyAreas = + fmap + (`ExactFractionSummary` 1) + [48, 36, 4, 16, 16] + } + +assertRight + :: (Eq value, Show value, Show obstruction) + => String + -> value + -> Either obstruction value + -> IO () +assertRight label expected result = + case result of + Left obstruction -> + die (label <> " failed with " <> show obstruction) + Right actual + | actual == expected -> pure () + | otherwise -> + die + ( label + <> " expected " + <> show expected + <> ", got " + <> show actual + ) diff --git a/test/ffi/Main.hs b/test/ffi/Main.hs --- a/test/ffi/Main.hs +++ b/test/ffi/Main.hs @@ -3,6 +3,8 @@ import Control.Exception (bracket) import Control.Monad (unless) import Data.Int (Int64) +import Data.List (nub) +import Data.Maybe (mapMaybe) import Data.Word (Word32) import Foreign.C.String (peekCString) import Foreign.C.Types (CDouble (..), CSize (..), CUInt) @@ -10,7 +12,10 @@ import Foreign.Marshal.Array (allocaArray, peekArray, withArray) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable (sizeOf), peek) -import Moonlight.Triangulation.Foreign.ABI +import Moonlight.Triangulation.Foreign.Contract +import Moonlight.Triangulation.Foreign.Mesh +import Moonlight.Triangulation.Foreign.Morphology +import Moonlight.Triangulation.Foreign.Region type MeshPointer = Ptr CMesh type RegionPointer = Ptr CRegion @@ -27,6 +32,7 @@ main :: IO () main = do + testStableWireContract unless (sizeOf obstructionLayoutWitness == 320) $ fail "C obstruction layout changed" unless (sizeOf receiptLayoutWitness == 72) $ @@ -37,6 +43,7 @@ requireMeshCount "left triangle count" meshTriangleCount left 2 testDenseCopies left testImmutableBatch left + testBatchAdmission left testSiteSetAlgebra left right testExactRegionSurface testTypedCoordinateRefusal @@ -45,6 +52,47 @@ testRegionLayoutRefusal putStrLn "ffi: ok" +testStableWireContract :: IO () +testStableWireContract = do + unless + ( allDistinct (fmap abiStatusId allAbiStatuses) + && allDistinct (fmap obstructionCodeId allObstructionCodes) + && allDistinct (fmap coordinateErrorCodeId allCoordinateErrorCodes) + && allDistinct (fmap regionLocationCodeId allRegionLocationCodes) + && allDistinct (fmap minkowskiOperationCodeId allMinkowskiOperationCodes) + && allDistinct wireSymbols + && allDistinct (fmap abiFunctionSymbol allAbiFunctions) + && allDistinct (mapMaybe haskellImplementationName allAbiFunctions) + && allDistinct (fmap abiHandleSymbol allAbiHandles <> fmap abiStructSymbol allAbiStructs) + ) + (fail "FFI contract contains duplicate identifiers") + unless + ( abiVersion == 2 + && fmap abiStatusId allAbiStatuses == [0, 1, 2, 3, 4, 5] + && obstructionCodeId ObstructionInvalidCoordinate == 1 + && obstructionCodeId ObstructionNullPointer == 100 + && obstructionCodeId ObstructionCountOverflow == 101 + && obstructionCodeId ObstructionBufferTooSmall == 102 + && obstructionCodeId ObstructionRegionLayoutInvalid == 200 + && fmap regionLocationCodeId allRegionLocationCodes == [0, 1, 2] + && fmap minkowskiOperationCodeId allMinkowskiOperationCodes == [0, 1, 2, 3] + ) + (fail "stable FFI wire identifiers changed") + where + wireSymbols = + fmap abiStatusSymbol allAbiStatuses + <> fmap obstructionCodeSymbol allObstructionCodes + <> fmap coordinateErrorCodeSymbol allCoordinateErrorCodes + <> fmap regionLocationCodeSymbol allRegionLocationCodes + <> fmap minkowskiOperationCodeSymbol allMinkowskiOperationCodes + haskellImplementationName function = + case abiFunctionImplementation function of + AbiFunctionRuntime -> Nothing + AbiFunctionHaskell _ name -> Just name + +allDistinct :: Eq value => [value] -> Bool +allDistinct values = length values == length (nub values) + obstructionLayoutWitness :: CObstruction obstructionLayoutWitness = CObstruction 0 0 0 0 0 0 0 0 0 "" @@ -61,23 +109,23 @@ alloca $ \written -> alloca $ \obstruction -> do status <- meshCopyVerticesF64 mesh nullPtr 0 written obstruction - requireStatus "undersized vertex copy" 3 status obstruction + requireStatus "undersized vertex copy" AbiStatusBufferTooSmall status obstruction required <- peek written refusal <- peek obstruction - unless (required == 4 && obstructionCode refusal == 102) $ + unless (required == 4 && obstructionCode refusal == obstructionCodeId ObstructionBufferTooSmall) $ fail "undersized vertex copy lost its required-capacity witness" allocaArray 8 $ \coordinates -> alloca $ \written -> alloca $ \obstruction -> do status <- meshCopyVerticesF64 mesh coordinates 4 written obstruction - requireStatus "vertex copy" 0 status obstruction + requireStatus "vertex copy" AbiStatusOk status obstruction values <- peekArray 8 coordinates unless (length values == 8) (fail "vertex copy wrote the wrong coordinate extent") allocaArray 6 $ \triangles -> alloca $ \written -> alloca $ \obstruction -> do status <- meshCopyTrianglesU32 mesh triangles 2 written obstruction - requireStatus "triangle copy" 0 status obstruction + requireStatus "triangle copy" AbiStatusOk status obstruction indices <- peekArray 6 triangles :: IO [Word32] unless (all (< 4) indices) (fail "triangle copy produced an out-of-range vertex") @@ -91,6 +139,43 @@ requireMeshCount "original after batch" meshVertexCount original 4 requireMeshCount "revised after batch" meshVertexCount revised 6) +testBatchAdmission :: MeshPointer -> IO () +testBatchAdmission original = do + testLateInvalidPoint + testCanonicalZeros + where + testLateInvalidPoint = + withPointArray [(1, 1), (3, 1), (0 / 0, 1)] $ \coordinates -> + alloca $ \output -> + alloca $ \obstruction -> do + status <- meshInsertManyF64 original coordinates 3 output obstruction + requireStatus "late invalid batch point" AbiStatusGeometryObstruction status obstruction + refusal <- peek obstruction + unless + ( obstructionCode refusal == obstructionCodeId ObstructionInvalidCoordinate + && obstructionCoordinateError refusal == coordinateErrorCodeId CoordinateErrorNaN + && obstructionInputIndex refusal == 2 + ) + (fail "late invalid batch point lost its raw input-index obstruction") + requireMeshCount "original after refused batch" meshVertexCount original 4 + testCanonicalZeros = + let negativeZero = -0.0 :: Double + in withPointArray [(negativeZero, 1), (1, negativeZero)] $ \coordinates -> + bracket + (produceHandle "canonical-zero batch" (meshInsertManyF64 original coordinates 2)) + meshFree + (\revised -> do + requireMeshCount "canonical-zero batch vertex count" meshVertexCount revised 6 + allocaArray 12 $ \copiedCoordinates -> + alloca $ \_written -> + alloca $ \obstruction -> do + status <- meshCopyVerticesF64 revised copiedCoordinates 6 _written obstruction + requireStatus "canonical-zero batch copy" AbiStatusOk status obstruction + copied <- map unCDouble <$> peekArray 12 copiedCoordinates + unless (not (any isNegativeZero copied)) $ + fail "canonical-zero batch published a negative zero") + unCDouble (CDouble value) = value + testSiteSetAlgebra :: MeshPointer -> MeshPointer -> IO () testSiteSetAlgebra left right = do test "site union" meshSiteUnion 6 @@ -121,7 +206,7 @@ alloca $ \pointCountOutput -> alloca $ \obstruction -> do status <- regionCounts region componentCountOutput loopCountOutput pointCountOutput obstruction - requireStatus "region counts" 0 status obstruction + requireStatus "region counts" AbiStatusOk status obstruction componentCount <- fromIntegral <$> peek componentCountOutput loopCount <- fromIntegral <$> peek loopCountOutput pointCount <- fromIntegral <$> peek pointCountOutput @@ -140,7 +225,7 @@ componentOffsets (fromIntegral (componentCount + 1)) obstruction - requireStatus "region copy" 0 copyStatus obstruction + requireStatus "region copy" AbiStatusOk copyStatus obstruction copiedLoopOffsets <- peekArray (loopCount + 1) loopOffsets copiedComponentOffsets <- peekArray (componentCount + 1) componentOffsets unless (copiedLoopOffsets == [0, 4] && copiedComponentOffsets == [0, 1]) $ @@ -166,9 +251,9 @@ 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 + requireRegionLocation "interior location" region (1, 1) RegionLocationInterior + requireRegionLocation "boundary location" region (0, 1) RegionLocationBoundary + requireRegionLocation "exterior location" region (3, 1) RegionLocationExterior testRegionMorphology :: RegionPointer -> RegionPointer -> IO () testRegionMorphology left right = @@ -177,18 +262,18 @@ (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") + test "Minkowski sum" regionMinkowskiSum left right MinkowskiOperationAddition "16/1" + test "offset" regionOffset element left MinkowskiOperationAddition "9/1" + test "inset" regionInset element left MinkowskiOperationErosion "1/1" + test "open" regionOpen element left MinkowskiOperationOpening "4/1" + test "close" regionClose element left MinkowskiOperationClosing "4/1") where test :: String -> (first -> RegionPointer -> Ptr RegionPointer -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt) -> first -> RegionPointer - -> Word32 + -> MinkowskiOperationCode -> String -> IO () test label operation firstInput secondInput expectedOperation expectedArea = @@ -197,7 +282,7 @@ (regionFree . fst) (\(result, receipt) -> do measurement <- measureRegion result - unless (receiptOperation receipt == expectedOperation && measuredArea measurement == expectedArea) $ + unless (receiptOperation receipt == minkowskiOperationCodeId expectedOperation && measuredArea measurement == expectedArea) $ fail (label <> " lost its result or morphology receipt")) measureRegion :: RegionPointer -> IO RegionMeasurement @@ -218,7 +303,7 @@ perimeterLowerOutput perimeterUpperOutput obstruction - requireStatus "region measure" 0 status obstruction + requireStatus "region measure" AbiStatusOk status obstruction measuredEuler <- peek eulerOutput measuredArea <- peekCString areaOutput CDouble measuredPerimeterLower <- peek perimeterLowerOutput @@ -230,14 +315,14 @@ unless (lower <= expected && expected <= upper) $ fail (label <> " perimeter certificate excludes the exact perimeter") -requireRegionLocation :: String -> RegionPointer -> Point -> CUInt -> IO () +requireRegionLocation :: String -> RegionPointer -> Point -> RegionLocationCode -> IO () requireRegionLocation label region (x, y) expected = alloca $ \output -> alloca $ \obstruction -> do status <- regionLocatePointF64 region (CDouble x) (CDouble y) output obstruction - requireStatus label 0 status obstruction + requireStatus label AbiStatusOk status obstruction observed <- peek output - unless (observed == expected) $ + unless (observed == fromIntegral (regionLocationCodeId expected)) $ fail (label <> " returned location " <> show observed) buildRegion :: [ComponentInput] -> IO RegionPointer @@ -269,9 +354,9 @@ alloca $ \output -> alloca $ \obstruction -> do status <- regionCreateF64 coordinates 4 loopCounts 1 componentCounts 1 output obstruction - requireStatus "invalid region layout" 4 status obstruction + requireStatus "invalid region layout" AbiStatusGeometryObstruction status obstruction refusal <- peek obstruction - unless (obstructionCode refusal == 200) $ + unless (obstructionCode refusal == obstructionCodeId ObstructionRegionLayoutInvalid) $ fail "invalid region layout lost its typed obstruction" testTypedCoordinateRefusal :: IO () @@ -280,9 +365,13 @@ alloca $ \output -> alloca $ \obstruction -> do status <- delaunayF64 coordinates 3 output obstruction - requireStatus "invalid coordinate" 4 status obstruction + requireStatus "invalid coordinate" AbiStatusGeometryObstruction status obstruction refusal <- peek obstruction - unless (obstructionCode refusal == 1 && obstructionCoordinateError refusal == 1 && obstructionInputIndex refusal == 1) $ + unless + ( obstructionCode refusal == obstructionCodeId ObstructionInvalidCoordinate + && obstructionCoordinateError refusal == coordinateErrorCodeId CoordinateErrorNaN + && obstructionInputIndex refusal == 1 + ) $ fail "invalid coordinate lost its typed witness" testNullPointerRefusal :: IO () @@ -290,9 +379,9 @@ alloca $ \count -> alloca $ \obstruction -> do status <- meshVertexCount nullPtr count obstruction - requireStatus "null mesh" 1 status obstruction + requireStatus "null mesh" AbiStatusNullPointer status obstruction refusal <- peek obstruction - unless (obstructionCode refusal == 100) $ + unless (obstructionCode refusal == obstructionCodeId ObstructionNullPointer) $ fail "null pointer refusal lost its typed witness" testCoordinateCountOverflow :: IO () @@ -301,9 +390,9 @@ alloca $ \obstruction -> do let overflowingCount = fromIntegral (maxBound `div` 2 + 1 :: Int) status <- delaunayF64 nullPtr overflowingCount output obstruction - requireStatus "coordinate count overflow" 2 status obstruction + requireStatus "coordinate count overflow" AbiStatusCountOverflow status obstruction refusal <- peek obstruction - unless (obstructionCode refusal == 101) $ + unless (obstructionCode refusal == obstructionCodeId ObstructionCountOverflow) $ fail "coordinate count overflow lost its typed witness" requireMeshCount :: String -> (MeshPointer -> Ptr CSize -> Ptr CObstruction -> IO CUInt) -> MeshPointer -> Int -> IO () @@ -311,7 +400,7 @@ alloca $ \count -> alloca $ \obstruction -> do status <- operation mesh count obstruction - requireStatus label 0 status obstruction + requireStatus label AbiStatusOk status obstruction observed <- peek count unless (observed == fromIntegral expected) $ fail (label <> " produced " <> show observed <> ", expected " <> show expected) @@ -321,7 +410,7 @@ alloca $ \output -> alloca $ \obstruction -> do status <- operation output obstruction - requireStatus label 0 status obstruction + requireStatus label AbiStatusOk status obstruction handle <- peek output unless (handle /= nullPtr) (fail (label <> " returned a null handle")) pure handle @@ -335,15 +424,15 @@ alloca $ \receiptOutput -> alloca $ \obstruction -> do status <- operation output receiptOutput obstruction - requireStatus label 0 status obstruction + requireStatus label AbiStatusOk status obstruction handle <- peek output receipt <- peek receiptOutput unless (handle /= nullPtr) (fail (label <> " returned a null region")) pure (handle, receipt) -requireStatus :: String -> CUInt -> CUInt -> Ptr CObstruction -> IO () +requireStatus :: String -> AbiStatus -> CUInt -> Ptr CObstruction -> IO () requireStatus label expected observed obstruction - | observed == expected = pure () + | observed == fromIntegral (abiStatusId expected) = pure () | otherwise = do refusal <- peek obstruction fail (label <> " returned status " <> show observed <> ": " <> obstructionMessage refusal) 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 @@ -58,6 +58,7 @@ ( CoordinateError (..) , Point (..) , PointValidationError (..) + , queryPointValue ) import Support (assertEqual, integerPoint, requireRight) import System.Mem (performGC) @@ -233,7 +234,7 @@ requireRight "finite point candidate projection" (exactPointToEmbeddingCandidate exactFinite) - assertEqual "finite exact point roundtrip" finitePoint projectedFinite + assertEqual "finite exact point roundtrip" finitePoint (queryPointValue projectedFinite) assertEqual "coincident exact segment endpoints" (Left (ExactSegmentEndpointsCoincide exactFinite)) @@ -301,6 +302,15 @@ ] } certificate <- requireRight "ordinary local embedding" (certifyLocalEmbedding draft) + westEmbedding <- + maybe + (fail "ordinary local embedding omitted its admitted west candidate") + pure + (Map.lookup west (certificateRoundedVertices certificate)) + assertEqual + "ordinary certificate retains admitted projection" + (Point (-1) 0) + (queryPointValue westEmbedding) assertEqual "ordinary distinctness obligations" 10 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 @@ -1668,6 +1668,27 @@ testConstrainedDelaunay = do base <- requirePointBuild "CDT base" [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 1 1, Point 3 3, Point 1 3, Point 3 1] let cdt0 = fromDelaunay (buildTriangulation base) + invalidPoint = Point (0 / 0) 0 + case addConstraintEdge cdt0 invalidPoint (Point 4 0) of + Left (CdtBuildError (InvalidCoordinate Nothing _ CoordinateNaN)) -> pure () + outcome -> fail ("invalid first constraint endpoint was admitted: " <> either show (const "success") outcome) + case addConstraintEdge cdt0 (Point 0 0) invalidPoint of + Left (CdtBuildError (InvalidCoordinate Nothing _ CoordinateNaN)) -> pure () + outcome -> fail ("invalid second constraint endpoint was admitted: " <> either show (const "success") outcome) + assertEqual + "invalid endpoint refusal leaves the immutable source unpublished" + (8, 0) + (numVertices cdt0, numConstraints cdt0) + partlyResident <- + requireRight + "one resident one new constraint endpoint" + (addConstraintEdge cdt0 (Point 0 0) (Point 2 2)) + let partlyResidentCdt = constraintRecoveryTriangulation partlyResident + assertEqual + "one resident endpoint reserves only the missing site" + (numVertices cdt0 + 1) + (numVertices partlyResidentCdt) + assertCdtValid "one resident one new constraint endpoint" partlyResidentCdt diagonalBatch <- requireRight "constraint recovery" @@ -2370,22 +2391,28 @@ (numInnerFaces right) (V.length (constrainedSeamRightFaceEvidence seam)) forM_ (V.toList (constrainedSeamRightFaceEvidence seam)) $ \evidence -> - assertEqual - "right face witness names the exact target triangle" - (faceKeyOf right (constrainedSeamSourceFace evidence)) - (faceKeyOf joined (constrainedSeamTargetFace evidence)) + let sourceFaceKey = faceKeyOf right (constrainedSeamSourceFace evidence) + targetFaceKey = faceKeyOf joined (constrainedSeamTargetFace evidence) + evidenceFaceKey = + [ constrainedSeamFaceFirstPoint evidence + , constrainedSeamFaceSecondPoint evidence + , constrainedSeamFaceThirdPoint evidence + ] + in do + assertEqual + "right face witness names the exact target triangle" + sourceFaceKey + targetFaceKey + assertEqual + "right face witness carries the exact target triangle" + targetFaceKey + evidenceFaceKey when (V.null (constrainedSeamJoinFaces seam)) $ fail "separated seam did not identify any new corridor face" assertEqual "copied source constraints require no corridor recovery" 0 (constraintBatchRequests (constrainedSeamConstraintStats seam)) - unless - ( all - ((== Nothing) . constrainedSeamConstraintRecovery) - (V.toList (constrainedSeamRightConstraintEvidence seam)) - ) $ - fail "separated seam recovered a constraint already represented by its copied source" let seamPublication = constrainedSeamPublicationStats seam assertEqual "separated seam does not enumerate resident unboxed base pages" @@ -2471,7 +2498,7 @@ locallyRefined <- requireRight "seam refinement preserves cached hull frontier" - (refineWithinDomain (const ()) localParameters allJoinedFaces Set.empty joined) + (refineWithinDomain (const ()) localParameters allJoinedFaces joined) let refinedJoined = refinedTriangulation (refinementDomainResult locallyRefined) unless (refinementComplete (refinementDomainResult locallyRefined)) $ fail "seam refinement fixture did not drain its local worklist" @@ -2861,7 +2888,7 @@ refined <- requireRight "encroached hull local refinement" - (refineWithinDomain (const ()) parameters permitted Set.empty source) + (refineWithinDomain (const ()) parameters permitted source) let refinementResult = refinementDomainResult refined result = refinedTriangulation refinementResult unless (refinementComplete refinementResult) $ @@ -3098,29 +3125,57 @@ crossingParameters = calmParameters{refineMaxArea = Just 1} unless (not (Set.null permitted) && not (null protected) && not (Set.null interface)) $ fail "checked local refinement fixture did not form a nontrivial cover" - case refineWithinDomain id calmParameters{refineMaxAdditionalVertices = Nothing} permitted interface source of + case refineWithinDomain id calmParameters{refineMaxAdditionalVertices = Nothing} permitted source of Left RefinementDomainRequiresFiniteVertexBudget -> pure () outcome -> fail ("checked local refinement accepted an unbounded local budget: " <> either show (const "success") outcome) - case Set.minView interface of - Nothing -> fail "checked local refinement fixture has no interface" - Just (_, incomplete) -> - case refineWithinDomain id calmParameters permitted incomplete source of - Left (RefinementDomainInterfaceMissing _) -> pure () - Left obstruction -> fail ("checked local refinement returned the wrong incomplete-interface obstruction: " <> show obstruction) - Right _ -> fail "checked local refinement accepted an incomplete interface" refined <- requireRight "checked local refinement" - (refineWithinDomain id calmParameters permitted interface source) + (refineWithinDomain id calmParameters permitted source) let localResult = refinementDomainResult refined target = refinedTriangulation localResult targetProtectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint target) (faceVertices target face)))) protected receipt = refinementDomainReceipt refined + finalPermitted = Set.fromList (V.toList (refinementFinalPermittedFaces receipt)) + expectedFinalInterfaceIncidence = + V.fromList + [ if Set.member sourceForwardFace permitted + then (edge, sourceBackwardFace, targetForwardFace) + else (edge, sourceForwardFace, targetBackwardFace) + | edge <- Set.toAscList interface + , let (forward, backward) = directedPair edge + sourceForwardFace = incidentFace source forward + sourceBackwardFace = incidentFace source backward + targetForwardFace = incidentFace target forward + targetBackwardFace = incidentFace target backward + ] + actualFinalInterfaceIncidence = refinementFinalInterfaceIncidence receipt assertEqual "checked local protected face restriction" protectedSignatures targetProtectedSignatures assertEqual "checked local final permitted lineage" permitted - (Set.fromList (V.toList (refinementFinalPermittedFaces receipt))) + finalPermitted + assertEqual + "checked local final interface incidence" + expectedFinalInterfaceIncidence + actualFinalInterfaceIncidence + assertEqual + "checked local final interface edge set" + interface + (Set.fromList [edge | (edge, _, _) <- V.toList actualFinalInterfaceIncidence]) + traverse_ + (\(edge, protectedFace, finalPermittedFace) -> + unless + ( Set.notMember protectedFace permitted + && Set.member finalPermittedFace finalPermitted + ) + ( fail + ( "checked local final interface incidence misclassified " + <> show (edge, protectedFace, finalPermittedFace) + ) + ) + ) + actualFinalInterfaceIncidence assertEqual "checked local protected visit receipt" V.empty (refinementVisitedProtectedFaces receipt) assertEqual "checked local boundary crossing receipt" 0 (refinementAttemptedBoundaryCrossings receipt) let closureStats = refinementValidationClosureStats receipt @@ -3139,17 +3194,17 @@ (constraintSegments source) (constraintSegments target) assertValid "checked local refinement" target - case refineWithinDomain id crossingParameters permitted interface source of + case refineWithinDomain id crossingParameters permitted source of Left (RefinementDomainWouldCrossInterface _ _) -> pure () Left obstruction -> fail ("checked local refinement returned the wrong crossing obstruction: " <> show obstruction) Right _ -> fail "checked local refinement silently crossed its immutable interface" - case refineWithinDomain id calmParameters{refinePreserveConvexHull = False} permitted interface source of + case refineWithinDomain id calmParameters{refinePreserveConvexHull = False} permitted source of Left RefinementDomainRequiresConvexHullPreservation -> pure () outcome -> fail ("checked local refinement accepted hull mutation: " <> either show (const "success") outcome) - case refineWithinDomain id calmParameters{refineKeepConstraintEdges = False} permitted interface source of + case refineWithinDomain id calmParameters{refineKeepConstraintEdges = False} permitted source of Left RefinementDomainRequiresConstraintPreservation -> pure () outcome -> fail ("checked local refinement accepted constraint mutation: " <> either show (const "success") outcome) - case refineWithinDomain id calmParameters{refineExcludeOuterFaces = True} permitted interface source of + case refineWithinDomain id calmParameters{refineExcludeOuterFaces = True} permitted source of Left RefinementDomainForbidsOuterFaceExclusion -> pure () outcome -> fail ("checked local refinement accepted outer-face exclusion: " <> either show (const "success") outcome) wholeRefined <- @@ -3159,7 +3214,6 @@ id crossingParameters (Set.fromList (innerFaces source)) - Set.empty source ) let wholeResult = refinementDomainResult wholeRefined @@ -3224,7 +3278,7 @@ partial <- requireRight "maximum-edge budget-limited refinement" - (refineWithinDomain id parameters allPermitted Set.empty source) + (refineWithinDomain id parameters allPermitted source) let partialResult = refinementDomainResult partial partialTarget = refinedTriangulation partialResult partialReceipt = refinementDomainReceipt partial @@ -3241,7 +3295,6 @@ id parameters{refineMaxAdditionalVertices = Just 8} resumedPermitted - Set.empty partialTarget ) let resumedResult = refinementDomainResult resumed @@ -3287,7 +3340,6 @@ id parameters{refineMaxAdditionalVertices = Just 8} permitted - interface source case blocked of Left (RefinementOversizedEdge face edge actual bound) @@ -3354,7 +3406,7 @@ "deterministic crossing source has one interface edge" 1 (Set.size interface) - case refineWithinDomain id parameters permitted interface source of + case refineWithinDomain id parameters permitted source of Left (RefinementDomainWouldCrossInterface _ _) -> pure () Left obstruction -> fail @@ -3385,7 +3437,7 @@ (V.singleton (2, 6)) ) let source = buildTriangulation built - (sourcePermitted, sourceInterface) = leftSection source + sourcePermitted = leftSection source fullParameters = defaultRefinementParameters { refineMaxAdditionalVertices = Just 20 @@ -3396,7 +3448,7 @@ fullRefinement <- requireRight "full boundary-adjacent refinement" - (refineWithinDomain id fullParameters sourcePermitted sourceInterface source) + (refineWithinDomain id fullParameters sourcePermitted source) let fullResult = refinementDomainResult fullRefinement fullTarget = refinedTriangulation fullResult fullReceipt = refinementDomainReceipt fullRefinement @@ -3421,7 +3473,7 @@ progressFirstRefinement <- requireRight "first bounded boundary-adjacent refinement" - (refineWithinDomain id progressParameters sourcePermitted sourceInterface source) + (refineWithinDomain id progressParameters sourcePermitted source) let progressFirstResult = refinementDomainResult progressFirstRefinement progressFirstTarget = refinedTriangulation progressFirstResult progressFirstReceipt = refinementDomainReceipt progressFirstRefinement @@ -3438,7 +3490,6 @@ id progressParameters progressPermitted - sourceInterface progressFirstTarget ) let progressSecondResult = refinementDomainResult progressSecondRefinement @@ -3458,26 +3509,13 @@ where leftSection :: Triangulation mode vertex directed undirected face - -> (Set.Set FaceId, Set.Set UndirectedEdgeId) + -> Set.Set FaceId leftSection triangulation = - let permitted = - Set.fromList - [ face - | face <- innerFaces triangulation - , faceCentroidX triangulation face < 8 - ] - interface = - Set.fromList - [ edge - | edge <- undirectedEdges triangulation - , let (forward, backward) = directedPair edge - forwardFace = incidentFace triangulation forward - backwardFace = incidentFace triangulation backward - , forwardFace /= outerFace - , backwardFace /= outerFace - , Set.member forwardFace permitted /= Set.member backwardFace permitted - ] - in (permitted, interface) + Set.fromList + [ face + | face <- innerFaces triangulation + , faceCentroidX triangulation face < 8 + ] faceCentroidX :: Triangulation mode vertex directed undirected face -> FaceId