diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +`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. + +## 0.1.0.0 + +* Initial release with an honest binary64 geometry surface, dense DCEL + projections, coverage-guided boundary targets, and PVP-bounded dependencies. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Fable, Blue Rose + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,397 @@ +# moonlight-triangulation + +> Part of **Moonlight**, the sheaf-theoretic computation layer beneath +> [Melusine](https://bluerose.blue) and Pale Meridian. + +`moonlight-triangulation` carries Delaunay and constrained Delaunay +triangulations as a lawful finite-set algebra under canonical observation: a +mesh represents its site set, a join returns a valid Delaunay representative, +and the result is a triangulation again — so the operations close, compose, and +fold. Operations return typed obstructions where the finite arena cannot +represent a result. + +Delaunay triangulation, constrained Delaunay (CDT), the Voronoi dual, +natural-neighbour interpolation, Ruppert refinement, walk point location, +convex hull, exact Shewchuk predicates, incremental insertion and removal, +versioned binary serialization. + +## 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. | + +### Choose the operation + +| What you need | Use | Do not substitute | +| --- | --- | --- | +| 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 | `joinSeparatedConstrainedWith` | 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 and interface edges; a guessed boundary is a typed refusal, not a hint. | +| Require construction-independent numbering | `canonicalize` at the observation boundary | Do not canonicalize every intermediate value; it is intentionally global work. | + +`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. | + +On the retained one-million-site / five-thousand-site witnesses, raw +`difference` fell from 4.997 s to 0.169 s. Near-full `intersection` now takes +0.116 s from a cold persistent-index context and 0.100 s after that cache has +already been forced, down from 3.475 s before indexed descent. A +five-thousand-site `symmetricDifference` result fell from 4.022 s / 2.19 GB +allocated to 0.121 s / 244 MB. Exact `siteRelation` now takes 0.083 s cold and +0.115 s after forcing the persistent cache, down from 3.417 s before indexed +descent. Singleton insertion remains 5.326 ms from 48.037 ms. These are raw +publication measurements; paying for `canonicalize` afterward is deliberately +reported separately rather than smuggled into the local-operation claim. + +```haskell +union :: JoinSemilattice annotation + => Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) + +unions :: JoinSemilattice annotation + => [Triangulation 'Unconstrained annotation () () ()] + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) + +siteRelation + :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace + -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace + -> SiteRelation + +intersection + :: Triangulation 'Unconstrained () () () () + -> Triangulation 'Unconstrained () () () () + -> Either BuildError (Triangulation 'Unconstrained () () () ()) + +intersectionWith + :: (leftAnnotation -> rightAnnotation -> annotation) + -> Triangulation 'Unconstrained leftAnnotation () () () + -> Triangulation 'Unconstrained rightAnnotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) + +difference + :: Triangulation 'Unconstrained leftAnnotation () () () + -> Triangulation 'Unconstrained rightAnnotation () () () + -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ()) + +symmetricDifference + :: Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +``` + +## 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. +* Coordinates are binary64 throughout the public surface. `vertexPoints` and + `innerFaceVertexTriples` project dense vectors directly from the authoritative + DCEL; callers do not reconstruct a sibling mesh DTO. +* One half-edge mesh underneath. `Cdt` is a mode index on it, not a second + structure. + +## 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 Double ()) + build coords = case delaunay unitElementDefaults (fromList [Point x y | (x, y) <- coords]) of + Left err -> fail (show err) + Right result -> pure (mapVertices (const ()) (buildTriangulation result)) + 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. + +Payloads annotate geometry through `mapVertices`; the input `Point`s arrive as +their own vertex payload. The example deliberately erases them with +`mapVertices (const ())`, while 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, the mesh itself carries one. Every Delaunay face +has a circumradius: faces inside a sampled region sit near the local pitch, +while faces spanning concavities and voids circumscribe them and blow up. +Keeping the faces below a threshold derived from the data — a multiple of the +median circumradius, so no authored constant — is the alpha-complex, and its +boundary falls out as the edges with exactly one kept side. Those edges are +already edges of the triangulation, so feeding them to `constrainedDelaunay` +as index pairs recovers without conflicts, and the parity machinery above +takes over from there. + +```haskell +module Main where + +import Data.List (sort, span) +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 <- case delaunay unitElementDefaults (fromList [Point x y | (x, y) <- pts]) of + Left err -> fail (show err) + Right result -> pure (mapVertices (const () :: Point -> ()) (buildTriangulation result)) + let corners f = + [(x, y) | v <- faceVertices mesh f, let Point x y = vertexPoint mesh v] + circumradius (ax, ay) (bx, by) (cx, cy) = + let dab = sqrt ((bx - ax) ** 2 + (by - ay) ** 2) + dbc = sqrt ((cx - bx) ** 2 + (cy - by) ** 2) + dca = sqrt ((ax - cx) ** 2 + (ay - cy) ** 2) + area2 = abs ((bx - ax) * (cy - ay) - (cx - ax) * (by - ay)) + in if area2 == 0 then 1 / 0 else dab * dbc * dca / (2 * area2) + radii = + [ (k, circumradius p q s) + | k <- [0 .. numFaces mesh - 1] + , [p, q, s] <- [corners (FaceId (fromIntegral k))] + ] + sorted = sort (map snd radii) + medianR = case drop (length sorted `div` 2) sorted of + m : _ -> m + [] -> 1 + kept = [FaceId (fromIntegral k) | (k, r) <- radii, r <= 1.35 * medianR] + norm (p, q) = if p <= q then (p, q) else (q, p) + edges f = case corners f of + [p, q, s] -> [norm (p, q), norm (q, s), norm (s, p)] + _ -> [] + runs xs = case xs of + [] -> [] + x : rest -> let (same, more) = span (== x) rest in (x, 1 + length same) : runs more + boundary = [e | (e, n) <- runs (sort (concatMap edges kept)), n == 1] + print (length radii, length kept, length boundary) +``` + +Output: `(110,96,48)` — 110 finite faces, 96 in the alpha-complex, and the +derived boundary is exactly the 48 ring edges: both loops recovered from the +point set alone. 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. + +## 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. + +```haskell +insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8 +``` + +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, and determinants are evaluated over +`Integer`. The floating approximation is trusted only inside Shewchuk's error +bounds — `(3 + 16u)u` for orientation, `(10 + 96u)u` for incircle — and falls +through to the 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`, `Interop`, `Dcel`, `Payload`, `JoinSemilattice`, `Handles` with its iterator family, `PointLocation`, `Validation`, `FloodFillIterator`, `IntersectionIterator`. Adds `primitive` and `vector-algorithms` over `core`. | +| `build` | Everything that *constructs*: `BulkLoad`, `Session`, `Removal`, typed `SetAlgebra`, `Cdt` constraint recovery, and `Refinement`. Adds no external dependency over `core` and `dcel`. | +| `parallel` | Concurrent evaluation of the pure union plan. Adds `async` at this effect boundary rather than below it. | +| `serialize` | `Serialization` — the versioned binary envelope, and the only sublibrary that costs you `binary`, `bytestring`, and `transformers`. Deliberately absent from the facade. | +| `dual` | The Voronoi dual and what reads it: `Voronoi`, `Voronoi.Handles`, `Interpolation` (natural-neighbour), `HintGenerator` (Delaunay hierarchy hints). Sits over `core`, `dcel` and `build`. | +| facade (`moonlight-triangulation`) | `Moonlight.Triangulation` alone: the equational surface, one export list stating a theory. It re-exports selected names from `core`/`dcel`/`build`/`dual` — and *not* `serialize`. A caller who wants more than the theory names the machine-room module directly. | + +## Surface + +* `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 and barrier fill. +* `.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. diff --git a/bench/aggregate/Main.hs b/bench/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/bench/aggregate/Main.hs @@ -0,0 +1,17 @@ +-- | Every benchmark slice, in one process. This imports the slice modules +-- rather than restating their contents, so a benchmark added to a slice appears +-- here without anyone remembering to add it. An aggregate that duplicates its +-- slices instead of importing them drifts the moment a slice grows. +module Main (main) where + +import qualified Moonlight.Triangulation.BuildBench as BuildBench +import qualified Moonlight.Triangulation.DcelBench as DcelBench +import qualified Moonlight.Triangulation.DualBench as DualBench +import qualified Moonlight.Triangulation.JoinBench as JoinBench + +main :: IO () +main = do + BuildBench.benchmarks + DcelBench.benchmarks + DualBench.benchmarks + JoinBench.benchmarks diff --git a/bench/build/Main.hs b/bench/build/Main.hs new file mode 100644 --- /dev/null +++ b/bench/build/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.BuildBench as BuildBench + +main :: IO () +main = BuildBench.benchmarks diff --git a/bench/build/Moonlight/Triangulation/BuildBench.hs b/bench/build/Moonlight/Triangulation/BuildBench.hs new file mode 100644 --- /dev/null +++ b/bench/build/Moonlight/Triangulation/BuildBench.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | The construction side: circle-sweep bulk load against the arrival-order +-- session kernel, persistent single insertion, constraint recovery and Ruppert +-- refinement. Each reports the library's own work counters alongside the time, +-- because the claim being measured is about work done rather than seconds. +module Moonlight.Triangulation.BuildBench (benchmarks) where + +import BenchSupport (randomPoints, requireRight, timedValue) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad (forM_, unless) +import Data.List (sort) +import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad (empty, insert) +import Moonlight.Triangulation.Cdt (constraintBatchStats, recoverConstraints) +-- The facade withholds this constructor. The benchmark indexes the builder's +-- own input mapping, so every handle it forges is one the builder issued, and +-- it owns that obligation explicitly by naming the module that grants it. +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (VertexId)) +import Moonlight.Triangulation.Session (insertVertex, withLocalSession, withSession) +import Moonlight.Triangulation.Types + ( InsertionResult (insertionTriangulation) + , refinementStats + , statEdgeFlips + , statLocationWalkSteps + , statRefinementFaceChecks + , statRefinementQueuePops + ) + +benchmarks :: IO () +benchmarks = do + putStrLn "moonlight-triangulation native construction benchmark" + forM_ [1_000, 10_000, 50_000] benchmarkConstruction + forM_ [1_000, 10_000, 50_000, 100_000, 1_000_000] benchmarkSingletonInsertionCrossover + benchmarkConstraints 8_000 800 + benchmarkRefinement 2_500 + +benchmarkConstruction :: Int -> IO () +benchmarkConstruction count = do + let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count) + swept <- timedValue ("circle-sweep/" <> show count) $ requireRight (delaunay unitElementDefaults points) + (_, sessioned, _) <- timedValue ("session/" <> show count) $ + requireRight + ( withSession (empty unitElementDefaults) (V.length points) $ + V.mapM_ insertVertex points + ) + evaluate (force (canonicalEdges (buildTriangulation swept) == canonicalEdges sessioned)) >>= \equal -> + if equal then pure () else fail "circle-sweep and session construction disagree" + +benchmarkSingletonInsertionCrossover :: Int -> IO () +benchmarkSingletonInsertionCrossover count = do + let points = V.fromList (randomPoints 0xd1b54a32d192ed03 count) + built <- requireRight (delaunay unitElementDefaults points) + let query = Point 0.000_123_456_7 (-0.000_765_432_1) + base = buildTriangulation built + scheduled <- timedValue ("singleton-scheduled-public-insert/" <> show count) $ requireRight (insert base query) + (_, local, _) <- timedValue ("singleton-local-session-insert/" <> show count) $ + requireRight (withLocalSession base 1 (insertVertex query)) + let scheduledMesh = insertionTriangulation scheduled + unless (null (validateTriangulation scheduledMesh)) $ + fail ("scheduled singleton insertion produced an invalid triangulation at " <> show count <> " sites") + unless (null (validateTriangulation local)) $ + fail ("local singleton insertion produced an invalid triangulation at " <> show count <> " sites") + scheduledCanonical <- requireRight (canonicalize scheduledMesh) + localCanonical <- requireRight (canonicalize local) + equal <- evaluate (force (scheduledCanonical == localCanonical)) + unless equal $ + fail ("scheduled and local singleton insertion disagree semantically at " <> show count <> " sites") + putStrLn ("singleton-insertion-crossover/" <> show count <> "-semantic-witness: ok") + +benchmarkConstraints :: Int -> Int -> IO () +benchmarkConstraints pointCount constraintCount = do + built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x94d049bb133111eb pointCount))) + let cdt = fromDelaunay (buildTriangulation built) + inputMapping = buildInputVertices built + requestIndices = + V.fromList + ( take constraintCount + [ (a, b) + | index <- [0 ..] + , let a = index `mod` pointCount + b = (index * 6151 + pointCount `quot` 2) `mod` pointCount + , a /= b + ] + ) + pairs <- + V.mapM + (\(fromIndex, toIndex) -> + let len = sizeofPrimArray inputMapping + mFrom = if fromIndex >= 0 && fromIndex < len then Just (VertexId (indexPrimArray inputMapping fromIndex)) else Nothing + mTo = if toIndex >= 0 && toIndex < len then Just (VertexId (indexPrimArray inputMapping toIndex)) else Nothing + in case (mFrom, mTo) of + (Just from, Just to) -> pure (from, to) + _ -> fail "constraint benchmark endpoint is out of range" + ) + requestIndices + batch <- timedValue "cdt/recovery" (requireRight (recoverConstraints cdt pairs)) + putStrLn ("cdt/recovery-stats: " <> show (constraintBatchStats batch)) + +-- Ruppert refinement on a constrained square. The Steiner budget is the +-- variable of interest: both the encroachment search and the outer-region +-- classification are per-insertion costs, so their growth shows as a widening +-- gap between the two budgets rather than in either figure alone. +benchmarkRefinement :: Int -> IO () +benchmarkRefinement steinerBudget = do + cdtBuild <- requireRight $ constrainedDelaunay + unitElementDefaults + (V.fromList [Point 0 0, Point 64 0, Point 64 64, Point 0 64, Point 20 20, Point 44 44] :: V.Vector (Point)) + (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (4, 5)]) + let cdt :: ConstrainedDelaunayTriangulation (Point) + cdt = buildTriangulation cdtBuild + parameters :: Int -> RefinementParameters + parameters budget = defaultRefinementParameters + { refineMaxAdditionalVertices = Just budget + , refineMaxArea = Just 0.5 + , refineMaxRadiusEdgeRatio = Just 1.0 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + forM_ [steinerBudget `quot` 4, steinerBudget] $ \budget -> do + refined <- timedValue ("refine/steiner-" <> show budget) (requireRight (refine id (parameters budget) cdt)) + let stats = refinementStats refined + putStrLn ("refine-added/" <> show budget <> ": " <> show (refinementAddedVertices refined)) + putStrLn + ( "refine-work/" + <> show budget + <> ": location-steps=" + <> show (statLocationWalkSteps stats) + <> ", face-checks=" + <> show (statRefinementFaceChecks stats) + <> ", queue-pops=" + <> show (statRefinementQueuePops stats) + <> ", flips=" + <> show (statEdgeFlips stats) + ) + +canonicalEdges :: Triangulation mode vertex directed undirected face -> [(Point, Point)] +canonicalEdges triangulation = + sort + [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge)) + | undirected <- undirectedEdges triangulation + , let edge = normalizedDirected undirected + ] + where + ordered :: Ord value => value -> value -> (value, value) + ordered left right = if left <= right then (left, right) else (right, left) diff --git a/bench/dcel/Main.hs b/bench/dcel/Main.hs new file mode 100644 --- /dev/null +++ b/bench/dcel/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.DcelBench as DcelBench + +main :: IO () +main = DcelBench.benchmarks diff --git a/bench/dcel/Moonlight/Triangulation/DcelBench.hs b/bench/dcel/Moonlight/Triangulation/DcelBench.hs new file mode 100644 --- /dev/null +++ b/bench/dcel/Moonlight/Triangulation/DcelBench.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Read-side traversal over a finished mesh: ordered line intersection and the +-- circle shape query. Construction here is fixture cost, not the subject. +module Moonlight.Triangulation.DcelBench (benchmarks) where + +import BenchSupport (randomPoints, requireRight, timedValue) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.FloodFillIterator (edgesInCircle) +import Moonlight.Triangulation.IntersectionIterator (lineIntersections) + +benchmarks :: IO () +benchmarks = benchmarkQueries 20_000 10_000 + +benchmarkQueries :: Int -> Int -> IO () +benchmarkQueries pointCount queryCount = do + built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0xbf58476d1ce4e5b9 pointCount))) + circleEdges <- requireRight (edgesInCircle (buildTriangulation built) (Point 0 0) 0.25) + queries <- + requireRight + (traverse mkQueryPoint (V.fromList (take (2 * queryCount) (randomPoints 0x632be59bd9b4e019 (2 * queryCount))))) + let triangulation = buildTriangulation built + total = V.ifoldl' (lineCount triangulation queries queryCount) 0 (V.take queryCount queries) + shapeTotal = length circleEdges + _ <- timedValue "line-and-shape-queries" (evaluate (force (total, shapeTotal))) + pure () + where + lineCount + :: DelaunayTriangulation (Point) + -> V.Vector (QueryPoint) + -> Int + -> Int + -> Int + -> QueryPoint + -> Int + lineCount triangulation queries stride !accumulator index from = + accumulator + length (lineIntersections triangulation from (queries V.! (index + stride))) diff --git a/bench/dual/Main.hs b/bench/dual/Main.hs new file mode 100644 --- /dev/null +++ b/bench/dual/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.DualBench as DualBench + +main :: IO () +main = DualBench.benchmarks diff --git a/bench/dual/Moonlight/Triangulation/DualBench.hs b/bench/dual/Moonlight/Triangulation/DualBench.hs new file mode 100644 --- /dev/null +++ b/bench/dual/Moonlight/Triangulation/DualBench.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | The dual side: Delaunay-hierarchy hints against an unhinted walk, and +-- natural-neighbour interpolation over a reused workspace. Both report +-- allocation, because the claim in each case is about work avoided rather than +-- time taken. +module Moonlight.Triangulation.DualBench (benchmarks) where + +import BenchSupport (randomPoints, requireRight, timedValue) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad.ST (stToIO) +import qualified Data.Vector as V +import GHC.Exts (RealWorld) +import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled) +import Moonlight.Triangulation +import Moonlight.Triangulation.HintGenerator + ( HierarchyHint + , buildHierarchyHint + , defaultHierarchyBranchFactor + , hierarchyHint + , hierarchyLevelCount + , hierarchyVertexCount + ) +import Moonlight.Triangulation.Interpolation + ( NaturalNeighborWorkspace + , interpolateNaturalNeighbor + , newNaturalNeighborWorkspace + , workspaceBytes + ) +import System.Mem (performGC) + +benchmarks :: IO () +benchmarks = do + benchmarkHierarchy 20_000 5_000 + benchmarkSibson 10_000 5_000 + +benchmarkHierarchy :: Int -> Int -> IO () +benchmarkHierarchy pointCount queryCount = do + built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x123456789abcdef pointCount))) + queries <- + requireRight + (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0x3141592653589793 queryCount)))) + let triangulation = buildTriangulation built + hierarchy <- requireRight (buildHierarchyHint defaultHierarchyBranchFactor triangulation) + (_, baselineSteps) <- timedValue "nearest/no-hierarchy" (evaluate (force (walkTotal triangulation Nothing queries))) + (_, hierarchySteps) <- timedValue "nearest/delaunay-hierarchy" (evaluate (force (walkHierarchyTotal triangulation hierarchy queries))) + putStrLn ("hierarchy-levels: " <> show (hierarchyLevelCount hierarchy)) + putStrLn ("hierarchy-vertices: " <> show (hierarchyVertexCount hierarchy)) + putStrLn ("nearest-walk-steps/no-hierarchy: " <> show baselineSteps) + putStrLn ("nearest-walk-steps/hierarchy: " <> show hierarchySteps) + where + walkTotal + :: DelaunayTriangulation (Point) + -> Maybe VertexId + -> V.Vector (QueryPoint) + -> (Int, Int) + walkTotal triangulation hint queries = V.foldl' step (0 :: Int, 0 :: Int) queries + where + step (!count, !steps) query = + case nearestNeighbor triangulation hint query of + Nothing -> (count, steps) + Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats) + + walkHierarchyTotal + :: DelaunayTriangulation (Point) + -> HierarchyHint + -> V.Vector (QueryPoint) + -> (Int, Int) + walkHierarchyTotal triangulation hierarchy queries = V.foldl' step (0 :: Int, 0 :: Int) queries + where + step (!count, !steps) query = + let hint = case hierarchyHint hierarchy query of + Just (VertexHint vertex) -> Just vertex + _ -> Nothing + in case nearestNeighbor triangulation hint query of + Nothing -> (count, steps) + Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats) + +benchmarkSibson :: Int -> Int -> IO () +benchmarkSibson pointCount queryCount = do + built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x8cb92baa3f3d8dd7 pointCount))) + queries <- + requireRight + (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0xdb4f0b9175ae2165 queryCount)))) + let triangulation = buildTriangulation built + height vertex = + let Point x y = vertexPoint triangulation vertex + in x * x + 0.5 * y + workspace <- stToIO (newNaturalNeighborWorkspace triangulation) + putStrLn ("sibson-workspace-bytes: " <> show (workspaceBytes workspace)) + statsEnabled <- getRTSStatsEnabled + if statsEnabled then performGC else pure () + before <- if statsEnabled then Just <$> getRTSStats else pure Nothing + _ <- timedValue "sibson/reused-workspace" (queryLoop workspace height queries) + after <- if statsEnabled then Just <$> getRTSStats else pure Nothing + case (before, after) of + (Just left, Just right) -> do + let allocated = allocated_bytes right - allocated_bytes left + perQuery = fromIntegral allocated / fromIntegral queryCount :: Double + putStrLn ("sibson-allocated-bytes-total: " <> show allocated) + putStrLn ("sibson-allocated-bytes/query: " <> show perQuery) + _ -> putStrLn "sibson allocation counters unavailable; run with +RTS -T" + where + queryLoop + :: NaturalNeighborWorkspace RealWorld 'Unconstrained (Point) () () () + -> (VertexId -> Double) + -> V.Vector (QueryPoint) + -> IO Double + queryLoop workspace height queries = go 0 0 + where + !count = V.length queries + go !index !total + | index >= count = evaluate total + | otherwise = do + (value, _) <- stToIO (interpolateNaturalNeighbor height workspace Nothing (queries V.! index)) + go (index + 1) (total + maybe 0 id value) diff --git a/bench/join/Main.hs b/bench/join/Main.hs new file mode 100644 --- /dev/null +++ b/bench/join/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.JoinBench as JoinBench + +main :: IO () +main = JoinBench.benchmarks diff --git a/bench/join/Moonlight/Triangulation/JoinBench.hs b/bench/join/Moonlight/Triangulation/JoinBench.hs new file mode 100644 --- /dev/null +++ b/bench/join/Moonlight/Triangulation/JoinBench.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | What the join costs, and against what. +-- +-- These lanes compare the public union schedules with rebuild, local insertion, +-- and explicit canonical observation. Schedule claims live or die by these +-- measurements rather than by asymptotic theatre. +module Moonlight.Triangulation.JoinBench + ( benchmarks + , publicationBenchmarks + ) where + +import BenchSupport (randomPoints, requireRight, timedValue) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad (foldM, unless) +import Data.List (sort, sortBy) +import Data.Ord (comparing) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.BulkLoad (insertMany) +import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex) +import Moonlight.Triangulation.Internal.Representation + ( Triangulation (triPointIndex, triPointX, triPointY) + ) +import System.Mem (performGC) + +type Mesh = DelaunayTriangulation () +type SiteMesh = DelaunayTriangulation (Point) + +benchmarks :: IO () +benchmarks = do + benchmarkBalanced 20_000 + benchmarkSeparated 20_000 + benchmarkSkew 20_000 200 + benchmarkOverlap 20_000 + benchmarkTournament 20_000 16 + benchmarkSpatialTournament 20_000 16 + benchmarkTournamentScaling 20_000 + benchmarkCanonicalize 20_000 + benchmarkSetAlgebra 20_000 + +publicationBenchmarks :: IO () +publicationBenchmarks = do + benchmarkIndexedSupportContexts 1_000_000 5_000 + benchmarkPersistentSetOperations 1_000_000 5_000 + benchmarkPersistentPublication 5_000_000 5_000 + +benchmarkIndexedSupportContexts :: Int -> Int -> IO () +benchmarkIndexedSupportContexts baseCount deltaCount = do + let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount + retainedSites = drop deltaCount baseSites + benchmarkColdRelationWarmIntersection baseSites retainedSites + performGC + benchmarkColdIntersectionWarmRelation baseSites retainedSites + performGC + +benchmarkColdRelationWarmIntersection :: [Point] -> [Point] -> IO () +benchmarkColdRelationWarmIntersection baseSites retainedSites = do + base <- geometryMesh baseSites + retained <- geometryMesh retainedSites + _ <- evaluate (force (base, retained)) + relation <- timedValue "set-relation-near-full-cold-index" (evaluate (force (siteRelation base retained))) + unless (relation == RightProperSubset) $ + fail "cold indexed relation misclassified the retained operand" + forceExactPointIndex base baseSites + benchmarkIndexedIntersection "set-intersection-near-full-warm-index" base retained + +benchmarkColdIntersectionWarmRelation :: [Point] -> [Point] -> IO () +benchmarkColdIntersectionWarmRelation baseSites retainedSites = do + base <- geometryMesh baseSites + retained <- geometryMesh retainedSites + _ <- evaluate (force (base, retained)) + benchmarkIndexedIntersection "set-intersection-near-full-cold-index" base retained + forceExactPointIndex base baseSites + relation <- timedValue "set-relation-near-full-warm-index" (evaluate (force (siteRelation base retained))) + unless (relation == RightProperSubset) $ + fail "warm indexed relation misclassified the retained operand" + +benchmarkIndexedIntersection :: String -> Mesh -> Mesh -> IO () +benchmarkIndexedIntersection label base retained = do + result <- benchmarkValidatedSetOperation label (intersection base retained) + observedCanonical <- evaluate . force =<< requireRight (canonicalize result) + expectedCanonical <- evaluate . force =<< requireRight (canonicalize retained) + unless (observedCanonical == expectedCanonical) $ + fail (label <> " disagreed with the retained operand") + +forceExactPointIndex :: Mesh -> [Point] -> IO () +forceExactPointIndex triangulation points = + case points of + [] -> fail "cannot warm a point index without a witness" + witness : _ -> + case + lookupPointIndex + (triPointX triangulation) + (triPointY triangulation) + (triPointIndex triangulation) + witness + of + Nothing -> fail "point-index warmup missed its exact witness" + Just vertex -> () <$ evaluate (force vertex) + +-- | Two halves of one point set, joined. +-- +-- The balanced pair rebuilds from its combined site set. The input-order and +-- ranked lanes distinguish ordinary construction from construction whose +-- vertex numbering is already canonical. +benchmarkBalanced :: Int -> IO () +benchmarkBalanced total = do + let sites = randomPoints 0x9e3779b97f4a7c15 total + (left, right) = splitAt (total `div` 2) sites + leftMesh <- geometryMesh left + rightMesh <- geometryMesh right + _ <- evaluate (force (leftMesh, rightMesh)) + _ <- timedValue "join-balanced" (evaluate . force =<< requireRight (union leftMesh rightMesh)) + _ <- timedValue "join-balanced-rebuild-input-order" (evaluate . force =<< geometryMesh sites) + _ <- timedValue "join-balanced-rebuild-ranked-order" (evaluate . force =<< geometryMesh (canonical sites)) + pure () + +-- | Two operands whose sites are separated by a vertical line. +-- +-- This is the stratum a seam merge is defined on, and the number here is the +-- one it has to beat: the reference schedule does not know the operands are +-- separated and rebuilds the union regardless. A linear-time merge wins +-- asymptotically over an @O(n log n)@ rebuild; whether it wins at the sizes +-- anything actually merges at is this measurement and not an argument. +-- +-- Three gap widths, because the seam's work is the cross-edge chain and the +-- deletions it drives, and how far the two clouds stand apart decides how much +-- of each interior the chain disturbs. A distant pair is the easy case — the +-- chain is short and nothing inside either operand dies. An abutting pair is +-- the hard one. +benchmarkSeparated :: Int -> IO () +benchmarkSeparated total = do + let half = total `div` 2 + sites = randomPoints 0xd1b54a32d192ed03 half + extent = 2 * maximum [abs x | Point x _ <- sites] + leftMesh <- geometryMesh sites + _ <- evaluate (force leftMesh) + mapM_ + ( \(name, gap) -> do + let shifted = [Point (x + gap * extent) y | Point x y <- sites] + rightMesh <- geometryMesh shifted + _ <- evaluate (force rightMesh) + _ <- timedValue ("join-separated-" <> name) (evaluate . force =<< requireRight (union leftMesh rightMesh)) + pure () + ) + [("distant" :: String, 8), ("near", 2), ("abutting", 1.02)] + +-- | A large mesh joined with a small one. Rebuilding costs the whole union; +-- inserting the small operand's sites into the large mesh costs only the +-- insertions. This is the ratio that says whether a skewed lane is worth +-- having, and it needs no new algorithm — 'insertMany' is already the +-- one-transaction batch path. +-- +-- Both lanes carry the same vertex payload so the comparison is of the +-- schedules and not of the stores. +benchmarkSkew :: Int -> Int -> IO () +benchmarkSkew large small = do + let bulk = randomPoints 0xbf58476d1ce4e5b9 large + addition = randomPoints 0x94d049bb133111eb small + bulkMesh <- siteMesh bulk + _ <- evaluate (force bulkMesh) + _ <- + timedValue + "join-skew-rebuild" + (evaluate . force =<< siteMesh (canonical (bulk <> addition))) + _ <- + timedValue + "join-skew-insert-many" + ( evaluate . force . buildTriangulation + =<< requireRight (insertMany bulkMesh (V.fromList addition)) + ) + pure () + +benchmarkPersistentPublication :: Int -> Int -> IO () +benchmarkPersistentPublication baseCount extensionCount = do + let baseSites = randomPoints 0x6a09e667f3bcc909 baseCount + extensionSites = + fmap + (\(Point x y) -> Point (1.2 + 0.1 * x) y) + (randomPoints 0xbb67ae8584caa73b extensionCount) + base <- geometryMesh baseSites + extension <- geometryMesh extensionSites + _ <- evaluate (force (base, extension)) + putStrLn ("publication-base-sites: " <> show (numVertices base)) + putStrLn ("publication-base-faces: " <> show (numFaces base)) + putStrLn ("publication-extension-sites: " <> show (numVertices extension)) + putStrLn ("publication-extension-faces: " <> show (numFaces extension)) + joined <- + timedValue + "publication-skew-union" + (evaluate . force =<< requireRight (union base extension)) + case validateTriangulation joined of + [] -> pure () + violations -> fail ("publication-skew-union invalid: " <> show violations) + canonicalResult <- + timedValue + "publication-explicit-canonicalize" + (evaluate . force =<< requireRight (canonicalize joined)) + unless (numVertices canonicalResult == numVertices joined) $ + fail "publication canonicalization changed the site count" + putStrLn ("publication-result-sites: " <> show (numVertices joined)) + putStrLn ("publication-result-faces: " <> show (numFaces joined)) + +benchmarkPersistentSetOperations :: Int -> Int -> IO () +benchmarkPersistentSetOperations baseCount deltaCount = do + let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount + removedSites = take deltaCount baseSites + retainedSites = drop deltaCount baseSites + extensionSites = + fmap + (\(Point x y) -> Point (1.2 + 0.1 * x) y) + (randomPoints 0x629a292a367cd507 deltaCount) + base <- geometryMesh baseSites + removed <- geometryMesh removedSites + retained <- geometryMesh retainedSites + extension <- geometryMesh extensionSites + empty <- requireRight (unions []) + _ <- evaluate (force (base, removed, retained, extension, empty)) + putStrLn ("set-publication-base-sites: " <> show (numVertices base)) + putStrLn ("set-publication-delta-sites: " <> show (numVertices removed)) + _ <- benchmarkValidatedSetOperation "set-publication-difference-right-empty" (difference base empty) + _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-left-empty" (symmetricDifference empty base) + _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-right-empty" (symmetricDifference base empty) + benchmarkPublishedSetOperation + "set-publication-difference-skew" + (difference base removed) + (pure retained) + benchmarkPublishedSetOperation + "set-publication-intersection-skew" + (intersection base retained) + (pure retained) + benchmarkPublishedSetOperation + "set-publication-symmetric-difference-disjoint-skew" + (symmetricDifference base extension) + (geometryMesh (baseSites <> extensionSites)) + benchmarkPublishedSetOperation + "set-publication-symmetric-difference-small-output" + (symmetricDifference base retained) + (pure removed) + +benchmarkPublishedSetOperation :: String -> Either BuildError Mesh -> IO Mesh -> IO () +benchmarkPublishedSetOperation label operation expectedWitness = do + result <- benchmarkValidatedSetOperation label operation + observedCanonical <- + timedValue + (label <> "-explicit-canonicalize") + (evaluate . force =<< requireRight (canonicalize result)) + expected <- expectedWitness + expectedCanonical <- evaluate . force =<< requireRight (canonicalize expected) + unless (observedCanonical == expectedCanonical) $ + fail (label <> " disagreed with the independently rebuilt witness") + +benchmarkValidatedSetOperation :: String -> Either BuildError Mesh -> IO Mesh +benchmarkValidatedSetOperation label operation = do + result <- timedValue label (evaluate . force =<< requireRight operation) + case validateTriangulation result of + [] -> pure () + violations -> fail (label <> " invalid: " <> show violations) + pure result + +-- | The same operand sizes at three overlap fractions. A join is sized by the +-- union, so wholly overlapping operands must cost what one of them costs. +benchmarkOverlap :: Int -> IO () +benchmarkOverlap total = do + let sites = randomPoints 0x2545f4914f6cdd1d total + half = total `div` 2 + disjointLeft <- geometryMesh (take half sites) + disjointRight <- geometryMesh (drop half sites) + halfLeft <- geometryMesh (take half sites) + halfRight <- geometryMesh (drop (half `div` 2) (take (half + half `div` 2) sites)) + sameLeft <- geometryMesh (take half sites) + sameRight <- geometryMesh (reverse (take half sites)) + _ <- evaluate (force (disjointLeft, disjointRight, halfLeft, halfRight, sameLeft, sameRight)) + _ <- timedValue "join-overlap-000" (evaluate . force =<< requireRight (union disjointLeft disjointRight)) + _ <- timedValue "join-overlap-050" (evaluate . force =<< requireRight (union halfLeft halfRight)) + _ <- timedValue "join-overlap-100" (evaluate . force =<< requireRight (union sameLeft sameRight)) + pure () + +-- | 'unions' is a balanced tournament and not a fold, which is a cost claim +-- and therefore has to be measured rather than asserted. A fold republishes an +-- accumulator that grows by one shard per step. +-- +-- This lane once reported the fold as the faster of the two, which was true and +-- was not a fact about the schedules: @joinBalanced@ carried no specialization, +-- so every join inside the tournament ran through a dictionary while +-- the left-associated schedule at a known element type ran specialized. The tournament was +-- paying twice for arithmetic, and that swamped the asymptotic gap it was +-- supposed to be demonstrating. +-- +-- The shards are dealt round-robin, so every one of them spans the whole extent +-- and no join in the tournament is separable. That is deliberate: it is the +-- adversarial sharding, and it measures the operator with no structure to +-- exploit. 'benchmarkSpatialTournament' is the same tournament over the +-- sharding a caller who wanted it to be fast would actually choose. +benchmarkTournament :: Int -> Int -> IO () +benchmarkTournament total shardCount = do + let sites = randomPoints 0x14057b7ef767814f total + indexed = zip [0 :: Int ..] sites + shards <- + traverse + (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard]) + [0 .. shardCount - 1] + _ <- evaluate (force shards) + _ <- timedValue "join-tournament" (evaluate . force =<< requireRight (unions shards)) + _ <- timedValue "join-left-fold" (evaluate . force =<< requireRight (unionsLeftAssociated shards)) + pure () + +-- | Where the tournament's advantage over the fold actually appears. +-- +-- A fold republishes an accumulator that grows by one shard per step, so it +-- rebuilds @Θ(nk)@ sites over @k@ shards where halving rebuilds @Θ(n log k)@. +-- That is a statement about @k@, and at the sixteen shards the lane above uses +-- the predicted factor is barely two — small enough to be swamped by the +-- per-join costs both schedules pay fifteen times each. This sweep is here +-- because a cost claim that only holds asymptotically has to say at what size +-- it starts holding, and the answer has to be measured rather than asserted. +benchmarkTournamentScaling :: Int -> IO () +benchmarkTournamentScaling total = + mapM_ + ( \shardCount -> do + let sites = randomPoints 0x9e3779b97f4a7c15 total + indexed = zip [0 :: Int ..] sites + shards <- + traverse + (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard]) + [0 .. shardCount - 1] + _ <- evaluate (force shards) + _ <- timedValue ("join-shards-" <> show shardCount <> "-tournament") (evaluate . force =<< requireRight (unions shards)) + _ <- timedValue ("join-shards-" <> show shardCount <> "-fold") (evaluate . force =<< requireRight (unionsLeftAssociated shards)) + pure () + ) + [4 :: Int, 16, 64] + + +-- | The same tournament over shards cut by abscissa rather than dealt. +-- +-- This is the workload a seam schedule exists for, and the only one where it +-- can pay off more than once. Shards cut into contiguous x-ranges are pairwise +-- separated; so is every intermediate result, because the union of two adjacent +-- ranges is a range. Every one of the fifteen joins in the tournament is +-- therefore separable — the tournament /is/ the divide-and-conquer recursion, +-- entered from the leaves. +-- +-- Against the reference schedule this must cost about what the dealt +-- tournament costs, since a rebuild cannot tell the two shardings apart. That +-- agreement is the baseline; the gap that opens between these two lanes is the +-- whole return on a merge kernel. +benchmarkSpatialTournament :: Int -> Int -> IO () +benchmarkSpatialTournament total shardCount = do + let sites = randomPoints 0x3c6ef372fe94f82a total + ordered = sortBy (comparing (\(Point x _) -> x)) sites + width = (total + shardCount - 1) `div` shardCount + shards <- + traverse + (\shard -> geometryMesh (take width (drop (shard * width) ordered))) + [0 .. shardCount - 1] + _ <- evaluate (force shards) + _ <- timedValue "join-spatial-tournament" (evaluate . force =<< requireRight (unions shards)) + pure () + +-- | The renumbering pass on its own, against the construction it follows. +benchmarkCanonicalize :: Int -> IO () +benchmarkCanonicalize total = do + let sites = randomPoints 0x27d4eb2f165667c5 total + mesh <- geometryMesh sites + _ <- evaluate (force mesh) + _ <- timedValue "canonicalize-alone" (evaluate (force (canonicalize mesh))) + pure () + +-- | The shared canonical rebuild boundary under half overlap, on both its +-- geometry-only specializations and its annotation-preserving surface. Setup +-- and source publication are forced before every clock; the measurements are +-- therefore the exact site classification, rebuild, canonical publication and +-- payload transport the public operations own. +benchmarkSetAlgebra :: Int -> IO () +benchmarkSetAlgebra total = do + let common = total `quot` 2 + sites = randomPoints 0x6A09E667F3BCC909 (total + common) + leftPoints = take total sites + rightPoints = drop common sites + leftGeometry <- geometryMesh leftPoints + rightGeometry <- geometryMesh rightPoints + emptyGeometry <- requireRight (unions []) + _ <- evaluate (force (leftGeometry, rightGeometry, emptyGeometry)) + _ <- timedValue "set-intersection-unit" (evaluate . force =<< requireRight (intersection leftGeometry rightGeometry)) + _ <- timedValue "set-difference-unit" (evaluate . force =<< requireRight (difference leftGeometry rightGeometry)) + _ <- + timedValue + "set-symmetric-difference-unit" + (evaluate . force =<< requireRight (symmetricDifference leftGeometry rightGeometry)) + _ <- + timedValue + "set-difference-right-empty" + (evaluate . force =<< requireRight (difference leftGeometry emptyGeometry)) + _ <- + timedValue + "set-symmetric-difference-left-empty" + (evaluate . force =<< requireRight (symmetricDifference emptyGeometry leftGeometry)) + _ <- timedValue "set-relation-half-overlap" (evaluate (force (siteRelation leftGeometry rightGeometry))) + leftAnnotated <- siteMesh leftPoints + rightAnnotated <- siteMesh rightPoints + _ <- evaluate (force (leftAnnotated, rightAnnotated)) + _ <- + timedValue + "set-intersection-annotated" + (evaluate . force =<< requireRight (intersectionWith (,) leftAnnotated rightAnnotated)) + _ <- + timedValue + "set-difference-annotated" + (evaluate . force =<< requireRight (difference leftAnnotated rightAnnotated)) + _ <- + timedValue + "set-symmetric-difference-annotated" + (evaluate . force =<< requireRight (symmetricDifference leftAnnotated rightAnnotated)) + pure () + + +canonical :: [Point] -> [Point] +canonical points = [Point x y | (x, y) <- dropAdjacentDuplicates (sort [(x, y) | Point x y <- points])] + +dropAdjacentDuplicates :: Eq a => [a] -> [a] +dropAdjacentDuplicates (first : second : rest) + | first == second = dropAdjacentDuplicates (second : rest) + | otherwise = first : dropAdjacentDuplicates (second : rest) +dropAdjacentDuplicates rest = rest + +geometryMesh :: [Point] -> IO Mesh +geometryMesh points = mapVertices (const ()) <$> siteMesh points + +siteMesh :: [Point] -> IO SiteMesh +siteMesh points = + buildTriangulation <$> requireRight (delaunay unitElementDefaults (V.fromList points)) + +unionsLeftAssociated :: [Mesh] -> Either BuildError Mesh +unionsLeftAssociated meshes = unions [] >>= \identity -> foldM union identity meshes diff --git a/bench/publication/PublicationMain.hs b/bench/publication/PublicationMain.hs new file mode 100644 --- /dev/null +++ b/bench/publication/PublicationMain.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.JoinBench as JoinBench + +main :: IO () +main = JoinBench.publicationBenchmarks diff --git a/bench/support/BenchSupport.hs b/bench/support/BenchSupport.hs new file mode 100644 --- /dev/null +++ b/bench/support/BenchSupport.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- | The measurement harness every benchmark slice shares. Deliberately not +-- @tasty-bench@: allocated bytes and the work counters the library reports +-- about itself are the figures a slice is here to expose, and a harness built +-- around a timing distribution cannot express either. +module BenchSupport + ( timedValue + , requireRight + , randomPoints + ) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled) +import Moonlight.Triangulation (Point (Point)) +import System.CPUTime (getCPUTime) + +-- | Both clocks, because they answer different questions and neither +-- substitutes for the other. Elapsed is what anything is compared against — +-- the board against spade is wall clock, and a parallel construction that used +-- more cores gets no allowance for having used them. CPU is the work receipt: +-- on one capability the two agree, and where they diverge the ratio is the +-- parallelism actually obtained. Reporting CPU alone, as this did, would let a +-- change that halves elapsed time and doubles total work read as a regression. +timedValue :: NFData value => String -> IO value -> IO value +timedValue label action = do + statsEnabled <- getRTSStatsEnabled + before <- if statsEnabled then Just <$> getRTSStats else pure Nothing + wallStart <- getMonotonicTimeNSec + cpuStart <- getCPUTime + value <- action >>= evaluate . force + cpuEnd <- getCPUTime + wallEnd <- getMonotonicTimeNSec + after <- if statsEnabled then Just <$> getRTSStats else pure Nothing + putStrLn (label <> "-elapsed: " <> show (fromIntegral (wallEnd - wallStart) / 1.0e9 :: Double) <> "s") + putStrLn (label <> "-cpu: " <> show (fromIntegral (cpuEnd - cpuStart) / 1.0e12 :: Double) <> "s") + case (before, after) of + (Just left, Just right) -> + putStrLn (label <> "-allocated-bytes: " <> show (allocated_bytes right - allocated_bytes left)) + _ -> pure () + pure value + +requireRight :: Show error => Either error value -> IO value +requireRight value = case value of + Left failure -> fail (show failure) + Right result -> pure result + +randomPoints :: Word64 -> Int -> [Point] +randomPoints seed count = take count (go seed) + where + go :: Word64 -> [Point] + go state = + let state1 = state * 6364136223846793005 + 1442695040888963407 + state2 = state1 * 6364136223846793005 + 1442695040888963407 + unit :: Word64 -> Double + unit value = fromIntegral (value `div` 2048) / 9_007_199_254_740_992 + in Point (2 * unit state1 - 1) (2 * unit state2 - 1) : go state2 diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md new file mode 100644 --- /dev/null +++ b/docs/ARCHITECTURE.md @@ -0,0 +1,170 @@ +# moonlight-triangulation architecture laws + +`moonlight-triangulation.cabal` is the authoritative component, module, and +dependency graph. Duplicating that inventory here only manufactures a stale +second owner. This document records the laws the manifest cannot express. + +## Geometry has one owner + +The coordinate pages `triPointX` and `triPointY` own vertex geometry. Vertex +payloads are independent annotations: `setVertexData` and `mapVertices` may +change them without moving a vertex. `triPointIndex` is a derived lookup over +the coordinate pages. + +Construction may read a position from an incoming payload through +`HasPosition`; no operation may later reconstruct geometry from that payload. +The versioned serialization boundary therefore persists coordinate pages and +payloads independently, then derives only the point index on decode. + +## Topology is finite and mutation is sealed + +The half-edge DCEL is a structure of arrays. Twin half-edges are arithmetic +complements (`e xor 1`), and every inner face has a three-edge cycle. Persistent +operations thaw into `MutableDcel` in `ST`, perform a bounded local rewrite, and +freeze the result; mutable references never escape. + +Validation descends in two stages. Structural cardinality, range, link, face, +vertex, point-index, and Euler obligations must glue first. Geometric +orientation and Delaunay checks run only after that structural section is +valid, because reading geometry through malformed links would turn a reported +obstruction into an indexing crash. + +## Constrained regions descend by barrier parity + +For a constrained triangulation, a face's region is determined by the minimum +number of constrained edges crossed from the outer face. Even depths are +outside: depth zero is the exterior, depth one the first bounded domain, depth +two a hole, and so on. A dangling constraint can be walked around at depth +zero. + +`FloodFillIterator.facesAtEvenBarrierDepth` owns this derived classification. +CDT queries and refinement import it; neither maintains a second definition of +"outside." + +## Component cuts justify dependencies + +Sublibraries are proof boundaries, not size buckets. In particular, +`serialize` alone owns the `binary` and `bytestring` dependencies. Modules named +`Internal` may be exposed only where Cabal sublibraries must cross them; that +exposure does not make them a supported public API. + +## The surface states a theory + +`Moonlight.Triangulation` is one export list read as the statement of a theory, +in eight sections: the object, generation, the annotation functor, the +finite-set algebra and its normal form, the constraint layer, refinement, +observations, discharge. A name reaches the surface because a law mentions it. + +The headline law is a homomorphism from finite site sets to canonical +observations of triangulations, + + publish (A ∪ B) = canonicalize (union (publish A) (publish B)) + +where `publish` sends a site set through `delaunay` and then through +`canonicalize . mapVertices (const ())`. A raw build or local union may retain +the schedule that produced it, so structural `Eq` compares resident +representations while the finite-set laws compare their canonical, +payload-free images. `canonicalize` is that explicit physical normal form, and +`mapVertices (const ())` is the arrow onto the carrier used by the +geometry-only laws. Annotated `union` and `unions` glue equal-site payloads +through `JoinSemilattice` without allowing payloads to author geometry. + +The exact support order is observed by `siteRelation`: equality, either proper +subset direction, disjointness, or a positive partial-overlap count. Restriction +descends through the same private site-set owner. `intersectionWith` combines +the left and right annotations only where both supports contain the coordinate; +`difference` preserves the left annotation; `symmetricDifference` preserves +the annotation of whichever exclusive support contains the coordinate. All +three publish through the same canonical rebuild boundary as the geometry-only +operations. + +The generator is named `delaunay` because the equation is false of +triangulations in general and true of Delaunay triangulations. The name has to +make the law true. + +The topology arena is finite, so union is not total. `union` and `unions` +therefore return `Either BuildError`; arena exhaustion is a typed obstruction, +not a lawful `Semigroup` instance with a trapdoor beneath it. + +The constrained layer is not a total semilattice and does not pretend to be +one. Its +extension is the pair lattice of site sets and segment sets under componentwise +union, on which `constrainedDelaunay` is a partial homomorphism restricted to +the realizable sublattice: partiality kills `Semigroup`, and greedy +totalization kills associativity. `unionConstrained` is therefore surfaced as +an explicit operation returning `ConstrainedUnionError`, never as a typeclass +instance. + +## Tiers govern names at their export site + +Four tiers, and a name's tier is where it is exported rather than where it is +defined — a surface name may be defined below without lowering its tier. + +The facade is the surface, and a subtraction there is a major version. The +sublibrary components are a partition: no manifest outside this package names +one, the in-repo spade referent excepted, since it ships with the package it +measures. Non-`Internal` sublibrary modules are the machine room, semi-stable +and reached by consumers who accept that. `Internal` modules promise nothing. + +## Results are values, not histories + +`BuildResult` and `RefinementResult` are abstract, reached through named +projections; `buildStats` and the rest of the telemetry stay below the wall. +Neither derives `Eq` or `Show`, because a derived instance observes through a +facade that hides — equality would consult counters the surface does not admit +exist. + +## One concept has one owner + +`isConstraintEdge` is owned by `Dcel`, polymorphic in the constraint mode; +`Cdt` does not restate it, and no alias survives. `innerFaceVertices` remains a +genuine collision — `Dcel`'s takes raw identifiers and answers `Maybe`, while +`Handles.Dynamic`'s takes and answers handles. Neither is surfaced, so the +collision stays in the machine room and callers name the module they mean. + +## Vocabulary precedes representation + +`Internal.Types` holds the vocabulary the surface names, none of which mentions +the stored mesh. `Internal.Representation` holds the structure of arrays, the +payload traversals, and the records that carry a built mesh beside its +telemetry. Representation imports vocabulary; the reverse import does not +exist. A type whose definition mentions the `Triangulation` record belongs to +Representation, which is why the result records live there. + +## Mechanical acceptance + +The native suite checks geometry and topology laws without depending on +`serialize`; the serialization suite checks the binary boundary separately. The +algebra suite is three slices with three dependency sets: fixtures, the laws +stated against the facade alone, and the agreement between the seam schedule +and the reference rebuild, which names an internal schedule and travels with +it. The parallel suite owns tournament behavior. The separate coherence test +imports every slice against the union of their dependencies at `-O0`; it detects +module and instance collisions but does not execute the behavioral suites a +second time. +The package's `warnings-as-errors` flag and `weeder.toml` turn compiler warnings +and unreachable internal declarations into refusals. The dedicated GitHub +workflow selects all library components from Cabal's generated plan rather than +restating build directories by hand. + +## Published documentation is assembled, not generated + +Cabal writes a Haddock interface for every sublibrary and hands none of them to +the siblings. The facade re-exports names it therefore cannot resolve, and +renders them as text. Cabal also writes one documentation tarball per +component, each under the same name, so the components overwrite one another +and only the last to run survives. + +Hackage adds conditions of its own. A module on the package page links to its +documentation only when that page sits at the documentation root, so Cabal's +per-sublibrary subdirectories leave every module listed and unreachable. A +tarball is refused outright for a colon in any filename — which is how Cabal +names the sublibrary Hoogle databases — and for the extended attributes a macOS +`tar` attaches unbidden. + +None of this is a defect in the component cuts. The repair changes no module, +no export, and no dependency; it is entirely downstream of the manifest, which +is why the manifest cannot express it. `release/hackage-docs.sh` owns it: +regenerate the facade against every sibling interface, flatten the module pages +to one root, cut a portable tarball. A release that skips the script publishes +a surface of unlinked names. diff --git a/fuzz/README.md b/fuzz/README.md new file mode 100644 --- /dev/null +++ b/fuzz/README.md @@ -0,0 +1,25 @@ +# Coverage-guided fuzzing + +The fuzz executables are byte-oriented boundaries for an external coverage-guided engine. They are excluded from ordinary builds and add no dependency to any library component. + +```bash +cabal build -ffuzz-targets \ + exe:moonlight-triangulation-fuzz-decode \ + exe:moonlight-triangulation-fuzz-constraints \ + exe:moonlight-triangulation-fuzz-refinement +``` + +Each executable accepts one corpus path in `@@` form or reads the input from standard input. On Linux, AFL++ can guide an uninstrumented GHC executable through QEMU mode: + +```bash +afl-fuzz -Q -i fuzz/corpus/decode -o fuzz/artifacts/decode -- \ + "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-decode)" @@ + +afl-fuzz -Q -i fuzz/corpus/constraints -o fuzz/artifacts/constraints -- \ + "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-constraints)" @@ + +afl-fuzz -Q -i fuzz/corpus/refinement -o fuzz/artifacts/refinement -- \ + "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-refinement)" @@ +``` + +Decoder refusals, unrealizable constraint batches, invalid refinement parameters, and rejected domains are expected typed outcomes. A target fails only when an admitted result violates the DCEL laws or serialization round-trip. diff --git a/fuzz/constraints/Main.hs b/fuzz/constraints/Main.hs new file mode 100644 --- /dev/null +++ b/fuzz/constraints/Main.hs @@ -0,0 +1,27 @@ +module Main (main) where + +import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Cdt +import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget) +import Moonlight.Triangulation.Fuzz.Input (decodeConstraints, decodePoints) + +newtype ConstraintFuzzFailure = ConstraintInvariantFailure (NonEmpty InvariantViolation) + deriving stock (Show) + +main :: IO () +main = runFuzzTarget fuzzConstraintRecovery + +fuzzConstraintRecovery :: BS.ByteString -> Either ConstraintFuzzFailure () +fuzzConstraintRecovery bytes = + case constrainedDelaunayMaximal unitElementDefaults points constraints of + Left _ -> Right () + Right result -> + case validateTriangulation (cdtBuildTriangulation result) of + violation : violations -> Left (ConstraintInvariantFailure (violation :| violations)) + [] -> Right () + where + points = decodePoints bytes + constraints = decodeConstraints bytes (V.length points) diff --git a/fuzz/corpus/constraints/seed.bin b/fuzz/corpus/constraints/seed.bin new file mode 100644 Binary files /dev/null and b/fuzz/corpus/constraints/seed.bin differ diff --git a/fuzz/corpus/decode/seed.bin b/fuzz/corpus/decode/seed.bin new file mode 100644 Binary files /dev/null and b/fuzz/corpus/decode/seed.bin differ diff --git a/fuzz/corpus/refinement/seed.bin b/fuzz/corpus/refinement/seed.bin new file mode 100644 Binary files /dev/null and b/fuzz/corpus/refinement/seed.bin differ diff --git a/fuzz/decode/Main.hs b/fuzz/decode/Main.hs new file mode 100644 --- /dev/null +++ b/fuzz/decode/Main.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} + +module Main (main) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Triangulation +import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget) +import Moonlight.Triangulation.Serialization +import Moonlight.Triangulation.Types (KnownConstraintMode) + +data DecodeFuzzFailure + = DecodeInvariantFailure !(NonEmpty InvariantViolation) + | DecodeRoundTripFailure + deriving stock (Show) + +main :: IO () +main = runFuzzTarget fuzzDecodeTriangulation + +fuzzDecodeTriangulation :: BS.ByteString -> Either DecodeFuzzFailure () +fuzzDecodeTriangulation bytes = + checkUnconstrained (decodeTriangulation lazyBytes) + *> checkConstrained (decodeTriangulation lazyBytes) + where + lazyBytes = BL.fromStrict bytes + +checkUnconstrained + :: Either SerializationError (Triangulation 'Unconstrained () () () ()) + -> Either DecodeFuzzFailure () +checkUnconstrained = either (const (Right ())) checkDecoded + +checkConstrained + :: Either SerializationError (Triangulation 'Constrained () () () ()) + -> Either DecodeFuzzFailure () +checkConstrained = either (const (Right ())) checkDecoded + +checkDecoded + :: KnownConstraintMode mode + => Triangulation mode () () () () + -> Either DecodeFuzzFailure () +checkDecoded triangulation = + case validateTriangulation triangulation of + violation : violations -> Left (DecodeInvariantFailure (violation :| violations)) + [] -> + case decodeTriangulation (encodeTriangulation triangulation) of + Right decoded + | decoded == triangulation -> Right () + _ -> Left DecodeRoundTripFailure diff --git a/fuzz/refinement/Main.hs b/fuzz/refinement/Main.hs new file mode 100644 --- /dev/null +++ b/fuzz/refinement/Main.hs @@ -0,0 +1,117 @@ +module Main (main) where + +import qualified Data.ByteString as BS +import qualified Data.Set as Set +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Vector as V +import Moonlight.Triangulation +import Moonlight.Triangulation.Cdt +import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget) +import Moonlight.Triangulation.Fuzz.Input + ( decodeConstraints + , decodePoints + , decodeRefinementParameters + , inputByte + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId (..) + , UndirectedEdgeId (..) + ) + +data RefinementFuzzFailure + = RefinementInvariantFailure !(NonEmpty InvariantViolation) + | RefinementFullDomainInvariantFailure !(NonEmpty InvariantViolation) + | RefinementDomainInvariantFailure !(NonEmpty InvariantViolation) + deriving stock (Show) + +main :: IO () +main = runFuzzTarget fuzzRefinementAdmission + +fuzzRefinementAdmission :: BS.ByteString -> Either RefinementFuzzFailure () +fuzzRefinementAdmission bytes = + case constrainedDelaunayMaximal unitElementDefaults points constraints of + Left _ -> Right () + Right buildResult -> + let triangulation = cdtBuildTriangulation buildResult + in checkOrdinary triangulation + *> checkFullDomain triangulation + *> checkHostileDomain triangulation + where + points = decodePoints bytes + constraints = decodeConstraints bytes (V.length points) + parameters = decodeRefinementParameters bytes + checkOrdinary triangulation = + case validateRefinementParameters parameters of + Left _ -> Right () + Right () -> + either + (const (Right ())) + (checkResult RefinementInvariantFailure) + (refine id parameters triangulation) + checkFullDomain triangulation = + either + (const (Right ())) + (checkResult RefinementFullDomainInvariantFailure . refinementDomainResult) + ( refineWithinDomain + id + domainParameters + (allInnerFaces triangulation) + Set.empty + triangulation + ) + checkHostileDomain triangulation = + either + (const (Right ())) + (checkResult RefinementDomainInvariantFailure . refinementDomainResult) + ( refineWithinDomain + id + domainParameters + (faceSelection triangulation) + (edgeSelection triangulation) + triangulation + ) + allInnerFaces + :: Triangulation mode vertex directed undirected face + -> Set.Set FaceId + allInnerFaces triangulation = + Set.fromDistinctAscList + (FaceId . fromIntegral <$> [1 .. numFaces triangulation - 1]) + domainParameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just (fromIntegral (inputByte bytes 7) `mod` 9) + , refineMaxArea = Just (fromIntegral (inputByte bytes 8) / 8 + 1 / 8) + , refinePreserveConvexHull = True + , refineKeepConstraintEdges = True + , refineExcludeOuterFaces = False + } + faceSelection triangulation = + Set.fromList + ( V.toList + ( V.generate + (min 24 (fromIntegral (inputByte bytes 9))) + (FaceId . fromIntegral . selectedFace triangulation) + ) + ) + selectedFace triangulation index + | inputByte bytes (index + 10) `mod` 8 == 0 = numFaces triangulation + index + | otherwise = fromIntegral (inputByte bytes (index + 10)) `mod` max 1 (numFaces triangulation) + edgeSelection triangulation = + Set.fromList + ( V.toList + ( V.generate + (min 24 (fromIntegral (inputByte bytes 34))) + (UndirectedEdgeId . fromIntegral . selectedEdge triangulation) + ) + ) + selectedEdge triangulation index + | inputByte bytes (index + 35) `mod` 8 == 0 = numUndirectedEdges triangulation + index + | otherwise = fromIntegral (inputByte bytes (index + 35)) `mod` max 1 (numUndirectedEdges triangulation) + +checkResult + :: (NonEmpty InvariantViolation -> RefinementFuzzFailure) + -> RefinementResult mode vertex directed undirected face + -> Either RefinementFuzzFailure () +checkResult failure result = + case validateTriangulation (refinedTriangulation result) of + violation : violations -> Left (failure (violation :| violations)) + [] -> Right () diff --git a/fuzz/support/Moonlight/Triangulation/Fuzz/Boundary.hs b/fuzz/support/Moonlight/Triangulation/Fuzz/Boundary.hs new file mode 100644 --- /dev/null +++ b/fuzz/support/Moonlight/Triangulation/Fuzz/Boundary.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE LambdaCase #-} + +module Moonlight.Triangulation.Fuzz.Boundary + ( runFuzzTarget + ) where + +import qualified Data.ByteString as BS +import System.Environment (getArgs) +import System.Exit (die) + +runFuzzTarget :: Show failure => (BS.ByteString -> Either failure ()) -> IO () +runFuzzTarget target = + readInput >>= either (die . show) (const (pure ())) . target + +readInput :: IO BS.ByteString +readInput = + getArgs >>= \case + [] -> BS.getContents + [path] -> BS.readFile path + _ -> die "expected zero arguments for stdin or one input path" diff --git a/fuzz/support/Moonlight/Triangulation/Fuzz/Input.hs b/fuzz/support/Moonlight/Triangulation/Fuzz/Input.hs new file mode 100644 --- /dev/null +++ b/fuzz/support/Moonlight/Triangulation/Fuzz/Input.hs @@ -0,0 +1,65 @@ +module Moonlight.Triangulation.Fuzz.Input + ( decodeConstraints + , decodePoints + , decodeRefinementParameters + , inputByte + ) where + +import qualified Data.ByteString as BS +import qualified Data.Vector as V +import Data.Word (Word8) +import Moonlight.Triangulation + +decodePoints :: BS.ByteString -> V.Vector Point +decodePoints bytes = + V.generate pointCount $ \index -> + Point + (coordinate (inputByte bytes (2 * index)) + fromIntegral (index `mod` 3) / 1024) + (coordinate (inputByte bytes (2 * index + 1)) + fromIntegral ((index * index) `mod` 5) / 1024) + where + pointCount = max 3 (min 64 ((BS.length bytes + 1) `quot` 2)) + coordinate :: Word8 -> Double + coordinate value = (fromIntegral value - 127.5) / 4 + +decodeConstraints :: BS.ByteString -> Int -> V.Vector (Int, Int) +decodeConstraints bytes pointCount = + V.generate constraintCount $ \index -> + (endpoint (inputByte bytes (2 * index)), endpoint (inputByte bytes (2 * index + 1))) + where + constraintCount = max 1 (min 96 ((BS.length bytes + 1) `quot` 2)) + endpoint value + | value `mod` 8 == 0 = pointCount + fromIntegral (value `mod` 5) + | otherwise = fromIntegral value `mod` pointCount + +decodeRefinementParameters :: BS.ByteString -> RefinementParameters +decodeRefinementParameters bytes = + defaultRefinementParameters + { refineMaxAdditionalVertices = budget (inputByte bytes 0) + , refineMinArea = metric (inputByte bytes 1) + , refineMaxArea = metric (inputByte bytes 2) + , refineMaxRadiusEdgeRatio = metric (inputByte bytes 3) + , refinePreserveConvexHull = odd (inputByte bytes 4) + , refineKeepConstraintEdges = odd (inputByte bytes 5) + , refineExcludeOuterFaces = odd (inputByte bytes 6) + } + where + budget :: Word8 -> Maybe Int + budget value = + case value `mod` 5 of + 0 -> Nothing + 1 -> Just (-1) + _ -> Just (fromIntegral value `mod` 17) + metric :: Word8 -> Maybe Double + metric value = + case value `mod` 8 of + 0 -> Nothing + 1 -> Just (-1) + 2 -> Just 0 + 3 -> Just (0 / 0) + 4 -> Just (1 / 0) + _ -> Just (fromIntegral value / 8) + +inputByte :: BS.ByteString -> Int -> Word8 +inputByte bytes index + | BS.null bytes = fromIntegral index + | otherwise = BS.index bytes (index `mod` BS.length bytes) diff --git a/moonlight-triangulation.cabal b/moonlight-triangulation.cabal new file mode 100644 --- /dev/null +++ b/moonlight-triangulation.cabal @@ -0,0 +1,583 @@ +cabal-version: 3.4 +name: moonlight-triangulation +version: 0.1.0.0 +synopsis: Delaunay triangulations as a lawful finite-set algebra. +description: Delaunay and constrained Delaunay triangulation as a lawful + finite-set algebra: a mesh is a value of its site set, so + union, intersection and difference return triangulations + and refinement composes after them rather than replacing + them. One structure-of-arrays half-edge mesh carries the + constrained and unconstrained layers, 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. + Failure is values: every refusal names its witness. +license: MIT +license-file: LICENSE +author: Fable, Blue Rose +maintainer: rosaliafialkova@gmail.com +copyright: (c) 2026 Fable, Blue Rose +category: Geometry, Math +homepage: https://github.com/PaleRoses/moonlight +bug-reports: https://github.com/PaleRoses/moonlight/issues +build-type: Simple +tested-with: GHC == 9.10.3 + GHC == 9.12.4 + GHC == 9.14.1 +extra-doc-files: + README.md + CHANGELOG.md + docs/ARCHITECTURE.md +extra-source-files: + weeder.toml + fuzz/README.md + fuzz/corpus/constraints/seed.bin + fuzz/corpus/decode/seed.bin + fuzz/corpus/refinement/seed.bin + +source-repository head + type: git + location: https://github.com/PaleRoses/moonlight.git + subdir: moonlight-triangulation + +flag warnings-as-errors + description: Treat compiler warnings as errors in package validation. + default: False + manual: True + +flag fuzz-targets + description: Build the external coverage-guided fuzz entrypoints. + default: False + manual: True + +common shared-properties + default-language: GHC2024 + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wno-missing-import-lists + if flag(warnings-as-errors) + ghc-options: -Werror + +-- ── the tower ──────────────────────────────────────────────────────────────── +-- The main tower is core <- dcel <- build <- dual <- facade. Serialize branches +-- from dcel and parallel branches from build, keeping their effect dependencies +-- out of the tower. The graph is acyclic and uses no @.hs-boot@ files. + +library core + import: shared-properties + visibility: public + hs-source-dirs: src-core + exposed-modules: + Moonlight.Triangulation.Scalar + Moonlight.Triangulation.LineSideInfo + Moonlight.Triangulation.Internal.Dyadic + Moonlight.Triangulation.Internal.PageDirectory + Moonlight.Triangulation.Internal.Paged + Moonlight.Triangulation.Internal.BoxedPaged + Moonlight.Triangulation.Internal.Growable + Moonlight.Triangulation.Internal.PackedIndex + Moonlight.Triangulation.Internal.FaceQueue + build-depends: + base >= 4.20 && < 5 + , containers >= 0.8 && < 0.9 + , deepseq >= 1.5 && < 1.6 + , vector >= 0.13 && < 0.14 + ghc-options: -fexpose-all-unfoldings + +library dcel + import: shared-properties + visibility: public + hs-source-dirs: src-dcel + exposed-modules: + Moonlight.Triangulation.Types + Moonlight.Triangulation.Math + Moonlight.Triangulation.Interop + Moonlight.Triangulation.Dcel + Moonlight.Triangulation.Payload + Moonlight.Triangulation.JoinSemilattice + Moonlight.Triangulation.Handles + Moonlight.Triangulation.Handles.HandleDefs + Moonlight.Triangulation.Handles.Dynamic + Moonlight.Triangulation.Handles.Iterators + Moonlight.Triangulation.Handles.Iterators.CircularIterator + Moonlight.Triangulation.Handles.Iterators.DynamicIterators + Moonlight.Triangulation.Handles.Iterators.FixedIterators + Moonlight.Triangulation.Handles.Iterators.HullIterator + Moonlight.Triangulation.PointLocation + Moonlight.Triangulation.Validation + Moonlight.Triangulation.FloodFillIterator + Moonlight.Triangulation.IntersectionIterator + Moonlight.Triangulation.Internal.FaceProbe + Moonlight.Triangulation.Internal.Types + Moonlight.Triangulation.Internal.Representation + Moonlight.Triangulation.Internal.PointIndex + Moonlight.Triangulation.Internal.Mutable + Moonlight.Triangulation.Internal.OperationState + Moonlight.Triangulation.Internal.Probe + Moonlight.Triangulation.Internal.DcelOperations + Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + Moonlight.Triangulation.Internal.DcelOperations.Chain + Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite + Moonlight.Triangulation.Internal.DcelOperations.FlipRule + Moonlight.Triangulation.Internal.DcelOperations.Hull + Moonlight.Triangulation.Internal.DcelOperations.Legalize + Moonlight.Triangulation.Internal.DcelOperations.Normalize + Moonlight.Triangulation.Internal.DcelOperations.Subdivide + Moonlight.Triangulation.Internal.DcelOperations.Twin + Moonlight.Triangulation.Internal.Canonical + build-depends: + base >= 4.20 && < 5 + , containers >= 0.8 && < 0.9 + , deepseq >= 1.5 && < 1.6 + , primitive >= 0.9 && < 0.10 + , vector >= 0.13 && < 0.14 + , vector-algorithms >= 0.9 && < 0.10 + , moonlight-triangulation:core + ghc-options: -fexpose-all-unfoldings + +library build + import: shared-properties + visibility: public + hs-source-dirs: src-build + exposed-modules: + Moonlight.Triangulation.BulkLoad + Moonlight.Triangulation.Removal + Moonlight.Triangulation.Session + Moonlight.Triangulation.Cdt + Moonlight.Triangulation.Refinement + Moonlight.Triangulation.SetAlgebra + Moonlight.Triangulation.Internal.Cdt.Build + Moonlight.Triangulation.Internal.Cdt.Query + Moonlight.Triangulation.Internal.Cdt.Types + Moonlight.Triangulation.Internal.Cdt.Union + Moonlight.Triangulation.Internal.Join + Moonlight.Triangulation.Internal.Join.Seam + other-modules: + Moonlight.Triangulation.Insertion + Moonlight.Triangulation.Internal.Capacity + Moonlight.Triangulation.Internal.Cdt.Admission + Moonlight.Triangulation.Internal.Cdt.Batch + Moonlight.Triangulation.Internal.Cdt.Combinators + Moonlight.Triangulation.Internal.Cdt.Corridor + Moonlight.Triangulation.Internal.Cdt.Corridor.Trace + Moonlight.Triangulation.Internal.Cdt.Recovery + Moonlight.Triangulation.Internal.Cdt.Region + Moonlight.Triangulation.Internal.Cdt.Segment + Moonlight.Triangulation.Internal.Cdt.Site + Moonlight.Triangulation.Internal.Cdt.Split + Moonlight.Triangulation.Internal.Excision + Moonlight.Triangulation.Internal.Location + Moonlight.Triangulation.Internal.CircleSweep + Moonlight.Triangulation.Internal.Refinement + Moonlight.Triangulation.Internal.Transaction + Moonlight.Triangulation.Internal.Join.Plan + Moonlight.Triangulation.Internal.Join.Rebuild + Moonlight.Triangulation.Internal.Join.SiteSet + build-depends: + base >= 4.20 && < 5 + , containers >= 0.8 && < 0.9 + , deepseq >= 1.5 && < 1.6 + , primitive >= 0.9 && < 0.10 + , vector >= 0.13 && < 0.14 + , vector-algorithms >= 0.9 && < 0.10 + , moonlight-triangulation:core + , moonlight-triangulation:dcel + ghc-options: -fexpose-all-unfoldings + +-- Concurrency is an effect boundary over the pure build planner. Keeping it in +-- its own sublibrary prevents @async@ from infecting the geometry core. +library parallel + import: shared-properties + visibility: public + hs-source-dirs: src-parallel + exposed-modules: + Moonlight.Triangulation.Parallel + build-depends: + base >= 4.20 && < 5 + , async >= 2.2 && < 2.3 + , deepseq >= 1.5 && < 1.6 + , moonlight-triangulation:core + , moonlight-triangulation:build + , moonlight-triangulation:dcel + ghc-options: -fexpose-all-unfoldings + +-- Its own sublibrary so that @binary@ and @bytestring@ stay out of the minimal +-- geometry core. This is a dependency boundary, not a size split; it replaces +-- the former @serialization@ flag, which could not be checked by a single build. +library serialize + import: shared-properties + visibility: public + hs-source-dirs: src-serialize + exposed-modules: + Moonlight.Triangulation.Serialization + build-depends: + base >= 4.20 && < 5 + , binary >= 0.8 && < 0.9 + , bytestring >= 0.12 && < 0.13 + , containers >= 0.8 && < 0.9 + , transformers >= 0.6 && < 0.7 + , vector >= 0.13 && < 0.14 + , moonlight-triangulation:core + , moonlight-triangulation:dcel + -- The @Binary@ instances for the identifier and point types are orphans by + -- construction: the types belong to @dcel@ and the class to @binary@, and the + -- whole purpose of this component is that neither one has to know about the + -- other. Rehoming them would pull @binary@ into the core and defeat the split. + ghc-options: -fexpose-all-unfoldings -Wno-orphans + +library dual + import: shared-properties + visibility: public + hs-source-dirs: src-dual + exposed-modules: + Moonlight.Triangulation.Voronoi + Moonlight.Triangulation.Voronoi.Handles + Moonlight.Triangulation.Interpolation + Moonlight.Triangulation.HintGenerator + other-modules: + Moonlight.Triangulation.Internal.InterpolationWorkspace + build-depends: + base >= 4.20 && < 5 + , deepseq >= 1.5 && < 1.6 + , primitive >= 0.9 && < 0.10 + , vector >= 0.13 && < 0.14 + , moonlight-triangulation:core + , moonlight-triangulation:dcel + , moonlight-triangulation:build + ghc-options: -fexpose-all-unfoldings + +library + import: shared-properties + hs-source-dirs: src-public + exposed-modules: + Moonlight.Triangulation + build-depends: + base >= 4.20 && < 5 + , moonlight-triangulation:core + , moonlight-triangulation:dcel + , moonlight-triangulation:build + , moonlight-triangulation:dual + ghc-options: -fexpose-all-unfoldings + +common triangulation-fuzz-properties + import: shared-properties + hs-source-dirs: fuzz/support + other-modules: + Moonlight.Triangulation.Fuzz.Boundary + Moonlight.Triangulation.Fuzz.Input + build-depends: + base >= 4.20 && < 5 + , bytestring >= 0.12 && < 0.13 + , containers >= 0.8 && < 0.9 + , vector >= 0.13 && < 0.14 + , moonlight-triangulation + , moonlight-triangulation:build + , moonlight-triangulation:dcel + +executable moonlight-triangulation-fuzz-decode + import: triangulation-fuzz-properties + if !flag(fuzz-targets) + buildable: False + main-is: Main.hs + hs-source-dirs: fuzz/decode + build-depends: + binary >= 0.8 && < 0.9 + , moonlight-triangulation:serialize + +executable moonlight-triangulation-fuzz-constraints + import: triangulation-fuzz-properties + if !flag(fuzz-targets) + buildable: False + main-is: Main.hs + hs-source-dirs: fuzz/constraints + +executable moonlight-triangulation-fuzz-refinement + import: triangulation-fuzz-properties + if !flag(fuzz-targets) + buildable: False + main-is: Main.hs + hs-source-dirs: fuzz/refinement + +-- ── test slices ────────────────────────────────────────────────────────────── + +-- Each slice is an ATOM: a @common@ stanza binding a spec module to the +-- dependencies and RTS options that module requires. A suite is then a choice +-- of atoms and nothing more. The coherence component below imports every atom +-- and therefore checks their combined module, instance, and dependency surface +-- without running every behavioral suite a second time. + +common triangulation-test-properties + import: shared-properties + build-depends: + base >= 4.20 && < 5 + , deepseq >= 1.5 && < 1.6 + , vector >= 0.13 && < 0.14 + , primitive >= 0.9 && < 0.10 + , moonlight-triangulation + +common triangulation-test-support-slice + other-modules: Support + +common triangulation-native-test-slice + other-modules: + Moonlight.Triangulation.NativeSpec + Moonlight.Triangulation.FilteredPredicateOptimizationSpec + -- The RTS options this module needs are named on the SUITES rather than + -- here, which is the one place the slice-owns-its-requirements rule cannot + -- hold. @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so a + -- suite importing two slices that both name it links a binary whose RTS + -- string is the two spliced together — @-N4 -T-N4 -T@ — which the RTS + -- discards whole, silently disarming both. It must appear exactly once per + -- suite, so @triangulation-suite-rtsopts@ below carries it. + ghc-options: -threaded -rtsopts + build-depends: + containers >= 0.8 && < 0.9 + , moonlight-triangulation:core + , moonlight-triangulation:dcel + , moonlight-triangulation:build + , moonlight-triangulation:dual + +common triangulation-serialization-test-slice + other-modules: Moonlight.Triangulation.SerializationSpec + build-depends: + binary >= 0.8 && < 0.9 + , bytestring >= 0.12 && < 0.13 + , moonlight-triangulation:serialize + +-- The operand meshes both algebra slices are stated over. It sits at the +-- surface tier with them, so the fixtures cannot quietly acquire a +-- machine-room dependency that the law slice would then inherit. +common triangulation-algebra-fixture-slice + other-modules: Moonlight.Triangulation.AlgebraFixtures + build-depends: containers >= 0.8 && < 0.9 + +-- The finite-set laws, stated against the facade a caller has. +common triangulation-algebra-law-slice + other-modules: Moonlight.Triangulation.AlgebraSpec + build-depends: containers >= 0.8 && < 0.9 + +-- The agreement between the seam schedule and the reference rebuild. It names +-- an internal schedule, so it reaches below the wall and travels with the +-- schedule it names: a replacement kernel carries its own copy of this. +common triangulation-algebra-schedule-slice + other-modules: Moonlight.Triangulation.ScheduleAgreementSpec + build-depends: moonlight-triangulation:build + +common triangulation-parallel-test-slice + other-modules: Moonlight.Triangulation.ParallelSpec + ghc-options: -threaded -rtsopts + build-depends: moonlight-triangulation:parallel + +-- The single statement of the RTS environment every suite runs under: -N so +-- that the concurrent tournament has more than one capability to be scheduled +-- onto, -T so that the filtered-predicate test can read allocation counters. +-- It is one stanza rather than a line on each slice because @-with-rtsopts@ +-- concatenates rather than replaces, so naming it twice in one suite produces +-- a spliced string the RTS rejects entirely. Every behavioral suite that +-- needs those capabilities imports this exactly once; the compile-only +-- coherence suite deliberately installs no runtime defaults. +common triangulation-suite-rtsopts + ghc-options: -threaded -rtsopts "-with-rtsopts=-N4 -T" + +test-suite moonlight-triangulation-native-test + import: + triangulation-suite-rtsopts, + triangulation-test-properties, + triangulation-test-support-slice, + triangulation-native-test-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/native + test/support + +test-suite moonlight-triangulation-serialization-test + import: + triangulation-test-properties, + triangulation-test-support-slice, + triangulation-serialization-test-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/serialization + test/support + +test-suite moonlight-triangulation-algebra-test + import: + triangulation-test-properties, + triangulation-test-support-slice, + triangulation-algebra-fixture-slice, + triangulation-algebra-law-slice, + triangulation-algebra-schedule-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/algebra + test/support + +test-suite moonlight-triangulation-parallel-test + import: + triangulation-suite-rtsopts, + triangulation-test-properties, + triangulation-test-support-slice, + triangulation-algebra-fixture-slice, + triangulation-parallel-test-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/parallel + test/algebra + test/support + +-- This component owns only cross-slice compile coherence. Behavioral ownership +-- remains in the four focused suites. The shared test-properties stanza keeps +-- every test body at @-O0@, so the union retains type/module/instance collision +-- detection without paying to optimize a second copy of every test body. +test-suite moonlight-triangulation-coherence-test + import: + triangulation-test-properties, + triangulation-test-support-slice, + triangulation-native-test-slice, + triangulation-serialization-test-slice, + triangulation-algebra-fixture-slice, + triangulation-algebra-law-slice, + triangulation-algebra-schedule-slice, + triangulation-parallel-test-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test/coherence + test/native + test/serialization + test/algebra + test/parallel + test/support + +-- ── benchmark slices ───────────────────────────────────────────────────────── +-- Deliberately not @tasty-bench@: these report allocated bytes and the work +-- counters the library keeps about itself — hierarchy walk steps, refinement +-- queue pops, bytes per interpolation query — and a wall-clock harness cannot +-- express any of them. @core@ and @serialize@ carry no benchmark today; that is +-- stated rather than filled with an invented one. + +common triangulation-benchmark-properties + import: shared-properties + -- The allocation arms read GHC.Stats, which is dark without -T. As with the + -- test suites, @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so + -- it must appear exactly once per benchmark: this stanza is that one place, + -- and no benchmark slice may name it again. + ghc-options: -threaded -rtsopts "-with-rtsopts=-T" + build-depends: + base >= 4.20 && < 5 + , deepseq >= 1.5 && < 1.6 + , vector >= 0.13 && < 0.14 + , moonlight-triangulation + +common triangulation-benchmark-support-slice + other-modules: BenchSupport + +common triangulation-build-benchmark-slice + other-modules: Moonlight.Triangulation.BuildBench + build-depends: + primitive >= 0.9 && < 0.10 + , moonlight-triangulation:dcel + , moonlight-triangulation:build + +common triangulation-dcel-benchmark-slice + other-modules: Moonlight.Triangulation.DcelBench + build-depends: moonlight-triangulation:dcel + +common triangulation-dual-benchmark-slice + other-modules: Moonlight.Triangulation.DualBench + build-depends: moonlight-triangulation:dual + +common triangulation-join-benchmark-slice + other-modules: Moonlight.Triangulation.JoinBench + build-depends: + moonlight-triangulation:dcel + , moonlight-triangulation:build + +benchmark moonlight-triangulation-build-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-build-benchmark-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench/build + bench/support + +benchmark moonlight-triangulation-dcel-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-dcel-benchmark-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench/dcel + bench/support + +benchmark moonlight-triangulation-dual-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-dual-benchmark-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench/dual + bench/support + +benchmark moonlight-triangulation-join-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-join-benchmark-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench/join + bench/support + +benchmark moonlight-triangulation-publication-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-join-benchmark-slice + type: exitcode-stdio-1.0 + main-is: PublicationMain.hs + hs-source-dirs: + bench/publication + bench/join + bench/support + +benchmark moonlight-triangulation-bench + import: + triangulation-benchmark-properties, + triangulation-benchmark-support-slice, + triangulation-build-benchmark-slice, + triangulation-dcel-benchmark-slice, + triangulation-dual-benchmark-slice, + triangulation-join-benchmark-slice + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench/aggregate + bench/build + bench/dcel + bench/dual + bench/join + bench/support diff --git a/src-build/Moonlight/Triangulation/BulkLoad.hs b/src-build/Moonlight/Triangulation/BulkLoad.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/BulkLoad.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Generation. @delaunay@ builds a mesh from a whole site set by circle sweep; +-- the insertion verbs extend an existing mesh one site at a time. +module Moonlight.Triangulation.BulkLoad + ( empty + , clear + , delaunay + , DuplicatePayloadPolicy (..) + , delaunayFromCoordinates + , insert + , insertAt + , insertMany + ) where + +import Control.Monad (forM_) +import Control.Monad.ST (ST, runST) +import qualified Data.IntSet as IntSet +import Data.Primitive.PrimArray + ( MutablePrimArray + , newPrimArray + , unsafeFreezePrimArray + , writePrimArray + ) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices) +import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..), VertexId (..)) +import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector, boxedUpdate, emptyBoxedPaged) +import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) +import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation, insertVertexAtPoint) +import Moonlight.Triangulation.Internal.Location (MutableLocation (..)) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , freezeBuildStats + , newOperationState + , setCounter + ) +import Moonlight.Triangulation.Internal.CircleSweep (circleSweepInsert) +import Moonlight.Triangulation.Internal.PointIndex + ( MutablePointIndex + , emptyPointIndex + , newMutablePointIndex + , resolveMutablePoint + , seedMutablePointIndex + ) +import Moonlight.Triangulation.Math (canonicalCoordinate, validatePoint) +import Moonlight.Triangulation.PointLocation (locatePointWithHint) +import Moonlight.Triangulation.Internal.Probe (Probe (..)) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.PackedIndex (noIndex) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction), emptyPaged, fromVector) +import Moonlight.Triangulation.Internal.Transaction (runTransaction) +import Moonlight.Triangulation.Types + +-- | The vertexless triangulation: the outer face and nothing else. This is the +-- canonical origin of the type — bulk loading, incremental insertion and +-- refinement all agree with growing this value. +empty + :: ElementDefaults directed undirected face + -> Triangulation mode vertex directed undirected face +empty defaults@ElementDefaults{defaultDirectedEdgeData, defaultUndirectedEdgeData, defaultFaceData} = + Triangulation + { triPointX = emptyPaged + , triPointY = emptyPaged + , triPointIndex = emptyPointIndex + , triVertexOut = emptyPaged + , triVertexData = emptyBoxedPaged Nothing + , triHalfTopology = emptyPaged + , triDirectedData = emptyBoxedPaged (Just defaultDirectedEdgeData) + , triUndirectedData = emptyBoxedPaged (Just defaultUndirectedEdgeData) + , triFaceEdge = fromVector noIndex (U.singleton noIndex) + , triFaceData = boxedFromVector (Just defaultFaceData) (V.singleton defaultFaceData) + , triConstraint = emptyPaged + , triConstraintCount = 0 + , triConstraintEdges = IntSet.empty + , triElementDefaults = defaults + } + +-- | Discard every vertex while retaining the element defaults the +-- triangulation was built with. +clear + :: Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed undirected face +clear = empty . triElementDefaults + +-- | How a canonical bulk source combines payloads whose exact coordinates +-- coincide. Geometry identity is settled independently by the point index. +data DuplicatePayloadPolicy vertex + = KeepFirstPayload + | CombineDuplicatePayload !(vertex -> vertex -> vertex) + +-- | Build a finite Delaunay DCEL while preserving the first input payload at +-- every duplicate position. The returned mapping relates every input slot to +-- the canonical stored vertex. +delaunay + :: forall vertex directed undirected face + . HasPosition vertex + => ElementDefaults directed undirected face + -> V.Vector vertex + -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face) +delaunay defaults input = do + validateVertices input + buildDelaunayFromSource + defaults + (V.length input) + (position . (input V.!)) + (input V.!) + KeepFirstPayload + +-- | Canonical construction from separate geometry and annotation sources. +-- The coordinate vector remains the only geometry in ingress; payloads never +-- acquire a fabricated 'HasPosition' instance merely to reach the loader. +delaunayFromCoordinates + :: forall vertex directed undirected face + . ElementDefaults directed undirected face + -> V.Vector (Point) + -> V.Vector vertex + -> DuplicatePayloadPolicy vertex + -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face) +delaunayFromCoordinates defaults coordinates payloads duplicatePolicy + | coordinateCount /= payloadCount = + Left (CoordinatePayloadCountMismatch coordinateCount payloadCount) + | otherwise = do + V.iforM_ coordinates (\index point -> validatePoint (Just index) point) + buildDelaunayFromSource + defaults + coordinateCount + (coordinates V.!) + (payloads V.!) + duplicatePolicy + where + !coordinateCount = V.length coordinates + !payloadCount = V.length payloads + +buildDelaunayFromSource + :: forall vertex directed undirected face + . ElementDefaults directed undirected face + -> Int + -> (Int -> Point) + -> (Int -> vertex) + -> DuplicatePayloadPolicy vertex + -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face) +buildDelaunayFromSource defaults inputCount pointAtInput payloadAtInput duplicatePolicy = do + ensureCapacity inputCount + runST $ do + mutable <- newMutableDcel defaults inputCount + operation <- newOperationState (halfEdgeCapacity mutable) + table <- newMutablePointIndex inputCount + mapping <- newPrimArray inputCount + ingressed <- ingress mutable operation table mapping 0 0 0 + case ingressed of + Left failure -> pure (Left failure) + Right (sumX, sumY) -> do + unique <- pointCount mutable + inserted <- + if unique == 0 + then pure (Right 0) + else do + let !scale = recip (fromIntegral unique) + arena <- + fillRadialArena + mutable + (sumX * scale) + (sumY * scale) + (\index -> pure (fromIntegral index)) + unique + circleSweepInsert mutable operation arena + case inserted of + Left failure -> pure (Left failure) + Right seedCount -> do + setCounter operation CounterSpatialSeedPoints seedCount + frozenOutcome <- freezeTriangulation mutable + case frozenOutcome of + Left failure -> pure (Left failure) + Right frozen -> do + mapped <- unsafeFreezePrimArray mapping + stats <- freezeBuildStats operation + pure + ( Right + BuildResult + { buildTriangulation = frozen + , buildInputVertices = mapped + , buildStats = stats + } + ) + where + -- One indexed ingress loop: read the position once, claim it against the + -- transient table, write the input mapping, and accumulate the sort centre + -- over the vertices that are actually new. No list, no decorated vector. + ingress + :: forall s + . MutableDcel s vertex directed undirected face + -> OperationState s + -> MutablePointIndex s + -> MutablePrimArray s Word32 + -> Int + -> Double + -> Double + -> ST s (Either BuildError (Double, Double)) + ingress mutable operation table mapping !index !sumX !sumY + | index >= inputCount = pure (Right (sumX, sumY)) + | otherwise = do + addCounter operation CounterInputPoints 1 + let !vertexData = payloadAtInput index + claimed <- claimPosition mutable table (pointAtInput index) vertexData + case claimed of + Left failure -> pure (Left failure) + Right (vertex, fresh) -> do + writePrimArray mapping index (fromIntegral vertex) + if fresh + then do + addCounter operation CounterUniquePoints 1 + x <- readPointX mutable vertex + y <- readPointY mutable vertex + ingress mutable operation table mapping (index + 1) (sumX + x) (sumY + y) + else do + case duplicatePolicy of + KeepFirstPayload -> pure () + CombineDuplicatePayload combine -> do + resident <- vertexDataAt mutable vertex + writeVertexData mutable vertex (combine resident vertexData) + addCounter operation CounterDuplicatePoints 1 + ingress mutable operation table mapping (index + 1) sumX sumY + +-- | Insert or replace a vertex payload. A payload at an existing position is +-- overwritten without changing topology. +-- +-- The published mesh is independent of the one passed in. A singleton below +-- ten thousand resident sites copies densely; larger bases publish through +-- copy-on-write pages. A caller inserting a sequence wants one +-- 'Moonlight.Triangulation.Session.withSession' over +-- 'Moonlight.Triangulation.Session.insertVertex' instead — see 'insertAt'. +insert + :: HasPosition vertex + => Triangulation mode vertex directed undirected face + -> vertex + -> Either BuildError (InsertionResult mode vertex directed undirected face) +insert triangulation vertexData = insertAt triangulation (position vertexData) vertexData + +-- | Insert at a stated point. 'insert' is this with the point read out of the +-- payload, which is what a caller holding only a payload wants; a caller that +-- computed the point — a constraint split, a Steiner refinement — wants to say +-- so rather than build a payload and hope the round trip through 'HasPosition' +-- returns what it started with. +-- +-- This is one shaped transaction over a single insertion. Replacing a fold of +-- it with one session is sound because the two agree on every mesh and differ +-- only in how many intermediate meshes they publish. A fold publishes @k@ +-- meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays one +-- thaw and runs in O(k·log n) expected. +insertAt + :: Triangulation mode vertex directed undirected face + -> Point + -> vertex + -> Either BuildError (InsertionResult mode vertex directed undirected face) +insertAt triangulation rawPoint vertexData = do + queryPoint <- validatePoint Nothing rawPoint + case locatePointWithHint triangulation Nothing queryPoint of + (OnVertex resident, walked) -> + Right (replaceResidentPayload triangulation resident walked vertexData) + (located, walked) -> do + let transactionShape = + if numVertices triangulation < 10_000 + then DenseTransaction + else LocalTransaction + ((vertex, disposition), frozen, stats) <- + runTransaction + id + transactionShape + triangulation + 1 + (\mutable operation -> do + addCounter operation CounterInputPoints 1 + inserted <- + case located of + -- A frozen degenerate-line location points at an arbitrary visible + -- segment, while the line extension interpreter requires a terminal + -- edge. The frozen section carries no terminal witness, so retain + -- the existing mutable line locator for this one non-lawful case. + OutsideConvexHull (Just _) + | numInnerFaces triangulation == 0 -> + insertVertexAtPoint @'ProbeOff mutable operation Nothing (queryPointValue queryPoint) vertexData + _ -> do + capacityOutcome <- ensurePointCapacity mutable 1 + case capacityOutcome of + Left failure -> pure (Left failure) + Right () -> do + vertex <- appendVertex mutable (queryPointValue queryPoint) vertexData + let thawedLocation = + case located of + EmptyTriangulation -> MutableEmpty + OnEdge (DirectedEdgeId raw) -> MutableOnEdge (fromIntegral raw) + InFace (FaceId raw) -> MutableInFace (fromIntegral raw) + -- The frozen locator emits no edge only for a + -- singleton mesh. Its mutable interpreter ignores + -- this sentinel while constructing the second vertex. + OutsideConvexHull Nothing -> MutableOutsideHull 0 + OutsideConvexHull (Just (DirectedEdgeId raw)) -> MutableOutsideHull (fromIntegral raw) + ((vertex, Inserted) <$) <$> insertExistingVertexAtLocation @'ProbeOff mutable operation vertex thawedLocation + case inserted of + Left failure -> pure (Left failure) + Right (vertex, disposition) -> do + case disposition of + Inserted -> addCounter operation CounterUniquePoints 1 + AlreadyPresent -> do + writeVertexData mutable vertex vertexData + addCounter operation CounterExistingPoints 1 + addCounter operation CounterDuplicatePoints 1 + pure (Right (vertex, disposition)) + ) + pure + InsertionResult + { insertionTriangulation = frozen + , insertionVertex = VertexId (fromIntegral vertex) + , insertionDisposition = disposition + , insertionStats = withFrozenLocationStats walked stats + } + +-- | Publish a payload replacement without opening a transaction. +-- +-- A position already resident changes exactly one thing: the payload slot the +-- vertex already occupies. No coordinate, no half-edge, no constraint flag and +-- no face record differs, so the five unboxed planes are the ones the argument +-- already holds rather than copies taken out of it — which is what a thaw costs +-- and what this exists to refuse. They are immutable values; nothing reached +-- from here is a mutable buffer, and 'boxedUpdate' materializes a fresh page +-- for the one it rewrites, leaving the argument's own directory intact. +-- +-- The location counters are the frozen walk's, not a thawed walk's. They +-- describe the walk that actually ran. +replaceResidentPayload + :: Triangulation mode vertex directed undirected face + -> VertexId + -> LocationStats + -> vertex + -> InsertionResult mode vertex directed undirected face +replaceResidentPayload triangulation resident@(VertexId raw) walked vertexData = + InsertionResult + { insertionTriangulation = + triangulation + { triVertexData = + boxedUpdate (fromIntegral raw) vertexData (triVertexData triangulation) + } + , insertionVertex = resident + , insertionDisposition = AlreadyPresent + , insertionStats = + withFrozenLocationStats + walked + emptyBuildStats + { statInputPoints = 1 + , statExistingPoints = 1 + , statDuplicatePoints = 1 + } + } + +-- | Add the frozen locator's observation to the local topology interpreter's +-- operation-owned counters. Direct frozen-site insertion contributes no mutable +-- walk; the degenerate fallback contributes its real mutable walk rather than +-- having it erased from the published result. +withFrozenLocationStats :: LocationStats -> BuildStats -> BuildStats +withFrozenLocationStats walked stats = + stats + { statLocationWalkSteps = locationWalkSteps walked + statLocationWalkSteps stats + , statLocationMaxWalk = max (locationWalkSteps walked) (statLocationMaxWalk stats) + , statLocationFallbacks = (if locationUsedFallback walked then 1 else 0) + statLocationFallbacks stats + } + +-- | Apply a batch in one page transaction. Duplicate positions are processed +-- in input order, so their last payload wins exactly as repeated 'insert' +-- calls would, while topology is inserted only once per new position. +insertMany + :: forall mode vertex directed undirected face + . HasPosition vertex + => Triangulation mode vertex directed undirected face + -> V.Vector vertex + -> Either BuildError (BuildResult mode vertex directed undirected face) +insertMany triangulation input = do + validateVertices input + ensureCapacity (numVertices triangulation + V.length input) + runST $ do + mutable <- + thawTriangulationDense + (numVertices triangulation + V.length input) + triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + table <- newMutablePointIndex (numVertices triangulation + V.length input) + seeded <- seedPointTable mutable table + case seeded of + Left failure -> pure (Left failure) + Right () -> do + mapping <- newPrimArray (V.length input) + freshBuffer <- MUV.new (V.length input) + filled <- fill mutable operation table mapping freshBuffer 0 0 0 0 + case filled of + Left failure -> pure (Left failure) + Right (sumX, sumY, freshCount) -> do + inserted <- + if freshCount == 0 + then pure (Right 0) + else do + let !scale = recip (fromIntegral freshCount) + arena <- + fillRadialArena + mutable + (sumX * scale) + (sumY * scale) + (MUV.unsafeRead freshBuffer) + freshCount + circleSweepInsert mutable operation arena + case inserted of + Left failure -> pure (Left failure) + Right seedCount -> do + setCounter operation CounterSpatialSeedPoints seedCount + frozenOutcome <- freezeTriangulation mutable + case frozenOutcome of + Left failure -> pure (Left failure) + Right frozen -> do + mapped <- unsafeFreezePrimArray mapping + stats <- freezeBuildStats operation + pure + ( Right + BuildResult + { buildTriangulation = frozen + , buildInputVertices = mapped + , buildStats = stats + } + ) + where + fill + :: forall s + . MutableDcel s vertex directed undirected face + -> OperationState s + -> MutablePointIndex s + -> MutablePrimArray s Word32 + -> MUV.MVector s Word32 + -> Int + -> Double + -> Double + -> Int + -> ST s (Either BuildError (Double, Double, Int)) + fill mutable operation table mapping freshBuffer !index !sumX !sumY !freshCount + | index >= V.length input = pure (Right (sumX, sumY, freshCount)) + | otherwise = do + addCounter operation CounterInputPoints 1 + let !vertexData = input V.! index + claimed <- claimPosition mutable table (position vertexData) vertexData + case claimed of + Left failure -> pure (Left failure) + Right (vertex, fresh) -> do + writePrimArray mapping index (fromIntegral vertex) + if fresh + then do + addCounter operation CounterUniquePoints 1 + MUV.unsafeWrite freshBuffer freshCount (fromIntegral vertex) + x <- readPointX mutable vertex + y <- readPointY mutable vertex + fill + mutable + operation + table + mapping + freshBuffer + (index + 1) + (sumX + x) + (sumY + y) + (freshCount + 1) + else do + writeVertexData mutable vertex vertexData + addCounter operation CounterExistingPoints 1 + addCounter operation CounterDuplicatePoints 1 + fill mutable operation table mapping freshBuffer (index + 1) sumX sumY freshCount + +-- | One packed radial record per swept vertex — the derived sort fields and +-- the vertex handle, nothing else — filled straight from the coordinate +-- arenas and consumed in place by the sweep. The squared distance is stated +-- against the ingress-accumulated centre, in the widened comparison format. +fillRadialArena + :: MutableDcel s vertex directed undirected face + -> Double + -> Double + -> (Int -> ST s Word32) + -> Int + -> ST s (MUV.MVector s (Double, Double, Double, Word32)) +fillRadialArena mutable centerX centerY lookupId count = do + arena <- MUV.new count + forM_ [0 .. count - 1] $ \index -> do + raw <- lookupId index + x <- readPointX mutable (fromIntegral raw) + y <- readPointY mutable (fromIntegral raw) + let !wideX = x + !wideY = y + !deltaX = centerX - wideX + !deltaY = centerY - wideY + MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, wideX, wideY, raw) + pure arena + +-- | Claim a position for the vertex the arena would append next, or answer the +-- vertex already holding it. The claim is written before the append, so the two +-- must stay adjacent: nothing may consume a vertex slot in between. +claimPosition + :: MutableDcel s vertex directed undirected face + -> MutablePointIndex s + -> Point + -> vertex + -> ST s (Either BuildError (Int, Bool)) +claimPosition mutable table rawPoint vertexData = + case rawPoint of + Point x y -> do + let !canonicalX = canonicalCoordinate x + !canonicalY = canonicalCoordinate y + candidate <- pointCount mutable + owner <- + resolveMutablePoint + table + (readPointX mutable) + (readPointY mutable) + canonicalX + canonicalY + candidate + case owner of + Left failure -> pure (Left failure) + Right (Just existing) -> pure (Right (existing, False)) + Right Nothing -> do + vertex <- appendVertexCoordinates mutable canonicalX canonicalY vertexData + pure (Right (vertex, True)) +-- | Enter the positions a batch inherits from the triangulation it extends, so +-- that an input repeating one of them maps to the vertex already there. +seedPointTable + :: MutableDcel s vertex directed undirected face + -> MutablePointIndex s + -> ST s (Either BuildError ()) +seedPointTable mutable table = do + existing <- pointCount mutable + seedMutablePointIndex + table + existing + (readPointX mutable) + (readPointY mutable) + +validateVertices :: HasPosition vertex => V.Vector vertex -> Either BuildError () +validateVertices vertices = + V.iforM_ vertices (\index vertexData -> validatePoint (Just index) (position vertexData)) diff --git a/src-build/Moonlight/Triangulation/Cdt.hs b/src-build/Moonlight/Triangulation/Cdt.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Cdt.hs @@ -0,0 +1,120 @@ +-- | The constraint layer: the partial map from sites and segments, defined +-- exactly on realizable segment sets and naming its witness where it is not. +module Moonlight.Triangulation.Cdt + ( ConstrainedDelaunayTriangulation + , CdtError (..) + , CorridorObstruction (..) + , ConstraintResult (..) + , ConstraintOutcome (..) + , ConstraintBatchStats (..) + , ConstraintBatchResult (..) + , ConstrainedExtensionResult (..) + , ConstrainedSeamSource (..) + , ConstrainedSeamFaceEvidence + , constrainedSeamSourceFace + , constrainedSeamTargetFace + , constrainedSeamFaceFirstPoint + , constrainedSeamFaceSecondPoint + , constrainedSeamFaceThirdPoint + , ConstrainedSeamConstraintEvidence + , constrainedSeamConstraintSegment + , constrainedSeamConstraintRecovery + , ConstrainedSeamResult + , constrainedSeamResultTriangulation + , constrainedSeamLeftFaceEvidence + , constrainedSeamRightFaceEvidence + , constrainedSeamNewFaces + , constrainedSeamLeftConstraintEvidence + , constrainedSeamRightConstraintEvidence + , constrainedSeamConstraintStats + , constrainedSeamBuildStats + , ConstraintSplitBatchResult (..) + , CdtBuildResult (..) + , constrainedDelaunay + , constrainedDelaunayMaximal + , fromDelaunay + , constraintEdges + , CanonicalSegment + , segmentStart + , segmentEnd + , ConstraintConflict + , conflictFirstSegment + , conflictSecondSegment + , ConstrainedUnionError (..) + , constraintSegments + , unionConstrainedWith + , unionConstrained + , joinSeparatedConstrainedWith + , extendConstrainedWith + , constraintStorageBytes + , existsConstraint + , canAddConstraint + , intersectsConstraint + , getConflictingEdgesBetweenPoints + , getConflictingEdgesBetweenVertices + , recoverConstraints + , addConstraintEdge + , addConstraintEdges + , addConstraintAndSplit + , addConstraintsAndSplit + , removeConstraintEdge + , outerRegionFaces + , boundedRegionFaces + ) where + +import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints) +import Moonlight.Triangulation.Internal.Cdt.Build + ( constrainedDelaunay + , constrainedDelaunayMaximal + , fromDelaunay + ) +import Moonlight.Triangulation.Internal.Cdt.Query + ( canAddConstraint + , constraintEdges + , constraintStorageBytes + , existsConstraint + , getConflictingEdgesBetweenPoints + , getConflictingEdgesBetweenVertices + , intersectsConstraint + ) +import Moonlight.Triangulation.Internal.Cdt.Region + ( boundedRegionFaces + , outerRegionFaces + ) +import Moonlight.Triangulation.Internal.Cdt.Segment + ( addConstraintEdge + , addConstraintEdges + , removeConstraintEdge + ) +import Moonlight.Triangulation.Internal.Cdt.Split + ( addConstraintAndSplit + , addConstraintsAndSplit + ) +import Moonlight.Triangulation.Internal.Cdt.Types + ( CanonicalSegment (..) + , CdtBuildResult (..) + , CdtError (..) + , ConstrainedUnionError (..) + , ConstraintBatchResult (..) + , ConstraintBatchStats (..) + , ConstrainedExtensionResult (..) + , ConstrainedSeamConstraintEvidence (..) + , ConstrainedSeamFaceEvidence (..) + , ConstrainedSeamResult (..) + , ConstrainedSeamSource (..) + , ConstraintConflict (..) + , ConstraintOutcome (..) + , ConstraintResult (..) + , ConstraintSplitBatchResult (..) + , CorridorObstruction (..) + ) +import Moonlight.Triangulation.Internal.Cdt.Union + ( constraintSegments + , extendConstrainedWith + , joinSeparatedConstrainedWith + , unionConstrained + , unionConstrainedWith + ) +import Moonlight.Triangulation.Internal.Representation + ( ConstrainedDelaunayTriangulation + ) diff --git a/src-build/Moonlight/Triangulation/Insertion.hs b/src-build/Moonlight/Triangulation/Insertion.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Insertion.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Moonlight.Triangulation.Insertion + ( insertExistingVertex + , insertExistingVertexWithHint + , insertPointCombining + , insertVertexAtPoint + , insertExistingVertexAtLocation + ) where + +import Control.Monad.ST (ST) +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.Location +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + ) +import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..)) +import Moonlight.Triangulation.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. +insertPointCombining + :: (vertex -> vertex -> vertex) + -> Maybe Int + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> Point + -> vertex + -> ST s (Either BuildError (Int, InsertionDisposition)) +insertPointCombining combine seed mutable operation point payload = + case validatePoint Nothing point of + Left failure -> pure (Left failure) + Right _ -> 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) +{-# INLINE insertPointCombining #-} + +insertExistingVertex + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> ST s (Either BuildError ()) +insertExistingVertex mutable operation = insertExistingVertexWithHint @p mutable operation Nothing + +-- | Insert a materialized vertex while beginning point location from a face +-- already known to be geometrically adjacent to the request. The hint changes +-- only the amount of walking; the located site remains authoritative. +insertExistingVertexWithHint + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe Int + -> Int + -> ST s (Either BuildError ()) +insertExistingVertexWithHint mutable operation hint vertex = do + query <- pointAt mutable vertex + located <- locateMutable mutable operation hint query + case located of + Left obstruction -> pure (Left obstruction) + Right site -> insertExistingVertexAtLocation @p mutable operation vertex site + +-- | Locate before materializing a point, so duplicate detection remains a +-- topological fact rather than a resident coordinate index. +insertVertexAtPoint + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe Int + -> Point + -> vertex + -> ST s (Either BuildError (Int, InsertionDisposition)) +insertVertexAtPoint mutable operation hint point vertexData = do + located <- locateMutable mutable operation hint point + case located of + Left obstruction -> pure (Left obstruction) + Right (MutableOnVertex existing) -> pure (Right (existing, AlreadyPresent)) + Right site -> do + capacity <- ensurePointCapacity mutable 1 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + vertex <- appendVertex mutable point vertexData + inserted <- insertExistingVertexAtLocation @p mutable operation vertex site + pure ((vertex, Inserted) <$ inserted) + +-- | Interpret a point-location result without locating the same point again. +-- Callers may hold this witness only while no topology mutation intervenes. +-- +-- The site decides which counts are consulted, and the vertex's own point is +-- read only by the two strata that compare against it — the degenerate line and +-- the failure report. The area strata already stand on a located site and would +-- otherwise rebuild a point the locate stage was handed. +insertExistingVertexAtLocation + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> MutableLocation + -> ST s (Either BuildError ()) +insertExistingVertexAtLocation mutable operation vertex located = + case located of + MutableOnVertex existing -> + pure + ( Left + ( FreshInsertionMatchedExistingVertex + (VertexId (fromIntegral vertex)) + (VertexId (fromIntegral existing)) + ) + ) + MutableEmpty -> do + connected <- connectedCount mutable + if connected == 0 + then setupFirstVertex mutable vertex >> pure (Right ()) + else locationFailed + MutableOnEdge edge -> do + faces <- faceCount mutable + if faces <= 1 + then splitLineEdge mutable operation edge vertex + else insertOnEdge @p mutable operation edge vertex + MutableInFace face -> do + faces <- faceCount mutable + if faces <= 1 + then locationFailed + else insertIntoFace @p mutable operation face vertex + MutableOutsideHull edge -> do + connected <- connectedCount mutable + if connected == 1 + then setupSecondVertex mutable vertex + else do + faces <- faceCount mutable + if faces <= 1 + then extendDegenerateLine edge + else insertOutsideHull @p mutable operation edge vertex + where + extendDegenerateLine edge = do + from <- edgeOriginPoint mutable edge + to <- edgeOriginPoint mutable (edge `xorInt` 1) + query <- pointAt mutable vertex + if orient2d from to query == EQ + then do + endpoint <- readOrigin mutable edge + extendLine mutable operation endpoint vertex + else lineToArea @p mutable operation vertex + + locationFailed = do + query <- pointAt mutable vertex + pure (Left (PointLocationFailed query)) + +xorInt :: Int -> Int -> Int +xorInt value 1 = if even value then value + 1 else value - 1 +xorInt value _ = value +{-# INLINE xorInt #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Capacity.hs b/src-build/Moonlight/Triangulation/Internal/Capacity.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Capacity.hs @@ -0,0 +1,18 @@ +-- | Admissibility of a requested vertex count against the packed index limit. +module Moonlight.Triangulation.Internal.Capacity + ( ensureCapacity + ) where + +import Moonlight.Triangulation.Internal.PackedIndex (indexLimit) +import Moonlight.Triangulation.Internal.Types (BuildError (..)) + +ensureCapacity :: Int -> Either BuildError () +ensureCapacity count + | count < 0 || count > maximumVertexCapacity = Left (CapacityExceeded count) + | otherwise = Right () + +-- Mutable allocation reserves @8n + 16@ directed-edge slots. Every topology +-- handle is packed below 'indexLimit', so admissibility is stated against that +-- actual representation bound rather than the machine 'Int' bound. +maximumVertexCapacity :: Int +maximumVertexCapacity = (indexLimit - 16) `quot` 8 diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Admission.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Admission.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Admission.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Immutable admission of one requested segment against the sparse +-- constrained-edge section, decided without thawing topology. +module Moonlight.Triangulation.Internal.Cdt.Admission + ( ConstraintAdmission (..) + , constraintAdmission + , segmentBoxesAreDisjoint + ) where + +import qualified Data.IntSet as IntSet +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math + +-- | Immutable admission descends through the sparse constrained-edge section, +-- not through every ordinary edge in the requested corridor. Constraint +-- cardinality is the lawful index here: rejection depends only on a proper +-- crossing with an existing protected segment, while shared endpoints, +-- duplicate segments, and collinear overlap remain recoverable by the mutable +-- corridor algebra. Accepted singleton requests descend once more inside their +-- sealed transaction; the overwhelmingly common rejected request stops here +-- without thawing topology. +data ConstraintAdmission + = ConstraintBlocked !UndirectedEdgeId + | ConstraintAdmitted + +constraintAdmission + :: Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> VertexId + -> ConstraintAdmission +constraintAdmission triangulation from to = + IntSet.foldr firstBlocking ConstraintAdmitted (triConstraintEdges triangulation) + where + !requestFrom = Dcel.vertexPoint triangulation from + !requestTo = Dcel.vertexPoint triangulation to + + firstBlocking raw later = + let !edge = UndirectedEdgeId (fromIntegral raw) + (!edgeFromId, !edgeToId) = Dcel.undirectedEndpoints triangulation edge + in if + from == edgeFromId + || from == edgeToId + || to == edgeFromId + || to == edgeToId + then later + else + let !edgeFrom = Dcel.vertexPoint triangulation edgeFromId + !edgeTo = Dcel.vertexPoint triangulation edgeToId + in if segmentBoxesAreDisjoint requestFrom requestTo edgeFrom edgeTo + then later + else + if segmentsProperlyCross requestFrom requestTo edgeFrom edgeTo + then ConstraintBlocked edge + else later + +segmentBoxesAreDisjoint + :: Point + -> Point + -> Point + -> Point + -> Bool +segmentBoxesAreDisjoint (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) = + max ax bx < min cx dx + || max cx dx < min ax bx + || max ay by < min cy dy + || max cy dy < min ay by +{-# INLINE segmentBoxesAreDisjoint #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | The batch interpreter: many constraint requests in order inside one sealed +-- dense transaction, with rejection carried as a value. +module Moonlight.Triangulation.Internal.Cdt.Batch + ( recoverConstraints + , recoverConstraintBatch + , initialConstraintBatchStats + , interpretConstraintRequest + , interpretConstraintRequests + ) where + +import Control.Monad.ST (ST) +import Data.Either (isRight) +import qualified Data.Vector as V +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM) +import Moonlight.Triangulation.Internal.Cdt.Query (validateEndpoints) +import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , newGrowableWord32 + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( OperationState ) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction)) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Transaction (runTransaction) +import Moonlight.Triangulation.Internal.Types (ConstraintMode (..)) + +-- | Interpret constraint requests in order inside one sealed mutable DCEL +-- transaction. Rejections are values because an earlier accepted request can +-- lawfully obstruct a later request; structural recovery failures remain typed +-- errors and prevent a partially rewritten mesh from escaping. The public batch +-- interpreter amortizes dense materialization; known singleton repair sites +-- reuse this algebra under the sparse persistent-page interpretation. +recoverConstraints + :: Triangulation 'Constrained vertex directed undirected face + -> V.Vector (VertexId, VertexId) + -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face) +recoverConstraints triangulation requests + | V.null requests = + Right + ConstraintBatchResult + { constraintBatchTriangulation = triangulation + , constraintBatchOutcomes = V.empty + , constraintBatchStats = initialConstraintBatchStats 0 + } + | otherwise = + recoverConstraintBatch + triangulation + requests + +recoverConstraintBatch + :: Triangulation 'Constrained vertex directed undirected face + -> V.Vector (VertexId, VertexId) + -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face) +recoverConstraintBatch triangulation requests = do + V.mapM_ (uncurry (validateEndpoints triangulation)) requests + (completed, frozen, _) <- + runTransaction + CdtBuildError + DenseTransaction + triangulation + 0 + (interpretConstraintRequests requests) + pure (finalizeConstraintBatch frozen completed) +{-# INLINE recoverConstraintBatch #-} + +-- | Interpret a complete constraint request section against an already-open +-- transaction. Both ordinary recovery and asymmetric constrained extension +-- use this one interpreter; callers decide only which request section is +-- resident before it begins. +interpretConstraintRequests + :: V.Vector (VertexId, VertexId) + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> ST s (Either (CdtError) ConstraintBatchAccumulator) +interpretConstraintRequests requests mutable operation = do + programWords <- newGrowableWord32 256 + let initialAccumulator = + ConstraintBatchAccumulator + { accumulatedConstraintOutcomes = [] + , accumulatedConstraintStats = + initialConstraintBatchStats (V.length requests) + } + foldWhileM + isRight + (interpretConstraintRequest programWords mutable operation) + (Right initialAccumulator) + requests +{-# INLINE interpretConstraintRequests #-} + +-- | Materialize the ordinary recovery receipt only after the enclosing +-- transaction has frozen. The mutable accumulator cannot escape as a partial +-- constrained mesh. +finalizeConstraintBatch + :: Triangulation 'Constrained vertex directed undirected face + -> ConstraintBatchAccumulator + -> ConstraintBatchResult vertex directed undirected face +finalizeConstraintBatch frozen completed = + ConstraintBatchResult + { constraintBatchTriangulation = frozen + , constraintBatchOutcomes = V.fromList (reverse (accumulatedConstraintOutcomes completed)) + , constraintBatchStats = accumulatedConstraintStats completed + } +{-# INLINE finalizeConstraintBatch #-} + +initialConstraintBatchStats :: Int -> ConstraintBatchStats +initialConstraintBatchStats requestCount = + ConstraintBatchStats + { constraintBatchRequests = requestCount + , constraintBatchAccepted = 0 + , constraintBatchRejected = 0 + , constraintBatchCorridors = 0 + , constraintBatchReusedFaces = 0 + , constraintBatchCrossedEdges = 0 + } + +interpretConstraintRequest + :: GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> Either (CdtError) ConstraintBatchAccumulator + -> (VertexId, VertexId) + -> ST s (Either (CdtError) ConstraintBatchAccumulator) +interpretConstraintRequest _ _ _ rejected@(Left _) _ = pure rejected +interpretConstraintRequest programWords mutable operation (Right accumulator) (from, to) = do + applied <- applyMutableConstraint programWords mutable operation from to + pure $ case applied of + Left obstruction -> Left obstruction + Right (MutableConstraintRejected blocking) -> + let previousStats = accumulatedConstraintStats accumulator + in Right + accumulator + { accumulatedConstraintOutcomes = + ConstraintRejected blocking : accumulatedConstraintOutcomes accumulator + , accumulatedConstraintStats = + previousStats + { constraintBatchRejected = constraintBatchRejected previousStats + 1 + } + } + Right (MutableConstraintAccepted request) -> + let previousStats = accumulatedConstraintStats accumulator + in Right + accumulator + { accumulatedConstraintOutcomes = + ConstraintAccepted + (V.fromList (reverse (accumulatedRequestPath request))) + (accumulatedRequestAddedEdges request) + : accumulatedConstraintOutcomes accumulator + , accumulatedConstraintStats = + previousStats + { constraintBatchAccepted = constraintBatchAccepted previousStats + 1 + , constraintBatchCorridors = + constraintBatchCorridors previousStats + accumulatedRequestCorridors request + , constraintBatchReusedFaces = + constraintBatchReusedFaces previousStats + accumulatedRequestReusedFaces request + , constraintBatchCrossedEdges = + constraintBatchCrossedEdges previousStats + accumulatedRequestCrossedEdges request + } + } diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Constrained bulk loading: an unconstrained load promoted to the +-- constrained layer, then driven through the batch corridor interpreter. +module Moonlight.Triangulation.Internal.Cdt.Build + ( fromDelaunay + , constrainedDelaunay + , constrainedDelaunayMaximal + ) where + +import qualified Data.Vector as V +import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray) +import Data.Word (Word32) +import Moonlight.Triangulation.BulkLoad (delaunay) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints) +import Moonlight.Triangulation.Internal.Cdt.Combinators (mapLeft) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types + +-- | Promote an unconstrained mesh into the constrained layer with no marked edges. +fromDelaunay + :: Triangulation 'Unconstrained vertex directed undirected face + -> Triangulation 'Constrained vertex directed undirected face +fromDelaunay = promoteConstrained + +-- | Build a constrained triangulation, refusing the complete request when any +-- input constraint cannot be admitted. +constrainedDelaunay + :: HasPosition vertex + => ElementDefaults directed undirected face + -> V.Vector vertex + -> V.Vector (Int, Int) + -> Either (CdtError) (BuildResult 'Constrained vertex directed undirected face) +constrainedDelaunay defaults inputVertices constraints = do + result <- constrainedDelaunayMaximal defaults inputVertices constraints + if V.null (cdtRejectedConstraints result) + then + Right + BuildResult + { buildTriangulation = cdtBuildTriangulation result + , buildInputVertices = cdtBuildInputVertices result + , buildStats = cdtBuildStats result + } + else Left (ConstraintInputConflicts (cdtRejectedConstraints result)) + +-- | Stable constrained bulk loading. Duplicate input vertices are rerouted to +-- the first surviving handle. Every proper constraint conflict is returned in +-- input order; accepted constraints remain in the result. +constrainedDelaunayMaximal + :: HasPosition vertex + => ElementDefaults directed undirected face + -> V.Vector vertex + -> V.Vector (Int, Int) + -> Either (CdtError) (CdtBuildResult vertex directed undirected face) +constrainedDelaunayMaximal defaults inputVertices constraints = do + built <- mapLeft CdtBuildError (delaunay defaults inputVertices) + let !mapping = buildInputVertices built + !initial = fromDelaunay (buildTriangulation built) + requests <- V.mapM (mapConstraintRequest mapping) constraints + batch <- recoverConstraints initial requests + let rejected = + V.mapMaybe + (\(request, outcome) -> + case outcome of + ConstraintAccepted _ _ -> Nothing + ConstraintRejected _ -> Just request + ) + (V.zip constraints (constraintBatchOutcomes batch)) + pure + CdtBuildResult + { cdtBuildTriangulation = constraintBatchTriangulation batch + , cdtBuildInputVertices = mapping + , cdtBuildStats = buildStats built + , cdtRejectedConstraints = rejected + } + where + mapConstraintRequest + :: PrimArray Word32 + -> (Int, Int) + -> Either (CdtError) (VertexId, VertexId) + mapConstraintRequest mapping (fromIndex, toIndex) = + (,) + <$> mapConstraintEndpoint mapping fromIndex + <*> mapConstraintEndpoint mapping toIndex + + mapConstraintEndpoint + :: PrimArray Word32 + -> Int + -> Either (CdtError) VertexId + mapConstraintEndpoint mapping endpointIndex + | endpointIndex >= 0 && endpointIndex < sizeofPrimArray mapping = + Right (VertexId (indexPrimArray mapping endpointIndex)) + | otherwise = + Left (ConstraintEndpointIndexOutOfRange endpointIndex (sizeofPrimArray mapping)) diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Bounded monadic folding, refusable transaction sequencing, and the handle +-- and error coercions the constrained layer shares. +module Moonlight.Triangulation.Internal.Cdt.Combinators + ( foldWhileM + , bindMutable + , asConstraintStep + , mapLeft + , vertexInt + , directedInt + ) where + +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId (..) + , VertexId (..) + ) +import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..)) +import Moonlight.Triangulation.Internal.Types (BuildError) + +-- | Monadic left fold whose continuation is supplied by a lazy right fold. +-- The state predicate decides descent before the next effect is constructed, +-- so graph walks stop at their authoritative local answer without mutable loop +-- control or traversing the unused safety suffix. +foldWhileM + :: (Foldable container, Monad monad) + => (state -> Bool) + -> (state -> item -> monad state) + -> state + -> container item + -> monad state +foldWhileM shouldContinue step initial items = + foldr + (\item continuation state -> + if shouldContinue state + then step state item >>= continuation + else pure state + ) + pure + items + initial +{-# INLINE foldWhileM #-} + +-- | Sequence two refusable transaction steps. Refusal short-circuits, so a +-- transaction that abandons never reaches its publication; writing the bind +-- once is what keeps the constraint verbs from nesting their case analysis +-- five deep. +bindMutable :: Monad monad => monad (Either failure a) -> (a -> monad (Either failure b)) -> monad (Either failure b) +bindMutable step continue = do + outcome <- step + case outcome of + Left failure -> pure (Left failure) + Right value -> continue value +{-# INLINE bindMutable #-} + +-- | Relabel a step whose refusal is a build failure, so it composes with the +-- constraint layer's own. +asConstraintStep :: Functor f => f (Either BuildError a) -> f (Either (CdtError) a) +asConstraintStep = fmap (mapLeft CdtBuildError) +{-# INLINE asConstraintStep #-} + +mapLeft :: (left -> right) -> Either left value -> Either right value +mapLeft convert = either (Left . convert) Right + +vertexInt :: VertexId -> Int +vertexInt (VertexId value) = fromIntegral value + +directedInt :: DirectedEdgeId -> Int +directedInt (DirectedEdgeId value) = fromIntegral value diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | The corridor walk: one traversal of the requested segment that yields +-- either the first oriented blocking witness or a complete recovery program. +module Moonlight.Triangulation.Internal.Cdt.Corridor + ( constraintWorkspaceFor + , scanMutableConstraint + , advanceMutablePlan + , continueMutablePlan + , beginMutableRecover + , finishMutableRecover + , settleMutableProgram + , mutablePlanIsActive + , writeConstraintProgram + , readConstraintProgram + , existingProgramTag + , recoverProgramTag + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.IntersectionIterator (Intersection (..)) +import Moonlight.Triangulation.Internal.Cdt.Combinators + ( directedInt + , foldWhileM + , vertexInt + ) +import Moonlight.Triangulation.Internal.Cdt.Corridor.Trace (nextMutableIntersection) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , clearGrowable + , readGrowable + , writeGrowable + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.Types (Point) + +-- | The walk budget bounds a corridor through the mesh as it stands, so it is +-- taken per request rather than per transaction: a verb that inserts before it +-- recovers has changed the mesh the budget describes. Recovery itself adds +-- neither vertex nor edge, so a batch reads the same number every time. +constraintWorkspaceFor + :: GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> ST s (ConstraintWorkspace s) +constraintWorkspaceFor constraintProgramWords mutable = do + halfEdges <- directedEdgeCount mutable + vertices <- pointCount mutable + pure + ConstraintWorkspace + { constraintProgramWords + , constraintWalkBudget = 2 * halfEdges + vertices + 8 + } + +writeConstraintProgram :: ConstraintWorkspace s -> Int -> Int -> ST s () +writeConstraintProgram ConstraintWorkspace{constraintProgramWords} index value = + writeGrowable constraintProgramWords index (fromIntegral value) +{-# INLINE writeConstraintProgram #-} + +readConstraintProgram :: ConstraintWorkspace s -> Int -> ST s Int +readConstraintProgram ConstraintWorkspace{constraintProgramWords} index = + fromIntegral <$> readGrowable constraintProgramWords index +{-# INLINE readConstraintProgram #-} + +-- | Walk one corridor once, gluing the local observations into either the +-- first oriented blocking witness or a complete recovery program. The former +-- admission/planning pair traversed every admitted corridor twice and could +-- disagree if either walk evolved independently; this scanner is their single +-- semantic owner. +scanMutableConstraint + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> VertexId + -> VertexId + -> ST s (Either (CdtError) MutableConstraintScan) +scanMutableConstraint workspace@ConstraintWorkspace{constraintProgramWords, constraintWalkBudget} mutable from to = do + clearGrowable constraintProgramWords + lineFrom <- pointAt mutable (vertexInt from) + lineTo <- pointAt mutable (vertexInt to) + initialCursor <- beginMutableRecover workspace 0 from 0 False + walked <- + foldWhileM + mutablePlanIsActive + (advanceMutablePlan workspace mutable lineFrom lineTo to) + (MutablePlanActive (VertexIntersection from) initialCursor) + [1 .. constraintWalkBudget] + pure $ case walked of + MutablePlanComplete plan -> Right (MutableConstraintScanAdmitted plan) + MutablePlanBlocked blocking -> Right (MutableConstraintScanBlocked blocking) + MutablePlanFailed obstruction -> Left (ConstraintCorridorObstructed obstruction) + MutablePlanActive _ _ -> + Left + ( ConstraintCorridorObstructed + (CorridorWalkDidNotTerminate constraintWalkBudget) + ) + +advanceMutablePlan + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> Point + -> Point + -> VertexId + -> MutablePlanWalk + -> Int + -> ST s MutablePlanWalk +advanceMutablePlan _ _ _ _ _ complete@(MutablePlanComplete _) _ = pure complete +advanceMutablePlan _ _ _ _ _ blocked@(MutablePlanBlocked _) _ = pure blocked +advanceMutablePlan _ _ _ _ _ failed@(MutablePlanFailed _) _ = pure failed +advanceMutablePlan workspace mutable lineFrom lineTo target (MutablePlanActive event cursor) _ = + case event of + EdgeIntersection directed -> do + constrained <- readConstraint mutable (directedInt directed) + if constrained + then pure (MutablePlanBlocked directed) + else do + writeConstraintProgram workspace (mutableCursorWriteAt cursor) (directedInt directed) + continueMutablePlan + workspace + mutable + lineFrom + lineTo + target + event + cursor + { mutableCursorWriteAt = mutableCursorWriteAt cursor + 1 + , mutableCursorConflictCount = mutableCursorConflictCount cursor + 1 + , mutableCursorAfterOverlap = False + } + VertexIntersection vertex + | mutableCursorAfterOverlap cursor -> + continueMutablePlan + workspace + mutable + lineFrom + lineTo + target + event + cursor{mutableCursorAfterOverlap = False} + | vertex == mutableCursorAt cursor -> + continueMutablePlan + workspace + mutable + lineFrom + lineTo + target + event + cursor{mutableCursorAfterOverlap = False} + | otherwise -> do + finished <- finishMutableRecover workspace vertex cursor + nextCursor <- + beginMutableRecover + workspace + (mutableCursorWriteAt finished) + vertex + (mutableCursorPieceCount finished) + False + continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor + EdgeOverlap rawDirected -> do + let rawEdge = directedInt rawDirected + rawOrigin <- readOrigin mutable rawEdge + rawDestination <- readOrigin mutable (rawEdge `xor` 1) + let current = vertexInt (mutableCursorAt cursor) + oriented + | rawOrigin == current = Just rawEdge + | rawDestination == current = Just (rawEdge `xor` 1) + | otherwise = Nothing + case oriented of + Nothing -> + pure + ( MutablePlanFailed + ( CorridorBoundaryMissing + (mutableCursorAt cursor) + (VertexId (fromIntegral rawOrigin)) + ) + ) + Just edge -> do + prefix <- + if mutableCursorConflictCount cursor == 0 + then pure cursor + else finishMutableRecover workspace (mutableCursorAt cursor) cursor + let !existingAt = + if mutableCursorConflictCount cursor == 0 + then mutableCursorHeader cursor + else mutableCursorWriteAt prefix + !edgeDestination = + VertexId + ( fromIntegral + (if edge == rawEdge then rawDestination else rawOrigin) + ) + !pieceCount = mutableCursorPieceCount prefix + 1 + !nextHeader = existingAt + 2 + writeConstraintProgram workspace existingAt existingProgramTag + writeConstraintProgram workspace (existingAt + 1) edge + nextCursor <- + beginMutableRecover + workspace + nextHeader + edgeDestination + pieceCount + True + continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor + +continueMutablePlan + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> Point + -> Point + -> VertexId + -> Intersection + -> MutableProgramCursor + -> ST s MutablePlanWalk +continueMutablePlan workspace mutable lineFrom lineTo target event cursor = do + following <- nextMutableIntersection mutable lineFrom lineTo event + case following of + Just nextEvent -> pure (MutablePlanActive nextEvent cursor) + Nothing -> MutablePlanComplete <$> settleMutableProgram workspace target cursor + +beginMutableRecover + :: ConstraintWorkspace s + -> Int + -> VertexId + -> Int + -> Bool + -> ST s MutableProgramCursor +beginMutableRecover workspace header from pieceCount afterOverlap = do + writeConstraintProgram workspace header recoverProgramTag + writeConstraintProgram workspace (header + 1) (vertexInt from) + writeConstraintProgram workspace (header + 2) 0 + writeConstraintProgram workspace (header + 3) 0 + pure + MutableProgramCursor + { mutableCursorAt = from + , mutableCursorHeader = header + , mutableCursorWriteAt = header + 4 + , mutableCursorConflictCount = 0 + , mutableCursorPieceCount = pieceCount + , mutableCursorAfterOverlap = afterOverlap + } + +finishMutableRecover + :: ConstraintWorkspace s + -> VertexId + -> MutableProgramCursor + -> ST s MutableProgramCursor +finishMutableRecover workspace to cursor = do + writeConstraintProgram workspace (mutableCursorHeader cursor + 2) (vertexInt to) + writeConstraintProgram workspace (mutableCursorHeader cursor + 3) (mutableCursorConflictCount cursor) + pure + cursor + { mutableCursorAt = to + , mutableCursorPieceCount = mutableCursorPieceCount cursor + 1 + } + +settleMutableProgram + :: ConstraintWorkspace s + -> VertexId + -> MutableProgramCursor + -> ST s MutableConstraintProgram +settleMutableProgram workspace target cursor + | mutableCursorAt cursor == target = + pure + MutableConstraintProgram + { mutableProgramWordCount = mutableCursorHeader cursor + , mutableProgramPieceCount = mutableCursorPieceCount cursor + } + | otherwise = do + finished <- finishMutableRecover workspace target cursor + pure + MutableConstraintProgram + { mutableProgramWordCount = mutableCursorWriteAt finished + , mutableProgramPieceCount = mutableCursorPieceCount finished + } + +existingProgramTag :: Int +existingProgramTag = 0 + +recoverProgramTag :: Int +recoverProgramTag = 1 + +mutablePlanIsActive :: MutablePlanWalk -> Bool +mutablePlanIsActive (MutablePlanActive _ _) = True +mutablePlanIsActive _ = False diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor/Trace.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor/Trace.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Corridor/Trace.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Local direction tracing inside the thawed mesh: where a directed line +-- leaves the vertex or edge it currently stands on. +module Moonlight.Triangulation.Internal.Cdt.Corridor.Trace + ( MutableVertexOut (..) + , MutableVertexTrace (..) + , MutableEdgeOut (..) + , nextMutableIntersection + , traceMutableDirectionOutOfVertex + , advanceMutableVertexTrace + , traceMutableDirectionOutOfEdge + , mutableEdgeIntersectsNonCollinear + , mutableVertexTraceIsSearching + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.IntersectionIterator +import Moonlight.Triangulation.Internal.Cdt.Combinators + ( directedInt + , foldWhileM + , vertexInt + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Scalar (orient2dCoordinates) + +data MutableVertexOut + = MutableVertexOutHull + | MutableVertexOutOverlap {-# UNPACK #-} !Int + | MutableVertexOutEdge {-# UNPACK #-} !Int + +data MutableVertexTrace + = MutableVertexTraceSearching {-# UNPACK #-} !Int !Ordering + | MutableVertexTraceComplete !MutableVertexOut + +data MutableEdgeOut + = MutableEdgeOutHull + | MutableEdgeOutVertex {-# UNPACK #-} !Int + | MutableEdgeOutEdge {-# UNPACK #-} !Int + | MutableEdgeOutNone + +nextMutableIntersection + :: MutableDcel s vertex directed undirected face + -> Point + -> Point + -> Intersection + -> ST s (Maybe Intersection) +nextMutableIntersection mutable lineFrom lineTo current = + case current of + EdgeIntersection directed -> do + edgeOut <- traceMutableDirectionOutOfEdge mutable (directedInt directed) lineFrom lineTo + pure $ case edgeOut of + MutableEdgeOutHull -> Nothing + MutableEdgeOutVertex vertex -> + Just (VertexIntersection (VertexId (fromIntegral vertex))) + MutableEdgeOutEdge edge -> + Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge))) + MutableEdgeOutNone -> Nothing + VertexIntersection vertex -> do + currentPoint <- pointAt mutable (vertexInt vertex) + if currentPoint == lineTo + then pure Nothing + else do + vertexOut <- traceMutableDirectionOutOfVertex mutable (vertexInt vertex) lineTo + case vertexOut of + MutableVertexOutHull -> pure Nothing + MutableVertexOutOverlap edge -> + pure (Just (EdgeOverlap (DirectedEdgeId (fromIntegral edge)))) + MutableVertexOutEdge edge -> do + edgeFrom <- edgeOriginPoint mutable edge + edgeTo <- edgeOriginPoint mutable (edge `xor` 1) + pure + ( if orient2d edgeFrom edgeTo lineTo == LT + then Nothing + else Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge))) + ) + EdgeOverlap directed + | lineFrom == lineTo -> pure Nothing + | otherwise -> do + destination <- readOrigin mutable (directedInt directed `xor` 1) + destinationPoint <- pointAt mutable destination + pure + ( if onClosedSegment lineFrom lineTo destinationPoint + then Just (VertexIntersection (VertexId (fromIntegral destination))) + else Nothing + ) + +traceMutableDirectionOutOfVertex + :: MutableDcel s vertex directed undirected face + -> Int + -> Point + -> ST s MutableVertexOut +traceMutableDirectionOutOfVertex mutable vertex target = do + start <- readVertexOut mutable vertex + if start < 0 + then pure MutableVertexOutHull + else do + currentPoint <- pointAt mutable vertex + startTarget <- edgeOriginPoint mutable (start `xor` 1) + halfEdges <- directedEdgeCount mutable + let startSide = orient2d currentPoint startTarget target + rotateCounterClockwise = startSide == GT + traced <- + foldWhileM + mutableVertexTraceIsSearching + (advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise) + (MutableVertexTraceSearching start startSide) + [0 .. halfEdges] + pure $ case traced of + MutableVertexTraceComplete result -> result + MutableVertexTraceSearching _ _ -> MutableVertexOutHull + +advanceMutableVertexTrace + :: MutableDcel s vertex directed undirected face + -> Point + -> Point + -> Bool + -> MutableVertexTrace + -> Int + -> ST s MutableVertexTrace +advanceMutableVertexTrace _ _ _ _ complete@(MutableVertexTraceComplete _) _ = pure complete +advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise (MutableVertexTraceSearching current currentSide) _ = do + currentTarget <- edgeOriginPoint mutable (current `xor` 1) + if currentSide == EQ && projectionFactor currentPoint currentTarget target >= 0 + then pure (MutableVertexTraceComplete (MutableVertexOutOverlap current)) + else do + following <- + if rotateCounterClockwise + then (`xor` 1) <$> readPrevious mutable current + else readNext mutable (current `xor` 1) + followingTarget <- edgeOriginPoint mutable (following `xor` 1) + let followingSide = orient2d currentPoint followingTarget target + if followingSide == EQ && projectionFactor currentPoint followingTarget target >= 0 + then pure (MutableVertexTraceComplete (MutableVertexOutOverlap following)) + else do + faceBetween <- + readFace mutable (if rotateCounterClockwise then current else following) + if faceBetween == 0 + then pure (MutableVertexTraceComplete MutableVertexOutHull) + else + if rotateCounterClockwise == (followingSide == LT) + then do + segment <- + if rotateCounterClockwise + then readNext mutable current + else readPrevious mutable (current `xor` 1) + pure + ( MutableVertexTraceComplete + (MutableVertexOutEdge (segment `xor` 1)) + ) + else pure (MutableVertexTraceSearching following followingSide) + +traceMutableDirectionOutOfEdge + :: MutableDcel s vertex directed undirected face + -> Int + -> Point + -> Point + -> ST s MutableEdgeOut +traceMutableDirectionOutOfEdge mutable edge lineFrom lineTo = do + incident <- readFace mutable edge + if incident == 0 + then pure MutableEdgeOutHull + else do + edgePrevious <- readPrevious mutable edge + edgeNext <- readNext mutable edge + edgeOrigin <- edgeOriginPoint mutable edge + oppositeVertex <- edgeOriginPoint mutable edgePrevious + let !originSide = orient2d lineFrom lineTo edgeOrigin + !oppositeSide = orient2d lineFrom lineTo oppositeVertex + if originSide == EQ || oppositeSide == EQ + then classifyDegenerate edgePrevious edgeNext + else + if originSide == oppositeSide + then do + nextOrigin <- edgeOriginPoint mutable edgeNext + let !outgoing = edgeNext `xor` 1 + !targetSide = orient2d oppositeVertex nextOrigin lineTo + pure + ( if targetSide == LT + then MutableEdgeOutNone + else MutableEdgeOutEdge outgoing + ) + else do + let !outgoing = edgePrevious `xor` 1 + !targetSide = orient2d edgeOrigin oppositeVertex lineTo + pure + ( if targetSide == LT + then MutableEdgeOutNone + else MutableEdgeOutEdge outgoing + ) + where + classifyDegenerate edgePrevious edgeNext = do + previousIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgePrevious + nextIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgeNext + case (previousIntersects, nextIntersects) of + (True, False) -> pure (MutableEdgeOutEdge (edgePrevious `xor` 1)) + (False, True) -> pure (MutableEdgeOutEdge (edgeNext `xor` 1)) + (True, True) -> MutableEdgeOutVertex <$> readOrigin mutable edgePrevious + (False, False) -> pure MutableEdgeOutNone + +mutableEdgeIntersectsNonCollinear + :: MutableDcel s vertex directed undirected face + -> Point + -> Point + -> Int + -> ST s Bool +mutableEdgeIntersectsNonCollinear + mutable + (Point lineFromX lineFromY) + (Point lineToX lineToY) + edge = do + edgeFromVertex <- readOrigin mutable edge + edgeToVertex <- readOrigin mutable (edge `xor` 1) + Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex + Point edgeToX edgeToY <- pointAt mutable edgeToVertex + let !lineFromSide = + orient2dCoordinates + edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY + !lineToSide = + orient2dCoordinates + edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY + !edgeFromSide = + orient2dCoordinates + lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY + !edgeToSide = + orient2dCoordinates + lineFromX lineFromY lineToX lineToY edgeToX edgeToY + pure + ( lineFromSide /= lineToSide + && edgeFromSide /= edgeToSide + ) + +mutableVertexTraceIsSearching :: MutableVertexTrace -> Bool +mutableVertexTraceIsSearching (MutableVertexTraceSearching _ _) = True +mutableVertexTraceIsSearching _ = False diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Query.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Query.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Query.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Read-only interrogation of the constrained layer, over both the published +-- mesh and the thawed one, plus the endpoint validity the verbs share. +module Moonlight.Triangulation.Internal.Cdt.Query + ( constraintEdges + , constraintStorageBytes + , existsConstraint + , canAddConstraint + , intersectsConstraint + , getConflictingEdgesBetweenPoints + , getConflictingEdgesBetweenVertices + , findDirectedEdge + , findMutableEdge + , validateEndpoints + , validVertex + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor) +import qualified Data.IntSet as IntSet +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.IntersectionIterator +import Moonlight.Triangulation.Internal.Cdt.Admission + ( ConstraintAdmission (..) + , constraintAdmission + ) +import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..)) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.Paged (pagedLength) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types + +-- | Marked undirected edges in ascending identifier order. +constraintEdges + :: Triangulation 'Constrained vertex directed undirected face + -> [UndirectedEdgeId] +constraintEdges = + fmap (UndirectedEdgeId . fromIntegral) + . IntSet.toAscList + . triConstraintEdges +{-# INLINE constraintEdges #-} + +constraintStorageBytes + :: Triangulation 'Constrained vertex directed undirected face + -> Integer +constraintStorageBytes = toInteger . pagedLength . triConstraint + +existsConstraint + :: Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> VertexId + -> Bool +existsConstraint triangulation from to = + case findDirectedEdge triangulation from to of + Just edge -> Dcel.isConstraintEdge triangulation (asUndirected edge) + Nothing -> False + +canAddConstraint + :: Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> VertexId + -> Bool +canAddConstraint triangulation from to = + from /= to + && validVertex triangulation from + && validVertex triangulation to + && case constraintAdmission triangulation from to of + ConstraintBlocked _ -> False + ConstraintAdmitted -> True + +intersectsConstraint + :: Triangulation 'Constrained vertex directed undirected face + -> QueryPoint + -> QueryPoint + -> Bool +intersectsConstraint triangulation from to = + case foldCorridorBetweenPoints triangulation from to firstBlocking () of + Just (Left ()) -> True + Just (Right ()) -> False + Nothing -> not (null (getConflictingEdgesBetweenPoints triangulation from to)) + where + firstBlocking :: () -> Intersection -> Either () () + firstBlocking _ (EdgeIntersection edge) + | Dcel.isConstraintEdge triangulation (asUndirected edge) = Left () + firstBlocking _ _ = Right () + +getConflictingEdgesBetweenPoints + :: Triangulation 'Constrained vertex directed undirected face + -> QueryPoint + -> QueryPoint + -> [DirectedEdgeId] +getConflictingEdgesBetweenPoints triangulation from to = + [ edge + | EdgeIntersection edge <- lineIntersections triangulation from to + , Dcel.isConstraintEdge triangulation (asUndirected edge) + ] + +getConflictingEdgesBetweenVertices + :: Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> VertexId + -> [DirectedEdgeId] +getConflictingEdgesBetweenVertices triangulation from to + | not (validVertex triangulation from && validVertex triangulation to) = [] + | otherwise = + [ edge + | EdgeIntersection edge <- lineIntersectionsBetweenVertices triangulation from to + , Dcel.isConstraintEdge triangulation (asUndirected edge) + ] + +findDirectedEdge :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Maybe DirectedEdgeId +findDirectedEdge triangulation from to = + case filter ((== to) . Dcel.destination triangulation) (Dcel.vertexOutgoingEdges triangulation from) of + edge : _ -> Just edge + [] -> Nothing + +findMutableEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Maybe Int) +findMutableEdge mutable from to = do + start <- readVertexOut mutable from + halfEdges <- directedEdgeCount mutable + if start < 0 + then pure Nothing + else go (halfEdges + 1) start start False + where + go !remaining !start !edge !visited + | remaining <= 0 = pure Nothing + | visited && edge == start = pure Nothing + | otherwise = do + destination <- readOrigin mutable (edge `xor` 1) + if destination == to + then pure (Just edge) + else do + previousEdge <- readPrevious mutable edge + go (remaining - 1) start (previousEdge `xor` 1) True + +validateEndpoints :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Either (CdtError) () +validateEndpoints triangulation from to + | not (validVertex triangulation from) = Left (InvalidConstraintVertex from) + | not (validVertex triangulation to) = Left (InvalidConstraintVertex to) + | otherwise = Right () + +validVertex :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> Bool +validVertex triangulation (VertexId vertex) = fromIntegral vertex < Dcel.numVertices triangulation diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Interpretation of a recovery program against the thawed mesh: conflict +-- strips are flipped away segment by segment and the constraints are set. +module Moonlight.Triangulation.Internal.Cdt.Recovery + ( ConflictRecovery (..) + , applyMutableConstraint + , emptyConstraintRequest + , recoverMutableRequest + , recoverMutableProgramPiece + , recordRecoveredSegment + , resolveConflictStrip + , mutableEdgeCrosses + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor) +import Data.Either (isRight) +import Data.Foldable (traverse_) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Cdt.Combinators + ( foldWhileM + , vertexInt + ) +import Moonlight.Triangulation.Internal.Cdt.Corridor + ( constraintWorkspaceFor + , existingProgramTag + , readConstraintProgram + , recoverProgramTag + , scanMutableConstraint + ) +import Moonlight.Triangulation.Internal.Cdt.Query (findMutableEdge) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.Growable (GrowableWord32) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Scalar (orient2dCoordinates) + +data ConflictRecovery = ConflictRecovery + { recoveredConstraintEdge :: {-# UNPACK #-} !Int + , recoveredConstraintFresh :: !Bool + } + +-- | Admit one request against the thawed mesh and recover it. Every constraint +-- verb in this module reaches the topology through here; the callers differ +-- only in what they do with a rejection and in when they publish. +applyMutableConstraint + :: GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> VertexId + -> VertexId + -> ST s (Either (CdtError) MutableConstraintOutcome) +applyMutableConstraint programWords mutable operation from to + | from == to = pure (Right (MutableConstraintAccepted emptyConstraintRequest)) + | otherwise = do + workspace <- constraintWorkspaceFor programWords mutable + scanned <- scanMutableConstraint workspace mutable from to + case scanned of + Left failure -> pure (Left failure) + Right (MutableConstraintScanBlocked blocking) -> + pure (Right (MutableConstraintRejected (asUndirected blocking))) + Right (MutableConstraintScanAdmitted program) -> + fmap MutableConstraintAccepted + <$> recoverMutableRequest workspace mutable operation program + +emptyConstraintRequest :: ConstraintRequestAccumulator +emptyConstraintRequest = + ConstraintRequestAccumulator + { accumulatedRequestPath = [] + , accumulatedRequestAddedEdges = 0 + , accumulatedRequestCorridors = 0 + , accumulatedRequestReusedFaces = 0 + , accumulatedRequestCrossedEdges = 0 + } + +recoverMutableRequest + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> MutableConstraintProgram + -> ST s (Either (CdtError) ConstraintRequestAccumulator) +recoverMutableRequest workspace mutable operation program = do + interpreted <- + foldWhileM + isRight + (recoverMutableProgramPiece workspace mutable operation (mutableProgramWordCount program)) + ( Right + ConstraintProgramAccumulator + { accumulatedProgramCursor = 0 + , accumulatedProgramRequest = emptyConstraintRequest + } + ) + [1 .. mutableProgramPieceCount program] + pure $ case interpreted of + Left obstruction -> Left obstruction + Right completed + | accumulatedProgramCursor completed == mutableProgramWordCount program -> + Right (accumulatedProgramRequest completed) + | otherwise -> + Left + ( ConstraintCorridorObstructed + (CorridorProgramMalformed (accumulatedProgramCursor completed)) + ) + +recoverMutableProgramPiece + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Either (CdtError) ConstraintProgramAccumulator + -> Int + -> ST s (Either (CdtError) ConstraintProgramAccumulator) +recoverMutableProgramPiece _ _ _ _ failed@(Left _) _ = pure failed +recoverMutableProgramPiece workspace mutable operation wordCount (Right accumulator) _ = do + let !cursor = accumulatedProgramCursor accumulator + malformed = + Left + ( ConstraintCorridorObstructed + (CorridorProgramMalformed cursor) + ) + if cursor < 0 || cursor >= wordCount + then pure malformed + else do + tag <- readConstraintProgram workspace cursor + case tag of + _ + | tag == existingProgramTag && cursor + 1 < wordCount -> do + edge <- readConstraintProgram workspace (cursor + 1) + fresh <- setConstraint mutable edge + pure + ( Right + accumulator + { accumulatedProgramCursor = cursor + 2 + , accumulatedProgramRequest = + recordRecoveredSegment + (accumulatedProgramRequest accumulator) + edge + fresh + 0 + 0 + } + ) + | tag == recoverProgramTag && cursor + 3 < wordCount -> do + rawFrom <- readConstraintProgram workspace (cursor + 1) + rawTo <- readConstraintProgram workspace (cursor + 2) + conflictCount <- readConstraintProgram workspace (cursor + 3) + let !conflictStart = cursor + 4 + !nextCursor = conflictStart + conflictCount + !from = VertexId (fromIntegral rawFrom) + !to = VertexId (fromIntegral rawTo) + if conflictCount < 0 || nextCursor > wordCount + then pure malformed + else do + direct <- findMutableEdge mutable rawFrom rawTo + recovered <- + case direct of + Just edge -> do + fresh <- setConstraint mutable edge + pure + ( Right + ConflictRecovery + { recoveredConstraintEdge = edge + , recoveredConstraintFresh = fresh + } + ) + Nothing + | conflictCount == 0 -> + pure + ( Left + ( ConstraintCorridorObstructed + (CorridorTargetMissing from to) + ) + ) + | otherwise -> + resolveConflictStrip + workspace + mutable + operation + from + to + conflictStart + conflictCount + pure $ case recovered of + Left obstruction -> Left obstruction + Right recovery -> + Right + accumulator + { accumulatedProgramCursor = nextCursor + , accumulatedProgramRequest = + recordRecoveredSegment + (accumulatedProgramRequest accumulator) + (recoveredConstraintEdge recovery) + (recoveredConstraintFresh recovery) + conflictCount + (if conflictCount == 0 then 0 else conflictCount + 1) + } + | otherwise -> pure malformed + +recordRecoveredSegment + :: ConstraintRequestAccumulator + -> Int + -> Bool + -> Int + -> Int + -> ConstraintRequestAccumulator +recordRecoveredSegment accumulator edge fresh crossed reusedFaces = + accumulator + { accumulatedRequestPath = DirectedEdgeId (fromIntegral edge) : accumulatedRequestPath accumulator + , accumulatedRequestAddedEdges = + accumulatedRequestAddedEdges accumulator + if fresh then 1 else 0 + , accumulatedRequestCorridors = + accumulatedRequestCorridors accumulator + if crossed == 0 then 0 else 1 + , accumulatedRequestReusedFaces = + accumulatedRequestReusedFaces accumulator + reusedFaces + , accumulatedRequestCrossedEdges = + accumulatedRequestCrossedEdges accumulator + crossed + } + +resolveConflictStrip + :: ConstraintWorkspace s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> VertexId + -> VertexId + -> Int + -> Int + -> ST s (Either (CdtError) ConflictRecovery) +resolveConflictStrip workspace mutable operation from to conflictStart stripLength = do + fromPoint <- pointAt mutable (vertexInt from) + toPoint <- pointAt mutable (vertexInt to) + traverse_ + (\index -> do + edge <- readConstraintProgram workspace (conflictStart + index) + writeScratch operation index edge + ) + [0 .. stripLength - 1] + recovered <- + recover + stripLength + safetyBudget + 0 + 0 + stripLength + stripLength + [] + fromPoint + toPoint + case recovered of + Left failure -> pure (Left failure) + Right (edge, flipped) -> do + fresh <- setConstraint mutable edge + legalizeEdges mutable operation flipped + pure + ( Right + ConflictRecovery + { recoveredConstraintEdge = edge + , recoveredConstraintFresh = fresh + } + ) + where + safetyBudget = max 64 (32 * (stripLength + 1) * (stripLength + 1)) + + -- The corridor is an ordered section through the current triangulation. + -- Until an original section is dequeued, no flip can have changed that + -- edge's endpoints: flips only repurpose the identity being flipped, and + -- requeued identities remain behind every unseen original in this FIFO. + -- Consequently the first visit inherits the crossing proof established by + -- the corridor walk. Only requeued edges require the predicate again. + recover !capacity !remaining !stalled !headIndex !pendingCount !unseenOriginalCount !flipped !fromPoint !toPoint + | remaining <= 0 = + pure + ( Left + ( ConstraintRecoverySafetyBudgetExhausted + from + to + safetyBudget + (safetyBudget - remaining) + ) + ) + | pendingCount <= 0 = do + direct <- findMutableEdge mutable (vertexInt from) (vertexInt to) + case direct of + Just edge -> pure (Right (edge, flipped)) + Nothing -> + pure + (Left (ConstraintRecoveryStripExhausted from to stripLength)) + | otherwise = do + edge <- readScratch operation headIndex + let !nextHead = advance capacity headIndex + !restCount = pendingCount - 1 + !nextUnseenOriginalCount = max 0 (unseenOriginalCount - 1) + stillCrosses <- + if unseenOriginalCount > 0 + then pure True + else mutableEdgeCrosses mutable fromPoint toPoint edge + if not stillCrosses + then recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount flipped fromPoint toPoint + else do + flippable <- isFlippableEdge mutable edge + if flippable + then do + rewritten <- flipEdge mutable edge + case rewritten of + Left obstruction -> pure (Left (CdtBuildError obstruction)) + Right () -> do + addCounter operation CounterEdgeFlips 1 + crossesAfterFlip <- mutableEdgeCrosses mutable fromPoint toPoint edge + if crossesAfterFlip + then do + enqueue capacity nextHead restCount edge + recover + capacity + (remaining - 1) + 0 + nextHead + (restCount + 1) + nextUnseenOriginalCount + (edge : flipped) + fromPoint + toPoint + else recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount (edge : flipped) fromPoint toPoint + else do + enqueue capacity nextHead restCount edge + let !nextCount = restCount + 1 + !nextStalled = stalled + 1 + if nextStalled >= nextCount + then + pure + ( Left + ( ConstraintRecoveryStripUnflippable + from + to + (DirectedEdgeId (fromIntegral edge)) + nextCount + ) + ) + else recover capacity (remaining - 1) nextStalled nextHead nextCount nextUnseenOriginalCount flipped fromPoint toPoint + + enqueue !capacity !headIndex !count !edge = + writeScratch operation (wrap capacity (headIndex + count)) edge + + advance :: Int -> Int -> Int + advance !capacity !index + | index + 1 == capacity = 0 + | otherwise = index + 1 + + wrap :: Int -> Int -> Int + wrap !capacity !index + | index >= capacity = index - capacity + | otherwise = index + +mutableEdgeCrosses + :: MutableDcel s vertex directed undirected face + -> Point + -> Point + -> Int + -> ST s Bool +mutableEdgeCrosses + mutable + (Point lineFromX lineFromY) + (Point lineToX lineToY) + edge = do + edgeFromVertex <- readOrigin mutable edge + edgeToVertex <- readOrigin mutable (edge `xor` 1) + Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex + Point edgeToX edgeToY <- pointAt mutable edgeToVertex + let !edgeFromSide = + orient2dCoordinates + lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY + !edgeToSide = + orient2dCoordinates + lineFromX lineFromY lineToX lineToY edgeToX edgeToY + !lineFromSide = + orient2dCoordinates + edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY + !lineToSide = + orient2dCoordinates + edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY + pure + ( opposite edgeFromSide edgeToSide + && opposite lineFromSide lineToSide + ) + where + opposite LT GT = True + opposite GT LT = True + opposite _ _ = False diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Region.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Region.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Region.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} + +-- | The two-sided reading of the constrained domain: which faces lie outside +-- the protected boundary and which lie within it. +module Moonlight.Triangulation.Internal.Cdt.Region + ( outerRegionFaces + , boundedRegionFaces + ) where + +import qualified Data.IntSet as IntSet +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types + +outerRegionFaces + :: Triangulation 'Constrained vertex directed undirected face + -> [FaceId] +-- Crossing depth, not bare reachability. A face lies outside the constrained +-- domain when the fewest constraints separating it from the outer face is even, +-- so the hole of an annulus (two crossings) is outside exactly as its exterior +-- (none) is. Reachability alone is the depth-zero layer and calls that hole +-- domain, which would mesh it. +outerRegionFaces triangulation = + facesAtEvenBarrierDepth triangulation (Dcel.isConstraintEdge triangulation) + +boundedRegionFaces + :: Triangulation 'Constrained vertex directed undirected face + -> [FaceId] +boundedRegionFaces triangulation = + [ face + | face <- innerFaces triangulation + , let FaceId raw = face + , not (IntSet.member (fromIntegral raw) outside) + ] + where + outside = IntSet.fromList [fromIntegral raw | FaceId raw <- outerRegionFaces triangulation] diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | The singleton segment verbs: glue one segment or a polyline, and retire a +-- constraint, each inside one sealed transaction. +module Moonlight.Triangulation.Internal.Cdt.Segment + ( addConstraintEdge + , addConstraintEdges + , applyConstraintToExistingEndpoints + , applyAndPublishConstraint + , publishConstraintResult + , insertPolylineVertices + , removeConstraintEdge + , retireConstraintEdge + ) where + +import Control.Monad.ST (ST, runST) +import qualified Data.Vector as V +import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray) +import Moonlight.Triangulation.BulkLoad (insertMany) +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) +import Moonlight.Triangulation.Internal.Cdt.Admission + ( ConstraintAdmission (..) + , constraintAdmission + ) +import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints) +import Moonlight.Triangulation.Internal.Cdt.Combinators + ( asConstraintStep + , bindMutable + , mapLeft + ) +import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint) +import Moonlight.Triangulation.Internal.Cdt.Site + ( lookupExistingConstraintEndpoint + , placeConstraintEndpoint + ) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , newGrowableWord32 + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , newOperationState + ) +import Moonlight.Triangulation.Internal.Representation +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 + => Triangulation 'Constrained vertex directed undirected face + -> vertex + -> vertex + -> Either (CdtError) (ConstraintResult vertex directed undirected face) +addConstraintEdge triangulation fromVertex toVertex = do + _ <- mapLeft CdtBuildError (validatePoint Nothing fromPoint) + _ <- mapLeft CdtBuildError (validatePoint Nothing toPoint) + result <- + case + ( lookupExistingConstraintEndpoint triangulation fromPoint + , lookupExistingConstraintEndpoint triangulation toPoint + ) of + (Just from, Just to) -> + case constraintAdmission triangulation from to of + ConstraintBlocked blocking -> Left (ConstraintIntersection blocking) + ConstraintAdmitted -> + applyConstraintToExistingEndpoints + triangulation + from + fromVertex + to + toVertex + _ -> addConstraintWithEndpointPlacement + pure result + where + !fromPoint = position fromVertex + !toPoint = position toVertex + -- Both endpoints may be new; neither may be. The reservation is for the peak. + !capacity = Dcel.numVertices triangulation + 2 + + addConstraintWithEndpointPlacement = do + mapLeft CdtBuildError (ensureCapacity capacity) + runST $ do + mutable <- thawTriangulation capacity triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + programWords <- newGrowableWord32 256 + asConstraintStep (placeConstraintEndpoint mutable operation Nothing fromPoint fromVertex) + `bindMutable` \from -> + asConstraintStep (placeConstraintEndpoint mutable operation Nothing toPoint toVertex) + `bindMutable` \to -> + applyAndPublishConstraint programWords mutable operation from to +-- | The common singleton case already owns both sites. Resolve them before +-- opening topology, then retain the original payload and counter semantics in +-- the transaction. The corridor worker is unchanged; only two redundant point +-- locations and two unused vertex-capacity reservations disappear. +applyConstraintToExistingEndpoints + :: Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> vertex + -> VertexId + -> vertex + -> Either (CdtError) (ConstraintResult vertex directed undirected face) +applyConstraintToExistingEndpoints triangulation from@(VertexId rawFrom) fromPayload to@(VertexId rawTo) toPayload = + runST $ do + mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + programWords <- newGrowableWord32 256 + addCounter operation CounterInputPoints 2 + addCounter operation CounterExistingPoints 2 + addCounter operation CounterDuplicatePoints 2 + writeVertexData mutable (fromIntegral rawFrom) fromPayload + writeVertexData mutable (fromIntegral rawTo) toPayload + applyAndPublishConstraint programWords mutable operation from to + +applyAndPublishConstraint + :: GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> VertexId + -> VertexId + -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face)) +applyAndPublishConstraint programWords mutable operation from to = + applyMutableConstraint programWords mutable operation from to + `bindMutable` \applied -> + case applied of + MutableConstraintRejected blocking -> + pure (Left (ConstraintIntersection blocking)) + MutableConstraintAccepted request -> + publishConstraintResult + mutable + (accumulatedRequestPath request) + (accumulatedRequestAddedEdges request) +{-# INLINE applyAndPublishConstraint #-} + +-- | Close the transaction on an accepted request. The accumulated path runs +-- newest-first, so it is reversed exactly once, here. +publishConstraintResult + :: MutableDcel s vertex directed undirected face + -> [DirectedEdgeId] + -> Int + -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face)) +publishConstraintResult mutable reversedPath added = do + frozenOutcome <- freezeTriangulation mutable + pure $ case frozenOutcome of + Left obstruction -> Left (CdtBuildError obstruction) + Right frozen -> + Right + ConstraintResult + { constraintTriangulation = frozen + , constraintPath = V.fromList (reverse reversedPath) + , constraintAddedEdges = added + } + +addConstraintEdges + :: HasPosition vertex + => Triangulation 'Constrained vertex directed undirected face + -> V.Vector vertex + -> Bool + -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face) +addConstraintEdges triangulation polylineVertices closed + | V.null polylineVertices = Right triangulation + | otherwise = do + (withVertices, handles) <- insertPolylineVertices triangulation polylineVertices + let adjacent = V.zip handles (V.drop 1 handles) + closing = + if closed && V.length handles > 1 + then + case (handles V.!? (V.length handles - 1), handles V.!? 0) of + (Just finalVertex, Just firstVertex) -> + V.singleton (finalVertex, firstVertex) + _ -> V.empty + else V.empty + batch <- recoverConstraints withVertices (adjacent V.++ closing) + case V.foldl' firstBlocking Nothing (constraintBatchOutcomes batch) of + Nothing -> Right (constraintBatchTriangulation batch) + Just blocking -> Left (ConstraintIntersection blocking) + where + firstBlocking found@(Just _) _ = found + firstBlocking Nothing outcome = + case outcome of + ConstraintAccepted _ _ -> Nothing + ConstraintRejected blocking -> Just blocking + +insertPolylineVertices + :: HasPosition vertex + => Triangulation 'Constrained vertex directed undirected face + -> V.Vector vertex + -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face, V.Vector VertexId) +insertPolylineVertices triangulation points = do + result <- mapLeft CdtBuildError (insertMany triangulation points) + let !mapping = buildInputVertices result + pure (buildTriangulation result, V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping)) + +removeConstraintEdge + :: Triangulation 'Constrained vertex directed undirected face + -> UndirectedEdgeId + -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face) +removeConstraintEdge triangulation edge@(UndirectedEdgeId raw) + | fromIntegral raw >= edgeCount = + Left (ConstraintEdgeIndexOutOfRange edge edgeCount) + -- An edge carrying no constraint has nothing to retire, and answering that + -- without thawing is the difference between O(1) and a republished mesh. + | not (Dcel.isConstraintEdge triangulation edge) = Right triangulation + | otherwise = runST $ do + mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + retireConstraintEdge mutable operation edge `bindMutable` \() -> + fmap (mapLeft CdtBuildError) (freezeTriangulation mutable) + where + edgeCount = Dcel.numUndirectedEdges triangulation + +-- | Retire one constraint inside the open transaction and restore the Delaunay +-- property across the edge it protected. +retireConstraintEdge + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> UndirectedEdgeId + -> ST s (Either (CdtError) ()) +retireConstraintEdge mutable operation edge@(UndirectedEdgeId raw) = do + halfEdges <- directedEdgeCount mutable + let !directed = fromIntegral raw * 2 + if directed >= halfEdges + then pure (Left (ConstraintEdgeIndexOutOfRange edge (halfEdges `quot` 2))) + else do + constrained <- readConstraint mutable directed + if not constrained + then pure (Right ()) + else do + _ <- clearConstraint mutable directed + legalizeEdges mutable operation [directed] + pure (Right ()) diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Site.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Site.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Site.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Siting of constraint endpoints: resolving a point to an existing handle, +-- and materializing one inside an open transaction when it has none. +module Moonlight.Triangulation.Internal.Cdt.Site + ( lookupExistingConstraintEndpoint + , placeConstraintEndpoint + ) where + +import Control.Monad.ST (ST) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Insertion (insertVertexAtPoint) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + ) +import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex) +import Moonlight.Triangulation.Internal.Probe (Probe (..)) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math + +lookupExistingConstraintEndpoint + :: Triangulation mode vertex directed undirected face + -> Point + -> Maybe VertexId +lookupExistingConstraintEndpoint triangulation point = + VertexId . fromIntegral + <$> lookupPointIndex + (triPointX triangulation) + (triPointY triangulation) + (triPointIndex triangulation) + point + +-- | Materialize one point in the open transaction. A payload standing at an +-- occupied position keeps that handle and overwrites the payload, which is what +-- the persistent insertion verb settled on. +-- +-- The coordinates are checked here rather than by the callers, because a split +-- point is computed rather than supplied: @lineIntersection@ refuses only a +-- zero denominator, and a denominator merely close to zero answers a coordinate +-- no arena should hold. +placeConstraintEndpoint + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe Int + -> Point + -> vertex + -> ST s (Either BuildError VertexId) +placeConstraintEndpoint mutable operation hint point payload = + case validatePoint Nothing point of + Left failure -> pure (Left failure) + Right _ -> do + addCounter operation CounterInputPoints 1 + outcome <- insertVertexAtPoint @'ProbeOff mutable operation hint point payload + case outcome of + Left failure -> pure (Left failure) + Right (vertex, disposition) -> do + case disposition of + AlreadyPresent -> do + writeVertexData mutable vertex payload + addCounter operation CounterExistingPoints 1 + addCounter operation CounterDuplicatePoints 1 + Inserted -> addCounter operation CounterUniquePoints 1 + pure (Right (VertexId (fromIntegral vertex))) diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | The splitting program: corridors that divide every constraint they cross, +-- driven across as few sealed transactions as the vertex reservation allows. +module Moonlight.Triangulation.Internal.Cdt.Split + ( SplitChunkShape (..) + , SplitReceipt (..) + , SplitChunkOutcome (..) + , SplitRequest (..) + , SplitCursor (..) + , SplitStep (..) + , addConstraintAndSplit + , addConstraintsAndSplit + , splitCensus + , driveConstraintSplits + , runSplitChunk + , splitConstraintCorridor + , mutableEdgeWasSplit + , mutableConstraintBetween + , repairRoundedSplit + , lineIntersection + ) where + +import Control.Monad.ST (ST, runST) +import Data.Bits (xor) +import qualified Data.Vector as V +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) +import Moonlight.Triangulation.Internal.Cdt.Combinators + ( asConstraintStep + , bindMutable + , directedInt + , mapLeft + , vertexInt + ) +import Moonlight.Triangulation.Internal.Cdt.Corridor + ( constraintWorkspaceFor + , scanMutableConstraint + ) +import Moonlight.Triangulation.Internal.Cdt.Query + ( findMutableEdge + , getConflictingEdgesBetweenVertices + , validateEndpoints + ) +import Moonlight.Triangulation.Internal.Cdt.Recovery + ( applyMutableConstraint + , recoverMutableRequest + ) +import Moonlight.Triangulation.Internal.Cdt.Segment (retireConstraintEdge) +import Moonlight.Triangulation.Internal.Cdt.Site (placeConstraintEndpoint) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , newGrowableWord32 + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( OperationState + , newOperationState + ) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math + +-- | The part of a splitting request that does not move: the payload maker, the +-- endpoints the failure report must name, the iteration budget, and the +-- transaction's vertex reservation, past which the corridor suspends rather +-- than writes. +data SplitRequest vertex = SplitRequest + { splitRequestMakeVertex :: !(Point -> vertex) + , splitRequestFrom :: !VertexId + , splitRequestTo :: !VertexId + , splitRequestBudget :: {-# UNPACK #-} !Int + , splitRequestVertexBound :: {-# UNPACK #-} !Int + } + +-- | The part that does: how much budget is left, which vertex the unrecovered +-- remainder starts at, and the path and edge count accumulated behind it. The +-- path runs newest-first and is reversed once, at publication. +data SplitCursor = SplitCursor + { splitCursorRemaining :: {-# UNPACK #-} !Int + , splitCursorAt :: !VertexId + , splitCursorPath :: ![DirectedEdgeId] + , splitCursorAdded :: {-# UNPACK #-} !Int + } + +-- | How a corridor run ends inside its transaction: settled at the target, or +-- suspended mid-corridor because the next division would outgrow the vertex +-- reservation. A suspension is not a refusal; the driver publishes, +-- re-reserves against the published mesh, and resumes at the cursor. +data SplitStep + = SplitSettled !SplitCursor + | SplitSuspended !SplitCursor + +-- | The singleton opens corridor-local copy-on-write pages; the batch pays one +-- dense copy up front and writes flat. +data SplitChunkShape = SparseSplitChunk | DenseSplitChunk + +-- | What one settled request leaves behind. +data SplitReceipt = SplitReceipt + { splitReceiptPath :: !(V.Vector DirectedEdgeId) + , splitReceiptAdded :: {-# UNPACK #-} !Int + } + +data SplitChunkOutcome vertex directed undirected face = SplitChunkOutcome + { splitChunkTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , splitChunkReceipts :: ![SplitReceipt] + , splitChunkSuspended :: !(Maybe SplitCursor) + } + +-- | Glue the requested segment, dividing every constraint it crosses at the +-- crossing point rather than refusing it. One transaction carries the whole +-- corridor: a singleton is a batch of one under the shared driver. +addConstraintAndSplit + :: (Point -> vertex) + -> Triangulation 'Constrained vertex directed undirected face + -> VertexId + -> VertexId + -> Either (CdtError) (ConstraintResult vertex directed undirected face) +addConstraintAndSplit makeVertex triangulation from to = do + validateEndpoints triangulation from to + if from == to + then pure (ConstraintResult triangulation V.empty 0) + else do + (published, receipts) <- + driveConstraintSplits SparseSplitChunk makeVertex triangulation (V.singleton (from, to)) + pure + ( case receipts V.!? 0 of + Just receipt -> + ConstraintResult + { constraintTriangulation = published + , constraintPath = splitReceiptPath receipt + , constraintAddedEdges = splitReceiptAdded receipt + } + Nothing -> ConstraintResult published V.empty 0 + ) + +-- | Divide every requested segment inside as few transactions as the vertex +-- reservation allows: usually one, which is the referent semantics for a +-- splitting batch. Nothing is republished between corridors unless a corridor +-- crosses constraints created by an earlier request in the same batch -- +-- growth no census against the base can see. In that one case the corridor +-- suspends, the chunk publishes, and the driver re-reserves against the +-- published mesh and resumes at the suspended cursor. +addConstraintsAndSplit + :: (Point -> vertex) + -> Triangulation 'Constrained vertex directed undirected face + -> V.Vector (VertexId, VertexId) + -> Either (CdtError) (ConstraintSplitBatchResult vertex directed undirected face) +addConstraintsAndSplit makeVertex triangulation requests = do + (published, receipts) <- driveConstraintSplits DenseSplitChunk makeVertex triangulation requests + pure + ConstraintSplitBatchResult + { splitBatchTriangulation = published + , splitBatchPaths = V.map splitReceiptPath receipts + , splitBatchAddedEdges = V.sum (V.map splitReceiptAdded receipts) + } + +-- | The obstruction census for one request against a published mesh: how many +-- constrained crossings its corridor holds, and the first of them. The first +-- crossing is a valid local section of the next transaction before any rewrite +-- occurs, so a chunk's first request carries it across the thaw boundary +-- instead of immediately rediscovering it; every later request rescans, +-- because earlier corridors may have rewritten the topology the witness names. +splitCensus + :: Triangulation 'Constrained vertex directed undirected face + -> (VertexId, VertexId) + -> (Int, Maybe DirectedEdgeId) +splitCensus triangulation (from, to) + | from == to = (0, Nothing) + | otherwise = + foldl' + countCrossing + (0, Nothing) + (getConflictingEdgesBetweenVertices triangulation from to) + where + countCrossing :: (Int, Maybe DirectedEdgeId) -> DirectedEdgeId -> (Int, Maybe DirectedEdgeId) + countCrossing (!count, firstCrossing) crossing = + ( count + 1 + , case firstCrossing of + Just first -> Just first + Nothing -> Just crossing + ) + +-- | Interpret splitting requests in order across as few sealed transactions as +-- possible. Each chunk reserves against the exact obstruction census of every +-- remaining request, so a chunk always settles at least its first request: +-- that census ran against the very mesh the chunk thawed and is exact before +-- any in-session rewrite. Termination follows. +driveConstraintSplits + :: SplitChunkShape + -> (Point -> vertex) + -> Triangulation 'Constrained vertex directed undirected face + -> V.Vector (VertexId, VertexId) + -> Either + (CdtError) + ( Triangulation 'Constrained vertex directed undirected face + , V.Vector SplitReceipt + ) +driveConstraintSplits shape makeVertex base requests = do + V.mapM_ (uncurry (validateEndpoints base)) requests + advance base 0 [] Nothing + where + advance triangulation start settled resumed + | start >= V.length requests = + Right (triangulation, V.fromList (reverse settled)) + | otherwise = do + let remaining = V.drop start requests + firstRound = start == 0 && case resumed of + Nothing -> True + Just _ -> False + -- The opening chunk reserves optimistically -- one crossing per + -- request -- rather than walking every corridor for an exact + -- census before any work begins. A request that outgrows the + -- reservation suspends mid-corridor with its partial work kept, + -- and the next round censuses exactly against the published mesh, + -- so heavy batches pay at most one speculative chunk. + censuses + | firstRound = V.replicate (V.length remaining) (1, Nothing) + | otherwise = V.map (splitCensus triangulation) remaining + !reservedSites = V.sum (V.map fst censuses) + !capacity = Dcel.numVertices triangulation + 2 * reservedSites + 8 + -- The walk budget bounds divisions per request; constraints born + -- inside the chunk are covered by the reservation term. + !budget = + 2 * (Dcel.numConstraints triangulation + 2 * reservedSites + V.length remaining) + + Dcel.numUndirectedEdges triangulation + + 8 + mapLeft CdtBuildError (ensureCapacity capacity) + outcome <- runST $ do + mutable <- case shape of + SparseSplitChunk -> thawTriangulation capacity triangulation + DenseSplitChunk -> thawTriangulationDense capacity triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + programWords <- newGrowableWord32 32 + runSplitChunk makeVertex mutable operation programWords remaining censuses capacity budget resumed + case outcome of + SplitChunkOutcome published receipts suspended -> + advance published (start + length receipts) (receipts ++ settled) suspended + +-- | One sealed transaction over a prefix of the remaining requests. Receipts +-- run newest-first; a suspension carries no receipt, so the settled count is +-- exactly the receipt count. +runSplitChunk + :: (Point -> vertex) + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> GrowableWord32 s + -> V.Vector (VertexId, VertexId) + -> V.Vector (Int, Maybe DirectedEdgeId) + -> Int + -> Int + -> Maybe SplitCursor + -> ST s (Either (CdtError) (SplitChunkOutcome vertex directed undirected face)) +runSplitChunk makeVertex mutable operation programWords requests censuses capacity budget resumed = + go 0 [] resumed + where + go offset receipts pending + | offset >= V.length requests = seal receipts Nothing + | otherwise = + let (from, to) = requests V.! offset + in case pending of + Nothing + | from == to -> + go (offset + 1) (SplitReceipt V.empty 0 : receipts) Nothing + _ -> + let witness = if offset == 0 then snd (censuses V.! 0) else Nothing + cursor = case pending of + Just resumedCursor -> resumedCursor + Nothing -> SplitCursor budget from [] 0 + request = + SplitRequest + { splitRequestMakeVertex = makeVertex + , splitRequestFrom = from + , splitRequestTo = to + , splitRequestBudget = budget + , splitRequestVertexBound = capacity + } + in splitConstraintCorridor request programWords mutable operation witness cursor + `bindMutable` \step -> + case step of + SplitSettled settledCursor -> + go (offset + 1) (receiptOf settledCursor : receipts) Nothing + SplitSuspended suspendedCursor -> + seal receipts (Just suspendedCursor) + + receiptOf cursor = + SplitReceipt + { splitReceiptPath = V.fromList (reverse (splitCursorPath cursor)) + , splitReceiptAdded = splitCursorAdded cursor + } + + seal receipts suspended = do + frozenOutcome <- freezeTriangulation mutable + pure $ case frozenOutcome of + Left obstruction -> Left (CdtBuildError obstruction) + Right frozen -> Right (SplitChunkOutcome frozen receipts suspended) + +splitConstraintCorridor + :: SplitRequest vertex + -> GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe DirectedEdgeId + -> SplitCursor + -> ST s (Either (CdtError) SplitStep) +splitConstraintCorridor request programWords mutable operation initialCrossing initialCursor = + case initialCrossing of + Just crossing -> divide initialCursor crossing + Nothing -> descend initialCursor + where + !target = splitRequestTo request + + descend cursor + | splitCursorRemaining cursor <= 0 = + pure + ( Left + ( ConstraintSplitBudgetExhausted + (splitRequestFrom request) + target + (splitRequestBudget request) + ) + ) + | otherwise = do + workspace <- constraintWorkspaceFor programWords mutable + scanMutableConstraint workspace mutable (splitCursorAt cursor) target + `bindMutable` \scanned -> + case scanned of + MutableConstraintScanAdmitted program -> + recoverMutableRequest workspace mutable operation program + `bindMutable` \final -> + pure + ( Right + ( SplitSettled + (advanceCursor cursor (splitCursorRemaining cursor) target final) + ) + ) + MutableConstraintScanBlocked crossing -> divide cursor crossing + + divide cursor crossing = do + occupied <- pointCount mutable + if occupied + 2 > splitRequestVertexBound request + then pure (Right (SplitSuspended cursor)) + else divideWithin cursor crossing + + divideWithin cursor crossing = do + let !crossingEdge = directedInt crossing + !oldConstraint = asUndirected crossing + segmentFrom <- pointAt mutable (vertexInt (splitCursorAt cursor)) + segmentTo <- pointAt mutable (vertexInt target) + oldFrom <- readOrigin mutable crossingEdge + oldTo <- readOrigin mutable (crossingEdge `xor` 1) + edgeFrom <- pointAt mutable oldFrom + edgeTo <- pointAt mutable oldTo + -- The split point lies on the crossing edge, so both its incident faces + -- already contain it and the exact walk settles on its first probe. Without + -- this the locate is unhinted, and an unhinted locate descends vertex by + -- vertex from the arena's first face -- a distance that grows with the mesh + -- while the corridor it is splitting stays a fixed few faces wide. A hull + -- edge carries the outer face on one side, which the locator would refuse. + incidentFace <- readFace mutable crossingEdge + twinFace <- readFace mutable (crossingEdge `xor` 1) + let !splitHint = Just (if incidentFace > 0 then incidentFace else twinFace) + let !oldEndpoints = + ( VertexId (fromIntegral oldFrom) + , VertexId (fromIntegral oldTo) + ) + case lineIntersection crossing segmentFrom segmentTo edgeFrom edgeTo of + Left indeterminate -> pure (Left indeterminate) + Right splitPoint -> + -- The split lands where the intersection says, not where a round trip + -- through 'makeVertex' happens to put it. + asConstraintStep + ( placeConstraintEndpoint + mutable + operation + splitHint + splitPoint + (splitRequestMakeVertex request splitPoint) + ) + `bindMutable` \splitVertex -> + repairIfRounded oldConstraint oldEndpoints splitVertex `bindMutable` \() -> + applyMutableConstraint programWords mutable operation (splitCursorAt cursor) splitVertex + `bindMutable` \prefix -> + case prefix of + MutableConstraintRejected blocking -> + pure (Left (ConstraintIntersection blocking)) + MutableConstraintAccepted segment -> + descend + (advanceCursor cursor (splitCursorRemaining cursor - 1) splitVertex segment) + + repairIfRounded oldConstraint oldEndpoints splitVertex = do + divided <- mutableEdgeWasSplit mutable oldConstraint oldEndpoints splitVertex + if divided + then pure (Right ()) + else repairRoundedSplit programWords mutable operation oldConstraint oldEndpoints splitVertex + + advanceCursor cursor remaining reached segment = + cursor + { splitCursorRemaining = remaining + , splitCursorAt = reached + , splitCursorPath = accumulatedRequestPath segment ++ splitCursorPath cursor + , splitCursorAdded = splitCursorAdded cursor + accumulatedRequestAddedEdges segment + } + +-- | Whether the inserted vertex actually divided the constraint it was placed +-- on. It did if that constraint is gone — the split retired the identity — or +-- if both halves now carry one. Rounding can place the vertex somewhere that +-- leaves the old constraint standing and neither half glued. +mutableEdgeWasSplit + :: MutableDcel s vertex directed undirected face + -> UndirectedEdgeId + -> (VertexId, VertexId) + -> VertexId + -> ST s Bool +mutableEdgeWasSplit mutable (UndirectedEdgeId raw) (from, to) splitVertex = do + halfEdges <- directedEdgeCount mutable + let !directed = fromIntegral raw * 2 + stillConstrained <- + if directed >= halfEdges + then pure False + else readConstraint mutable directed + if not stillConstrained + then pure True + else do + leading <- mutableConstraintBetween mutable from splitVertex + if leading + then mutableConstraintBetween mutable splitVertex to + else pure False + +mutableConstraintBetween + :: MutableDcel s vertex directed undirected face + -> VertexId + -> VertexId + -> ST s Bool +mutableConstraintBetween mutable from to = do + found <- findMutableEdge mutable (vertexInt from) (vertexInt to) + case found of + Nothing -> pure False + Just edge -> readConstraint mutable edge + +-- | The split point rounded onto neither half of the constraint it was meant to +-- divide. Retire the stale identity and glue both halves against the vertex +-- that was actually sited. What this recovers is repair rather than the +-- requested segment, so it contributes nothing to the request's path. +repairRoundedSplit + :: GrowableWord32 s + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> UndirectedEdgeId + -> (VertexId, VertexId) + -> VertexId + -> ST s (Either (CdtError) ()) +repairRoundedSplit programWords mutable operation oldEdge (from, to) splitVertex = + retireConstraintEdge mutable operation oldEdge `bindMutable` \() -> + glue from splitVertex `bindMutable` \() -> glue splitVertex to + where + glue start end = + applyMutableConstraint programWords mutable operation start end `bindMutable` \recovered -> + pure $ case recovered of + MutableConstraintRejected blocking -> Left (ConstraintIntersection blocking) + MutableConstraintAccepted _ -> Right () + +lineIntersection + :: DirectedEdgeId + -> Point + -> Point + -> Point + -> Point + -> Either (CdtError) (Point) +lineIntersection crossing (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) + | denominator == 0 = + Left (ConstraintSplitIntersectionIndeterminate crossing) + | otherwise = + Right (canonicalPoint (Point (ax + t * rx) (ay + t * ry))) + where + rx = bx - ax + ry = by - ay + sx = dx - cx + sy = dy - cy + denominator = rx * sy - ry * sx + t = ((cx - ax) * sy - (cy - ay) * sx) / denominator diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | The shared vocabulary of the constrained layer: its refusals, its published +-- results, and the transaction-local state its interpreters carry. +module Moonlight.Triangulation.Internal.Cdt.Types + ( CdtError (..) + , CanonicalSegment (..) + , ConstraintConflict (..) + , ConstrainedUnionError (..) + , ConstrainedSeamSource (..) + , ConstrainedSeamFaceEvidence (..) + , ConstrainedSeamConstraintEvidence (..) + , ConstrainedSeamResult (..) + , CorridorObstruction (..) + , ConstraintResult (..) + , ConstraintOutcome (..) + , ConstraintBatchStats (..) + , ConstraintBatchResult (..) + , ConstrainedExtensionResult (..) + , ConstraintSplitBatchResult (..) + , ConstraintBatchAccumulator (..) + , ConstraintRequestAccumulator (..) + , ConstraintWorkspace (..) + , MutableConstraintProgram (..) + , MutableConstraintOutcome (..) + , MutableProgramCursor (..) + , MutablePlanWalk (..) + , MutableConstraintScan (..) + , ConstraintProgramAccumulator (..) + , CdtBuildResult (..) + ) where + +import Control.DeepSeq (NFData) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Vector as V +import Data.Primitive.PrimArray (PrimArray) +import Data.Word (Word32) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId + , FaceId + , UndirectedEdgeId + , VertexId + ) +import Moonlight.Triangulation.Internal.Growable (GrowableWord32) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.IntersectionIterator (Intersection) +import GHC.Generics (Generic) + +-- | Typed refusal surface for constrained construction and corridor recovery. +data CdtError + = CdtBuildError !BuildError + | InvalidConstraintVertex !VertexId + | ConstraintIntersection !UndirectedEdgeId + | ConstraintInputConflicts !(V.Vector (Int, Int)) + | ConstraintCorridorObstructed !CorridorObstruction + | ConstraintBatchCardinalityMismatch + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + | ConstraintEndpointIndexOutOfRange + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + | ConstraintSplitBudgetExhausted + !VertexId + !VertexId + {-# UNPACK #-} !Int + | ConstraintSplitIntersectionIndeterminate + !DirectedEdgeId + | ConstraintEdgeIndexOutOfRange + !UndirectedEdgeId + {-# UNPACK #-} !Int + | ConstraintRecoverySafetyBudgetExhausted + !VertexId + !VertexId + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + | ConstraintRecoveryStripExhausted + !VertexId + !VertexId + {-# UNPACK #-} !Int + | ConstraintRecoveryStripUnflippable + !VertexId + !VertexId + !DirectedEdgeId + {-# UNPACK #-} !Int + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Geometric identity of one constraint segment. The constructor is private: +-- endpoints are always canonical points in ascending order, so direction and +-- edge numbering cannot leak into union witnesses. +data CanonicalSegment = CanonicalSegment + { -- | Lesser endpoint under the point ordering. + segmentStart :: !(Point) + , -- | Greater endpoint under the point ordering. + segmentEnd :: !(Point) + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | A pair of properly crossing constraints, ordered independently of operand +-- and traversal order. +data ConstraintConflict = ConstraintConflict + { -- | Lesser segment under the canonical segment ordering. + conflictFirstSegment :: !(CanonicalSegment) + , -- | Greater segment under the canonical segment ordering. + conflictSecondSegment :: !(CanonicalSegment) + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Complete obstruction surface for atomic constrained union. +data ConstrainedUnionError + = ConstraintUnionConflicts !(NonEmpty (ConstraintConflict)) + | ConstraintUnionConstructionFailed !(CdtError) + | ConstraintUnionSiteMissing !(Point) + | ConstraintUnionNotSeparated + | ConstraintUnionSourceFaceNotTriangular + !ConstrainedSeamSource + !FaceId + {-# UNPACK #-} !Int + | ConstraintUnionTargetFaceNotTriangular + !FaceId + {-# UNPACK #-} !Int + | ConstraintUnionTargetFaceAmbiguous !FaceId !FaceId + | ConstraintUnionSourceFaceNotPreserved + !ConstrainedSeamSource + !FaceId + | ConstraintUnionSourceConstraintNotPreserved + !ConstrainedSeamSource + !(CanonicalSegment) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Operand identity in a separated constrained seam. This belongs in the +-- obstruction and receipt vocabulary rather than being encoded as a Boolean; +-- callers must handle both source sections explicitly. +data ConstrainedSeamSource + = ConstrainedSeamLeftSource + | ConstrainedSeamRightSource + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Exact proof that one active source face survives as one target face. The +-- three points are stored in ascending order, so the witness is independent +-- of local face rotation and handle numbering. +data ConstrainedSeamFaceEvidence = ConstrainedSeamFaceEvidence + { constrainedSeamSourceFace :: !FaceId + , constrainedSeamTargetFace :: !FaceId + , constrainedSeamFaceFirstPoint :: !(Point) + , constrainedSeamFaceSecondPoint :: !(Point) + , constrainedSeamFaceThirdPoint :: !(Point) + } + 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) + , constrainedSeamConstraintRecovery :: !(Maybe ConstraintOutcome) + } + 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 only +-- after canonical publication and exact source restriction checks succeed. +data ConstrainedSeamResult vertex = ConstrainedSeamResult + { constrainedSeamResultTriangulation + :: !(Triangulation 'Constrained vertex () () ()) + , constrainedSeamLeftFaceEvidence + :: !(V.Vector (ConstrainedSeamFaceEvidence)) + , constrainedSeamRightFaceEvidence + :: !(V.Vector (ConstrainedSeamFaceEvidence)) + , constrainedSeamNewFaces :: !(V.Vector FaceId) + , constrainedSeamLeftConstraintEvidence + :: !(V.Vector (ConstrainedSeamConstraintEvidence)) + , constrainedSeamRightConstraintEvidence + :: !(V.Vector (ConstrainedSeamConstraintEvidence)) + , constrainedSeamConstraintStats :: !ConstraintBatchStats + , constrainedSeamBuildStats :: !BuildStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance Eq vertex => Eq (ConstrainedSeamResult vertex) +deriving stock instance Show vertex => Show (ConstrainedSeamResult vertex) + +-- | Structural witness that corridor recovery could not complete. +data CorridorObstruction + = CorridorWalkDidNotTerminate {-# UNPACK #-} !Int + | CorridorBoundaryMissing !VertexId !VertexId + | CorridorProgramMalformed {-# UNPACK #-} !Int + | CorridorTargetMissing !VertexId !VertexId + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data ConstraintResult vertex directed undirected face = ConstraintResult + { constraintTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , constraintPath :: !(V.Vector DirectedEdgeId) + , constraintAddedEdges :: {-# UNPACK #-} !Int + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (ConstraintResult vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (ConstraintResult vertex directed undirected face) + +data ConstraintOutcome + = ConstraintAccepted + !(V.Vector DirectedEdgeId) + {-# UNPACK #-} !Int + | ConstraintRejected + !UndirectedEdgeId + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data ConstraintBatchStats = ConstraintBatchStats + { constraintBatchRequests :: {-# UNPACK #-} !Int + , constraintBatchAccepted :: {-# UNPACK #-} !Int + , constraintBatchRejected :: {-# UNPACK #-} !Int + , constraintBatchCorridors :: {-# UNPACK #-} !Int + , constraintBatchReusedFaces :: {-# UNPACK #-} !Int + , constraintBatchCrossedEdges :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Show, Read, Generic) + deriving anyclass (NFData) + +data ConstraintBatchResult vertex directed undirected face = ConstraintBatchResult + { constraintBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , constraintBatchOutcomes :: !(V.Vector ConstraintOutcome) + , constraintBatchStats :: !ConstraintBatchStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (ConstraintBatchResult vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (ConstraintBatchResult vertex directed undirected face) + +-- | Receipt of one asymmetric constrained extension. The triangulation and +-- all telemetry arise from the same sealed transaction: base sites were +-- resident, incoming sites were inserted, and only incoming constraints were +-- interpreted. A later refinement is deliberately a separate operation over +-- this immutable result, not a hidden continuation of this transaction. +data ConstrainedExtensionResult vertex directed undirected face = ConstrainedExtensionResult + { constrainedExtensionTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , constrainedExtensionConstraintOutcomes :: !(V.Vector ConstraintOutcome) + , constrainedExtensionConstraintStats :: !ConstraintBatchStats + , constrainedExtensionBuildStats :: !BuildStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (ConstrainedExtensionResult vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (ConstrainedExtensionResult vertex directed undirected face) + +-- | One published mesh carrying every requested division. The paths are +-- per-request receipts in traversal order; a later request may have rewritten +-- topology an earlier path names, which is the same as-traversed reading the +-- singleton path already carries. +data ConstraintSplitBatchResult vertex directed undirected face = ConstraintSplitBatchResult + { splitBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , splitBatchPaths :: !(V.Vector (V.Vector DirectedEdgeId)) + , splitBatchAddedEdges :: {-# UNPACK #-} !Int + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (ConstraintSplitBatchResult vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (ConstraintSplitBatchResult vertex directed undirected face) + +data ConstraintBatchAccumulator = ConstraintBatchAccumulator + { accumulatedConstraintOutcomes :: ![ConstraintOutcome] + , accumulatedConstraintStats :: !ConstraintBatchStats + } + +data ConstraintRequestAccumulator = ConstraintRequestAccumulator + { accumulatedRequestPath :: ![DirectedEdgeId] + , accumulatedRequestAddedEdges :: {-# UNPACK #-} !Int + , accumulatedRequestCorridors :: {-# UNPACK #-} !Int + , accumulatedRequestReusedFaces :: {-# UNPACK #-} !Int + , accumulatedRequestCrossedEdges :: {-# UNPACK #-} !Int + } + +data ConstraintWorkspace s = ConstraintWorkspace + { constraintProgramWords :: !(GrowableWord32 s) + , constraintWalkBudget :: {-# UNPACK #-} !Int + } + +data MutableConstraintProgram = MutableConstraintProgram + { mutableProgramWordCount :: {-# UNPACK #-} !Int + , mutableProgramPieceCount :: {-# UNPACK #-} !Int + } + +-- | What one request did to the thawed mesh. A rejection is a value: the batch +-- interpreter records it and carries on, the singleton verbs abandon the +-- transaction on it, and both readings are lawful because an accepted request +-- may lawfully obstruct a later one. +data MutableConstraintOutcome + = MutableConstraintRejected !UndirectedEdgeId + | MutableConstraintAccepted !ConstraintRequestAccumulator + +data MutableProgramCursor = MutableProgramCursor + { mutableCursorAt :: !VertexId + , mutableCursorHeader :: {-# UNPACK #-} !Int + , mutableCursorWriteAt :: {-# UNPACK #-} !Int + , mutableCursorConflictCount :: {-# UNPACK #-} !Int + , mutableCursorPieceCount :: {-# UNPACK #-} !Int + , mutableCursorAfterOverlap :: !Bool + } + +data MutablePlanWalk + = MutablePlanActive !Intersection !MutableProgramCursor + | MutablePlanComplete !MutableConstraintProgram + | MutablePlanBlocked !DirectedEdgeId + | MutablePlanFailed !CorridorObstruction + +data MutableConstraintScan + = MutableConstraintScanBlocked !DirectedEdgeId + | MutableConstraintScanAdmitted !MutableConstraintProgram + +data ConstraintProgramAccumulator = ConstraintProgramAccumulator + { accumulatedProgramCursor :: {-# UNPACK #-} !Int + , accumulatedProgramRequest :: !ConstraintRequestAccumulator + } + +data CdtBuildResult vertex directed undirected face = CdtBuildResult + { cdtBuildTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) + , cdtBuildInputVertices :: !(PrimArray Word32) + , cdtBuildStats :: !BuildStats + , cdtRejectedConstraints :: !(V.Vector (Int, Int)) + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (CdtBuildResult vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (CdtBuildResult vertex directed undirected face) diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Canonical constraint segments and the atomic partial union of two +-- constrained meshes, retaining or combining their site annotations. +module Moonlight.Triangulation.Internal.Cdt.Union + ( canonicalSegment + , constraintSegments + , unionConstrainedWith + , unionConstrained + , joinSeparatedConstrainedWith + , extendConstrainedWith + , segmentRequest + , firstRejected + , completeConstraintConflicts + , orderedConflict + , crossingIsRepresented + ) where + +import Control.Monad (foldM) +import Control.Monad.ST (ST) +import Data.Either (isRight) +import Data.List (sort) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Vector as V +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.IntersectionIterator (foldCorridorBetweenPoints) +import Moonlight.Triangulation.Internal.Canonical (canonicalize) +import Moonlight.Triangulation.Insertion (insertPointCombining) +import Moonlight.Triangulation.Internal.Cdt.Batch + ( interpretConstraintRequests + , recoverConstraints + ) +import Moonlight.Triangulation.Internal.Cdt.Build (fromDelaunay) +import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM, mapLeft) +import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) +import Moonlight.Triangulation.Internal.Cdt.Types +import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) +import Moonlight.Triangulation.Internal.Join.Seam + ( executeConstrainedSeam + , planSeam + , seamExecutionBuildStats + , seamExecutionTriangulation + ) +import Moonlight.Triangulation.Internal.Join.SiteSet + ( SiteSet + , siteSetAssocs + , siteSetFromTriangulation + , siteSetPoints + , siteSetSize + , siteSetUnionWith + ) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction)) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Mutable (MutableDcel) +import Moonlight.Triangulation.Internal.OperationState (OperationState) +import Moonlight.Triangulation.Internal.Transaction (runTransaction) +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math + +canonicalSegment :: Point -> Point -> CanonicalSegment +canonicalSegment from to + | from <= to = CanonicalSegment from to + | otherwise = CanonicalSegment to from +{-# INLINE canonicalSegment #-} + +-- | Geometry of the constraint section, deduplicated and canonically ordered. +constraintSegments + :: Triangulation 'Constrained vertex directed undirected face + -> V.Vector (CanonicalSegment) +constraintSegments triangulation = + V.fromList + ( Set.toAscList + ( Set.fromList + [ canonicalSegment + (Dcel.vertexPoint triangulation from) + (Dcel.vertexPoint triangulation to) + | edge <- constraintEdges triangulation + , let (from, to) = Dcel.undirectedEndpoints triangulation edge + ] + ) + ) + +-- | Atomic partial union of constrained meshes. Coincident sites combine +-- their annotations before construction. Complete canonical conflict +-- witnesses descend first; a successful branch then reaches the existing +-- batch corridor interpreter exactly once. +unionConstrainedWith + :: (annotation -> annotation -> annotation) + -> Triangulation 'Constrained annotation () () () + -> Triangulation 'Constrained annotation () () () + -> Either + (ConstrainedUnionError) + (Triangulation 'Constrained annotation () () ()) +unionConstrainedWith combine left right = + case NonEmpty.nonEmpty (Set.toAscList conflicts) of + Just witnesses -> Left (ConstraintUnionConflicts witnesses) + Nothing -> do + unconstrained <- + mapLeft + (ConstraintUnionConstructionFailed . CdtBuildError) + (rebuildCanonicalSiteSet unionSites) + requests <- traverse (segmentRequest unconstrained) (V.toList segments) + recovered <- + mapLeft ConstraintUnionConstructionFailed + (recoverConstraints (fromDelaunay unconstrained) (V.fromList requests)) + case firstRejected (constraintBatchOutcomes recovered) of + Just blocking -> + Left + ( ConstraintUnionConstructionFailed + (ConstraintIntersection blocking) + ) + Nothing -> + mapLeft + (ConstraintUnionConstructionFailed . CdtBuildError) + (canonicalize (constraintBatchTriangulation recovered)) + where + leftSites = siteSetFromTriangulation left + rightSites = siteSetFromTriangulation right + unionSites = siteSetUnionWith combine leftSites rightSites + segments = + V.fromList + ( Set.toAscList + ( Set.union + (Set.fromList (V.toList (constraintSegments left))) + (Set.fromList (V.toList (constraintSegments right))) + ) + ) + conflicts = completeConstraintConflicts unionSites segments +{-# INLINE unionConstrainedWith #-} + +-- | Atomic partial union specialized to geometry-only constrained meshes. +unionConstrained + :: Triangulation 'Constrained () () () () + -> Triangulation 'Constrained () () () () + -> Either + (ConstrainedUnionError) + (Triangulation 'Constrained () () () ()) +unionConstrained = unionConstrainedWith (\_ _ -> ()) +{-# INLINE unionConstrained #-} + +-- | Join two strictly separated constrained triangulations by copying both +-- source meshes and zippering only their common tangent corridor. The source +-- constraint planes are present during legalization, so contour edges are +-- immutable barriers rather than edges recovery tries to resurrect after a +-- solved face has already disappeared. +-- +-- The annotation combiner is intentionally not evaluated: strict x-separation +-- proves that the two site sets have no coincident point. It remains in the +-- signature so this operation composes at the same annotation boundary as the +-- other constrained joins without inventing a geometry-only facade. +joinSeparatedConstrainedWith + :: (annotation -> annotation -> annotation) + -> Triangulation 'Constrained annotation () () () + -> Triangulation 'Constrained annotation () () () + -> Either + (ConstrainedUnionError) + (ConstrainedSeamResult annotation) +joinSeparatedConstrainedWith _combine left right = do + seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right) + seamExecution <- + mapLeft + (ConstraintUnionConstructionFailed . CdtBuildError) + (executeConstrainedSeam seamPlan left right) + let copied = seamExecutionTriangulation seamExecution + leftSegments = constraintSegments left + rightSegments = constraintSegments right + copiedSegments = Set.fromList (V.toList (constraintSegments copied)) + missingSegments = + V.filter (`Set.notMember` copiedSegments) (leftSegments V.++ rightSegments) + requests <- traverse (segmentRequest copied) (V.toList missingSegments) + recovered <- + mapLeft ConstraintUnionConstructionFailed + (recoverConstraints copied (V.fromList requests)) + case firstRejected (constraintBatchOutcomes recovered) of + Just blocking -> + Left + ( ConstraintUnionConstructionFailed + (ConstraintIntersection blocking) + ) + Nothing -> do + published <- + mapLeft + (ConstraintUnionConstructionFailed . CdtBuildError) + (canonicalize (constraintBatchTriangulation recovered)) + targetFaces <- targetFaceIndex published + leftFaces <- + sourceFaceEvidence + ConstrainedSeamLeftSource + left + targetFaces + rightFaces <- + sourceFaceEvidence + ConstrainedSeamRightSource + right + targetFaces + let preservedTargets = + Set.fromList + ( fmap constrainedSeamTargetFace (V.toList leftFaces) + <> fmap constrainedSeamTargetFace (V.toList rightFaces) + ) + newFaces = + V.fromList + ( filter + (`Set.notMember` preservedTargets) + (innerFaceIds published) + ) + recoveredOutcomes = + Map.fromList + (V.toList (V.zip missingSegments (constraintBatchOutcomes recovered))) + finalSegments = Set.fromList (V.toList (constraintSegments published)) + leftConstraintEvidence <- + sourceConstraintEvidence + ConstrainedSeamLeftSource + finalSegments + recoveredOutcomes + leftSegments + rightConstraintEvidence <- + sourceConstraintEvidence + ConstrainedSeamRightSource + finalSegments + recoveredOutcomes + rightSegments + pure + ConstrainedSeamResult + { constrainedSeamResultTriangulation = published + , constrainedSeamLeftFaceEvidence = leftFaces + , constrainedSeamRightFaceEvidence = rightFaces + , constrainedSeamNewFaces = newFaces + , constrainedSeamLeftConstraintEvidence = leftConstraintEvidence + , constrainedSeamRightConstraintEvidence = rightConstraintEvidence + , constrainedSeamConstraintStats = constraintBatchStats recovered + , constrainedSeamBuildStats = seamExecutionBuildStats seamExecution + } + +data CanonicalFaceKey = CanonicalFaceKey + !(Point) + !(Point) + !(Point) + deriving stock (Eq, Ord) + +targetFaceIndex + :: Triangulation mode vertex directed undirected face + -> Either + (ConstrainedUnionError) + (Map.Map CanonicalFaceKey FaceId) +targetFaceIndex triangulation = + foldM insertTarget Map.empty (innerFaceIds triangulation) + where + insertTarget + :: Map.Map CanonicalFaceKey FaceId + -> FaceId + -> Either (ConstrainedUnionError) (Map.Map CanonicalFaceKey FaceId) + insertTarget index face = do + key <- targetFaceKey triangulation face + case Map.lookup key index of + Just existing -> Left (ConstraintUnionTargetFaceAmbiguous existing face) + Nothing -> Right (Map.insert key face index) + +sourceFaceEvidence + :: ConstrainedSeamSource + -> Triangulation mode vertex directed undirected face + -> Map.Map CanonicalFaceKey FaceId + -> Either + (ConstrainedUnionError) + (V.Vector (ConstrainedSeamFaceEvidence)) +sourceFaceEvidence source triangulation targetFaces = + V.fromList <$> traverse evidenceFor (innerFaceIds triangulation) + where + evidenceFor sourceFace = do + key@(CanonicalFaceKey first second third) <- + sourceFaceKey source triangulation sourceFace + targetFace <- + maybe + (Left (ConstraintUnionSourceFaceNotPreserved source sourceFace)) + Right + (Map.lookup key targetFaces) + pure + ConstrainedSeamFaceEvidence + { constrainedSeamSourceFace = sourceFace + , constrainedSeamTargetFace = targetFace + , constrainedSeamFaceFirstPoint = first + , constrainedSeamFaceSecondPoint = second + , constrainedSeamFaceThirdPoint = third + } + +sourceConstraintEvidence + :: ConstrainedSeamSource + -> Set.Set (CanonicalSegment) + -> Map.Map (CanonicalSegment) ConstraintOutcome + -> V.Vector (CanonicalSegment) + -> Either + (ConstrainedUnionError) + (V.Vector (ConstrainedSeamConstraintEvidence)) +sourceConstraintEvidence source finalSegments recovered = + traverse + (\segment -> + if Set.member segment finalSegments + then + Right + ConstrainedSeamConstraintEvidence + { constrainedSeamConstraintSegment = segment + , constrainedSeamConstraintRecovery = Map.lookup segment recovered + } + else Left (ConstraintUnionSourceConstraintNotPreserved source segment) + ) + +sourceFaceKey + :: ConstrainedSeamSource + -> Triangulation mode vertex directed undirected face + -> FaceId + -> Either (ConstrainedUnionError) CanonicalFaceKey +sourceFaceKey source triangulation face = + case sort (fmap (Dcel.vertexPoint triangulation) (Dcel.faceVertices triangulation face)) of + [first, second, third] -> Right (CanonicalFaceKey first second third) + points -> + Left + ( ConstraintUnionSourceFaceNotTriangular + source + face + (length points) + ) + +targetFaceKey + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Either (ConstrainedUnionError) CanonicalFaceKey +targetFaceKey triangulation face = + case sort (fmap (Dcel.vertexPoint triangulation) (Dcel.faceVertices triangulation face)) of + [first, second, third] -> Right (CanonicalFaceKey first second third) + points -> Left (ConstraintUnionTargetFaceNotTriangular face (length points)) + +innerFaceIds + :: Triangulation mode vertex directed undirected face + -> [FaceId] +innerFaceIds triangulation = + fmap (FaceId . fromIntegral) [1 .. Dcel.numFaces triangulation - 1] + +-- | Extend one already-resident constrained triangulation with one new +-- constrained section. This is intentionally asymmetric: the base mesh is +-- thawed once, extension sites are inserted into it, and only the extension's +-- constraint section is replayed. Unlike 'unionConstrainedWith', it neither +-- rebuilds a canonical site set nor replays base constraints, because both +-- would erase the physical distinction between solved base and new work. +-- +-- Incoming constraint recovery is itself the spatial conflict authority. It +-- walks only the incoming corridors against the resident base and returns a +-- typed intersection obstruction. Re-running the canonical all-pairs union +-- preflight here would make a tiny extension quadratic in the base. Any +-- structural or recovery obstruction abandons the transaction before a +-- partially extended mesh can be published. +extendConstrainedWith + :: (annotation -> annotation -> annotation) + -> Triangulation 'Constrained annotation () () () + -> Triangulation 'Constrained annotation () () () + -> Either + (ConstrainedUnionError) + (ConstrainedExtensionResult annotation () () ()) +extendConstrainedWith combine base extension = do + (completed, extended, buildStats) <- + runTransaction + (ConstraintUnionConstructionFailed . CdtBuildError) + transactionShape + base + (siteSetSize extensionSites) + (insertAndRecoverExtension combine extensionSites extensionSegments) + pure + ConstrainedExtensionResult + { constrainedExtensionTriangulation = extended + , constrainedExtensionConstraintOutcomes = accumulatorOutcomes completed + , constrainedExtensionConstraintStats = accumulatedConstraintStats completed + , constrainedExtensionBuildStats = buildStats + } + where + extensionSites = siteSetFromTriangulation extension + extensionSegments = constraintSegments extension + transactionShape = + case V.uncons extensionSegments of + Just (segment, remaining) + | Dcel.numVertices base >= 200000 + , siteSetSize extensionSites <= 128 + , V.null remaining + , residentCorridorIsEmpty segment -> LocalTransaction + _ -> DenseTransaction + residentCorridorIsEmpty segment = + case (mkQueryPoint (segmentStart segment), mkQueryPoint (segmentEnd segment)) of + (Right from, Right to) -> + foldCorridorBetweenPoints base from to (\_ _ -> Left ()) () == Just (Right ()) + _ -> False +{-# INLINE extendConstrainedWith #-} + +insertAndRecoverExtension + :: (annotation -> annotation -> annotation) + -> SiteSet annotation + -> V.Vector (CanonicalSegment) + -> MutableDcel s annotation () () () + -> OperationState s + -> ST s (Either (ConstrainedUnionError) ConstraintBatchAccumulator) +insertAndRecoverExtension combine extensionSites extensionSegments mutable operation = do + placed <- insertExtensionSites combine extensionSites mutable operation + case placed of + Left obstruction -> pure (Left obstruction) + Right handles -> + case traverse (segmentRequestFromHandles handles) (V.toList extensionSegments) of + Left obstruction -> pure (Left obstruction) + Right requests -> do + interpreted <- + fmap + (mapLeft ConstraintUnionConstructionFailed) + (interpretConstraintRequests (V.fromList requests) mutable operation) + case interpreted of + Left obstruction -> pure (Left obstruction) + Right completed -> + case firstRejected (accumulatorOutcomes completed) of + Just blocking -> + pure + ( Left + ( ConstraintUnionConstructionFailed + (ConstraintIntersection blocking) + ) + ) + Nothing -> pure (Right completed) + +insertExtensionSites + :: forall s annotation + . (annotation -> annotation -> annotation) + -> SiteSet annotation + -> MutableDcel s annotation () () () + -> OperationState s + -> ST s (Either (ConstrainedUnionError) (Map.Map (Point) VertexId)) +insertExtensionSites combine extensionSites mutable operation = + fmap + (fmap (Map.fromDistinctAscList . reverse)) + ( foldWhileM + isRight + insertOne + (Right []) + (siteSetAssocs extensionSites) + ) + where + insertOne + :: Either (ConstrainedUnionError) [(Point, VertexId)] + -> (Point, annotation) + -> ST s (Either (ConstrainedUnionError) [(Point, VertexId)]) + insertOne rejected@(Left _) _ = pure rejected + insertOne (Right accumulated) (point, annotation) = + fmap + ( mapLeft (ConstraintUnionConstructionFailed . CdtBuildError) + . fmap + (\(vertex, _) -> (point, VertexId (fromIntegral vertex)) : accumulated) + ) + (insertPointCombining combine Nothing mutable operation point annotation) + +accumulatorOutcomes :: ConstraintBatchAccumulator -> V.Vector ConstraintOutcome +accumulatorOutcomes = V.fromList . reverse . accumulatedConstraintOutcomes +{-# INLINE accumulatorOutcomes #-} + +segmentRequest + :: Triangulation mode annotation () () () + -> CanonicalSegment + -> Either (ConstrainedUnionError) (VertexId, VertexId) +segmentRequest triangulation segment = + segmentRequestFromHandles handles segment + where + handles = + Map.fromList + [ ( Dcel.vertexPoint triangulation vertex + , vertex + ) + | raw <- [0 .. Dcel.numVertices triangulation - 1] + , let vertex = VertexId (fromIntegral raw) + ] + +segmentRequestFromHandles + :: Map.Map (Point) VertexId + -> CanonicalSegment + -> Either (ConstrainedUnionError) (VertexId, VertexId) +segmentRequestFromHandles handles segment = + case + ( Map.lookup (segmentStart segment) handles + , Map.lookup (segmentEnd segment) handles + ) of + (Just from, Just to) -> Right (from, to) + (Nothing, _) -> Left (ConstraintUnionSiteMissing (segmentStart segment)) + (_, Nothing) -> Left (ConstraintUnionSiteMissing (segmentEnd segment)) + +firstRejected :: V.Vector ConstraintOutcome -> Maybe UndirectedEdgeId +firstRejected = + V.foldr + (\outcome later -> + case outcome of + ConstraintAccepted _ _ -> later + ConstraintRejected blocking -> Just blocking + ) + Nothing + +completeConstraintConflicts + :: SiteSet annotation + -> V.Vector (CanonicalSegment) + -> Set.Set (ConstraintConflict) +completeConstraintConflicts unionSites segments = + Set.fromList + [ orderedConflict leftSegment rightSegment + | leftIndex <- [0 .. V.length segments - 1] + , rightIndex <- [leftIndex + 1 .. V.length segments - 1] + , let leftSegment = segments V.! leftIndex + , let rightSegment = segments V.! rightIndex + , segmentsProperlyCross + (segmentStart leftSegment) + (segmentEnd leftSegment) + (segmentStart rightSegment) + (segmentEnd rightSegment) + , not (crossingIsRepresented unionSites leftSegment rightSegment) + ] + +orderedConflict + :: CanonicalSegment + -> CanonicalSegment + -> ConstraintConflict +orderedConflict left right + | left <= right = ConstraintConflict left right + | otherwise = ConstraintConflict right left + +crossingIsRepresented + :: SiteSet annotation + -> CanonicalSegment + -> CanonicalSegment + -> Bool +crossingIsRepresented sites first second = + V.any + (\point -> + onClosedSegment (segmentStart first) (segmentEnd first) point + && onClosedSegment (segmentStart second) (segmentEnd second) point + ) + (siteSetPoints sites) diff --git a/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs b/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs @@ -0,0 +1,642 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +module Moonlight.Triangulation.Internal.CircleSweep + ( circleSweepInsert + ) where + +import Control.Monad (forM_, when) +import Control.Monad.ST (ST) +import Data.Bits (xor) +import Data.STRef + ( STRef + , newSTRef + , readSTRef + , writeSTRef + ) +import qualified Data.Vector.Algorithms.Intro as Intro +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..)) +import Moonlight.Triangulation.Insertion (insertExistingVertex) +import Moonlight.Triangulation.Internal.DcelOperations + ( closeOuterTurn + , drainLegalization + , fixHullConvexity + , insertOutsideHullBetween + , LegalizationLaw (..) + , noStarVertex + , seedGenericEdges + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , maxCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.Probe (Probe (..)) +import Moonlight.Triangulation.Scalar (orient2dCoordinates) +import Moonlight.Triangulation.Types (BuildError (..)) + +-- | The hull is an angular index over the DCEL outer-face cycle. The cycle +-- itself already owns hull adjacency, so left and right walking is +-- 'readPrevious'/'readNext' on the live mesh and this record only caches what +-- topology cannot state: the pseudo-angle of each outer edge's origin and the +-- bucket anchors accelerating the predecessor search. An outer edge's key is +-- its origin's @(angle, x, y)@ with the edge id as the final tie-break; the +-- angle lives in 'hullAngleByEdge' and the coordinates are re-read from the +-- immutable origin only when two cached angles compare exactly equal. Slots +-- of edges that have left the outer cycle are never read again, so the cache +-- needs no invalidation, and there is no second ring beside the authoritative +-- one. +data Hull s = Hull + { hullCenterX :: {-# UNPACK #-} !Double + , hullCenterY :: {-# UNPACK #-} !Double + , hullBucketCapacity :: {-# UNPACK #-} !Int + , hullAngleByEdge :: !(MUV.MVector s Double) + , hullActiveCount :: !(MUV.MVector s Int) + , hullBuckets :: !(STRef s (MUV.MVector s Word32)) + } + +readActiveCount :: Hull s -> ST s Int +readActiveCount hull = MUV.unsafeRead (hullActiveCount hull) 0 +{-# INLINE readActiveCount #-} + +writeActiveCount :: Hull s -> Int -> ST s () +writeActiveCount hull = MUV.unsafeWrite (hullActiveCount hull) 0 +{-# INLINE writeActiveCount #-} + +noOuterEdge :: Word32 +noOuterEdge = maxBound + +-- | Circle sweep over one mutable DCEL, consuming one packed radial arena of +-- @(squaredDistance, x, y, vertex)@ records. The arena is sorted in place and +-- then read directly — no decorated freeze, no undecoration pass. Insertions +-- initially close only acute hull turns. One terminal Graham pass restores +-- full convexity, so construction does not repeatedly pay for global +-- convexity that no intermediate observer can see. +circleSweepInsert + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> MUV.MVector s (Double, Double, Double, Word32) + -> ST s (Either BuildError Int) +circleSweepInsert mutable operation arena + | MUV.length arena == 0 = pure (Right 0) + | otherwise = do + Intro.sort arena + let !ordered = MUV.length arena + seed <- insertSeed 0 + case seed of + Left failure -> pure (Left failure) + Right seedCount -> do + faces <- faceCount mutable + if faces <= 1 || seedCount >= ordered + then pure (Right seedCount) + else do + (centerX, centerY) <- seedCentre mutable + builtHull <- buildHull mutable operation centerX centerY + case builtHull of + Left failure -> pure (Left failure) + Right hull -> do + skipped <- MUV.new (ordered - seedCount) + inserted <- insertRemaining hull ordered seedCount skipped 0 0 0 0 + case inserted of + Left failure -> pure (Left failure) + Right (!skippedCount, !fastCount, !flips, !maxDepth) -> do + -- The sweep counts its own hull insertions; its drains + -- hand their flip and depth tallies up once. + addCounter operation CounterHullInsertions fastCount + -- The angular candidate leaves a point to the fallback + -- whenever it lands right of, or on, the hull edge its + -- own angle selected — spade's + -- `is_on_right_side_or_on_line` branch, which spade's own + -- source calls "very slow". Both counts ride out in + -- BuildStats so the split is comparable across the two + -- implementations and satisfies + -- seed + fast + skipped = unique. + -- + -- CounterSweepFastPoints is NOT CounterHullInsertions + -- renamed: the latter is also charged by + -- insertOutsideHull, so it counts hull-adjacent + -- insertions from either path and dominates this one + -- whenever a skipped point lands outside the hull. The + -- two coincide only while skipped is zero, and charging + -- them independently is what makes the identity a check + -- rather than a restatement. + addCounter operation CounterSweepFastPoints fastCount + addCounter operation CounterSweepSkippedPoints skippedCount + addCounter operation CounterEdgeFlips flips + maxCounter operation CounterLegalizationMaxStack maxDepth + repaired <- fixHullConvexity @'ProbeOff mutable operation + case repaired of + Left failure -> pure (Left failure) + Right (!_closures, !terminalFlips, !terminalMaxDepth) -> do + addCounter operation CounterEdgeFlips terminalFlips + maxCounter operation CounterLegalizationMaxStack terminalMaxDepth + insertedSkipped <- insertSkipped skipped skippedCount 0 + pure (seedCount <$ insertedSkipped) + where + insertSeed !index + | index >= MUV.length arena = pure (Right index) + | otherwise = do + (_, _, _, raw) <- MUV.unsafeRead arena index + result <- insertExistingVertex @'ProbeOff mutable operation (fromIntegral raw) + case result of + Left failure -> pure (Left failure) + Right () -> do + faces <- faceCount mutable + if faces > 1 + then pure (Right (index + 1)) + else insertSeed (index + 1) + + insertRemaining !hull !ordered !index !skipped !skippedCount !fastCount !flips !maxDepth + | index >= ordered = pure (Right (skippedCount, fastCount, flips, maxDepth)) + | otherwise = do + (_, queryXWide, queryYWide, raw) <- MUV.unsafeRead arena index + let !vertex = fromIntegral raw + queryX <- readPointX mutable vertex + queryY <- readPointY mutable vertex + let !queryAngle = + pseudoAngle (hullCenterX hull) (hullCenterY hull) queryXWide queryYWide + edge <- hullCandidate mutable hull queryAngle queryXWide queryYWide + fromVertex <- readOrigin mutable edge + toVertex <- readOrigin mutable (edge `xor` 1) + fromX <- readPointX mutable fromVertex + fromY <- readPointY mutable fromVertex + toX <- readPointX mutable toVertex + toY <- readPointY mutable toVertex + if orient2dCoordinates fromX fromY toX toY queryX queryY == GT + then do + deferred <- insertDeferred mutable operation hull edge vertex queryAngle + case deferred of + Left failure -> pure (Left failure) + Right (!_newClosures, !newFlips, !newMaxDepth) -> + insertRemaining + hull + ordered + (index + 1) + skipped + skippedCount + (fastCount + 1) + (flips + newFlips) + (max maxDepth newMaxDepth) + else do + MUV.unsafeWrite skipped skippedCount raw + insertRemaining hull ordered (index + 1) skipped (skippedCount + 1) fastCount flips maxDepth + + insertSkipped skipped !count = go + where + go !index + | index >= count = pure (Right ()) + | otherwise = do + vertex <- fromIntegral <$> MUV.unsafeRead skipped index + inserted <- insertExistingVertex @'ProbeOff mutable operation vertex + case inserted of + Left failure -> pure (Left failure) + Right () -> go (index + 1) + +-- | The hull centre: the centroid of the first inner face, in the widened +-- comparison format, computed exactly as @centroid@ states it. +seedCentre + :: MutableDcel s vertex directed undirected face + -> ST s (Double, Double) +seedCentre mutable = do + (e0, e1, e2) <- faceEdges mutable 1 + o0 <- readOrigin mutable e0 + o1 <- readOrigin mutable e1 + o2 <- readOrigin mutable e2 + x0 <- readPointX mutable o0 + y0 <- readPointY mutable o0 + x1 <- readPointX mutable o1 + y1 <- readPointY mutable o1 + x2 <- readPointX mutable o2 + y2 <- readPointY mutable o2 + pure (x0 + (x1 - x0) / 3 + (x2 - x0) / 3, y0 + (y1 - y0) / 3 + (y2 - y0) / 3) + +-- | Index the authoritative outer cycle. The seed fan is star-shaped around +-- the first face's centroid — a collinear chain closed by its apex — so the +-- cycle is already the angular order the predecessor search assumes; what +-- remains is caching each edge's angle and anchoring the buckets. +buildHull + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Double + -> Double + -> ST s (Either BuildError (Hull s)) +buildHull mutable operation centerX centerY = do + countResult <- collectOuterEdges mutable operation + case countResult of + Left failure -> pure (Left failure) + Right count + | count <= 0 -> pure (Left CircleSweepHullEmpty) + | otherwise -> do + let !capacity = max (count + 4) (pointCapacity mutable + 8) + hullAngleByEdge <- MUV.new (halfEdgeCapacity mutable) + hullActiveCount <- MUV.replicate 1 count + initialBuckets <- MUV.replicate (initialBucketCount count capacity) noOuterEdge + hullBuckets <- newSTRef initialBuckets + let hull = + Hull + { hullCenterX = centerX + , hullCenterY = centerY + , hullBucketCapacity = capacity + , hullAngleByEdge + , hullActiveCount + , hullBuckets + } + forM_ [0 .. count - 1] $ \index -> do + edge <- readScratch operation index + origin <- readOrigin mutable edge + x <- readPointX mutable origin + y <- readPointY mutable origin + MUV.unsafeWrite hullAngleByEdge edge (pseudoAngle centerX centerY x y) + installBucketMaximum mutable hull edge + pure (Right hull) + +collectOuterEdges + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> ST s (Either BuildError Int) +collectOuterEdges mutable operation = do + start <- readFaceEdge mutable 0 + if start < 0 + then pure (Right 0) + else do + bound <- directedEdgeCount mutable + go (bound + 1) start start False 0 + where + go !remaining !start !edge !seen !count + | remaining <= 0 = + pure + ( Left + ( OuterCycleDidNotTerminate + (DirectedEdgeId (fromIntegral start)) + (DirectedEdgeId (fromIntegral edge)) + count + ) + ) + | seen && edge == start = pure (Right count) + | otherwise = do + writeScratch operation count edge + following <- readNext mutable edge + go (remaining - 1) start following True (count + 1) + +initialBucketCount :: Int -> Int -> Int +initialBucketCount active capacity = + min capacity (nextPowerOfTwo (max 8 ((active + 7) `quot` 8))) + +nextPowerOfTwo :: Int -> Int +nextPowerOfTwo requested = go 1 + where + target = max 1 requested + go !value + | value >= target = value + | value > maxBound `quot` 2 = maxBound + | otherwise = go (value * 2) + +readAngle :: Hull s -> Int -> ST s Double +readAngle hull edge = MUV.unsafeRead (hullAngleByEdge hull) edge +{-# INLINE readAngle #-} + +rebuildBuckets :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s () +rebuildBuckets mutable hull requested = do + let !count = max 1 (min (hullBucketCapacity hull) requested) + buckets <- MUV.replicate count noOuterEdge + writeSTRef (hullBuckets hull) buckets + active <- readActiveCount hull + start <- readFaceEdge mutable 0 + let go !remaining !edge + | remaining <= 0 = pure () + | otherwise = do + installBucketMaximum mutable hull edge + following <- readNext mutable edge + go (remaining - 1) following + when (active > 0 && start >= 0) (go active start) + +maybeGrowBuckets :: MutableDcel s vertex directed undirected face -> Hull s -> ST s () +maybeGrowBuckets mutable hull = do + active <- readActiveCount hull + buckets <- readSTRef (hullBuckets hull) + let !current = MUV.length buckets + when (active > 8 * current && current < hullBucketCapacity hull) $ + rebuildBuckets mutable hull (min (hullBucketCapacity hull) (2 * current)) + +bucketFor :: Int -> Double -> Int +bucketFor count angle = + min (count - 1) (max 0 (floor (angle * fromIntegral count * 0.25))) +{-# INLINE bucketFor #-} + +-- | Compare two outer edges by their origins' keys: cached angle first, then +-- the immutable origin coordinates, then the edge id. The coordinate reads +-- only happen on an exact angle tie, which is the same-ray case and no other. +compareEdgeKeys + :: MutableDcel s vertex directed undirected face + -> Hull s + -> Int + -> Int + -> ST s Ordering +compareEdgeKeys mutable hull left right = do + leftAngle <- readAngle hull left + rightAngle <- readAngle hull right + case compare leftAngle rightAngle of + LT -> pure LT + GT -> pure GT + EQ -> do + leftOrigin <- readOrigin mutable left + rightOrigin <- readOrigin mutable right + leftX <- readPointX mutable leftOrigin + rightX <- readPointX mutable rightOrigin + case compare leftX rightX of + LT -> pure LT + GT -> pure GT + EQ -> do + leftY <- readPointY mutable leftOrigin + rightY <- readPointY mutable rightOrigin + case compare leftY rightY of + LT -> pure LT + GT -> pure GT + EQ -> pure (compare left right) + +-- | Whether an outer edge's key orders at or before the stated query key, +-- settled field by field without materializing either key. +edgeAtMost + :: MutableDcel s vertex directed undirected face + -> Hull s + -> Int + -> Double + -> Double + -> Double + -> Int + -> ST s Bool +edgeAtMost mutable hull edge queryAngle queryX queryY tie = do + angle <- readAngle hull edge + case compare angle queryAngle of + LT -> pure True + GT -> pure False + EQ -> do + origin <- readOrigin mutable edge + x <- readPointX mutable origin + case compare x queryX of + LT -> pure True + GT -> pure False + EQ -> do + y <- readPointY mutable origin + case compare y queryY of + LT -> pure True + GT -> pure False + EQ -> pure (edge <= tie) + +installBucketMaximum :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s () +installBucketMaximum mutable hull edge = do + buckets <- readSTRef (hullBuckets hull) + angle <- readAngle hull edge + let !bucket = bucketFor (MUV.length buckets) angle + currentRaw <- MUV.unsafeRead buckets bucket + if currentRaw == noOuterEdge + then MUV.unsafeWrite buckets bucket (fromIntegral edge) + else do + verdict <- compareEdgeKeys mutable hull edge (fromIntegral currentRaw) + when (verdict == GT) (MUV.unsafeWrite buckets bucket (fromIntegral edge)) + +-- | Drop @edge@ from the bucket index. When it was its bucket's maximum, the +-- cyclic predecessor @left@ stands in provided it still belongs to the same +-- bucket — exact, because a bucket's edges form one contiguous arc of the +-- angular order. The caller states @left@ explicitly: the mesh has already +-- been mutated by the time the index is updated, so the retired edge no +-- longer knows its own neighbour. +removeBucketMaximum :: Hull s -> Int -> Int -> ST s () +removeBucketMaximum hull edge left = do + buckets <- readSTRef (hullBuckets hull) + angle <- readAngle hull edge + let !bucket = bucketFor (MUV.length buckets) angle + current <- MUV.unsafeRead buckets bucket + when (current == fromIntegral edge) $ do + leftAngle <- readAngle hull left + if left /= edge && bucketFor (MUV.length buckets) leftAngle == bucket + then MUV.unsafeWrite buckets bucket (fromIntegral left) + else MUV.unsafeWrite buckets bucket noOuterEdge + +retireEdge :: Hull s -> Int -> Int -> ST s () +retireEdge hull edge left = do + removeBucketMaximum hull edge left + active <- readActiveCount hull + writeActiveCount hull (active - 1) +{-# INLINE retireEdge #-} + +activateEdge :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s () +activateEdge mutable hull edge = do + active <- readActiveCount hull + writeActiveCount hull (active + 1) + installBucketMaximum mutable hull edge + maybeGrowBuckets mutable hull + +-- | The outer edge whose key is the greatest key at or below the query: the +-- visible candidate the sweep inserts against. Bucket anchors land the walk +-- near the answer and the live outer cycle carries it the rest of the way. +hullCandidate + :: MutableDcel s vertex directed undirected face + -> Hull s + -> Double + -> Double + -> Double + -> ST s Int +hullCandidate mutable hull queryAngle queryX queryY = do + buckets <- readSTRef (hullBuckets hull) + let !count = MUV.length buckets + !bucket = bucketFor count queryAngle + raw <- MUV.unsafeRead buckets bucket + if raw == noOuterEdge + then previousNonEmpty buckets (if bucket == 0 then count - 1 else bucket - 1) count + else adjustWithinBucket buckets bucket (fromIntegral raw) + where + previousNonEmpty buckets !bucket !remaining + | remaining <= 0 = readFaceEdge mutable 0 + | otherwise = do + raw <- MUV.unsafeRead buckets bucket + if raw /= noOuterEdge + then pure (fromIntegral raw) + else previousNonEmpty buckets (if bucket == 0 then MUV.length buckets - 1 else bucket - 1) (remaining - 1) + + adjustWithinBucket buckets !bucket !initial = do + active <- readActiveCount hull + go active initial + where + go !remaining !edge + | remaining <= 0 = pure initial + | otherwise = do + atMost <- edgeAtMost mutable hull edge queryAngle queryX queryY maxBound + if atMost + then pure edge + else do + left <- readPrevious mutable edge + leftAngle <- readAngle hull left + if bucketFor (MUV.length buckets) leftAngle /= bucket + then pure left + else go (remaining - 1) left + +insertDeferred + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Hull s + -> Int + -> Int + -> Double + -> ST s (Either BuildError (Int, Int, Int)) +insertDeferred mutable operation hull replacedEdge vertex insertedAngle = do + inserted <- insertOutsideHullBetween @'ProbeOff mutable operation replacedEdge replacedEdge vertex + case inserted of + Left failure -> pure (Left failure) + Right (firstEdge, lastEdge) -> insertDeferredBetween firstEdge lastEdge + where + insertDeferredBetween firstEdge lastEdge = do + -- The patch proves the new keys algebraically, so no key is rediscovered + -- from the mesh: replacing outer edge a->b with a->v, v->b keeps the + -- replaced edge's origin for the first spoke (its cached angle carries + -- over) and starts the last spoke at the inserted vertex, whose angle is the + -- one the candidate search was already given. The tie-break is each fresh + -- edge id itself. + replacedAngle <- readAngle hull replacedEdge + leftOfReplaced <- readPrevious mutable firstEdge + retireEdge hull replacedEdge leftOfReplaced + -- Both spokes join the outer cycle before either is indexed, and a bucket + -- rebuild during activation walks the live cycle: both angle slots must be + -- initialized before the first activation can read them. + MUV.unsafeWrite (hullAngleByEdge hull) firstEdge replacedAngle + MUV.unsafeWrite (hullAngleByEdge hull) lastEdge insertedAngle + activateEdge mutable hull firstEdge + activateEdge mutable hull lastEdge + -- Every turn this insertion closes legalizes together in one epoch. Closure + -- never deletes an edge and never touches the outer cycle, so which turns + -- close does not depend on when the interior is repaired; the fan above + -- keeps its own drain because its candidates are oriented against the + -- inserted vertex, and that star must still be intact when they are tested. + leftOutcome <- closeLeft firstEdge 0 0 + case leftOutcome of + Left obstruction -> pure (Left obstruction) + Right (_left, closuresLeft, topLeft) -> do + rightOutcome <- closeRight lastEdge 0 topLeft + case rightOutcome of + Left obstruction -> pure (Left obstruction) + Right (_right, closuresRight, topAll) -> do + (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation topAll noStarVertex ValidMesh + pure (Right (closuresLeft + closuresRight, flips, maxDepth)) + + closeLeft !current !closures !top = do + left <- readPrevious mutable current + close <- shouldCloseTurn mutable hull insertedAngle left current + if not close + then pure (Right (current, closures, top)) + else do + leftAngle <- readAngle hull left + closed <- closeOuterTurn mutable left + case closed of + Left obstruction -> pure (Left obstruction) + Right replacement -> do + -- Closing consecutive a->b, b->c into a->c keeps the first edge's + -- origin, so the replacement inherits its angle; the tie is the fresh + -- edge id. Both retired edges answer to the same left neighbour, the + -- edge now preceding the replacement on the outer cycle. Seeding + -- happens here, after the replacement's links exist. + leftOfReplacement <- readPrevious mutable replacement + retireEdge hull left leftOfReplacement + retireEdge hull current leftOfReplacement + MUV.unsafeWrite (hullAngleByEdge hull) replacement leftAngle + activateEdge mutable hull replacement + nextTop <- seedGenericEdges operation top [left, current] + closeLeft replacement (closures + 1) nextTop + + closeRight !current !closures !top = do + right <- readNext mutable current + close <- shouldCloseTurn mutable hull insertedAngle current right + if not close + then pure (Right (current, closures, top)) + else do + currentAngle <- readAngle hull current + closed <- closeOuterTurn mutable current + case closed of + Left obstruction -> pure (Left obstruction) + Right replacement -> do + leftOfReplacement <- readPrevious mutable replacement + retireEdge hull current leftOfReplacement + retireEdge hull right leftOfReplacement + MUV.unsafeWrite (hullAngleByEdge hull) replacement currentAngle + activateEdge mutable hull replacement + nextTop <- seedGenericEdges operation top [current, right] + closeRight replacement (closures + 1) nextTop +{-# INLINE insertDeferred #-} + +shouldCloseTurn + :: MutableDcel s vertex directed undirected face + -> Hull s + -> Double + -> Int + -> Int + -> ST s Bool +shouldCloseTurn mutable hull insertedAngle first second = do + following <- readNext mutable first + if following /= second + then pure False + else do + fromVertex <- readOrigin mutable first + middleVertex <- readOrigin mutable (first `xor` 1) + targetVertex <- readOrigin mutable (second `xor` 1) + fromX <- readPointX mutable fromVertex + fromY <- readPointY mutable fromVertex + middleX <- readPointX mutable middleVertex + middleY <- readPointY mutable middleVertex + targetX <- readPointX mutable targetVertex + targetY <- readPointY mutable targetVertex + if orient2dWide fromX fromY middleX middleY targetX targetY /= GT + then pure False + else do + -- The second edge begins at the middle vertex and stands on the outer + -- cycle, so its cached key already is that vertex's pseudo-angle; + -- same-ray is a slot read rather than a second angle. + middleAngle <- readAngle hull second + pure + ( middleAngle == insertedAngle + || acuteAtMiddle fromX fromY middleX middleY targetX targetY + ) +{-# INLINE shouldCloseTurn #-} + +-- The deferred turn test deliberately runs the widened Binary64 predicate +-- rather than the exact binary64 one; only the terminal Graham pass owns exact +-- convexity. This is the class's Double instance called by name, which is +-- what the boxed 'orient2d' on widened points resolved to. +orient2dWide :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering +orient2dWide = orient2dCoordinates +{-# INLINE orient2dWide #-} + +-- Spade's deferred-convexity rule is local: close the turn when the angle at +-- the shared hull vertex is strictly below 90 degrees. Requiring the entire +-- triangle to be acute leaves avoidable star-hull work for the terminal pass. +acuteAtMiddle :: Double -> Double -> Double -> Double -> Double -> Double -> Bool +acuteAtMiddle ax ay bx by cx cy = + let !ux = ax - bx + !uy = ay - by + !vx = cx - bx + !vy = cy - by + !dot = ux * vx + uy * vy + !scale = max 1 (ux * ux + uy * uy + vx * vx + vy * vy) + in dot > 64 * encodeFloat 1 (-52) * scale +{-# INLINE acuteAtMiddle #-} + +-- Clockwise pseudo-angle in [0,4), matching the orientation of the outer-face +-- cycle. +pseudoAngle :: Double -> Double -> Double -> Double -> Double +pseudoAngle centerX centerY x y + | norm == 0 = 0 + | raw >= 4 = 0 + | otherwise = raw + where + !dx = x - centerX + !dy = y - centerY + !norm = abs dx + abs dy + !projection = dx / norm + !raw = if dy > 0 then 1 + projection else 3 - projection +{-# INLINE pseudoAngle #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Excision.hs b/src-build/Moonlight/Triangulation/Internal/Excision.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Excision.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Excision of a vertex from a thawed mesh: the removal kernel, stated over +-- the mutable arena and publishing nothing. +module Moonlight.Triangulation.Internal.Excision + ( RemovalOutcome (..) + , removeMutable + ) where + +import Control.DeepSeq (NFData) +import Control.Monad (forM, when) +import Control.Monad.ST (ST) +import Data.Bits (xor) +import Data.Foldable (traverse_) +import qualified Data.IntSet as IntSet +import Moonlight.Triangulation.Internal.DcelOperations (flipEdge, legalizeCavityFanScratch, legalizeEdges) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math (orient2d) +import GHC.Generics (Generic) + +-- | What a single removal produced: the position and payload of the removed +-- vertex, and what swap compaction did — the slot it freed together with the +-- position now standing in it, when it moved anything. All fixed handles are +-- invalidated by removal, so the swap report is the only continuity the mesh +-- offers a caller still holding one. +-- +-- Slot and position travel together because they are one fact. A caller told +-- only the slot has to go back to the mesh to learn what landed there, and a +-- caller that reconstructs the position from its own records reconstructs it +-- from something the mesh never stored: the arena holds @canonicalPoint@ of +-- what it was given, so a signed zero would differ in the last bit and every +-- distance tie decided against it would answer a different vertex. +-- +-- It is not a location hint. A hint names a face; this names an arena slot, +-- and the vertex that landed in it is the arena's last, which stands wherever +-- it stands. The locator re-anchors on its own cached face, which +-- 'Moonlight.Triangulation.Internal.Mutable.swapRemoveFace' follows through +-- compaction. +data RemovalOutcome vertex = RemovalOutcome + { removalOutcomePoint :: !(Point) + , removalOutcomeData :: !vertex + , removalOutcomeSwap :: !(Maybe (VertexId, Point)) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The proved outgoing section of one ordinary removal. Its edges live in the +-- operation scratch arena in counter-clockwise order; the record carries only +-- the section's extent and the first outer-face incidence, if any. +data RemovalStar = RemovalStar {-# UNPACK #-} !Int !(Maybe Int) + +-- | The swap-compaction primitive reports raw arena indices; the public +-- concept carries the named handle. One conversion, one owner. +removalOutcomeOf + :: (Point, vertex, Maybe (Int, Point)) + -> RemovalOutcome vertex +removalOutcomeOf (point, payload, swapped) = + RemovalOutcome + { removalOutcomePoint = point + , removalOutcomeData = payload + , removalOutcomeSwap = + (\(slot, standing) -> (VertexId (fromIntegral slot), standing)) <$> swapped + } + +removeMutable + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> ST s (Either BuildError (RemovalOutcome vertex)) +removeMutable mutable operation vertex = do + faces <- faceCount mutable + if faces <= 1 + then fmap removalOutcomeOf <$> removeDegenerate mutable vertex + else do + collected <- collectRemovalStar mutable operation vertex + case collected of + Left obstruction -> pure (Left obstruction) + Right (RemovalStar degree outerOutgoing) -> do + case outerOutgoing of + Nothing -> fmap removalOutcomeOf <$> removeInterior mutable operation vertex degree + Just hullEdge -> fmap removalOutcomeOf <$> removeHull mutable operation vertex hullEdge + +removeDegenerate + :: MutableDcel s vertex directed undirected face + -> Int + -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point))) +removeDegenerate mutable vertex = do + vertexCount <- pointCount mutable + case vertexCount of + 0 -> + pure + (Left (RemovalEmptyTriangulation (VertexId (fromIntegral vertex)))) + 1 -> do + writeFaceEdge mutable 0 (-1) + swapRemoveVertex mutable vertex + 2 -> do + collected <- collectOutgoing mutable vertex + case collected of + Left obstruction -> pure (Left obstruction) + Right outgoing -> + case outgoing of + [edge] -> do + _ <- clearConstraint mutable edge + removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2) + case removedEdge of + Left obstruction -> pure (Left obstruction) + Right () -> do + let !other = if vertex == 0 then 1 else 0 + writeVertexOut mutable other (-1) + writeFaceEdge mutable 0 (-1) + swapRemoveVertex mutable vertex + _ -> + pure + ( Left + ( RemovalTwoPointDegreeMismatch + (VertexId (fromIntegral vertex)) + (length outgoing) + ) + ) + _ -> removeCollinear mutable vertex + +removeCollinear + :: MutableDcel s vertex directed undirected face + -> Int + -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point))) +removeCollinear mutable vertex = do + collected <- collectOutgoing mutable vertex + case collected of + Left obstruction -> pure (Left obstruction) + Right outgoing -> + case outgoing of + [edge] -> do + let !reversedEdge = edge `xor` 1 + target <- readOrigin mutable reversedEdge + edgeNext <- readNext mutable edge + writePrevious mutable edgeNext (edgeNext `xor` 1) + writeNext mutable (edgeNext `xor` 1) edgeNext + writeVertexOut mutable target edgeNext + writeFaceEdge mutable 0 edgeNext + _ <- clearConstraint mutable edge + removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2) + case removedEdge of + Left obstruction -> pure (Left obstruction) + Right () -> swapRemoveVertex mutable vertex + [edge1, edge2] -> do + let !t1 = edge1 `xor` 1 + !t1Reverse = edge1 + !t2 = edge2 `xor` 1 + constrained1 <- readConstraint mutable edge1 + constrained2 <- readConstraint mutable edge2 + edge2Next <- readNext mutable edge2 + edge2To <- readOrigin mutable t2 + t2Previous <- readPrevious mutable t2 + if edge2Next == t2 + then do + writeNext mutable t1 t1Reverse + writePrevious mutable t1Reverse t1 + else do + writePrevious mutable edge2Next t1 + writeNext mutable t1 edge2Next + writeNext mutable t2Previous t1Reverse + writePrevious mutable t1Reverse t2Previous + writeVertexOut mutable edge2To t1Reverse + writeOrigin mutable t1Reverse edge2To + -- The two segments meeting at the removed vertex are welded into + -- one, and edge1's slot now spans both. It is neither of them. + resetEdgeData mutable (edge1 `quot` 2) + writeFaceEdge mutable 0 t1 + _ <- clearConstraint mutable edge1 + _ <- clearConstraint mutable edge2 + when (constrained1 || constrained2) $ do + _ <- setConstraint mutable edge1 + pure () + removedVertex <- swapRemoveVertex mutable vertex + case removedVertex of + Left obstruction -> pure (Left obstruction) + Right result -> do + removedEdge <- swapRemoveUndirectedEdge mutable (edge2 `quot` 2) + pure (result <$ removedEdge) + _ -> + pure + ( Left + ( RemovalCollinearDegreeMismatch + (VertexId (fromIntegral vertex)) + (length outgoing) + ) + ) + +removeInterior + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point))) +removeInterior mutable operation vertex degree = do + traverse_ recordRing [0 .. degree - 1] + capacity <- ensureCellCapacity mutable (max 0 (degree - 3)) (max 0 (degree - 2)) + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + -- Taken before the fan appends anything, so it separates the fan's own edges + -- from the cavity border exactly, the way spade's is_new_edge does. + !cavityFloor <- (`quot` 2) <$> directedEdgeCount mutable + remeshed <- remeshRingScratch mutable operation degree + case remeshed of + Left obstruction -> pure (Left obstruction) + Right newEdgeCount -> do + legalizeCavityFanScratch + mutable + operation + cavityFloor + (3 * degree) + newEdgeCount + edgesToRemove <- + traverse + (readScratch operation . (degree +)) + [0 .. degree - 1] + facesToRemove <- + traverse + (readScratch operation . (2 * degree +)) + [0 .. degree - 1] + cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove + case cleaned of + Left obstruction -> pure (Left obstruction) + Right () -> swapRemoveVertex mutable vertex + where + recordRing index = do + edge <- readScratch operation index + following <- readNext mutable edge + face <- readFace mutable edge + writeScratch operation index following + writeScratch operation (degree + index) (edge `quot` 2) + writeScratch operation (2 * degree + index) face + +-- | Fan the cavity a removal leaves. The border arrives in ring order, which is +-- the order the fan consumes it in. +remeshRingScratch + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> ST s (Either BuildError Int) +remeshRingScratch mutable operation degree + | degree < 3 = pure (Left (RemovalBorderTooShort degree)) + | otherwise = do + inner0 <- readScratch operation 0 + fanOrigin <- readOrigin mutable inner0 + build fanOrigin 1 inner0 0 + where + build !fanOrigin !index !innerEdge !newEdgeCount + | index == degree - 2 = do + innerNext <- readScratch operation index + innerPrevious <- readScratch operation (index + 1) + newFace <- addFace mutable innerEdge + writeFace mutable innerEdge newFace + writeFace mutable innerPrevious newFace + writeFace mutable innerNext newFace + writeNext mutable innerEdge innerNext + writePrevious mutable innerNext innerEdge + writePrevious mutable innerEdge innerPrevious + writeNext mutable innerPrevious innerEdge + writePrevious mutable innerPrevious innerNext + writeNext mutable innerNext innerPrevious + previousOrigin <- readOrigin mutable innerPrevious + nextOrigin <- readOrigin mutable innerNext + writeVertexOut mutable previousOrigin innerPrevious + writeVertexOut mutable nextOrigin innerNext + writeVertexOut mutable fanOrigin innerEdge + pure (Right newEdgeCount) + | index < degree - 2 = do + outerEdge <- readScratch operation index + outerFrom <- readOrigin mutable outerEdge + outerTo <- readOrigin mutable (outerEdge `xor` 1) + (newEdge, newTwin) <- addEdge mutable outerTo fanOrigin + newFace <- addFace mutable newEdge + writeNext mutable newEdge innerEdge + writePrevious mutable newEdge outerEdge + writeFace mutable newEdge newFace + writeNext mutable newTwin 0 + writePrevious mutable newTwin 0 + writeFace mutable newTwin 0 + writeFace mutable outerEdge newFace + writeNext mutable outerEdge newEdge + writePrevious mutable outerEdge innerEdge + writePrevious mutable innerEdge newEdge + writeNext mutable innerEdge outerEdge + writeFace mutable innerEdge newFace + writeFaceEdge mutable newFace newEdge + writeVertexOut mutable outerFrom outerEdge + writeScratch operation (3 * degree + newEdgeCount) newEdge + build + fanOrigin + (index + 1) + newTwin + (newEdgeCount + 1) + | otherwise = + pure (Left (RemovalBorderArityMismatch (degree - index))) + +removeHull :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point))) +removeHull mutable operation vertex loopEnd = do + loopStart <- counterClockwiseMutable mutable loopEnd + loopEndNext <- readNext mutable loopEnd + collected <- collectConvexStrip loopEnd loopStart [] [] + case collected of + Left obstruction -> pure (Left obstruction) + Right (!convexEdges, !edgesToValidate) -> do + let !strip = convexEdges ++ [loopEndNext] + (!edgesToRemove, !facesToRemove) <- disconnectStrip strip + legalizeEdges mutable operation edgesToValidate + cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove + case cleaned of + Left obstruction -> pure (Left obstruction) + Right () -> swapRemoveVertex mutable vertex + where + collectConvexStrip !end !current !convexReversed !validate = do + nextCurrent <- counterClockwiseMutable mutable current + edge <- readNext mutable current + repaired <- repairConvexity (edge : convexReversed) validate + case repaired of + Left obstruction -> pure (Left obstruction) + Right (!repairedReversed, !validate') -> + if nextCurrent == end + then pure (Right (reverse repairedReversed, validate')) + else collectConvexStrip end nextCurrent repairedReversed validate' + + repairConvexity !edgesReversed !validate = + case edgesReversed of + edge2 : edge1 : restReversed -> do + target <- readOrigin mutable (edge2 `xor` 1) + from <- edgeOriginPoint mutable edge1 + to <- edgeOriginPoint mutable (edge1 `xor` 1) + targetPoint <- pointAt mutable target + if orient2d from to targetPoint == GT + then do + previousEdge <- readPrevious mutable edge2 + let !toFlip = previousEdge `xor` 1 + rewritten <- flipEdge mutable toFlip + case rewritten of + Left obstruction -> pure (Left obstruction) + Right () -> do + addCounter operation CounterEdgeFlips 1 + repairConvexity (toFlip : restReversed) (toFlip : validate) + else pure (Right (edgesReversed, validate)) + _ -> pure (Right (edgesReversed, validate)) + + disconnectStrip strip = do + removed <- forM strip $ \edge -> do + previousSpoke <- readPrevious mutable edge + face <- readFace mutable edge + from <- readOrigin mutable edge + ccw <- counterClockwiseMutable mutable edge + predecessor <- readPrevious mutable ccw + writeNext mutable predecessor edge + writePrevious mutable edge predecessor + writeFace mutable edge 0 + writeFaceEdge mutable 0 edge + writeVertexOut mutable from edge + pure (previousSpoke `quot` 2, face) + pure (map fst removed, map snd removed) + +cleanupEdgesAndFaces :: MutableDcel s vertex directed undirected face -> [Int] -> [Int] -> ST s (Either BuildError ()) +cleanupEdgesAndFaces mutable rawEdges rawFaces = do + let !edges = sortUniqueDesc rawEdges + !faces = sortUniqueDesc (filter (> 0) rawFaces) + removedEdges <- traverseUntilFailure (swapRemoveUndirectedEdge mutable) edges + case removedEdges of + Left obstruction -> pure (Left obstruction) + Right () -> traverseUntilFailure (swapRemoveFace mutable) faces + where + traverseUntilFailure + :: (Int -> ST s (Either BuildError ())) + -> [Int] + -> ST s (Either BuildError ()) + traverseUntilFailure action = + foldr + ( \item continuation -> do + outcome <- action item + case outcome of + Left obstruction -> pure (Left obstruction) + Right () -> continuation + ) + (pure (Right ())) + +-- | Descending, deduplicated. Both properties are load-bearing: swap-remove +-- must retire the high index first (a lower index shifts under it), and a +-- duplicated index would be retired twice. +-- +-- A removal hands over its vertex's degree, which is small on ordinary meshes +-- and unbounded in the worst case, so the shape is chosen by size. Insertion +-- sort wins outright while the ring is short — measured 6.75 against +-- 8.24 KiB/removal for @IntSet@ on the n=10000 lane — and is quadratic, so a +-- high-degree ring goes to the ordered set that carries the asymptotics. +-- +-- The lazy 'foldl' is deliberate: its accumulator is the output structure. +-- 'foldl'' forced each intermediate spine and measured 7.31 versus +-- 6.75 KiB/removal on the same lane. +sortUniqueDesc :: [Int] -> [Int] +sortUniqueDesc values + | exceedsInsertionRing values = IntSet.toDescList (IntSet.fromList values) + | otherwise = foldl insertUnique [] values + where + insertUnique :: [Int] -> Int -> [Int] + insertUnique sorted value = go sorted + where + go [] = [value] + go (first : rest) = case compare value first of + GT -> value : first : rest + EQ -> first : rest + LT -> first : go rest + +-- | Whether a ring is long enough to owe the ordered set its logarithm, +-- decided without measuring the whole list: the insertion path is chosen by +-- the prefix, never by a full traversal. +exceedsInsertionRing :: [Int] -> Bool +exceedsInsertionRing = not . null . drop insertionRingLimit + +insertionRingLimit :: Int +insertionRingLimit = 32 + +collectRemovalStar + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> ST s (Either BuildError RemovalStar) +collectRemovalStar mutable operation vertex = do + start <- readVertexOut mutable vertex + if start < 0 + then pure (Right (RemovalStar 0 Nothing)) + else do + halfEdges <- directedEdgeCount mutable + let !budget = halfEdges + 1 + go !remaining !current !seen !degree !outerEdge + | remaining <= 0 = + pure + ( Left + ( RemovalOutgoingCycleDidNotTerminate + (VertexId (fromIntegral vertex)) + (DirectedEdgeId (fromIntegral current)) + budget + ) + ) + | seen && current == start = + pure (Right (RemovalStar degree outerEdge)) + | otherwise = do + writeScratch operation degree current + face <- readFace mutable current + _ <- clearConstraint mutable current + previousEdge <- readPrevious mutable current + let !nextOuter = + case outerEdge of + Just edge -> Just edge + Nothing + | face == 0 -> Just current + | otherwise -> Nothing + go + (remaining - 1) + (previousEdge `xor` 1) + True + (degree + 1) + nextOuter + go budget start False 0 Nothing + +collectOutgoing + :: MutableDcel s vertex directed undirected face + -> Int + -> ST s (Either BuildError [Int]) +collectOutgoing mutable vertex = do + start <- readVertexOut mutable vertex + if start < 0 + then pure (Right []) + else do + halfEdges <- directedEdgeCount mutable + let !budget = halfEdges + 1 + go !remaining !current !seen !result + | remaining <= 0 = + pure + ( Left + ( RemovalOutgoingCycleDidNotTerminate + (VertexId (fromIntegral vertex)) + (DirectedEdgeId (fromIntegral current)) + budget + ) + ) + | seen && current == start = pure (Right (reverse result)) + | otherwise = do + previousEdge <- readPrevious mutable current + go (remaining - 1) (previousEdge `xor` 1) True (current : result) + go budget start False [] + +counterClockwiseMutable :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +counterClockwiseMutable mutable edge = (`xor` 1) <$> readPrevious mutable edge diff --git a/src-build/Moonlight/Triangulation/Internal/Join.hs b/src-build/Moonlight/Triangulation/Internal/Join.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Join.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The join of two triangulations: a Delaunay representative of the union of +-- their sites. +module Moonlight.Triangulation.Internal.Join + ( joinNormalForm + , joinBalanced + , executeTournamentPlan + , TournamentPlan (..) + , planTournament + ) where + +import Data.Foldable (traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Triangulation.BulkLoad (empty) +import Moonlight.Triangulation.Internal.Join.Plan + ( PairPlan (..) + , TournamentPlan (..) + , planPair + , planTournament + ) +import Moonlight.Triangulation.Internal.Join.Seam (executeSeam) +import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) +import Moonlight.Triangulation.Internal.Join.SiteSet + ( SiteSet + , siteSetAssocs + , siteSetSize + ) +import Moonlight.Triangulation.JoinSemilattice + ( JoinSemilattice (joinAnnotations) + ) +import Moonlight.Triangulation.Session + ( insertVertexAtCombining + , withLocalSession + ) +import Moonlight.Triangulation.Types + +-- | A Delaunay representative of the union of two site sets. +-- +-- Skewed operands descend through the existing local copy-on-write session, so +-- the larger operand's vertex handles and untouched pages survive. Comparable +-- operands may merge along a separating seam or rebuild from their combined +-- site set. Every schedule returns valid topology; 'canonicalize' is the +-- separate physical observation when construction-independent numbering is +-- required. +-- +-- Empty and structurally identical operands return an existing value verbatim. +-- Algebraic agreement between all schedules is stated by equal canonical +-- observations; structural equality continues to describe exact resident +-- representation. +joinNormalForm + :: JoinSemilattice annotation + => Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +joinNormalForm left right = executePairPlan (planPair left right) left right + +executePairPlan + :: JoinSemilattice annotation + => PairPlan annotation + -> Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +executePairPlan pairPlan left right = + case pairPlan of + ReturnLeftOperand -> Right left + ReturnRightOperand -> Right right + InsertLeftIntoRight sites -> insertSites sites right + InsertRightIntoLeft sites -> insertSites sites left + MergeSeparated seamPlan -> executeSeam seamPlan left right + RebuildCanonicalUnion sites -> rebuildCanonicalSiteSet sites + +insertSites + :: JoinSemilattice annotation + => SiteSet annotation + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +insertSites sites base = do + ((), inserted, _) <- + withLocalSession + base + (siteSetSize sites) + ( traverse_ + (\(point, annotation) -> + () <$ insertVertexAtCombining joinAnnotations point annotation + ) + (siteSetAssocs sites) + ) + pure inserted + +-- | Combine by a balanced tournament rather than by a fold. +-- +-- Associativity and commutativity make every bracketing canonically equivalent, +-- so this is a cost choice and not a semantic one. A left fold republishes an +-- accumulator that grows by one shard per step and so rebuilds @Θ(nk)@ sites +-- over @k@ shards; halving the list rebuilds @Θ(n log k)@. +-- +-- The specialization below is load-bearing rather than decorative. Without it +-- this function is the only one on the path that stays polymorphic, and every +-- join in the tournament pays for a dictionary while a caller's own fold at a +-- known element type does not. That alone cost a factor of two and hid the +-- advantage this function exists for. +-- +-- The tournament retains the binary operation's shortcut and annotation-gluing +-- semantics rather than inventing a second n-ary implementation. +joinBalanced + :: JoinSemilattice annotation + => [Triangulation 'Unconstrained annotation () () ()] + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +joinBalanced [] = Right (empty unitElementDefaults) +joinBalanced (first : rest) = + executeTournamentPlan (planTournament (first :| rest)) +{-# SPECIALIZE joinBalanced + :: [Triangulation 'Unconstrained () () () ()] + -> Either BuildError (Triangulation 'Unconstrained () () () ()) #-} + +executeTournamentPlan + :: JoinSemilattice annotation + => TournamentPlan (Triangulation 'Unconstrained annotation () () ()) + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +executeTournamentPlan tournament = + case tournament of + TournamentLeaf mesh -> Right mesh + TournamentNode left right -> do + leftMesh <- executeTournamentPlan left + rightMesh <- executeTournamentPlan right + joinNormalForm leftMesh rightMesh diff --git a/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs b/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | The sole physical planner for binary and n-ary joins. It derives exact +-- local compatibility facts, selects one schedule, and leaves execution to a +-- consumer; sequential and concurrent interpreters share the same tournament +-- tree rather than inventing pairing policies of their own. +module Moonlight.Triangulation.Internal.Join.Plan + ( PairPlan (..) + , planPair + , TournamentPlan (..) + , planTournament + ) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Moonlight.Triangulation.Dcel (numVertices) +import Moonlight.Triangulation.Internal.Join.Seam (SeamPlan, planSeam) +import Moonlight.Triangulation.Internal.Join.SiteSet + ( SiteSet + , siteSetFromTriangulation + , siteSetRelation + , siteSetUnionWith + ) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (joinAnnotations)) +import Moonlight.Triangulation.Internal.Types + ( ConstraintMode (Unconstrained) + , SiteRelation (..) + ) + +data PairPlan annotation + = ReturnLeftOperand + | ReturnRightOperand + | InsertLeftIntoRight !(SiteSet annotation) + | InsertRightIntoLeft !(SiteSet annotation) + | MergeSeparated !SeamPlan + | RebuildCanonicalUnion !(SiteSet annotation) + +-- | Stage cheap facts before exact set classification. Empty and structurally +-- identical operands return verbatim; skewed pairs preserve the larger value +-- through local insertion before seam planning is considered. +planPair + :: JoinSemilattice annotation + => Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> PairPlan annotation +planPair left right + | leftCount == 0 = ReturnRightOperand + | rightCount == 0 = ReturnLeftOperand + | left == right = ReturnLeftOperand + | insertionIsCheaper leftCount rightCount = InsertLeftIntoRight leftSites + | insertionIsCheaper rightCount leftCount = InsertRightIntoLeft rightSites + | Just seamPlan <- planSeam left right = MergeSeparated seamPlan + | otherwise = + case siteSetRelation leftSites rightSites of + EqualSites -> InsertLeftIntoRight leftSites + LeftProperSubset -> InsertLeftIntoRight leftSites + RightProperSubset -> InsertRightIntoLeft rightSites + DisjointSites -> rebuildUnion + PartialOverlap _ -> rebuildUnion + where + !leftCount = numVertices left + !rightCount = numVertices right + leftSites = siteSetFromTriangulation left + rightSites = siteSetFromTriangulation right + rebuildUnion = + RebuildCanonicalUnion + (siteSetUnionWith joinAnnotations leftSites rightSites) + +-- A transaction reuses an existing topology only when the added side is small +-- enough that its expected local cavities beat one bulk sweep. This is an +-- internal cost estimate, deliberately not a caller-controlled threshold. +insertionIsCheaper :: Int -> Int -> Bool +insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8 +{-# INLINE insertionIsCheaper #-} + +-- | A deterministic dependency graph. Leaves retain meshes as values; no site +-- flattening occurs, so singleton and repeated-value shortcut semantics remain +-- those of the binary operation. Duplicate operands need no planning pass: +-- every adjacent pair reaches the binary operation, whose structural-equality +-- shortcut already returns the operand verbatim, so a dedup here would buy a +-- quadratic scan of whole meshes to skip work the executor skips anyway. +data TournamentPlan mesh + = TournamentLeaf !mesh + | TournamentNode !(TournamentPlan mesh) !(TournamentPlan mesh) + +planTournament :: NonEmpty mesh -> TournamentPlan mesh +planTournament = buildBalanced . fmap TournamentLeaf + where + buildBalanced :: NonEmpty (TournamentPlan value) -> TournamentPlan value + buildBalanced (single :| []) = single + buildBalanced plans = buildBalanced (pairRound plans) + + pairRound :: NonEmpty (TournamentPlan value) -> NonEmpty (TournamentPlan value) + pairRound (left :| right : rest) = + TournamentNode left right :| pairTail rest + pairRound (single :| []) = single :| [] + + pairTail :: [TournamentPlan value] -> [TournamentPlan value] + pairTail (left : right : rest) = TournamentNode left right : pairTail rest + pairTail rest = rest diff --git a/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs b/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs @@ -0,0 +1,39 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Join/Seam.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Linear seam construction for separated Delaunay triangulations. Admission +-- returns an opaque proof carrying the exact source order and tangents; the +-- executor therefore has no untyped precondition and owns no fallback. +module Moonlight.Triangulation.Internal.Join.Seam + ( SeamPlan + , planSeam + , executeSeam + , ConstrainedSeamExecution + , seamExecutionTriangulation + , seamExecutionBuildStats + , executeConstrainedSeam + ) where + +import Control.Monad.ST (ST, runST) +import Data.Bits (xor) +import Data.Foldable (traverse_) +import qualified Data.Vector.Unboxed as U +import Moonlight.Triangulation.Dcel + ( adjacentEdge + , faceDirectedEdges + , numDirectedEdges + , numFaces + , numInnerFaces + , numVertices + , outerFace + , vertexOutEdge + , vertexData + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId (..) + , FaceId (..) + , UndirectedEdgeId (..) + , VertexId (..) + ) +import Moonlight.Triangulation.Internal.DcelOperations (closeOuterTurn, legalizeEdges) +import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( OperationState + , freezeBuildStats + , newOperationState + ) +import Moonlight.Triangulation.Internal.Paged (pagedUnsafeIndex) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Types + ( BuildError + , BuildStats + , ConstraintMode (Constrained, Unconstrained) + , unitElementDefaults + ) +import Moonlight.Triangulation.Scalar (inCircleCoordinates, orient2dCoordinates) + +-- | Proof that a particular pair can be copied and stitched by the seam +-- kernel. Constructors stay private so an unseparated pair cannot be handed to +-- the executor by accident. +data SeamPlan + = SeamLeftBeforeRight !SeamTangents + | SeamRightBeforeLeft !SeamTangents + +planSeam + :: Triangulation mode vertex () () () + -> Triangulation mode' vertex () () () + -> Maybe SeamPlan +planSeam left right = + case separatedOrder left right of + Just LeftBeforeRight -> + Just (SeamLeftBeforeRight (seamTangents left right)) + Just RightBeforeLeft -> + Just (SeamRightBeforeLeft (seamTangents right left)) + Nothing -> Nothing + +-- | Execute a proved seam schedule. Numbering follows the schedule; +-- 'canonicalize' remains the explicit construction-independent observation. +executeSeam + :: forall vertex + . SeamPlan + -> Triangulation 'Unconstrained vertex () () () + -> Triangulation 'Unconstrained vertex () () () + -> Either BuildError (Triangulation 'Unconstrained vertex () () ()) +executeSeam plan left right = + case plan of + SeamLeftBeforeRight tangents -> + fmap fst (mergeSeparated [] left right tangents) + SeamRightBeforeLeft tangents -> + fmap fst (mergeSeparated [] right left tangents) + +-- | Result of the constrained seam kernel. Constraint flags are copied before +-- legalization, so source contour edges are immutable barriers while the +-- zipper constructs only the missing corridor. +data ConstrainedSeamExecution vertex = ConstrainedSeamExecution + { seamExecutionTriangulation + :: !(Triangulation 'Constrained vertex () () ()) + , seamExecutionBuildStats :: !BuildStats + } + +-- | Execute a proved seam while transporting both source constraint planes. +-- This is distinct from promoting the unconstrained result afterward: source +-- hull constraints must already be visible to seam legalization or the +-- legalization schedule could erase a solved source face before recovery had +-- a chance to mark it. +executeConstrainedSeam + :: forall vertex + . SeamPlan + -> Triangulation 'Constrained vertex () () () + -> Triangulation 'Constrained vertex () () () + -> Either BuildError (ConstrainedSeamExecution vertex) +executeConstrainedSeam plan left right = + fmap + (uncurry ConstrainedSeamExecution) + (case plan of + SeamLeftBeforeRight tangents -> + mergeSeparated + [ (0, left) + , (numDirectedEdges left, right) + ] + left + right + tangents + SeamRightBeforeLeft tangents -> + mergeSeparated + [ (0, right) + , (numDirectedEdges right, left) + ] + right + left + tangents + ) + +data SeparatedOrder + = LeftBeforeRight + | RightBeforeLeft + +separatedOrder + :: Triangulation mode vertex directed undirected face + -> Triangulation mode' vertex' directed' undirected' face' + -> Maybe SeparatedOrder +separatedOrder left right + | numInnerFaces left <= 0 || numInnerFaces right <= 0 = Nothing + | otherwise = do + (leftMinimum, leftMaximum) <- xBounds left + (rightMinimum, rightMaximum) <- xBounds right + if leftMaximum < rightMinimum + then Just LeftBeforeRight + else + if rightMaximum < leftMinimum + then Just RightBeforeLeft + else Nothing + +xBounds + :: Triangulation mode vertex directed undirected face + -> Maybe (Double, Double) +xBounds triangulation + | total <= 0 = Nothing + | otherwise = Just (go 1 first first) + where + !total = numVertices triangulation + !coordinates = triPointX triangulation + !first = coordinates `pagedUnsafeIndex` 0 + go !index !minimumX !maximumX + | index >= total = (minimumX, maximumX) + | otherwise = + let !x = coordinates `pagedUnsafeIndex` index + in go (index + 1) (min minimumX x) (max maximumX x) + +-- The opposite-sign branch cannot overflow in its sum. The same-sign branch +-- cannot overflow in its difference. +data SeamTangents = SeamTangents + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + +seamTangents + :: Triangulation mode vertex directed undirected face + -> Triangulation mode' vertex' directed' undirected' face' + -> SeamTangents +seamTangents left right = + let (lowerLeft, lowerRight) = lowerTangent left right leftHull rightHull + (upperLeft, upperRight) = upperTangent left right leftHull rightHull + in SeamTangents lowerLeft lowerRight upperLeft upperRight + where + !leftHull = outerEdges left + !rightHull = outerEdges right + +lowerTangent + :: Triangulation mode vertex directed undirected face + -> Triangulation mode' vertex' directed' undirected' face' + -> U.Vector Int + -> U.Vector Int + -> (Int, Int) +-- The walk carries both endpoints' coordinates: a step replaces exactly one +-- endpoint, and the replacement is the neighbour whose coordinates the step's +-- own test already read. +lowerTangent left right leftHull rightHull = + walk leftStart leftStartX leftStartY rightStart rightStartX rightStartY + where + !leftStart = extremeHullIndex preferRightmost left leftHull + !rightStart = extremeHullIndex preferLeftmost right rightHull + (!leftStartX, !leftStartY) = hullPoint left leftHull leftStart + (!rightStartX, !rightStartY) = hullPoint right rightHull rightStart + + walk !leftIndex !leftX !leftY !rightIndex !rightX !rightY + | leftBelow = walk nextLeft nextLeftX nextLeftY rightIndex rightX rightY + | rightBelow = walk leftIndex leftX leftY previousRight previousRightX previousRightY + | otherwise = (leftHull `U.unsafeIndex` leftIndex, rightHull `U.unsafeIndex` rightIndex) + where + !nextLeft = nextIndex (U.length leftHull) leftIndex + (!nextLeftX, !nextLeftY) = hullPoint left leftHull nextLeft + !leftBelow = + orient2dCoordinates leftX leftY rightX rightY nextLeftX nextLeftY == LT + previousRight = previousIndex (U.length rightHull) rightIndex + (previousRightX, previousRightY) = hullPoint right rightHull previousRight + rightBelow = + orient2dCoordinates leftX leftY rightX rightY previousRightX previousRightY == LT + +upperTangent + :: Triangulation mode vertex directed undirected face + -> Triangulation mode' vertex' directed' undirected' face' + -> U.Vector Int + -> U.Vector Int + -> (Int, Int) +upperTangent left right leftHull rightHull = + walk leftStart leftStartX leftStartY rightStart rightStartX rightStartY + where + !leftStart = extremeHullIndex preferRightmostUpper left leftHull + !rightStart = extremeHullIndex preferLeftmostUpper right rightHull + (!leftStartX, !leftStartY) = hullPoint left leftHull leftStart + (!rightStartX, !rightStartY) = hullPoint right rightHull rightStart + + walk !leftIndex !leftX !leftY !rightIndex !rightX !rightY + | leftAbove = walk previousLeft previousLeftX previousLeftY rightIndex rightX rightY + | rightAbove = walk leftIndex leftX leftY nextRight nextRightX nextRightY + | otherwise = (leftHull `U.unsafeIndex` leftIndex, rightHull `U.unsafeIndex` rightIndex) + where + !previousLeft = previousIndex (U.length leftHull) leftIndex + (!previousLeftX, !previousLeftY) = hullPoint left leftHull previousLeft + !leftAbove = + orient2dCoordinates leftX leftY rightX rightY previousLeftX previousLeftY == GT + nextRight = nextIndex (U.length rightHull) rightIndex + (nextRightX, nextRightY) = hullPoint right rightHull nextRight + rightAbove = + orient2dCoordinates leftX leftY rightX rightY nextRightX nextRightY == GT + +type ExtremePreference = Double -> Double -> Double -> Double -> Bool + +preferRightmost :: ExtremePreference +preferRightmost bestX bestY candidateX candidateY = + candidateX > bestX || (candidateX == bestX && candidateY < bestY) +{-# INLINE preferRightmost #-} + +preferLeftmost :: ExtremePreference +preferLeftmost bestX bestY candidateX candidateY = + candidateX < bestX || (candidateX == bestX && candidateY < bestY) +{-# INLINE preferLeftmost #-} + +preferRightmostUpper :: ExtremePreference +preferRightmostUpper bestX bestY candidateX candidateY = + candidateX > bestX || (candidateX == bestX && candidateY > bestY) +{-# INLINE preferRightmostUpper #-} + +preferLeftmostUpper :: ExtremePreference +preferLeftmostUpper bestX bestY candidateX candidateY = + candidateX < bestX || (candidateX == bestX && candidateY > bestY) +{-# INLINE preferLeftmostUpper #-} + +extremeHullIndex + :: ExtremePreference + -> Triangulation mode vertex directed undirected face + -> U.Vector Int + -> Int +-- The running best carries its own coordinates. Re-reading them per candidate +-- read the same immutable slots @size@ times over instead of once. +extremeHullIndex prefer triangulation hull + | size <= 0 = 0 + | otherwise = + let (!firstX, !firstY) = hullPoint triangulation hull 0 + in go 1 0 firstX firstY + where + !size = U.length hull + go !index !best !bestX !bestY + | index >= size = best + | otherwise = + let (!candidateX, !candidateY) = hullPoint triangulation hull index + in if prefer bestX bestY candidateX candidateY + then go (index + 1) index candidateX candidateY + else go (index + 1) best bestX bestY + +outerEdges + :: Triangulation mode vertex directed undirected face + -> U.Vector Int +outerEdges = + U.fromList + . fmap (\(DirectedEdgeId edge) -> fromIntegral edge) + . (`faceDirectedEdges` outerFace) + +hullPoint + :: Triangulation mode vertex directed undirected face + -> U.Vector Int + -> Int + -> (Double, Double) +hullPoint triangulation hull index = + let !edge = hull `U.unsafeIndex` index + !vertex = topologyAt triangulation (4 * edge) + in ( triPointX triangulation `pagedUnsafeIndex` vertex + , triPointY triangulation `pagedUnsafeIndex` vertex + ) +{-# INLINE hullPoint #-} + +nextIndex :: Int -> Int -> Int +nextIndex size index + | index + 1 == size = 0 + | otherwise = index + 1 +{-# INLINE nextIndex #-} + +previousIndex :: Int -> Int -> Int +previousIndex size index + | index == 0 = size - 1 + | otherwise = index - 1 +{-# INLINE previousIndex #-} + +mergeSeparated + :: forall outputMode leftMode rightMode vertex + . [(Int, Triangulation 'Constrained vertex () () ())] + -> Triangulation leftMode vertex () () () + -> Triangulation rightMode vertex () () () + -> SeamTangents + -> Either + BuildError + (Triangulation outputMode vertex () () (), BuildStats) +mergeSeparated constraintSections left right (SeamTangents lowerLeft lowerRight upperLeft upperRight) = runST $ do + mutable <- newMutableDcel unitElementDefaults totalVertices + pointCapacityOutcome <- ensurePointCapacity mutable totalVertices + cellCapacityOutcome <- + ensureCellCapacity + mutable + ((leftDirected + rightDirected) `quot` 2 + 1) + (leftFaces + rightFaces - 2) + case (pointCapacityOutcome, cellCapacityOutcome) of + (Left obstruction, _) -> pure (Left obstruction) + (_, Left obstruction) -> pure (Left obstruction) + (Right (), Right ()) -> do + appendSourceVertices mutable left + appendSourceVertices mutable right + _ <- addEdgeBlock mutable ((leftDirected + rightDirected) `quot` 2) + _ <- addFaceBlock mutable (leftFaces + rightFaces - 2) + copySource mutable left 0 0 0 + copySource mutable right leftVertices leftDirected (leftFaces - 1) + traverse_ (uncurry (copySourceConstraints mutable)) constraintSections + base <- spliceLowerTangent mutable leftDirected lowerLeft lowerRight + operation <- newOperationState (halfEdgeCapacity mutable) + stitched <- + stitchSeam + mutable + operation + base + (topologyAt left (4 * upperLeft)) + (leftVertices + topologyAt right (4 * upperRight)) + [] + case stitched of + Left obstruction -> pure (Left obstruction) + Right () -> do + statistics <- freezeBuildStats operation + fmap (\triangulation -> (triangulation, statistics)) + <$> freezeTriangulation mutable + where + !leftVertices = numVertices left + !rightVertices = numVertices right + !totalVertices = leftVertices + rightVertices + !leftDirected = numDirectedEdges left + !rightDirected = numDirectedEdges right + !leftFaces = numFaces left + !rightFaces = numFaces right + +stitchSeam + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> Int + -> [Int] + -> ST s (Either BuildError ()) +stitchSeam mutable operation base upperLeft upperRight seeds = do + leftVertex <- readOrigin mutable base + rightVertex <- readOrigin mutable (base `xor` 1) + if leftVertex == upperLeft && rightVertex == upperRight + then legalizeEdges mutable operation seeds >> pure (Right ()) + else do + leftEdge <- readPrevious mutable base + rightEdge <- readNext mutable base + nextLeft <- readOrigin mutable leftEdge + nextRight <- readOrigin mutable (rightEdge `xor` 1) + leftTurn <- vertexOrientation mutable nextLeft leftVertex rightVertex + rightTurn <- vertexOrientation mutable leftVertex rightVertex nextRight + chooseRight <- + if rightVertex == upperRight + then pure False + else + if leftVertex == upperLeft + then pure True + else + case (leftTurn == GT, rightTurn == GT) of + (True, True) -> + (== GT) <$> vertexInCircle mutable nextLeft leftVertex rightVertex nextRight + (False, True) -> pure True + _ -> pure False + if chooseRight + then do + closed <- closeOuterTurn mutable base + case closed of + Left obstruction -> pure (Left obstruction) + Right nextBase -> + stitchSeam mutable operation nextBase upperLeft upperRight (base : rightEdge : seeds) + else do + closed <- closeOuterTurn mutable leftEdge + case closed of + Left obstruction -> pure (Left obstruction) + Right nextBase -> + stitchSeam mutable operation nextBase upperLeft upperRight (leftEdge : base : seeds) + +vertexOrientation + :: MutableDcel s vertex directed undirected face + -> Int + -> Int + -> Int + -> ST s Ordering +vertexOrientation mutable a b c = do + ax <- readPointX mutable a + ay <- readPointY mutable a + bx <- readPointX mutable b + by <- readPointY mutable b + cx <- readPointX mutable c + cy <- readPointY mutable c + pure $! orient2dCoordinates ax ay bx by cx cy +{-# INLINE vertexOrientation #-} + +vertexInCircle + :: MutableDcel s vertex directed undirected face + -> Int + -> Int + -> Int + -> Int + -> ST s Ordering +vertexInCircle mutable a b c d = do + ax <- readPointX mutable a + ay <- readPointY mutable a + bx <- readPointX mutable b + by <- readPointY mutable b + cx <- readPointX mutable c + cy <- readPointY mutable c + dx <- readPointX mutable d + dy <- readPointY mutable d + pure $! inCircleCoordinates ax ay bx by cx cy dx dy +{-# INLINE vertexInCircle #-} + +appendSourceVertices + :: MutableDcel s vertex () () () + -> Triangulation mode vertex () () () + -> ST s () +appendSourceVertices mutable source = + forRange 0 (numVertices source) $ \vertex -> do + _ <- + appendVertexCoordinates + mutable + (triPointX source `pagedUnsafeIndex` vertex) + (triPointY source `pagedUnsafeIndex` vertex) + (vertexData source (VertexId (fromIntegral vertex))) + pure () + +copySource + :: MutableDcel s vertex () () () + -> Triangulation mode vertex () () () + -> Int + -> Int + -> Int + -> ST s () +copySource mutable source vertexOffset edgeOffset faceOffset = do + forRange 0 (numDirectedEdges source) $ \edge -> do + let !target = edgeOffset + edge + !sourceBase = 4 * edge + !sourceFace = topologyAt source (sourceBase + 3) + !targetFace = if sourceFace == 0 then 0 else faceOffset + sourceFace + writeOrigin mutable target (vertexOffset + topologyAt source sourceBase) + writeNext mutable target (edgeOffset + topologyAt source (sourceBase + 1)) + writePrevious mutable target (edgeOffset + topologyAt source (sourceBase + 2)) + writeFace mutable target targetFace + forRange 0 (numVertices source) $ \vertex -> + case vertexOutEdge source (VertexId (fromIntegral vertex)) of + Nothing -> markConnected mutable (vertexOffset + vertex) (-1) + Just (DirectedEdgeId edge) -> + markConnected mutable (vertexOffset + vertex) (edgeOffset + fromIntegral edge) + forRange 1 (numFaces source) $ \face -> + case adjacentEdge source (FaceId (fromIntegral face)) of + Nothing -> writeFaceEdge mutable (faceOffset + face) (-1) + Just (DirectedEdgeId edge) -> + writeFaceEdge mutable (faceOffset + face) (edgeOffset + fromIntegral edge) + +copySourceConstraints + :: MutableDcel s vertex () () () + -> Int + -> Triangulation 'Constrained vertex () () () + -> ST s () +copySourceConstraints mutable directedEdgeOffset source = + traverse_ + (\(UndirectedEdgeId edge) -> + () + <$ setConstraint + mutable + (directedEdgeOffset + 2 * fromIntegral edge) + ) + (constraintEdges source) + +spliceLowerTangent + :: MutableDcel s vertex () () () + -> Int + -> Int + -> Int + -> ST s Int +spliceLowerTangent mutable rightEdgeOffset leftOuter rightOuterSource = do + let !rightOuter = rightEdgeOffset + rightOuterSource + leftVertex <- readOrigin mutable leftOuter + rightVertex <- readOrigin mutable rightOuter + leftPrevious <- readPrevious mutable leftOuter + rightPrevious <- readPrevious mutable rightOuter + (forward, backward) <- addEdge mutable leftVertex rightVertex + writeFace mutable forward 0 + writeFace mutable backward 0 + linkEdges mutable leftPrevious forward + linkEdges mutable forward rightOuter + linkEdges mutable rightPrevious backward + linkEdges mutable backward leftOuter + writeFaceEdge mutable 0 forward + writeVertexOut mutable leftVertex forward + writeVertexOut mutable rightVertex backward + pure forward +{-# INLINE spliceLowerTangent #-} + +topologyAt + :: Triangulation mode vertex directed undirected face + -> Int + -> Int +topologyAt triangulation slot = + fromIntegral (triHalfTopology triangulation `pagedUnsafeIndex` slot) +{-# INLINE topologyAt #-} + + +forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m () +forRange from to action = go from + where + go !index + | index >= to = pure () + | otherwise = action index >> go (index + 1) +{-# INLINE forRange #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs b/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Exact transient site sections derived from the authoritative coordinate +-- planes. This is the sole owner of coordinate-set classification for joins, +-- set algebra, and constrained union. Payloads travel as annotations; they do +-- not participate in site identity. +module Moonlight.Triangulation.Internal.Join.SiteSet + ( SiteSet + , siteSetFromTriangulation + , siteSupportFromTriangulation + , siteSetSize + , siteSetRelation + , siteRelationFromTriangulations + , siteSetUnionWith + , siteSetIntersectionWith + , siteSetDifference + , siteSetSymmetricDifferenceFromTriangulations + , siteSetAssocs + , siteSetPoints + ) where + +import Control.Monad.ST (ST, runST) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Merge.Strict as MapMerge +import Data.Functor.Const (Const (..)) +import Data.Maybe (isJust) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint) +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators + ( foldVertices' + ) +import Moonlight.Triangulation.Internal.Paged + ( pagedUnsafeIndex + , toVector + ) +import Moonlight.Triangulation.Internal.PointIndex + ( MutablePointIndex + , lookupMutablePoint + , lookupPointIndex + , newMutablePointIndex + , seedMutablePointIndex + ) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Types + ( BuildError + , Point (..) + , SiteRelation (..) + ) + +newtype SiteSet annotation = SiteSet (Map.Map (Point) annotation) + +-- Strict sufficient statistics for the one-pass ordered-map descent used by +-- 'siteSetRelation'. Keeping the census strict prevents a relation query from +-- replacing an intermediate map allocation with a chain of monoidal thunks. +data SiteRelationCensus = SiteRelationCensus !Int !Int !Int + +instance Semigroup SiteRelationCensus where + SiteRelationCensus leftA rightA overlapA <> SiteRelationCensus leftB rightB overlapB = + SiteRelationCensus + (leftA + leftB) + (rightA + rightB) + (overlapA + overlapB) + +instance Monoid SiteRelationCensus where + mempty = SiteRelationCensus 0 0 0 + +siteSetFromTriangulation + :: Triangulation mode annotation directed undirected face + -> SiteSet annotation +siteSetFromTriangulation triangulation = + SiteSet + ( Map.fromList + [ ( Point + (triPointX triangulation `pagedUnsafeIndex` vertex) + (triPointY triangulation `pagedUnsafeIndex` vertex) + , vertexData triangulation (VertexId (fromIntegral vertex)) + ) + | vertex <- [0 .. numVertices triangulation - 1] + ] + ) + +-- | Coordinate support without touching the boxed annotation plane. Order and +-- set identity are geometric observations; callers that discard annotations +-- should not pay a boxed-page read per vertex merely to manufacture ignored +-- map values. +siteSupportFromTriangulation + :: Triangulation mode vertex directed undirected face + -> SiteSet () +siteSupportFromTriangulation triangulation = + SiteSet + ( Map.fromList + [ ( Point + (triPointX triangulation `pagedUnsafeIndex` vertex) + (triPointY triangulation `pagedUnsafeIndex` vertex) + , () + ) + | vertex <- [0 .. numVertices triangulation - 1] + ] + ) +{-# INLINE siteSupportFromTriangulation #-} + +siteSetSize :: SiteSet annotation -> Int +siteSetSize (SiteSet sites) = Map.size sites +{-# INLINE siteSetSize #-} + +siteSetRelation + :: SiteSet leftAnnotation + -> SiteSet rightAnnotation + -> SiteRelation +siteSetRelation (SiteSet left) (SiteSet right) = + siteRelationFromCardinalities + (leftOnly + overlap) + (rightOnly + overlap) + overlap + where + SiteRelationCensus leftOnly rightOnly overlap = + getConst + ( MapMerge.mergeA + (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 1 0 0))) + (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 0 1 0))) + (MapMerge.zipWithAMatched (\_ _ _ -> Const (SiteRelationCensus 0 0 1))) + left + right + ) +{-# INLINE siteSetRelation #-} + +siteRelationFromTriangulations + :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace + -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace + -> SiteRelation +siteRelationFromTriangulations left right = + siteRelationFromCardinalities leftCount rightCount overlap + where + !leftCount = numVertices left + !rightCount = numVertices right + !overlap + | leftCount <= rightCount = exactOverlapCount right left + | otherwise = exactOverlapCount left right +{-# INLINE siteRelationFromTriangulations #-} + +siteRelationFromCardinalities :: Int -> Int -> Int -> SiteRelation +siteRelationFromCardinalities leftCount rightCount overlap + | leftCount == rightCount && overlap == leftCount = EqualSites + | overlap == leftCount = LeftProperSubset + | overlap == rightCount = RightProperSubset + | overlap == 0 = DisjointSites + | otherwise = PartialOverlap overlap +{-# INLINE siteRelationFromCardinalities #-} + +exactOverlapCount + :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace + -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace + -> Int +exactOverlapCount source indexed = + either + (const (persistentExactOverlapCount source indexed)) + id + (transientExactOverlapCount source indexed) +{-# INLINE exactOverlapCount #-} + +transientExactOverlapCount + :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace + -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace + -> Either BuildError Int +transientExactOverlapCount source indexed = runST $ do + pointIndex <- newMutablePointIndex (numVertices indexed) + seeded <- + seedMutablePointIndex + pointIndex + (numVertices indexed) + (readCoordinateX indexed) + (readCoordinateY indexed) + case seeded of + Left failure -> pure (Left failure) + Right () -> + fmap Right + ( U.ifoldM' + (\count vertex x -> do + let y = triPointY source `pagedUnsafeIndex` vertex + match <- + lookupMutablePoint + pointIndex + (readCoordinateX indexed) + (readCoordinateY indexed) + x + y + pure (if isJust match then count + 1 else count) + ) + 0 + (toVector (triPointX source)) + ) +{-# INLINE transientExactOverlapCount #-} + +persistentExactOverlapCount + :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace + -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace + -> Int +persistentExactOverlapCount source indexed = + foldVertices' + source + (\count vertex -> + if pointOccursIn indexed (vertexPoint source vertex) + then count + 1 + else count + ) + 0 +{-# INLINE persistentExactOverlapCount #-} + +siteSetUnionWith + :: (annotation -> annotation -> annotation) + -> SiteSet annotation + -> SiteSet annotation + -> SiteSet annotation +siteSetUnionWith combine (SiteSet left) (SiteSet right) = + SiteSet (Map.unionWith combine left right) +{-# INLINE siteSetUnionWith #-} + +siteSetIntersectionWith + :: (leftAnnotation -> rightAnnotation -> annotation) + -> SiteSet leftAnnotation + -> SiteSet rightAnnotation + -> SiteSet annotation +siteSetIntersectionWith combine (SiteSet left) (SiteSet right) = + SiteSet (Map.intersectionWith combine left right) +{-# INLINE siteSetIntersectionWith #-} + +siteSetDifference + :: SiteSet annotation + -> SiteSet other + -> SiteSet annotation +siteSetDifference (SiteSet left) (SiteSet right) = SiteSet (Map.difference left right) +{-# INLINE siteSetDifference #-} + +siteSetSymmetricDifferenceFromTriangulations + :: Triangulation leftMode annotation leftDirected leftUndirected leftFace + -> Triangulation rightMode annotation rightDirected rightUndirected rightFace + -> Either BuildError (SiteSet annotation) +siteSetSymmetricDifferenceFromTriangulations left right + | numVertices left >= numVertices right = indexedSymmetricDifference left right + | otherwise = indexedSymmetricDifference right left +{-# INLINE siteSetSymmetricDifferenceFromTriangulations #-} + +indexedSymmetricDifference + :: forall sourceMode annotation sourceDirected sourceUndirected sourceFace + indexedMode indexedDirected indexedUndirected indexedFace + . Triangulation sourceMode annotation sourceDirected sourceUndirected sourceFace + -> Triangulation indexedMode annotation indexedDirected indexedUndirected indexedFace + -> Either BuildError (SiteSet annotation) +indexedSymmetricDifference source indexed = + fmap (SiteSet . Map.fromList) (runST collectExclusiveAssociations) + where + collectExclusiveAssociations + :: forall state. ST state (Either BuildError [(Point, annotation)]) + collectExclusiveAssociations = do + pointIndex <- newMutablePointIndex (numVertices indexed) + seeded <- + seedMutablePointIndex + pointIndex + (numVertices indexed) + (readCoordinateX indexed) + (readCoordinateY indexed) + case seeded of + Left failure -> pure (Left failure) + Right () -> do + matchedIndexedVertices <- MUV.replicate (numVertices indexed) False + sourceExclusive <- + U.ifoldM' + (collectSourceExclusive pointIndex matchedIndexedVertices) + [] + (toVector (triPointX source)) + indexedExclusive <- + U.ifoldM' + (collectIndexedExclusive matchedIndexedVertices) + [] + (toVector (triPointX indexed)) + pure (Right (sourceExclusive <> indexedExclusive)) + where + collectSourceExclusive + :: MutablePointIndex state + -> MUV.MVector state Bool + -> [(Point, annotation)] + -> Int + -> Double + -> ST state [(Point, annotation)] + collectSourceExclusive pointIndex matchedIndexedVertices associations rawVertex x = do + let vertex = VertexId (fromIntegral rawVertex) + y = triPointY source `pagedUnsafeIndex` rawVertex + point = Point x y + match <- + lookupMutablePoint + pointIndex + (readCoordinateX indexed) + (readCoordinateY indexed) + x + y + case match of + Nothing -> pure ((point, vertexData source vertex) : associations) + Just indexedVertex -> do + MUV.unsafeWrite matchedIndexedVertices indexedVertex True + pure associations + + collectIndexedExclusive + :: MUV.MVector state Bool + -> [(Point, annotation)] + -> Int + -> Double + -> ST state [(Point, annotation)] + collectIndexedExclusive matchedIndexedVertices associations rawVertex x = do + let vertex = VertexId (fromIntegral rawVertex) + point = Point x (triPointY indexed `pagedUnsafeIndex` rawVertex) + matched <- MUV.unsafeRead matchedIndexedVertices rawVertex + pure + ( if matched + then associations + else (point, vertexData indexed vertex) : associations + ) +{-# INLINE indexedSymmetricDifference #-} + +readCoordinateX + :: Triangulation mode annotation directed undirected face + -> Int + -> ST state Double +readCoordinateX triangulation vertex = + pure (triPointX triangulation `pagedUnsafeIndex` vertex) +{-# INLINE readCoordinateX #-} + +readCoordinateY + :: Triangulation mode annotation directed undirected face + -> Int + -> ST state Double +readCoordinateY triangulation vertex = + pure (triPointY triangulation `pagedUnsafeIndex` vertex) +{-# INLINE readCoordinateY #-} + +pointOccursIn + :: Triangulation mode annotation directed undirected face + -> Point + -> Bool +pointOccursIn triangulation = isJust . lookupPointIn triangulation +{-# INLINE pointOccursIn #-} + +lookupPointIn + :: Triangulation mode annotation directed undirected face + -> Point + -> Maybe Int +lookupPointIn triangulation = + lookupPointIndex + (triPointX triangulation) + (triPointY triangulation) + (triPointIndex triangulation) +{-# INLINE lookupPointIn #-} + +siteSetAssocs :: SiteSet annotation -> [(Point, annotation)] +siteSetAssocs (SiteSet sites) = Map.toAscList sites +{-# INLINE siteSetAssocs #-} + +siteSetPoints :: SiteSet annotation -> V.Vector (Point) +siteSetPoints (SiteSet sites) = V.fromList (Map.keys sites) +{-# INLINE siteSetPoints #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Location.hs b/src-build/Moonlight/Triangulation/Internal/Location.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Location.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Moonlight.Triangulation.Internal.Location + ( MutableLocation (..) + , locateMutable + , locateLineMutable + , visibleOuterEdge + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor, (.&.)) +import Data.STRef (readSTRef, writeSTRef) +import Moonlight.Triangulation.Internal.FaceProbe +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , maxCounter + ) +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Types + +data MutableLocation + = MutableEmpty + | MutableOnVertex {-# UNPACK #-} !Int + | MutableOnEdge {-# UNPACK #-} !Int + | MutableInFace {-# UNPACK #-} !Int + | MutableOutsideHull {-# UNPACK #-} !Int + deriving stock (Eq, Ord, Show) + +reverseIndex :: Int -> Int +reverseIndex edge = edge `xor` 1 +{-# INLINE reverseIndex #-} + +locateMutable + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe Int + -> Point + -> ST s (Either BuildError MutableLocation) +locateMutable mutable operation hint rawQuery = do + connected <- connectedCount mutable + faces <- faceCount mutable + let !query = canonicalPoint rawQuery + case connected of + 0 -> pure (Right MutableEmpty) + _ | faces <= 1 -> Right <$> locateLineMutable mutable query + -- A hint is the caller vouching for adjacency, so the exact walk starts + -- there directly; only an unhinted locate buys the vertex descent. + _ | Just face <- hint, face > 0 && face < faces -> walk mutable operation query face + _ -> do + start <- chooseStartFace mutable hint + anchor <- readFaceEdge mutable start + if anchor < 0 + then walk mutable operation query start + else do + origin <- readOrigin mutable anchor + nearest <- descendToNearest mutable operation query origin + face <- incidentInnerFace mutable nearest start + walk mutable operation query face + +-- | Greedy first-improvement descent through vertex neighbours: hop to the +-- first neighbour strictly closer to the query until none improves. Distance +-- is a heuristic only — exact containment belongs to 'walk' — so the widened +-- comparison can lengthen the path but never move the located answer. +-- +-- Strictly decreasing distance bounds the hops and nothing else: no vertex is +-- entered twice, but the star rotation terminates only if @reverse . previous@ +-- closes an orbit, which is a property of the links rather than of the +-- geometry. Disjoint stars over distinct entered vertices spend at most one +-- step per outgoing half-edge, so a budget past 'directedEdgeCount' cannot be +-- exhausted while the links are well formed. Exhausting it means they are not, +-- and yields the vertex in hand rather than an error — a truncated descent can +-- only lengthen 'walk', never move what it finds. +descendToNearest + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Point + -> Int + -> ST s Int +descendToNearest mutable operation query start = do + halfEdges <- directedEdgeCount mutable + point <- pointAt mutable start + settle (halfEdges + 1) start (squaredDistanceWide query point) + where + settle !budget !vertex !best = do + first <- readVertexOut mutable vertex + if first < 0 + then pure vertex + else rotate budget vertex best first first + rotate !budget !vertex !best !first !edge + | budget <= 0 = pure vertex + | otherwise = do + neighbour <- readOrigin mutable (reverseIndex edge) + point <- pointAt mutable neighbour + let !candidate = squaredDistanceWide query point + if candidate < best + then do + addCounter operation CounterLocationWalkSteps 1 + settle (budget - 1) neighbour candidate + else do + previousEdge <- readPrevious mutable edge + let !outgoing = reverseIndex previousEdge + if outgoing == first then pure vertex else rotate (budget - 1) vertex best first outgoing + +-- | An inner face incident to the vertex, so the exact walk starts adjacent +-- to where the descent settled; the caller's face stands in when the star +-- offers none. +incidentInnerFace + :: MutableDcel s vertex directed undirected face + -> Int + -> Int + -> ST s Int +incidentInnerFace mutable vertex fallback = do + first <- readVertexOut mutable vertex + if first < 0 then pure fallback else rotate first first + where + rotate !first !edge = do + face <- readFace mutable edge + if face > 0 + then pure face + else do + previousEdge <- readPrevious mutable edge + let !outgoing = reverseIndex previousEdge + if outgoing == first then pure fallback else rotate first outgoing + +locateLineMutable :: MutableDcel s vertex directed undirected face -> Point -> ST s MutableLocation +locateLineMutable mutable rawQuery = do + let !query = canonicalPoint rawQuery + vertices <- pointCount mutable + exactVertex <- findVertex query vertices 0 + case exactVertex of + Just vertex -> pure (MutableOnVertex vertex) + Nothing -> do + halfEdges <- directedEdgeCount mutable + if halfEdges == 0 + then pure (MutableOutsideHull 0) + else do + onEdge <- findSegment query halfEdges 0 + case onEdge of + Just edge -> pure (MutableOnEdge edge) + Nothing -> do + firstConnected <- findConnected vertices 0 + firstOut <- readVertexOut mutable firstConnected + let edge = if firstOut < 0 then 0 else firstOut + from <- edgeOriginPoint mutable edge + to <- edgeOriginPoint mutable (reverseIndex edge) + case orient2d from to query of + GT -> pure (MutableOutsideHull (orientOuter edge)) + LT -> pure (MutableOutsideHull (orientOuter (reverseIndex edge))) + EQ -> MutableOutsideHull <$> nearestTerminalEdge query halfEdges edge + where + findVertex !query !limit !index + | index >= limit = pure Nothing + | otherwise = do + connected <- isConnected mutable index + if not connected + then findVertex query limit (index + 1) + else do + point <- pointAt mutable index + if point == query then pure (Just index) else findVertex query limit (index + 1) + + findSegment !query !limit !edge + | edge >= limit = pure Nothing + | otherwise = do + let normalized = edge .&. complementOne + from <- edgeOriginPoint mutable normalized + to <- edgeOriginPoint mutable (reverseIndex normalized) + if onClosedSegment from to query + then pure (Just normalized) + else findSegment query limit (normalized + 2) + + findConnected !limit !index + | index >= limit = pure 0 + | otherwise = do + connected <- isConnected mutable index + if connected then pure index else findConnected limit (index + 1) + + orientOuter :: Int -> Int + orientOuter edge = edge + + -- A degenerate chain's outer cycle doubles back exactly at its two terminal + -- vertices, so @next e == reverse e@ characterises the edge entering a + -- terminal. Collinear extension must attach to the terminal nearest the + -- query, which for three or more vertices is not an endpoint of any single + -- arbitrary edge. + nearestTerminalEdge !query !limit !fallback = go 0 Nothing + where + go !edge !best + | edge >= limit = pure (maybe fallback fst best) + | otherwise = do + edgeNext <- readNext mutable edge + if edgeNext /= reverseIndex edge + then go (edge + 1) best + else do + let !terminal = reverseIndex edge + point <- edgeOriginPoint mutable terminal + let !candidate = squaredDistanceWide query point + case best of + Just (_, closest) | closest <= candidate -> go (edge + 1) best + _ -> go (edge + 1) (Just (terminal, candidate)) + + complementOne = -2 + +walk + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Point + -> Int + -> ST s (Either BuildError MutableLocation) +walk mutable operation query initialFace = do + faces <- faceCount mutable + halfEdges <- directedEdgeCount mutable + let !budget = max 8 (faces + halfEdges `quot` 2 + 4) + go budget 0 initialFace + where + go !remaining !steps !face + | remaining <= 0 = do + addCounter operation CounterLocationFallbacks 1 + maxCounter operation CounterLocationMaxWalk steps + pure (Left (LocationWalkExhausted query steps)) + | face <= 0 = Right . MutableOutsideHull <$> visibleOuterEdge mutable query + | otherwise = do + addCounter operation CounterLocationWalkSteps 1 + let !nextSteps = steps + 1 + probe <- probeFace mutable face query + case probe of + MutableInFace found -> do + writeSTRef (mdLastFace mutable) found + maxCounter operation CounterLocationMaxWalk nextSteps + pure (Right probe) + MutableOnVertex _ -> do + writeSTRef (mdLastFace mutable) face + maxCounter operation CounterLocationMaxWalk nextSteps + pure (Right probe) + MutableOnEdge _ -> do + writeSTRef (mdLastFace mutable) face + maxCounter operation CounterLocationMaxWalk nextSteps + pure (Right probe) + MutableOutsideHull edge -> do + adjacent <- readFace mutable edge + if adjacent == 0 + then do + maxCounter operation CounterLocationMaxWalk nextSteps + pure (Right (MutableOutsideHull edge)) + else go (remaining - 1) nextSteps adjacent + MutableEmpty -> pure (Left (PointLocationFailed query)) + +probeFace :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s MutableLocation +-- 'faceEdges' walks the @next@ chain, so the cycle already states each +-- boundary's destination: @destination e0 = origin e1@. Reading the twin's +-- origin instead asks the store for what the face has already said, at twice +-- the endpoint loads and twice the coordinate loads per probe. Three origins +-- and three points settle all three boundaries. Vertex and edge hits still +-- return on the first boundary that reports one, and a later crossing still +-- displaces an earlier one. +probeFace mutable face query = do + (e0, e1, e2) <- faceEdges mutable face + a <- readOrigin mutable e0 + b <- readOrigin mutable e1 + c <- readOrigin mutable e2 + pa <- pointAt mutable a + pb <- pointAt mutable b + pc <- pointAt mutable c + let !first = probeBoundary reverseIndex query e0 a pa b pb + case first of + BoundaryOnVertex vertex -> pure (MutableOnVertex vertex) + BoundaryOnEdge boundary -> pure (MutableOnEdge boundary) + _ -> do + let !second = probeBoundary reverseIndex query e1 b pb c pc + case second of + BoundaryOnVertex vertex -> pure (MutableOnVertex vertex) + BoundaryOnEdge boundary -> pure (MutableOnEdge boundary) + _ -> do + let !third = probeBoundary reverseIndex query e2 c pc a pa + case third of + BoundaryOnVertex vertex -> pure (MutableOnVertex vertex) + BoundaryOnEdge boundary -> pure (MutableOnEdge boundary) + _ -> pure $ case keep third (keep second (keep first Nothing)) of + Nothing -> MutableInFace face + Just boundary -> MutableOutsideHull boundary + where + keep :: BoundaryProbe boundary probeVertex -> Maybe boundary -> Maybe boundary + keep (BoundaryCrossing boundary) _ = Just boundary + keep _ held = held + +chooseStartFace :: MutableDcel s vertex directed undirected face -> Maybe Int -> ST s Int +chooseStartFace mutable hint = do + faces <- faceCount mutable + cached <- readSTRef (mdLastFace mutable) + let candidate = case hint of + Just face | face > 0 && face < faces -> face + _ | cached > 0 && cached < faces -> cached + _ -> 1 + pure candidate + +visibleOuterEdge :: MutableDcel s vertex directed undirected face -> Point -> ST s Int +visibleOuterEdge mutable query = do + start <- readFaceEdge mutable 0 + halfEdges <- directedEdgeCount mutable + if start < 0 || halfEdges == 0 + then pure 0 + else go (halfEdges + 1) start start Nothing + where + go !remaining !start !edge !fallback + | remaining <= 0 = pure (maybe start id fallback) + | otherwise = do + from <- edgeOriginPoint mutable edge + to <- edgeOriginPoint mutable (reverseIndex edge) + let !side = orient2d from to query + !fallback' = if side /= LT then Just edge else fallback + if side == GT + then pure edge + else do + edgeNext <- readNext mutable edge + if edgeNext == start then pure (maybe edge id fallback') else go (remaining - 1) start edgeNext fallback' + + diff --git a/src-build/Moonlight/Triangulation/Internal/Refinement.hs b/src-build/Moonlight/Triangulation/Internal/Refinement.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Refinement.hs @@ -0,0 +1,1284 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Ruppert refinement over three local worklists: forced segment splits, +-- fixed-edge encroachment candidates, and skinny faces. A face candidate is +-- transactional: preflight locates the circumcenter and follows the +-- prospective legalization cavity without mutating topology; a fixed edge the +-- cavity meets is tested against the point's diametral disk and aborts the +-- plan into a segment split; otherwise the located site commits directly. +module Moonlight.Triangulation.Internal.Refinement + ( RefinementInitialSeed (..) + , RefinementDomain (..) + , refineMutable + ) where + +import Control.Monad (filterM, forM_, unless, when) +import Control.Monad.ST (ST) +import Data.Foldable (traverse_) +import Data.Bits (xor) +import qualified Data.IntSet as IntSet +import Data.List (find) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Handles.HandleDefs (FaceId (..), UndirectedEdgeId (..)) +import Moonlight.Triangulation.Internal.DcelOperations (insertOnEdge, legalizeEdges) +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , clearGrowable + , growableLength + , newGrowableWord32 + , popGrowableOr + , pushGrowable + , readGrowable + ) +import Moonlight.Triangulation.Internal.Location + ( MutableLocation (..) + , locateMutable + ) +import Moonlight.Triangulation.Internal.FaceQueue + ( FaceQueue + , newFaceQueue + , popFace + , pushFace + ) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel (..) + , addEdgeBlock + , addFaceBlock + , appendVertex + , directedEdgeCount + , edgeOriginPoint + , ensureCellCapacity + , faceCount + , faceEdges + , markConnected + , pointAt + , pointCapacity + , readConstraint + , readFace + , readNext + , readOrigin + , readPrevious + , readVertexOut + , resetEdgeData + , resetFaceData + , setCycle3 + , writeOrigin + , writeVertexOut + ) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , maxCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex) +import Moonlight.Triangulation.Internal.Probe (Probe (..)) +import Moonlight.Triangulation.Math + ( canonicalPoint + , circumcenter + , inCircle + , inDiametralCircle + , isFinite + , midpoint + , orient2d + , squaredDistance + , squaredDistanceWide + , triangleArea + , triangleRadiusEdgeRatioSquaredWithArea + , validateCoordinate + ) +import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation) +import Moonlight.Triangulation.Types + ( BuildError (..) + , Point (..) + , RefinementParameters (..) + ) + +-- | The worklists refinement owns for the duration of one transaction. Every +-- one is local to the cavity or segment it drains; nothing geometric is +-- indexed globally. +data Workspace s = Workspace + { wsQueue :: !(FaceQueue s) + , wsExcluded :: !(MUV.MVector s Bool) + , wsPermitted :: !(Maybe (MUV.MVector s Bool)) + , wsVisited :: !(Maybe (MUV.MVector s Bool)) + , wsInterfaceBoundaryReads :: !(STRef s Int) + , wsBoundaryCrossingAttempts :: !(STRef s Int) + , wsForcedSplits :: !(GrowableWord32 s) + , wsEncroachment :: !(GrowableWord32 s) + -- | Where each pair's live entry sits in 'wsEncroachment', 'noIndex' when + -- the pair is not queued. A re-push relocates the pair to the top and leaves + -- the older entry behind as a slot that no longer names it, so a pair is + -- tested once at its most recent offer instead of once per offer. + , wsEncroachmentSlot :: !(MUV.MVector s Word32) + -- | Steiner vertices on constraints carry the original segment's endpoint + -- pair, two words per vertex, 'noIndex' when the vertex is not on one. + , wsSegmentOrigin :: !(MUV.MVector s Word32) + -- | Cavity discovery state: an epoch stamp per face, edge pair and boundary + -- vertex, plus the three records a successful commit consumes. A cavity is + -- explored without mutating topology; the commit either fans the recorded + -- boundary or abandons the records entirely. + , wsCavityEpoch :: !(STRef s Word32) + , wsCavityFaceMarks :: !(MUV.MVector s Word32) + , wsCavityPairMarks :: !(MUV.MVector s Word32) + , wsCavityVertexMarks :: !(MUV.MVector s Word32) + , wsCavityFaces :: !(GrowableWord32 s) + , wsCavityInternal :: !(GrowableWord32 s) + , wsCavityBoundary :: !(GrowableWord32 s) + , wsCavityCocircular :: !(GrowableWord32 s) + -- | The recorded boundary in cycle order, written by the chaining walk and + -- read by the fan. + , wsCavityChain :: !(GrowableWord32 s) + -- | The flood and hull-simulation stack. The old mesh-global work stack + -- served both; the transaction owns it now, cleared before either use. + , wsCavityWork :: !(GrowableWord32 s) + } + +data FaceHint + = FaceAcceptable + | FaceMustRefine + | FaceShouldRefine + +-- | The initial support a refinement run is allowed to inspect. Subsequent +-- cavity, star, and fixed-edge propagation remains exactly the ordinary +-- refinement law; only the first offers differ. The constructor is internal +-- so public callers cannot smuggle a mutable worklist across the transaction +-- boundary. +data RefinementInitialSeed + = RefineEveryFace + | RefineSeededFaces !IntSet.IntSet + +-- | A checked local section. Face and edge integers are admitted by the +-- immutable constructor in "Moonlight.Triangulation.Refinement"; the mutable +-- interpreter sees only the already-descended dense membership witnesses. +data RefinementDomain = RefinementDomain + { refinementDomainPermittedFaces :: !IntSet.IntSet + , refinementDomainInterfacePairs :: !IntSet.IntSet + , refinementDomainInputFaces :: !(Map.Map FaceId [Point]) + , refinementDomainInputFaceCount :: {-# UNPACK #-} !Int + , refinementDomainInputEdgeCount :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Show) + +reverseIndex :: Int -> Int +reverseIndex edge = edge `xor` 1 +{-# INLINE reverseIndex #-} + +-- | Refine the existing finite DCEL. Fixed edges (constraints and the convex +-- hull) are legal barriers: a candidate whose prospective cavity meets one +-- inside its diametral disk is abandoned and the segment is split instead. +-- The result is @(worklists-drained, Steiner-count, excluded-outer-faces)@. +refineMutable + :: forall s vertex directed undirected face. (Point -> vertex) + -> MutableDcel s vertex directed undirected face + -> OperationState s + -> RefinementParameters + -> Int + -> IntSet.IntSet + -> RefinementInitialSeed + -> Maybe RefinementDomain + -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int)) +refineMutable makeVertex mutable operation parameters originalVertexCount initialExcludedFaces initialSeed domain = do + let !faceBound = 3 * pointCapacity mutable + 8 + !pairBound = mdHalfCapacity mutable `quot` 2 + wsQueue <- newFaceQueue faceBound + wsExcluded <- MUV.replicate faceBound False + wsPermitted <- traverse (const (MUV.replicate faceBound False)) domain + wsVisited <- traverse (const (MUV.replicate faceBound False)) domain + wsInterfaceBoundaryReads <- newSTRef 0 + wsBoundaryCrossingAttempts <- newSTRef 0 + traverse_ + (\membership -> + traverse_ + (\face -> when (face < faceBound) (MUV.unsafeWrite membership face True)) + (maybe [] (IntSet.toAscList . refinementDomainPermittedFaces) domain) + ) + wsPermitted + when (refineExcludeOuterFaces parameters) $ + forM_ (IntSet.toAscList initialExcludedFaces) $ \face -> + when (face < faceBound) (MUV.unsafeWrite wsExcluded face True) + wsForcedSplits <- newGrowableWord32 16 + wsEncroachment <- newGrowableWord32 64 + wsEncroachmentSlot <- MUV.replicate (max 1 pairBound) noIndex + wsSegmentOrigin <- MUV.replicate (2 * pointCapacity mutable) noIndex + wsCavityEpoch <- newSTRef 0 + wsCavityFaceMarks <- MUV.replicate faceBound 0 + wsCavityPairMarks <- MUV.replicate (max 1 pairBound) 0 + wsCavityVertexMarks <- MUV.replicate (pointCapacity mutable) 0 + wsCavityFaces <- newGrowableWord32 16 + wsCavityInternal <- newGrowableWord32 16 + wsCavityBoundary <- newGrowableWord32 16 + wsCavityCocircular <- newGrowableWord32 4 + wsCavityChain <- newGrowableWord32 16 + wsCavityWork <- newGrowableWord32 16 + let workspace = Workspace{wsQueue, wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts, wsForcedSplits, wsEncroachment, wsEncroachmentSlot, wsSegmentOrigin, wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityChain, wsCavityWork} + seedInitialWork workspace initialSeed + loop workspace 0 + where + !limit = max 0 (fromMaybe (10 * originalVertexCount) (refineMaxAdditionalVertices parameters)) + + -- The three bounds every queued face is measured against. They are fixed for + -- the whole run, and the ratio bound is squared once here rather than once + -- per face the ratio test reaches. + !maximumArea = refineMaxArea parameters + !minimumArea = refineMinArea parameters + !squaredRatioBound = case refineMaxRadiusEdgeRatio parameters of + Nothing -> Nothing + Just bound -> Just $! squareBound bound + + -- One charged stack push: the old mesh-global 'pushWork' wrapper fed the + -- legalization depth counter on every push, and the hull-simulation sites + -- used that wrapper deliberately. The cavity flood's bypass stays raw. + pushChargedWork :: GrowableWord32 s -> Int -> ST s () + pushChargedWork work value = do + pushGrowable work (packIndex value) + size <- growableLength work + maxCounter operation CounterLegalizationMaxStack size + + -- Offer a fixed edge pair for the encroachment question. An offer always + -- wins the pair's slot, so the pair is answered at its most recent offer and + -- the entries it left behind are recognised as superseded when reached. + pushEncroachment :: Workspace s -> Int -> ST s () + pushEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} pair = do + index <- growableLength wsEncroachment + pushGrowable wsEncroachment (packIndex pair) + MUV.unsafeWrite wsEncroachmentSlot pair (packIndex index) + + -- 'noIndex' when the offers are drained. + popEncroachment :: Workspace s -> ST s Word32 + popEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} = go + where + go = do + size <- growableLength wsEncroachment + if size <= 0 + then pure noIndex + else do + let !index = size - 1 + packed <- popGrowableOr noIndex wsEncroachment + let !pair = fromIntegral packed + slot <- MUV.unsafeRead wsEncroachmentSlot pair + if slot == packIndex index + then do + MUV.unsafeWrite wsEncroachmentSlot pair noIndex + pure packed + else go + + -- The cavity epoch stamps three planes and is compared against them, so the + -- wrap has to retire every stamp a reused value would answer for. + nextCavityEpoch :: Workspace s -> ST s Word32 + nextCavityEpoch Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks} = do + current <- readSTRef wsCavityEpoch + let !next = current + 1 + if next == 0 + then do + MUV.set wsCavityFaceMarks 0 + MUV.set wsCavityPairMarks 0 + MUV.set wsCavityVertexMarks 0 + writeSTRef wsCavityEpoch 1 + pure 1 + else do + writeSTRef wsCavityEpoch next + pure next + + loop :: Workspace s -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int)) + loop workspace@Workspace{wsQueue, wsForcedSplits} !added + | added >= limit = finish workspace False added + | otherwise = do + forced <- popGrowableOr noIndex wsForcedSplits + if forced /= noIndex + then do + splitOutcome <- resolveSplit workspace (fromIntegral forced) + case splitOutcome of + Left obstruction -> pure (Left obstruction) + Right split -> + if split + then loop workspace (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 + else do + candidate <- popEncroachment workspace + if candidate /= noIndex + then do + splitOutcome <- checkEncroachment workspace (fromIntegral candidate) + case splitOutcome of + Left obstruction -> pure (Left obstruction) + Right split -> loop workspace (if split then added + 1 else added) + else do + next <- popFace wsQueue + case next of + Nothing -> finish workspace True added + Just face -> do + outcome <- handleFace workspace face + case outcome of + Left failure -> pure (Left failure) + Right gained -> loop workspace (added + gained) + + finish :: Workspace s -> Bool -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int)) + finish Workspace{wsExcluded, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts} complete added = do + faces <- faceCount mutable + let gather :: [Int] -> Int -> ST s [Int] + gather !collected face + | face < 0 = pure collected + | otherwise = do + flagged <- MUV.unsafeRead wsExcluded face + gather (if flagged then face : collected else collected) (face - 1) + excludedFaces <- gather [] (min (MUV.length wsExcluded) faces - 1) + visitedFaces <- + case wsVisited of + Nothing -> pure [] + Just visited -> do + let gatherVisited :: [Int] -> Int -> ST s [Int] + gatherVisited !collected face + | face < 1 = pure collected + | otherwise = do + flagged <- MUV.unsafeRead visited face + gatherVisited (if flagged then face : collected else collected) (face - 1) + gatherVisited [] (min (MUV.length visited) faces - 1) + interfaceBoundaryReads <- readSTRef wsInterfaceBoundaryReads + boundaryCrossingAttempts <- readSTRef wsBoundaryCrossingAttempts + pure (Right (complete, added, excludedFaces, visitedFaces, interfaceBoundaryReads, boundaryCrossingAttempts)) + + offerAll :: FaceQueue s -> ST s () + offerAll queue = do + faces <- faceCount mutable + forM_ [1 .. faces - 1] (pushFace queue) + + -- A seeded run is not a weaker refinement interpreter. It begins at the + -- supplied faces and asks only the fixed edges those faces can immediately + -- encroach; every later cavity and star contributes its own local closure + -- through the same queue and encroachment machinery as the global entry. + seedInitialWork :: Workspace s -> RefinementInitialSeed -> ST s () + seedInitialWork workspace seed = + case seed of + RefineEveryFace -> seedFixedEdges workspace >> offerAll (wsQueue workspace) + RefineSeededFaces faces -> + traverse_ (seedFace workspace) (IntSet.toAscList faces) + + seedFace :: Workspace s -> Int -> ST s () + seedFace workspace face = do + pushFace (wsQueue workspace) face + (e0, e1, e2) <- faceEdges mutable face + traverse_ (offerFixedEdge workspace) [e0, e1, e2] + + -- Every fixed edge present at entry, queued once for the existing-vertex + -- encroachment question. Later candidates arrive from the star walks of the + -- insertions that could have created a new encroachment. + seedFixedEdges :: Workspace s -> ST s () + seedFixedEdges workspace = do + halfEdges <- directedEdgeCount mutable + traverse_ + (offerFixedEdge workspace . (2 *)) + [0 .. halfEdges `quot` 2 - 1] + + offerFixedEdge :: Workspace s -> Int -> ST s () + offerFixedEdge workspace directed = do + fixed <- isFixedEdge directed + let !pair = directed `quot` 2 + -- An interface is a fixed boundary condition, not a quality obligation + -- owned by this section. It is still encountered by candidate cavities, + -- where any demand to split or cross it is a typed obstruction. + when (fixed && not (isInterfacePair pair)) $ + pushEncroachment workspace pair + + isFixedEdge :: Int -> ST s Bool + isFixedEdge directed = do + if isInterfacePair (directed `quot` 2) + then pure True + else do + protected <- readConstraint mutable directed + if protected + then pure True + else do + own <- readFace mutable directed + if own == 0 + then pure True + else (== 0) <$> readFace mutable (reverseIndex directed) + + isInterfacePair :: Int -> Bool + isInterfacePair pair = + maybe False (IntSet.member pair . refinementDomainInterfacePairs) domain + {-# INLINE isInterfacePair #-} + + interfaceCrossing :: Workspace s -> Int -> ST s BuildError + interfaceCrossing Workspace{wsPermitted, wsBoundaryCrossingAttempts} pair = do + modifySTRef' wsBoundaryCrossingAttempts (+ 1) + forwardFace <- readFace mutable (2 * pair) + backwardFace <- readFace mutable (2 * pair + 1) + joinFace <- + case wsPermitted of + Nothing -> pure Nothing + Just permitted -> do + forwardPermitted <- dynamicPermitted permitted forwardFace + backwardPermitted <- dynamicPermitted permitted backwardFace + pure + ( if forwardPermitted + then Just forwardFace + else if backwardPermitted then Just backwardFace else Nothing + ) + pure + ( case joinFace of + Just face -> + RefinementDomainWouldCrossInterface + (UndirectedEdgeId (fromIntegral pair)) + (FaceId (fromIntegral face)) + Nothing -> RefinementDomainTopologyChanged + ) + where + dynamicPermitted :: MUV.MVector s Bool -> Int -> ST s Bool + dynamicPermitted membership face = + if face > 0 && face < MUV.length membership + then MUV.unsafeRead membership face + else pure False + + -- The area bound condemns outright ('FaceMustRefine'); the ratio bound only + -- invites refinement, which the input-angle guard may still decline. The + -- ratio is left for last: a face the area bound has already judged needs no + -- second reason, and the ratio is the more expensive of the two questions. + faceHint :: Point -> Point -> Point -> FaceHint + faceHint p0 p1 p2 + | areaBad = FaceMustRefine + | belowMinimum = FaceAcceptable + | angleBad = FaceShouldRefine + | otherwise = FaceAcceptable + where + !area = triangleArea p0 p1 p2 + areaBad = maybe False (exceeds area) maximumArea + belowMinimum = maybe False (area <) minimumArea + angleBad = case squaredRatioBound of + Nothing -> False + Just bound -> exceeds (triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2) bound + + handleFace :: Workspace s -> Int -> ST s (Either BuildError Int) + handleFace workspace@Workspace{wsExcluded, wsPermitted, wsVisited} face = do + addCounter operation CounterRefinementQueuePops 1 + permitted <- + maybe + (pure True) + (\membership -> MUV.unsafeRead membership face) + wsPermitted + if not permitted + then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral face)))) + else do + traverse_ (\visited -> MUV.unsafeWrite visited face True) wsVisited + skip <- MUV.unsafeRead wsExcluded face + if skip + then pure (Right 0) + else do + addCounter operation CounterRefinementFaceChecks 1 + (e0, e1, e2) <- faceEdges mutable face + p0 <- edgeOriginPoint mutable e0 + p1 <- edgeOriginPoint mutable e1 + p2 <- edgeOriginPoint mutable e2 + case faceHint p0 p1 p2 of + FaceAcceptable -> pure (Right 0) + FaceMustRefine -> 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 + + -- Two subsegments of one original segment meeting at a small input angle + -- cannot be refined apart: the angle is fixed by the input geometry. When + -- the shortest edge of a ratio-bound face joins two Steiner vertices whose + -- lineages share an original endpoint, the face is as good as it gets. + inputAngleBlocks :: Workspace s -> Int -> Int -> Int -> Point -> Point -> Point -> ST s Bool + inputAngleBlocks Workspace{wsSegmentOrigin} e0 e1 e2 p0 p1 p2 = do + let !shortest = shortestFaceEdge e0 e1 e2 p0 p1 p2 + a <- readOrigin mutable shortest + b <- readOrigin mutable (reverseIndex shortest) + shared <- sharedSegmentOrigin wsSegmentOrigin a b + if not shared + then pure False + else not <$> isFixedEdge shortest + + shortestFaceEdge :: Int -> Int -> Int -> Point -> Point -> Point -> Int + shortestFaceEdge e0 e1 e2 p0 p1 p2 + | side01 <= side12 && side01 <= side20 = e0 + | side12 <= side20 = e1 + | otherwise = e2 + where + !side01 = squaredDistanceWide p0 p1 + !side12 = squaredDistanceWide p1 p2 + !side20 = squaredDistanceWide p2 p0 + + sharedSegmentOrigin :: MUV.MVector s Word32 -> Int -> Int -> ST s Bool + sharedSegmentOrigin lineage a b = do + a0 <- MUV.unsafeRead lineage (2 * a) + a1 <- MUV.unsafeRead lineage (2 * a + 1) + b0 <- MUV.unsafeRead lineage (2 * b) + b1 <- MUV.unsafeRead lineage (2 * b + 1) + pure (a0 /= noIndex && b0 /= noIndex && (a0 == b0 || a0 == b1 || a1 == b0 || a1 == b1)) + + validCandidate :: Point -> Maybe (Point) + validCandidate point@(Point x y) + | validateCoordinate x == Nothing && validateCoordinate y == Nothing = Just point + | otherwise = Nothing + + attemptCandidate :: Workspace s -> Int -> Point -> Point -> Point -> ST s (Either BuildError Int) + attemptCandidate workspace@Workspace{wsExcluded, wsForcedSplits} face p0 p1 p2 = + case circumcenter p0 p1 p2 >>= validCandidate of + Nothing -> pure (Right 0) + Just point -> do + located <- locateMutable mutable operation (Just face) point + case located of + Left failure -> pure (Left failure) + Right site -> case site of + MutableOnVertex _ -> pure (Right 0) + MutableEmpty -> pure (Right 0) + MutableOutsideHull edge + | refinePreserveConvexHull parameters -> pure (Right 0) + | otherwise -> attemptOutside workspace face point edge + MutableOnEdge edge -> do + if isInterfacePair (edge `quot` 2) + then Left <$> interfaceCrossing workspace (edge `quot` 2) + else do + protected <- readConstraint mutable edge + if protected + then do + -- A circumcenter on a constraint is a request to split that + -- constraint, unless constraints are kept whole. + unless (refineKeepConstraintEdges parameters) $ + pushGrowable wsForcedSplits (packIndex (edge `quot` 2)) + pure (Right 0) + else exploreThenCommit workspace face point site + MutableInFace under -> do + permittedSite <- + maybe + (pure True) + (\membership -> MUV.unsafeRead membership under) + (wsPermitted workspace) + if not permittedSite + then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral under)))) + else do + excludedSite <- MUV.unsafeRead wsExcluded under + if excludedSite + then pure (Right 0) + else exploreThenCommit workspace face point site + + -- Follow the prospective legalization cavity of the candidate without + -- mutating topology, recording what the commit will consume: the cavity + -- faces, the internal edge pairs, and the ordered boundary. Fixed edges are + -- never crossed: the ones the cavity meets become boundary and are tested + -- against the candidate's diametral disk. Every encroached fixed edge met + -- is queued for splitting and the source face is revisited afterwards; a + -- clean cavity is committed directly. + exploreThenCommit :: Workspace s -> Int -> Point -> MutableLocation -> ST s (Either BuildError Int) + exploreThenCommit workspace@Workspace{wsQueue, wsForcedSplits} face point site = do + (visible, encroached) <- exploreCavity workspace point site + case find isInterfacePair encroached of + Just pair -> Left <$> interfaceCrossing workspace pair + Nothing -> + if null encroached + then commitCavity workspace point site visible + else do + pushable <- filterM splittablePair encroached + forM_ pushable $ \pair -> pushGrowable wsForcedSplits (packIndex pair) + unless (null pushable) $ pushFace wsQueue face + pure (Right 0) + + splittablePair :: Int -> ST s Bool + splittablePair pair = + if isInterfacePair pair + then pure False + else if refineKeepConstraintEdges parameters + then not <$> readConstraint mutable (2 * pair) + else pure True + + admitStar :: Workspace s -> Int -> ST s () + admitStar Workspace{wsPermitted} vertex = + traverse_ + (\membership -> + forEachStarFace vertex (\face -> MUV.unsafeWrite membership face True) + ) + wsPermitted + + -- The flood never mutates, so a popped edge can be retested idempotently: + -- an edge whose far face conflicts crosses, marks the face, and pushes that + -- face's other two edges; each directed edge has at most its two + -- face-neighbours as pushers, and a revisited crossing is deduplicated by + -- the face and pair stamps. Boundary visibility for the fan is accumulated + -- in place: every boundary edge is asked here, where its endpoints are + -- already loaded, whether the point sees it from the cavity side. + exploreCavity :: Workspace s -> Point -> MutableLocation -> ST s (Bool, [Int]) + exploreCavity workspace@Workspace{wsVisited, wsCavityFaceMarks, wsCavityPairMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityWork} point site = do + next <- nextCavityEpoch workspace + clearGrowable wsCavityFaces + clearGrowable wsCavityInternal + clearGrowable wsCavityBoundary + clearGrowable wsCavityCocircular + clearGrowable wsCavityWork + seedVisible <- case site of + MutableInFace under -> do + markFace next under + (e0, e1, e2) <- faceEdges mutable under + pushCavityWork e0 + pushCavityWork e1 + pushCavityWork e2 + pure True + MutableOnEdge edge -> do + seedAcross next edge + seedAcross next (reverseIndex edge) + -- The located edge is never encroachment-tested: a point on it lies + -- trivially inside its own diametral circle, and the question would + -- force the same split forever. A fixed edge is boundary; any other + -- is the cavity's first internal pair. Its visibility still counts. + fixed <- isFixedEdge edge + if fixed + then do + pushGrowable wsCavityBoundary (packIndex edge) + from <- edgeOriginPoint mutable edge + to <- edgeOriginPoint mutable (reverseIndex edge) + pure (orient2d from to point == GT) + else do + recordInternal next (edge `quot` 2) + pure True + _ -> pure True + drain next [] seedVisible + where + markFace :: Word32 -> Int -> ST s () + markFace epoch face = do + MUV.unsafeWrite wsCavityFaceMarks face epoch + traverse_ (\visited -> MUV.unsafeWrite visited face True) wsVisited + pushGrowable wsCavityFaces (packIndex face) + + isMarked :: Word32 -> Int -> ST s Bool + isMarked epoch face = (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks face + + recordInternal :: Word32 -> Int -> ST s () + recordInternal epoch pair = do + seen <- MUV.unsafeRead wsCavityPairMarks pair + when (seen /= epoch) $ do + MUV.unsafeWrite wsCavityPairMarks pair epoch + pushGrowable wsCavityInternal (packIndex pair) + + -- The flood's stack traffic is transaction-local and owns no diagnostics; + -- the charged wrapper would report every push as legalization depth. + pushCavityWork :: Int -> ST s () + pushCavityWork value = pushGrowable wsCavityWork (packIndex value) + + seedAcross :: Word32 -> Int -> ST s () + seedAcross epoch directed = do + adjacent <- readFace mutable directed + when (adjacent /= 0) $ do + markFace epoch adjacent + next <- readNext mutable directed + previous <- readPrevious mutable directed + pushCavityWork next + pushCavityWork previous + + -- Visibility is read by the caller only when nothing was encroached, so + -- the first encroached edge retires the question: every later boundary + -- edge skips the orientation that would only be conjoined into a value + -- about to be discarded. + drain :: Word32 -> [Int] -> Bool -> ST s (Bool, [Int]) + drain epoch = go + where + go !acc !visible = do + packed <- popGrowableOr noIndex wsCavityWork + if packed == noIndex + then pure (visible, acc) + else do + let !directed = fromIntegral packed + fixed <- isFixedEdge directed + if fixed + then do + pushGrowable wsCavityBoundary (packIndex directed) + from <- edgeOriginPoint mutable directed + to <- edgeOriginPoint mutable (reverseIndex directed) + let pair = directed `quot` 2 + encroached = inDiametralCircle from to point + when (isInterfacePair pair && not encroached) $ + modifySTRef' (wsInterfaceBoundaryReads workspace) (+ 1) + if encroached + then go (pair : acc) False + else go acc (visible && orient2d from to point == GT) + else do + across <- readFace mutable (reverseIndex directed) + marked <- isMarked epoch across + if marked + then do + recordInternal epoch (directed `quot` 2) + go acc visible + else do + let !twin = reverseIndex directed + acrossPrevious <- readPrevious mutable twin + opposite <- readOrigin mutable acrossPrevious + from <- edgeOriginPoint mutable directed + to <- pointAt mutable =<< readOrigin mutable twin + acrossPoint <- pointAt mutable opposite + let !verdict = inCircle to from acrossPoint point + if verdict == GT + then do + markFace epoch across + recordInternal epoch (directed `quot` 2) + acrossNext <- readNext mutable twin + pushCavityWork acrossNext + pushCavityWork acrossPrevious + go acc visible + else do + pushGrowable wsCavityBoundary (packIndex directed) + when (verdict == EQ) $ + pushGrowable wsCavityCocircular (packIndex directed) + go acc (visible && orient2d from to point == GT) + + -- The flood never mutates, so a popped edge can be retested idempotently: + -- an edge whose far face conflicts pushes that face's other two edges, and + -- each directed edge has at most its two face-neighbours as pushers. + drainSimulation :: GrowableWord32 s -> Point -> [Int] -> ST s [Int] + drainSimulation work point = go + where + go :: [Int] -> ST s [Int] + go !acc = do + packed <- popGrowableOr noIndex work + if packed == noIndex + then pure acc + else do + let !directed = fromIntegral packed + fixed <- isFixedEdge directed + if fixed + then do + from <- edgeOriginPoint mutable directed + to <- edgeOriginPoint mutable (reverseIndex directed) + if inDiametralCircle from to point + then go (directed `quot` 2 : acc) + else go acc + else do + let !twin = reverseIndex directed + acrossPrevious <- readPrevious mutable twin + opposite <- readOrigin mutable acrossPrevious + from <- edgeOriginPoint mutable directed + to <- pointAt mutable =<< readOrigin mutable twin + across <- pointAt mutable opposite + if inCircle to from across point == GT + then do + acrossNext <- readNext mutable twin + pushChargedWork work acrossNext + pushChargedWork work acrossPrevious + go acc + else go acc + + -- A cavity the fan commit cannot take: a degenerate or barrier-bent + -- boundary, a pinched boundary walk, or a duplicate site. The located site + -- commits through the ordinary split-and-legalize path instead; the + -- recorded cavity is simply abandoned. + commitFlipCandidate :: Workspace s -> Point -> MutableLocation -> ST s (Either BuildError Int) + commitFlipCandidate workspace@Workspace{wsQueue, wsExcluded} point site = do + let !canonical = canonicalPoint point + vertex <- appendVertex mutable canonical (makeVertex canonical) + splitSides <- case site of + MutableOnEdge edge + | refineExcludeOuterFaces parameters -> do + own <- readFace mutable edge + let !inner = if own == 0 then reverseIndex edge else edge + leftFace <- readFace mutable inner + rightFace <- readFace mutable (reverseIndex inner) + leftExcluded <- MUV.unsafeRead wsExcluded leftFace + rightExcluded <- sideExcluded wsExcluded (reverseIndex inner) + faceBase <- faceCount mutable + pure (Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase)) + _ -> pure Nothing + inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex site + case inserted of + Left failure -> pure (Left failure) + Right () -> do + addCounter operation CounterSteinerPoints 1 + admitStar workspace vertex + case splitSides of + Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase) -> + inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase + Nothing -> pure () + forEachStarFace vertex $ \starFace -> do + skip <- MUV.unsafeRead wsExcluded starFace + unless skip $ pushFace wsQueue starFace + pure (Right 1) + + -- Commit a clean cavity by fanning its boundary to the new vertex. The + -- recorded cavity faces and internal pairs are recycled into fan faces and + -- spokes; exactly two faces and three edge pairs are appended, whatever the + -- cavity's size. Any boundary that is not a simple, strictly-visible cycle + -- falls back to the split-and-legalize commit: that is the degenerate and + -- the barrier-bent case, never an error. + commitCavity :: Workspace s -> Point -> MutableLocation -> Bool -> ST s (Either BuildError Int) + commitCavity workspace@Workspace{wsCavityFaces, wsCavityInternal, wsCavityBoundary} point site visible = do + boundaryCount <- growableLength wsCavityBoundary + cavityFaceCount <- growableLength wsCavityFaces + internalCount <- growableLength wsCavityInternal + chained <- + if visible && boundaryCount == cavityFaceCount + 2 && boundaryCount == internalCount + 3 + then chainBoundary workspace boundaryCount + else pure False + if chained + then fanCommit workspace point boundaryCount cavityFaceCount internalCount + else commitFlipCandidate workspace point site + + -- Order the recorded boundary edges into the cycle they form, starting each + -- successor by rotating around the current edge's destination. The records + -- agree with a simple cycle only when the walk closes after exactly the + -- recorded count and meets no boundary vertex twice; anything else is the + -- pinched case the fan cannot take. + chainBoundary :: Workspace s -> Int -> ST s Bool + chainBoundary Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityVertexMarks, wsCavityBoundary, wsCavityChain} count = do + epoch <- readSTRef wsCavityEpoch + budget <- directedEdgeCount mutable + start <- fromIntegral <$> readGrowable wsCavityBoundary 0 + clearGrowable wsCavityChain + pushGrowable wsCavityChain (packIndex start) + walk epoch (budget + 2) start start (count - 1) + where + walk :: Word32 -> Int -> Int -> Int -> Int -> ST s Bool + walk epoch budget start current remaining = do + destination <- readOrigin mutable (reverseIndex current) + seen <- MUV.unsafeRead wsCavityVertexMarks destination + if seen == epoch + then pure False + else do + MUV.unsafeWrite wsCavityVertexMarks destination epoch + successor <- nextBoundaryEdge epoch budget current + if remaining == 0 + then pure (successor == start) + else + if successor == start + then pure False + else do + pushGrowable wsCavityChain (packIndex successor) + walk epoch budget start successor (remaining - 1) + + nextBoundaryEdge :: Word32 -> Int -> Int -> ST s Int + nextBoundaryEdge epoch budget edge = do + first <- readNext mutable edge + rotate first budget + where + rotate candidate !remaining + | remaining <= 0 = pure candidate + | otherwise = do + adjacent <- readFace mutable candidate + markedHere <- (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks adjacent + across <- readFace mutable (reverseIndex candidate) + markedAcross <- (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks across + if markedHere && not markedAcross + then pure candidate + else do + following <- readNext mutable (reverseIndex candidate) + rotate following (remaining - 1) + + fanCommit :: Workspace s -> Point -> Int -> Int -> Int -> ST s (Either BuildError Int) + fanCommit workspace@Workspace{wsQueue, wsExcluded, wsCavityFaces, wsCavityInternal, wsCavityCocircular, wsCavityChain} point boundaryCount cavityFaceCount internalCount = do + capacity <- ensureCellCapacity mutable (boundaryCount - internalCount) (boundaryCount - cavityFaceCount) + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> fanCommitWithCapacity + where + fanCommitWithCapacity = do + let !canonical = canonicalPoint point + vertex <- appendVertex mutable canonical (makeVertex canonical) + faceBase <- addFaceBlock mutable (boundaryCount - cavityFaceCount) + edgeBase <- addEdgeBlock mutable (boundaryCount - internalCount) + firstPair <- fanPair edgeBase 0 + let spoke :: Int -> Int -> ST s () + spoke !index !pair + | index >= boundaryCount = pure () + | otherwise = do + boundaryEdge <- fromIntegral <$> readGrowable wsCavityChain index + face <- fanFace faceBase index + nextPair <- + if index + 1 >= boundaryCount + then pure firstPair + else fanPair edgeBase (index + 1) + origin <- readOrigin mutable boundaryEdge + writeOrigin mutable (2 * pair) origin + writeOrigin mutable (2 * pair + 1) vertex + setCycle3 mutable face boundaryEdge (2 * nextPair) (2 * pair + 1) + writeVertexOut mutable origin boundaryEdge + -- 'fanFace' and 'fanPair' hand back the cavity's own faces and + -- interior edges before they hand out new ones. A recycled slot + -- is given a spoke to the Steiner vertex and a triangle that did + -- not exist, so whatever the cavity element it displaced was + -- labelled with does not survive. + resetEdgeData mutable pair + resetFaceData mutable face + spoke (index + 1) nextPair + spoke 0 firstPair + markConnected mutable vertex (2 * firstPair + 1) + addCounter operation CounterSteinerPoints 1 + admitStar workspace vertex + -- Exactly-cocircular boundary quads are legal ties for the flip + -- commit but not for a static boundary. Only those edges are drained: + -- the flood already decided every other boundary edge's quad, so a + -- full shouldFlip pass would ask again what it already answered. + cocircular <- growableLength wsCavityCocircular + when (cocircular > 0) $ do + ties <- traverse (\index -> fromIntegral <$> readGrowable wsCavityCocircular index) [0 .. cocircular - 1] + legalizeEdges mutable operation ties + let offer :: Int -> ST s () + offer !index + | index >= boundaryCount = pure () + | otherwise = do + face <- fanFace faceBase index + skip <- MUV.unsafeRead wsExcluded face + unless skip $ pushFace wsQueue face + offer (index + 1) + offer 0 + pure (Right 1) + + fanFace :: Int -> Int -> ST s Int + fanFace faceBase index + | index < cavityFaceCount = fromIntegral <$> readGrowable wsCavityFaces index + | otherwise = pure (faceBase + (index - cavityFaceCount)) + + fanPair :: Int -> Int -> ST s Int + fanPair edgeBase index + | index < internalCount = fromIntegral <$> readGrowable wsCavityInternal index + | otherwise = pure ((edgeBase + 2 * (index - internalCount)) `quot` 2) + + -- A candidate outside the hull (only reachable when the hull is not + -- preserved) preflights against the whole visible hull chain: the + -- prospective cavity reaches the hull, so the chain edges are exactly the + -- fixed edges the insertion would meet. + attemptOutside :: Workspace s -> Int -> Point -> Int -> ST s (Either BuildError Int) + attemptOutside workspace@Workspace{wsQueue, wsExcluded, wsForcedSplits, wsCavityWork} face point edge = do + chain <- visibleChain edge point + clearGrowable wsCavityWork + forM_ chain $ \hull -> do + pushChargedWork wsCavityWork hull + let !inner = reverseIndex hull + innerFace <- readFace mutable inner + when (innerFace /= 0) $ do + next <- readNext mutable inner + previous <- readPrevious mutable inner + pushChargedWork wsCavityWork next + pushChargedWork wsCavityWork previous + encroached <- drainSimulation wsCavityWork point [] + if not (null encroached) + then do + pushable <- filterM splittablePair encroached + forM_ pushable $ \pair -> pushGrowable wsForcedSplits (packIndex pair) + unless (null pushable) $ pushFace wsQueue face + pure (Right 0) + else do + let !canonical = canonicalPoint point + vertex <- appendVertex mutable canonical (makeVertex canonical) + inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex (MutableOutsideHull edge) + case inserted of + Left failure -> pure (Left failure) + Right () -> do + addCounter operation CounterSteinerPoints 1 + admitStar workspace vertex + when (refineExcludeOuterFaces parameters) $ do + seedCount <- newSTRef 0 + forEachStarFace vertex $ \starFace -> do + MUV.unsafeWrite wsExcluded starFace True + count <- readSTRef seedCount + writeScratch operation count starFace + writeSTRef seedCount (count + 1) + count <- readSTRef seedCount + propagateExcluded wsExcluded count + forEachStarFace vertex $ \starFace -> do + skip <- MUV.unsafeRead wsExcluded starFace + unless skip $ pushFace wsQueue starFace + forEachStarFace vertex $ \starFace -> do + (e0, e1, e2) <- faceEdges mutable starFace + forM_ [e0, e1, e2] $ \directed -> do + fixed <- isFixedEdge directed + when fixed $ pushEncroachment workspace (directed `quot` 2) + pure (Right 1) + + -- The maximal run of outer-cycle edges visible from the candidate, centred + -- on the edge location reported. Bounded by the hull length. + visibleChain :: Int -> Point -> ST s [Int] + visibleChain edge point = do + halfEdges <- directedEdgeCount mutable + left <- expand (readPrevious mutable) (halfEdges + 1) edge + right <- expand (readNext mutable) (halfEdges + 1) edge + walk left right (halfEdges + 1) [] + where + expand :: (Int -> ST s Int) -> Int -> Int -> ST s Int + expand step !budget !current + | budget <= 0 = pure current + | otherwise = do + candidate <- step current + if candidate == edge + then pure current + else do + from <- edgeOriginPoint mutable candidate + to <- edgeOriginPoint mutable (reverseIndex candidate) + if orient2d from to point == GT + then expand step (budget - 1) candidate + else pure current + + walk :: Int -> Int -> Int -> [Int] -> ST s [Int] + walk !current !end !budget !acc + | budget <= 0 = pure acc + | current == end = pure (current : acc) + | otherwise = do + following <- readNext mutable current + walk following end (budget - 1) (current : acc) + + -- New faces outside the hull sit at barrier depth zero; whatever they now + -- reach without crossing a constraint joined the outer region with them. + propagateExcluded :: MUV.MVector s Bool -> Int -> ST s () + propagateExcluded excluded = drain + where + drain :: Int -> ST s () + drain !count + | count <= 0 = pure () + | otherwise = do + face <- readScratch operation (count - 1) + (e0, e1, e2) <- faceEdges mutable face + next <- spread (count - 1) e0 >>= (`spread` e1) >>= (`spread` e2) + drain next + + spread :: Int -> Int -> ST s Int + spread !count !directed = do + protected <- readConstraint mutable directed + if protected + then pure count + else do + adjacent <- readFace mutable (reverseIndex directed) + if adjacent == 0 + then pure count + else do + already <- MUV.unsafeRead excluded adjacent + if already + then pure count + else do + MUV.unsafeWrite excluded adjacent True + writeScratch operation count adjacent + pure (count + 1) + + -- A queued fixed edge against the vertices currently opposite it, from each + -- non-excluded side. A stale candidate simply answers for the subsegment + -- its handle now names, which is the edge the queue cares about. + checkEncroachment :: Workspace s -> Int -> ST s (Either BuildError Bool) + checkEncroachment workspace@Workspace{wsExcluded} pair = do + let !directed = 2 * pair + first <- sideEncroaches wsExcluded directed + encroached <- + if first + then pure True + else sideEncroaches wsExcluded (reverseIndex directed) + if encroached + then + if isInterfacePair pair + then Left <$> interfaceCrossing workspace pair + else resolveSplit workspace pair + else pure (Right False) + where + sideEncroaches :: MUV.MVector s Bool -> Int -> ST s Bool + sideEncroaches excluded side = do + adjacent <- readFace mutable side + if adjacent == 0 + then pure False + else do + skip <- MUV.unsafeRead excluded adjacent + if skip + then pure False + else do + opposite <- readOrigin mutable =<< readPrevious mutable side + query <- pointAt mutable opposite + from <- edgeOriginPoint mutable side + to <- edgeOriginPoint mutable (reverseIndex side) + pure (inDiametralCircle from to query) + + -- Split a fixed edge. A first split lands at the midpoint; a subsegment + -- split rounds its offset to the nearest power of two toward the original + -- endpoint, so segments meeting at a small input angle stop encroaching + -- each other instead of subdividing forever. + resolveSplit :: Workspace s -> Int -> ST s (Either BuildError Bool) + resolveSplit workspace@Workspace{wsExcluded, wsSegmentOrigin} pair = do + let !directed = 2 * pair + protected <- readConstraint mutable directed + if isInterfacePair pair + then Left <$> interfaceCrossing workspace pair + else if refineKeepConstraintEdges parameters && protected + then pure (Right False) + else do + v0 <- readOrigin mutable directed + v1 <- readOrigin mutable (reverseIndex directed) + from <- pointAt mutable v0 + to <- pointAt mutable v1 + lineage0 <- MUV.unsafeRead wsSegmentOrigin (2 * v0) + lineage1 <- MUV.unsafeRead wsSegmentOrigin (2 * v1) + let !onSegment0 = lineage0 /= noIndex + !onSegment1 = lineage1 /= noIndex + !splitPoint = splitPosition onSegment0 onSegment1 from to + valid <- validateSplitPosition directed splitPoint + if not valid + then pure (Right False) + else do + -- Inheritance is read as structural face identities, never as + -- post-split handle membership: the split's own legalization can + -- flip seeded edges and relocate handles before any read, but it + -- cannot rename a face. The kept side faces and the append base + -- name the sides exactly. + own <- readFace mutable directed + let !inner = if own == 0 then reverseIndex directed else directed + leftFace <- readFace mutable inner + rightFace <- readFace mutable (reverseIndex inner) + leftExcluded <- MUV.unsafeRead wsExcluded leftFace + rightExcluded <- sideExcluded wsExcluded (reverseIndex inner) + faceBase <- faceCount mutable + let !canonical = canonicalPoint splitPoint + vertex <- appendVertex mutable canonical (makeVertex canonical) + inserted <- insertOnEdge @'ProbeOff mutable operation directed vertex + case inserted of + Left obstruction -> pure (Left obstruction) + Right () -> do + admitStar workspace vertex + if onSegment0 + then do + second <- MUV.unsafeRead wsSegmentOrigin (2 * v0 + 1) + writeSegmentOrigin wsSegmentOrigin vertex lineage0 second + else + if onSegment1 + then do + second <- MUV.unsafeRead wsSegmentOrigin (2 * v1 + 1) + writeSegmentOrigin wsSegmentOrigin vertex lineage1 second + else writeSegmentOrigin wsSegmentOrigin vertex (packIndex v0) (packIndex v1) + when (refineExcludeOuterFaces parameters) $ + inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase + addCounter operation CounterSteinerPoints 1 + pushStarAfterSplit workspace vertex + pure (Right True) + + splitPosition :: Bool -> Bool -> Point -> Point -> Point + splitPosition onSegment0 onSegment1 from to + | not onSegment0 && not onSegment1 = midpoint from to + | otherwise = + let !halfLength = sqrt (squaredDistance from to) * 0.5 + in if not (isFinite halfLength) || halfLength <= 0 + then midpoint from to + else + let !nearest = 2 ** fromIntegral (round (logBase 2 halfLength) :: Int) + !otherWeight = 0.5 * nearest / halfLength + !originalWeight = 1 - otherWeight + (!weight0, !weight1) = + if onSegment0 + then (otherWeight, originalWeight) + else (originalWeight, otherWeight) + Point fromX fromY = from + Point toX toY = to + in Point (fromX * weight0 + toX * weight1) (fromY * weight0 + toY * weight1) + + -- The split is refused when the constructed vertex would leave one of the + -- four new faces degenerate or clockwise — for an in-segment point that is + -- exactly the coincidence-with-an-endpoint-or-opposite case. + validateSplitPosition :: Int -> Point -> ST s Bool + validateSplitPosition directed splitPoint@(Point splitX splitY) + | validateCoordinate splitX /= Nothing = pure False + | validateCoordinate splitY /= Nothing = pure False + | otherwise = do + from <- edgeOriginPoint mutable directed + to <- edgeOriginPoint mutable (reverseIndex directed) + first <- sideKeepsOrientation directed from to + if not first + then pure False + else sideKeepsOrientation (reverseIndex directed) to from + where + sideKeepsOrientation :: Int -> Point -> Point -> ST s Bool + sideKeepsOrientation side sideFrom sideTo = do + adjacent <- readFace mutable side + if adjacent == 0 + then pure True + else do + opposite <- readOrigin mutable =<< readPrevious mutable side + oppositePoint <- pointAt mutable opposite + pure + ( orient2d sideFrom oppositePoint splitPoint == LT + && orient2d oppositePoint sideTo splitPoint == LT + ) + + sideExcluded :: MUV.MVector s Bool -> Int -> ST s Bool + sideExcluded excluded side = do + adjacent <- readFace mutable side + if adjacent == 0 then pure True else MUV.unsafeRead excluded adjacent + + -- A split keeps each side's classification. The faces a side holds + -- afterwards are the side face it kept and the face appended over it: + -- interior splits append two, boundary splits one, and both ids are + -- immune to the legalization that runs between the geometry and here. + inheritSplitExclusion :: MUV.MVector s Bool -> Int -> Bool -> Int -> Bool -> Int -> ST s () + inheritSplitExclusion excluded leftFace leftExcluded rightFace rightExcluded faceBase = do + writeSide leftExcluded leftFace + writeSide leftExcluded faceBase + when (rightFace /= 0) $ do + writeSide rightExcluded rightFace + writeSide rightExcluded (faceBase + 1) + where + writeSide :: Bool -> Int -> ST s () + writeSide status side = do + when (side /= 0) $ MUV.unsafeWrite excluded side status + + writeSegmentOrigin :: MUV.MVector s Word32 -> Int -> Word32 -> Word32 -> ST s () + writeSegmentOrigin lineage vertex first second = do + MUV.unsafeWrite lineage (2 * vertex) first + MUV.unsafeWrite lineage (2 * vertex + 1) second + + pushStarAfterSplit :: Workspace s -> Int -> ST s () + pushStarAfterSplit workspace@Workspace{wsQueue} vertex = + forEachStarFace vertex $ \starFace -> do + pushFace wsQueue starFace + (e0, e1, e2) <- faceEdges mutable starFace + forM_ [e0, e1, e2] $ \directed -> do + fixed <- isFixedEdge directed + when fixed $ pushEncroachment workspace (directed `quot` 2) + + -- Every interior face incident to a vertex, once. One rotation direction + -- covers a full interior star; a hull star additionally needs the other + -- direction from the starting edge. + forEachStarFace :: Int -> (Int -> ST s ()) -> ST s () + forEachStarFace vertex visit = do + start <- readVertexOut mutable vertex + when (start >= 0) $ do + wrapped <- rotate start start + unless wrapped (rotateBack start) + where + rotate :: Int -> Int -> ST s Bool + rotate !start !edge = do + adjacent <- readFace mutable edge + if adjacent == 0 + then pure False + else do + visit adjacent + next <- reverseIndex <$> readPrevious mutable edge + if next == start then pure True else rotate start next + + rotateBack :: Int -> ST s () + rotateBack edge = do + let !twin = reverseIndex edge + adjacent <- readFace mutable twin + when (adjacent /= 0) $ do + visit adjacent + next <- readNext mutable twin + rotateBack next + +-- | Whether a measurement is over its bound. A non-positive bound admits +-- nothing, which is what dividing by it used to say by returning an infinity +-- that then compared greater than one. +exceeds :: Double -> Double -> Bool +exceeds value bound = bound <= 0 || value > bound +{-# INLINE exceeds #-} + +-- | The bound the squared radius-edge ratio is compared against. Squaring is +-- monotone on the non-negative reals, so this asks the same question of the +-- squares that the unsquared bound asked of the lengths. +squareBound :: Double -> Double +squareBound bound + | bound <= 0 = bound + | otherwise = bound * bound +{-# INLINE squareBound #-} diff --git a/src-build/Moonlight/Triangulation/Internal/Transaction.hs b/src-build/Moonlight/Triangulation/Internal/Transaction.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Internal/Transaction.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} + +-- | The hidden publication boundary shared by persistent build-side edits. +-- +-- The rank-two action can observe one mutable section, but neither the section +-- nor any site witness can escape it. This is deliberately below the public +-- Session surface: a caller may compose public verbs, while an owner that has +-- just derived private evidence can interpret it without making that evidence +-- forgeable. +module Moonlight.Triangulation.Internal.Transaction + ( runTransaction + ) where + +import Control.Monad.ST (ST, runST) +import Moonlight.Triangulation.Dcel (numVertices) +import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel + , freezeTriangulation + , halfEdgeCapacity + , thawTriangulation + , thawTriangulationDense + ) +import Moonlight.Triangulation.Internal.OperationState + ( OperationState + , freezeBuildStats + , newOperationState + ) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (..)) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats) + +-- | Reserve, thaw, interpret, and publish one transaction. +-- +-- The physical section is selected by the operation that knows its edit +-- volume. Refusal short-circuits before freezing, so a partially rewritten +-- mutable mesh cannot escape as a published triangulation. +runTransaction + :: (BuildError -> failure) + -> TransactionShape + -> Triangulation mode vertex directed undirected face + -> Int + -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result)) + -> Either failure (result, Triangulation mode vertex directed undirected face, BuildStats) +runTransaction mapBuildFailure shape triangulation additional action = do + let !capacity = numVertices triangulation + max 0 additional + case ensureCapacity capacity of + Left failure -> Left (mapBuildFailure failure) + Right () -> pure () + runST $ do + mutable <- + case shape of + DenseTransaction -> thawTriangulationDense capacity triangulation + LocalTransaction -> thawTriangulation capacity triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + outcome <- action mutable operation + case outcome of + Left refusal -> pure (Left refusal) + Right value -> do + frozenOutcome <- freezeTriangulation mutable + case frozenOutcome of + Left obstruction -> pure (Left (mapBuildFailure obstruction)) + Right frozen -> do + stats <- freezeBuildStats operation + pure (Right (value, frozen, stats)) +{-# INLINE runTransaction #-} diff --git a/src-build/Moonlight/Triangulation/Refinement.hs b/src-build/Moonlight/Triangulation/Refinement.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Refinement.hs @@ -0,0 +1,448 @@ +{-# LANGUAGE NamedFieldPuns #-} + +-- | Ruppert refinement: Steiner insertion composed after a built mesh, never a +-- second kind of mesh. Parameters are reached through checked verbs rather than +-- a raw record, so an unrealizable quality bar is a refusal. +module Moonlight.Triangulation.Refinement + ( refine + , refineWithinDomain + , validateRefinementParameters + , withMinimumAngle + , radiusEdgeRatioForAngle + ) where + +import Control.Monad.ST (ST, runST) +import Data.Foldable (traverse_) +import qualified Data.IntSet as IntSet +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Moonlight.Triangulation.Dcel + ( faceVertices + , incidentFace + , isConstraintEdge + , numFaces + , numUndirectedEdges + , numVertices + , undirectedEndpoints + , vertexPoint + ) +import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth) +import Moonlight.Triangulation.Handles + ( FaceId (..) + , UndirectedEdgeId (..) + , directedPair + ) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) +import Moonlight.Triangulation.Internal.OperationState (freezeBuildStats, newOperationState) +import Moonlight.Triangulation.Internal.Refinement +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Validation (validateTopology) + +data RefinementExecution mode vertex directed undirected face = RefinementExecution + { refinementExecutionResult :: !(RefinementResult mode vertex directed undirected face) + , refinementExecutionVisitedFaces :: ![Int] + , refinementExecutionInterfaceBoundaryReads :: {-# UNPACK #-} !Int + , refinementExecutionBoundaryCrossingAttempts :: {-# UNPACK #-} !Int + } + +-- | The radius-edge ratio admitting a minimum angle, in degrees. +radiusEdgeRatioForAngle :: Double -> Either BuildError (Maybe Double) +radiusEdgeRatioForAngle degrees = + case classifyNonFinite degrees of + Just nonFinite -> + Left (RefinementMinimumAngleNotFinite nonFinite) + Nothing + | degrees < 0 || degrees > 60 -> + Left (RefinementMinimumAngleOutOfRange degrees) + | degrees == 0 -> Right Nothing + | otherwise -> + let ratio = 0.5 / sin (degrees * pi / 180) + in case classifyNonFinite ratio of + Just nonFinite -> + Left (RefinementMinimumAngleDerivedRatioNotFinite nonFinite) + Nothing -> Right (Just ratio) + +-- | Set the minimum angle, in degrees. +withMinimumAngle :: Double -> RefinementParameters -> Either BuildError (RefinementParameters) +withMinimumAngle degrees parameters = do + ratio <- radiusEdgeRatioForAngle degrees + pure parameters{refineMaxRadiusEdgeRatio = ratio} + +-- | Refine an unconstrained or constrained triangulation in the same finite +-- DCEL. The constructor supplies application payloads for Steiner vertices; +-- payloads annotate the requested geometric point and cannot reauthor it. +refine + :: (Point -> vertex) + -> RefinementParameters + -> Triangulation mode vertex directed undirected face + -> Either BuildError (RefinementResult mode vertex directed undirected face) +refine makeVertex parameters = + fmap refinementExecutionResult + . refineWithInitialSeed RefineEveryFace Nothing makeVertex parameters + +-- | 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. +mkRefinementDomain + :: Set.Set FaceId + -> Set.Set UndirectedEdgeId + -> Triangulation mode vertex directed undirected face + -> Either BuildError RefinementDomain +mkRefinementDomain permittedFaces interfaceEdges 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 + , refinementDomainInputFaces = + Map.fromAscList + [ (face, faceSignature triangulation face) + | raw <- [1 .. numFaces triangulation - 1] + , let face = FaceId (fromIntegral raw) + ] + , refinementDomainInputFaceCount = numFaces triangulation + , refinementDomainInputEdgeCount = numUndirectedEdges triangulation + } + where + totalEdges = numUndirectedEdges triangulation + validateInterfaceEdge edge@(UndirectedEdgeId raw) + | toInteger raw >= toInteger totalEdges = + Left (RefinementDomainInterfaceEdgeNotActive edge totalEdges) + | otherwise = Right (fromIntegral raw) + + expectedInterface permitted = + IntSet.fromList + [ pair + | pair <- [0 .. totalEdges - 1] + , let edge = UndirectedEdgeId (fromIntegral pair) + (forward, backward) = directedPair edge + FaceId forwardFace = incidentFace triangulation forward + FaceId backwardFace = incidentFace triangulation backward + forwardInner = forwardFace /= 0 + backwardInner = backwardFace /= 0 + forwardPermitted = IntSet.member (fromIntegral forwardFace) permitted + backwardPermitted = IntSet.member (fromIntegral backwardFace) permitted + , forwardInner && backwardInner && forwardPermitted /= backwardPermitted + ] + +-- | Refine exactly one checked local section. Interface edges are installed as +-- transaction-local legalization barriers and removed before publication; +-- every protected face signature is then compared with the input witness. +refineWithinDomain + :: (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 + validateDomainParameters parameters + domain <- mkRefinementDomain permittedFaces interfaceEdges triangulation + execution <- + refineWithInitialSeed + (RefineSeededFaces (refinementDomainPermittedFaces domain)) + (Just domain) + makeVertex + parameters + triangulation + let result = refinementExecutionResult execution + receipt = + buildRefinementReceipt + domain + triangulation + (refinedTriangulation result) + (refinementExecutionVisitedFaces execution) + (refinementExecutionInterfaceBoundaryReads execution) + (refinementExecutionBoundaryCrossingAttempts execution) + validateProtectedFaces domain triangulation (refinedTriangulation result) + case V.toList (refinementVisitedProtectedFaces receipt) of + protected : _ -> Left (RefinementDomainWouldRewriteProtectedFace protected) + [] -> + Right + RefinementDomainResult + { refinementDomainResult = result + , refinementDomainReceipt = receipt + } + +validateDomainParameters :: RefinementParameters -> Either BuildError () +validateDomainParameters parameters + | not (refinePreserveConvexHull parameters) = + Left RefinementDomainRequiresConvexHullPreservation + | not (refineKeepConstraintEdges parameters) = + Left RefinementDomainRequiresConstraintPreservation + | refineExcludeOuterFaces parameters = + Left RefinementDomainForbidsOuterFaceExclusion + | otherwise = Right () + +refineWithInitialSeed + :: RefinementInitialSeed + -> Maybe RefinementDomain + -> (Point -> vertex) + -> RefinementParameters + -> Triangulation mode vertex directed undirected face + -> Either BuildError (RefinementExecution mode vertex directed undirected face) +refineWithInitialSeed initialSeed domain makeVertex parameters triangulation = do + validateRefinementParameters parameters + case validateTopology triangulation of + violation : _ -> Left (RefinementInputTopologyInvalid violation) + [] -> pure () + let originalCount = numVertices triangulation + budget = max 0 (fromMaybe (10 * max 1 originalCount) (refineMaxAdditionalVertices parameters)) + maximumVerticesInteger = toInteger originalCount + toInteger budget + initialExcludedFaces = + if refineExcludeOuterFaces parameters + then + IntSet.fromList + [ fromIntegral raw + | FaceId raw <- + facesAtEvenBarrierDepth + triangulation + (isConstraintEdge triangulation) + ] + else IntSet.empty + let maximumVertices = + if maximumVerticesInteger > toInteger (maxBound :: Int) + then maxBound + else fromInteger maximumVerticesInteger + ensureCapacity maximumVertices + runST $ do + mutable <- + thawTriangulationDense + maximumVertices + triangulation + operation <- newOperationState (halfEdgeCapacity mutable) + installInterfaceBarriers mutable domain + outcome <- + refineMutable + makeVertex + mutable + operation + parameters + originalCount + initialExcludedFaces + initialSeed + domain + removeInterfaceBarriers mutable triangulation domain + case outcome of + Left failure -> pure (Left failure) + Right (complete, added, excluded, visited, interfaceBoundaryReads, boundaryCrossingAttempts) -> do + frozenOutcome <- freezeTriangulation mutable + case frozenOutcome of + Left obstruction -> pure (Left obstruction) + Right frozen -> do + stats <- freezeBuildStats operation + pure + ( Right + RefinementExecution + { refinementExecutionResult = + RefinementResult + { refinedTriangulation = frozen + , refinementStats = stats + , refinementAddedVertices = added + , refinementComplete = complete + , refinementExcludedFaces = V.fromList (map (FaceId . fromIntegral) excluded) + } + , refinementExecutionVisitedFaces = visited + , refinementExecutionInterfaceBoundaryReads = interfaceBoundaryReads + , refinementExecutionBoundaryCrossingAttempts = boundaryCrossingAttempts + } + ) + +installInterfaceBarriers + :: MutableDcel s vertex directed undirected face + -> Maybe RefinementDomain + -> ST s () +installInterfaceBarriers mutable = + traverse_ + (\pair -> setConstraint mutable (2 * pair) >> pure ()) + . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs) + +removeInterfaceBarriers + :: MutableDcel s vertex directed undirected face + -> Triangulation mode vertex directed undirected face + -> Maybe RefinementDomain + -> ST s () +removeInterfaceBarriers mutable input = + traverse_ + (\pair -> + let edge = UndirectedEdgeId (fromIntegral pair) + in if isConstraintEdge input edge + then pure () + else clearConstraint mutable (2 * pair) >> pure () + ) + . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs) + +validateProtectedFaces + :: RefinementDomain + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed undirected face + -> Either BuildError () +validateProtectedFaces domain before after = + traverse_ validateProtected protectedFaces + where + protectedFaces = + [ FaceId (fromIntegral face) + | face <- [1 .. refinementDomainInputFaceCount domain - 1] + , IntSet.notMember face (refinementDomainPermittedFaces domain) + ] + validateProtected face + | Map.lookup face (refinementDomainInputFaces domain) + == Just (faceSignature before face) + && Map.lookup face (refinementDomainInputFaces domain) + == Just (faceSignature after face) = Right () + | otherwise = Left (RefinementDomainProtectedFaceChanged face) + +faceSignature + :: Triangulation mode vertex directed undirected face + -> FaceId + -> [Point] +faceSignature triangulation = + sort . fmap (vertexPoint triangulation) . faceVertices triangulation + +type EdgeSignature = (Point, Point, [FaceId]) + +edgeSignature + :: Triangulation mode vertex directed undirected face + -> UndirectedEdgeId + -> EdgeSignature +edgeSignature triangulation edge = + (min fromPoint toPoint, max fromPoint toPoint, sort [forwardFace, backwardFace]) + where + (fromVertex, toVertex) = undirectedEndpoints triangulation edge + fromPoint = vertexPoint triangulation fromVertex + toPoint = vertexPoint triangulation toVertex + (forward, backward) = directedPair edge + forwardFace = incidentFace triangulation forward + backwardFace = incidentFace triangulation backward + +buildRefinementReceipt + :: RefinementDomain + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed undirected face + -> [Int] + -> Int + -> Int + -> RefinementReceipt +buildRefinementReceipt domain before after visited interfaceBoundaryReads boundaryCrossingAttempts = + RefinementReceipt + { refinementVisitedJoinFaces = V.fromList (fmap toFace visitedJoin) + , refinementVisitedProtectedFaces = V.fromList (fmap toFace visitedProtected) + , refinementCreatedFaces = + V.fromList + [ targetFace + | face <- [1 .. numFaces after - 1] + , let targetFace = toFace face + , face >= numFaces before + || faceSignature before targetFace /= faceSignature after targetFace + ] + , refinementTouchedEdges = V.fromList touched + , refinementRemovedEdges = V.fromList removed + , refinementInterfaceBoundaryReads = interfaceBoundaryReads + , refinementAttemptedBoundaryCrossings = boundaryCrossingAttempts + } + where + permitted = refinementDomainPermittedFaces domain + (visitedProtected, visitedJoin) = + foldr + (\face (protected, join) -> + if IntSet.member face permitted || face >= refinementDomainInputFaceCount domain + then (protected, face : join) + else (face : protected, join) + ) + ([], []) + visited + toFace = FaceId . fromIntegral + beforeEdges = numUndirectedEdges before + afterEdges = numUndirectedEdges after + touched = + [ edge + | raw <- [0 .. afterEdges - 1] + , let edge = UndirectedEdgeId (fromIntegral raw) + , raw >= beforeEdges || edgeSignature before edge /= edgeSignature after edge + ] + removed = + [ edge + | raw <- [0 .. beforeEdges - 1] + , let edge = UndirectedEdgeId (fromIntegral raw) + , raw >= afterEdges || edgeSignature before edge /= edgeSignature after edge + ] + +-- | Refuse outer or absent faces rather than silently treating an invalid +-- topology witness as an empty repair. Face zero is the outer face and has no +-- active refinement equation. +validateSeedFaces + :: Triangulation mode vertex directed undirected face + -> Set.Set FaceId + -> Either BuildError IntSet.IntSet +validateSeedFaces triangulation requested = + IntSet.fromList <$> traverse validateFace (Set.toAscList requested) + where + totalFaces = numFaces triangulation + + validateFace face@(FaceId raw) + | raw == 0 || toInteger raw >= toInteger totalFaces = + Left (RefinementSeedFaceNotActive face totalFaces) + | otherwise = Right (fromIntegral raw) + +-- | Refuse parameters no mesh can satisfy. +validateRefinementParameters :: RefinementParameters -> Either BuildError () +validateRefinementParameters RefinementParameters{refineMaxAdditionalVertices, refineMinArea, refineMaxArea, refineMaxRadiusEdgeRatio} = do + case refineMaxAdditionalVertices of + Just value + | value < 0 -> + Left (RefinementMaximumAdditionalVerticesNegative value) + _ -> Right () + validateOptionalRefinementParameter + RefinementMinimumAreaNotFinite + RefinementMinimumAreaNegative + (>= 0) + refineMinArea + validateOptionalRefinementParameter + RefinementMaximumAreaNotFinite + RefinementMaximumAreaNotPositive + (> 0) + refineMaxArea + validateOptionalRefinementParameter + RefinementMaximumRadiusEdgeRatioNotFinite + RefinementMaximumRadiusEdgeRatioNotPositive + (> 0) + refineMaxRadiusEdgeRatio + case (refineMinArea, refineMaxArea) of + (Just minimumArea, Just maximumArea) + | minimumArea > maximumArea -> + Left + ( RefinementMinimumAreaExceedsMaximum + minimumArea + maximumArea + ) + _ -> Right () + +validateOptionalRefinementParameter + :: (NonFiniteValue -> BuildError) + -> (Double -> BuildError) + -> (Double -> Bool) + -> Maybe Double + -> Either BuildError () +validateOptionalRefinementParameter nonFinite outsideRange predicate value = + case value of + Nothing -> Right () + Just number -> + case classifyNonFinite number of + Just nonFiniteValue -> + Left (nonFinite nonFiniteValue) + Nothing + | predicate number -> Right () + | otherwise -> + Left (outsideRange number) diff --git a/src-build/Moonlight/Triangulation/Removal.hs b/src-build/Moonlight/Triangulation/Removal.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Removal.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Persistent removal: one excision, published as its own triangulation. +module Moonlight.Triangulation.Removal + ( RemovalOutcome (..) + , RemovalResult (..) + , removeVertex + , locateAndRemove + ) where + +import Control.DeepSeq (NFData) +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Internal.Excision (RemovalOutcome (..)) +import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats, Point, queryPointValue) +import Moonlight.Triangulation.Math (validatePoint) +import Moonlight.Triangulation.Session (excise, withLocalSession) +import GHC.Generics (Generic) + +-- | One removal and its publication: the frozen triangulation, the outcome +-- record, and the operation's counters. The persistent entries publish all +-- three; a session publishes the outcome per call and the counters once. +data RemovalResult mode vertex directed undirected face = RemovalResult + { removalTriangulation :: !(Triangulation mode vertex directed undirected face) + , removalOutcome :: !(RemovalOutcome vertex) + , removalStats :: !BuildStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (RemovalResult mode vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (RemovalResult mode vertex directed undirected face) + +-- | Remove the vertex a handle names. The triangulation the caller passed in +-- still denotes the mesh it always did; the removal is in the returned one. +-- +-- This is a session over a single 'excise', which is what makes replacing a +-- fold of it with one session sound: the two agree on every mesh, and differ +-- only in how many of the intermediate ones are published. A fold publishes +-- @k@ meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays +-- one thaw and runs in O(k·deg). +removeVertex + :: Triangulation mode vertex directed undirected face + -> VertexId + -> Either BuildError (RemovalResult mode vertex directed undirected face) +removeVertex triangulation requested = do + (outcome, frozen, stats) <- withLocalSession triangulation 0 (excise requested) + pure + RemovalResult + { removalTriangulation = frozen + , removalOutcome = outcome + , removalStats = stats + } + +-- | Resolve a point through the mesh's exact derived identity section, then +-- remove the handle it proves. A hash is only a rejection filter; the lookup +-- confirms both authoritative coordinate planes before the topology is +-- opened. A point that sites no vertex answers 'Nothing' without publishing a +-- cosmetically different mesh. +-- +-- See 'removeVertex' on the cost of folding this rather than opening one +-- session over @removeAt@. +locateAndRemove + :: Triangulation mode vertex directed undirected face + -> Point + -> Either BuildError (Maybe (RemovalResult mode vertex directed undirected face)) +locateAndRemove triangulation point = do + queryPoint <- validatePoint Nothing point + case + lookupPointIndex + (triPointX triangulation) + (triPointY triangulation) + (triPointIndex triangulation) + -- Stored coordinates are canonical; the query must be too, or any + -- coordinate whose canonicalization exceeds signed zero misses a vertex + -- the session verbs would find. + (queryPointValue queryPoint) of + Nothing -> Right Nothing + Just rawVertex -> + Just <$> removeVertex triangulation (VertexId (fromIntegral rawVertex)) + +-- Polymorphic entries consumed from other packages; without exposed +-- unfoldings they run boxed through an imported boundary. diff --git a/src-build/Moonlight/Triangulation/Session.hs b/src-build/Moonlight/Triangulation/Session.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/Session.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE BangPatterns #-} + +-- | One owned editing transaction over a triangulation: thaw once, edit, publish once. +module Moonlight.Triangulation.Session + ( Session + , withSession + , withLocalSession + , insertVertex + , insertVertexAt + , insertVertexAtNear + , insertVertexAtCombining + , removeAt + , removeAtNear + , removeManyAt + , removeManyAtNear + , excise + , refuse + ) where + +import Control.Monad.ST (ST) +import Data.Bits (xor) +import qualified Data.Vector as V +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Insertion (insertPointCombining) +import Moonlight.Triangulation.Internal.Excision (RemovalOutcome, removeMutable) +import Moonlight.Triangulation.Internal.Location (MutableLocation (..), locateMutable) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.OperationState (OperationState) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (..)) +import Moonlight.Triangulation.Math (canonicalPoint) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Transaction (runTransaction) +import Moonlight.Triangulation.Internal.Types + +-- | An edit sequence against one thawed mesh. +-- +-- The two published entry points before this one — an insertion session and a +-- removal session — each handed the caller a function and could not compose, +-- so a caller who wanted to remove a hundred vertices and insert fifty thawed +-- twice and paid the O(n) publication a session exists to delete. They are the +-- same transaction; only the verb differed. This is that transaction, and the +-- verbs are its primitives. +-- +-- The public session algebra and the private exact-site single-insertion +-- interpreter cross the same hidden transaction boundary. Sessions provide +-- composition; the private interpreter reaches that boundary only with +-- evidence from the immediately preceding frozen read. A fold of persistent +-- verbs and a session over the same verbs therefore differ only in which +-- intermediate meshes they publish. +-- +-- Refusal short-circuits: the first 'BuildError' abandons the rest of the +-- sequence, and 'withSession' freezes nothing. A partly edited arena cannot +-- reach a caller as a published triangulation. +newtype Session s vertex directed undirected face a = Session + { stepSession + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> ST s (Either BuildError a) + } + +instance Functor (Session s vertex directed undirected face) where + fmap f (Session step) = Session $ \mesh operation -> fmap (fmap f) (step mesh operation) + {-# INLINE fmap #-} + +instance Applicative (Session s vertex directed undirected face) where + pure a = Session $ \_ _ -> pure (Right a) + {-# INLINE pure #-} + Session left <*> Session right = Session $ \mesh operation -> do + outcome <- left mesh operation + case outcome of + Left refusal -> pure (Left refusal) + Right f -> fmap (fmap f) (right mesh operation) + {-# INLINE (<*>) #-} + +instance Monad (Session s vertex directed undirected face) where + Session step >>= f = Session $ \mesh operation -> do + outcome <- step mesh operation + case outcome of + Left refusal -> pure (Left refusal) + Right a -> stepSession (f a) mesh operation + {-# INLINE (>>=) #-} + +-- | Abandon the transaction. Nothing is published. +refuse :: BuildError -> Session s vertex directed undirected face a +refuse failure = Session $ \_ _ -> pure (Left failure) +{-# INLINE refuse #-} + +-- | Insert a vertex, answering the handle it was given. A point already +-- present keeps its handle and takes the new payload. +insertVertex + :: HasPosition vertex + => vertex + -> Session s vertex directed undirected face VertexId +insertVertex payload = Session $ \mesh operation -> + fmap + (fmap (VertexId . fromIntegral . fst)) + (insertPointCombining (\_ replacement -> replacement) Nothing mesh operation (position payload) payload) + +-- | Insert at a stated point, answering the handle and whether a site was +-- created. 'insertVertex' is this with the point read out of the payload; a +-- caller that computed the point — a constraint split, a Steiner refinement — +-- states it rather than round-tripping through 'HasPosition'. +insertVertexAt + :: Point + -> vertex + -> Session s vertex directed undirected face (VertexId, InsertionDisposition) +insertVertexAt point payload = Session $ \mesh operation -> + fmap + (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition))) + (insertPointCombining (\_ replacement -> replacement) Nothing mesh operation point payload) + +-- | 'insertVertexAt' with the walk seeded at a face the caller vouches for -- +-- typically the face a locate on the just-published value settled on, which +-- is exact on the mesh this transaction thawed. The seed is a hint, not an +-- authority: an out-of-range face degrades to the unhinted descent, and the +-- walk corrects. +insertVertexAtNear + :: FaceId + -> Point + -> vertex + -> Session s vertex directed undirected face (VertexId, InsertionDisposition) +insertVertexAtNear (FaceId rawSeed) point payload = Session $ \mesh operation -> + fmap + (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition))) + (insertPointCombining + (\_ replacement -> replacement) + (Just (fromIntegral rawSeed)) + mesh + operation + point + 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 + :: (vertex -> vertex -> vertex) + -> Point + -> vertex + -> Session s vertex directed undirected face (VertexId, InsertionDisposition) +insertVertexAtCombining combine point payload = Session $ \mesh operation -> + fmap + (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition))) + (insertPointCombining combine Nothing mesh operation point payload) + +-- | Remove the vertex standing at a point, answering 'Nothing' when no vertex +-- stands there. +-- +-- Keyed by position rather than by handle because removal swap-compacts the +-- arenas: every outstanding t'VertexId' may relocate, and over a sequence of +-- removals a handle-keyed verb would force the caller to thread every +-- relocation by hand. A position is invariant under compaction. The relocation +-- is still reported, in the 'RemovalOutcome', for callers holding handles. +-- The question is an identity question -- which vertex stands at this exact +-- position. A session that has committed to identity work ('removeManyAt', +-- 'excise') answers it through the identity index in O(1); one that has not +-- answers it with a single walk, because a published index is a lazy rebuild +-- and forcing a whole-mesh build to answer one question is the wrong trade. +removeAt + :: Point + -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex)) +removeAt point = Session $ \mesh operation -> do + indexed <- identityIndexActive mesh + if indexed + then removeIndexed mesh operation point + else walkAndRemove mesh operation Nothing point + +removeIndexed + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Point + -> ST s (Either BuildError (Maybe (RemovalOutcome vertex))) +removeIndexed mesh operation point = do + located <- lookupPointVertex mesh point + case located of + Just vertex -> fmap (fmap Just) (removeMutable mesh operation vertex) + Nothing -> pure (Right Nothing) + +-- | Remove the vertex standing at a point, starting from a caller-supplied +-- near vertex -- a locate hint from an external structure such as the +-- Delaunay hierarchy. The guess is a hint, not an authority: a slot renamed +-- by swap-compaction or out of range degrades to a walk hinted by the +-- guess's incident face, and the walk corrects. +removeAtNear + :: VertexId + -> Point + -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex)) +removeAtNear (VertexId rawGuess) point = Session $ \mesh operation -> do + indexed <- identityIndexActive mesh + let !guess = fromIntegral rawGuess + !query = canonicalPoint point + if indexed + then removeIndexed mesh operation query + else do + vertices <- pointCount mesh + if guess < 0 || guess >= vertices + then walkAndRemove mesh operation Nothing query + else do + stored <- pointAt mesh guess + if stored == query + then fmap (fmap Just) (removeMutable mesh operation guess) + else do + outgoing <- readVertexOut mesh guess + let interiorFace edge fallback = do + face <- readFace mesh edge + if face > 0 then pure (Just face) else fallback + hint <- + if outgoing < 0 + then pure Nothing + else interiorFace outgoing (interiorFace (outgoing `xor` 1) (pure Nothing)) + walkAndRemove mesh operation hint query + +walkAndRemove + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Maybe Int + -> Point + -> ST s (Either BuildError (Maybe (RemovalOutcome vertex))) +walkAndRemove mesh operation hint query = do + located <- locateMutable mesh operation hint query + case located of + Left obstruction -> pure (Left obstruction) + Right (MutableOnVertex vertex) -> + fmap (fmap Just) (removeMutable mesh operation vertex) + Right _ -> pure (Right Nothing) + +-- | Remove the vertex standing at each point, answering per point in order. +-- One session-level decision buys the locate strategy: few removals walk the +-- mesh, each a ~O(sqrt n) descent, while many seed the existing mutable +-- open-addressed identity section once from coordinate authority and answer +-- each question by hash. The guard squares the crossover to avoid a root. +removeManyAt + :: V.Vector (Point) + -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex))) +removeManyAt points = + withBatchIdentityForLoad (V.length points) (V.mapM removeAt points) + +-- | Install the mutable identity section only around a dense removal program. +-- It is a local section over the coordinate arenas, not a new published cache: +-- on every result path it is discarded and freeze glues a lazy @PointIndex@ +-- back from those arenas. Sparse loads retain the existing locate walk. +withBatchIdentityForLoad + :: Int + -> Session s vertex directed undirected face result + -> Session s vertex directed undirected face result +withBatchIdentityForLoad count (Session action) = Session $ \mesh operation -> do + vertices <- pointCount mesh + if count * count > 10 * vertices + then do + activated <- activateBatchPointIndex mesh + case activated of + Left failure -> pure (Left failure) + Right () -> do + outcome <- action mesh operation + discardBatchPointIndex mesh + pure outcome + else action mesh operation + +identityCommitted :: Session s vertex directed undirected face Bool +identityCommitted = Session $ \mesh _ -> fmap Right (identityIndexActive mesh) +{-# INLINE identityCommitted #-} + +-- | 'removeManyAt' with a near vertex per point where the caller has one — a +-- hierarchy sample, a previous answer. The batch commits to its load first, +-- so the identity-index crossover decides the regime once: a dense batch buys +-- its local mutable table and never examines a guess, a sparse one walks from +-- its guesses. +removeManyAtNear + :: V.Vector (Maybe VertexId) + -> V.Vector (Point) + -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex))) +removeManyAtNear guesses points = + withBatchIdentityForLoad (V.length points) $ do + indexed <- identityCommitted + if indexed + then V.mapM removeAt points + else + V.zipWithM + (\guess point -> maybe (removeAt point) (\vertex -> removeAtNear vertex point) guess) + guesses + points + +-- | Remove a stated vertex. Sound only while the handle still denotes what the +-- caller means: the first removal in a sequence compacts the arenas, so a +-- handle taken before it may name a different vertex after. @removeAt@ is the +-- verb for a sequence; this is the verb for a handle the caller has just been +-- given and has not yet let a removal run underneath. +excise + :: VertexId + -> Session s vertex directed undirected face (RemovalOutcome vertex) +excise requested@(VertexId raw) = Session $ \mesh operation -> do + vertices <- pointCount mesh + if toInteger raw >= toInteger vertices + then pure (Left (RemovalVertexOutOfRange requested vertices)) + else do + activatePointIndex mesh + removeMutable mesh operation (fromIntegral raw) + +-- | Run an edit sequence: thaw once, edit, freeze once, and publish the +-- counters the whole transaction charged. +-- +-- The reservation is taken for the peak vertex count, so it is the insertion +-- count that sizes it; removals only shrink the mesh and a mixed sequence +-- cannot exceed the peak an insert-only sequence of the same count reaches. +-- +-- The session cannot escape its callback: the state token is universally +-- quantified, so the mesh it addresses is dead by the time the frozen +-- triangulation is returned. +withSession + :: forall mode vertex directed undirected face result + . Triangulation mode vertex directed undirected face + -> Int + -> (forall s. Session s vertex directed undirected face result) + -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats) +withSession triangulation additional session = + runTransaction + id + DenseTransaction + triangulation + additional + (\mesh operation -> stepSession session mesh operation) + +-- | The local-edit transaction: copy-on-write pages, publication proportional +-- to what the edit dirtied. This is the section for singleton persistent +-- verbs, whose one edit cannot amortize a dense copy of the whole mesh. +withLocalSession + :: forall mode vertex directed undirected face result + . Triangulation mode vertex directed undirected face + -> Int + -> (forall s. Session s vertex directed undirected face result) + -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats) +withLocalSession triangulation additional session = + runTransaction + id + LocalTransaction + triangulation + additional + (\mesh operation -> stepSession session mesh operation) diff --git a/src-build/Moonlight/Triangulation/SetAlgebra.hs b/src-build/Moonlight/Triangulation/SetAlgebra.hs new file mode 100644 --- /dev/null +++ b/src-build/Moonlight/Triangulation/SetAlgebra.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DataKinds #-} + +-- | Finite-set operations on unconstrained meshes. Every +-- constructing operation returns the finite-arena obstruction instead of +-- laundering it through a partial class instance. +module Moonlight.Triangulation.SetAlgebra + ( siteRelation + , union + , unions + , intersection + , intersectionWith + , difference + , symmetricDifference + ) where + +import Data.Foldable (traverse_) +import Data.Maybe (isJust) +import qualified Data.Vector as V +import Moonlight.Triangulation.BulkLoad (empty) +import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint) +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 + , siteSetFromTriangulation + , siteSetIntersectionWith + , siteSetPoints + , siteRelationFromTriangulations + , siteSetSymmetricDifferenceFromTriangulations + , siteSupportFromTriangulation + ) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types + ( BuildError (PointLocationFailed) + , ConstraintMode (Unconstrained) + , InsertionDisposition (..) + , Point + , SiteRelation (..) + , unitElementDefaults + ) +import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice) +import Moonlight.Triangulation.Session + ( Session + , insertVertexAt + , refuse + , removeAtNear + , removeManyAt + , withLocalSession + ) + +-- | Exact relation between two triangulations' coordinate supports. Vertex +-- annotations and topology-element payloads are observations over the support; +-- none participates in this classification. +siteRelation + :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace + -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace + -> SiteRelation +siteRelation left right = + siteRelationFromTriangulations left right +{-# INLINE siteRelation #-} + +-- | A valid Delaunay representative of both site sets. Use 'canonicalize' +-- when construction-independent dense numbering is required. +union + :: JoinSemilattice annotation + => Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +union = joinNormalForm + +-- | @union@ over a list, folded as a balanced tournament. +unions + :: JoinSemilattice annotation + => [Triangulation 'Unconstrained annotation () () ()] + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +unions = joinBalanced + +-- | The sites both meshes hold. +intersection + :: Triangulation 'Unconstrained () () () () + -> Triangulation 'Unconstrained () () () () + -> Either BuildError (Triangulation 'Unconstrained () () () ()) +intersection left right + | numVertices left == 0 = Right left + | numVertices right == 0 = Right right + | otherwise = + case siteRelationFromTriangulations left right of + EqualSites -> Right left + LeftProperSubset -> Right left + RightProperSubset -> Right right + DisjointSites -> Right (empty unitElementDefaults) + PartialOverlap overlap -> intersectPartialOverlap overlap + where + leftSites = siteSupportFromTriangulation left + rightSites = siteSupportFromTriangulation right + rebuildIntersection = intersectionWith (\_ _ -> ()) left right + intersectPartialOverlap overlap + | leftRemoved <= rightRemoved + , removalDeltaIsEligible leftRemoved overlap = + removeExpectedFrom left (siteSetPoints (siteSetDifference leftSites rightSites)) + | rightRemoved < leftRemoved + , removalDeltaIsEligible rightRemoved overlap = + removeExpectedFrom right (siteSetPoints (siteSetDifference rightSites leftSites)) + | otherwise = rebuildIntersection + where + leftRemoved = numVertices left - overlap + rightRemoved = numVertices right - overlap +{-# INLINE intersection #-} + +-- | The sites both meshes hold, with the result annotation computed from the +-- left and right annotations at that exact coordinate. The combiner is called +-- only for shared sites, in left-then-right order; geometry remains the sole +-- authority for membership. @intersectionWith const left mask@ is the +-- annotation-preserving restriction of @left@ to @mask@'s support. +intersectionWith + :: (leftAnnotation -> rightAnnotation -> annotation) + -> Triangulation 'Unconstrained leftAnnotation () () () + -> Triangulation 'Unconstrained rightAnnotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +intersectionWith combine left right = + rebuildCanonicalSiteSet + ( siteSetIntersectionWith + combine + (siteSetFromTriangulation left) + (siteSetFromTriangulation right) + ) +{-# INLINE intersectionWith #-} + +-- | The left's sites, less the right's. +difference + :: Triangulation 'Unconstrained leftAnnotation () () () + -> Triangulation 'Unconstrained rightAnnotation () () () + -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ()) +difference left right + | numVertices left == 0 || numVertices right == 0 = Right left + | numVertices right < numVertices left + , removalDeltaIsEligible (numVertices right) (numVertices left - numVertices right) = + removeAvailableFrom left (V.fromList (fmap (vertexPoint right) (vertices right))) + | otherwise = + rebuildCanonicalSiteSet + ( siteSetDifference + (siteSetFromTriangulation left) + (siteSupportFromTriangulation right) + ) +{-# INLINE difference #-} + +-- | The sites exactly one mesh holds. +symmetricDifference + :: Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +symmetricDifference left right + | numVertices left == 0 = Right right + | numVertices right == 0 = Right left + | numVertices right < numVertices left + , toggleDeltaIsEligible (numVertices right) (numVertices left - numVertices right) = + toggleIncoming left right + | numVertices left < numVertices right + , toggleDeltaIsEligible (numVertices left) (numVertices right - numVertices left) = + toggleIncoming right left + | otherwise = + siteSetSymmetricDifferenceFromTriangulations left right + >>= rebuildCanonicalSiteSet +{-# INLINE symmetricDifference #-} + +removalDeltaIsEligible :: Int -> Int -> Bool +removalDeltaIsEligible removed survivors = removed <= survivors `quot` 128 +{-# INLINE removalDeltaIsEligible #-} + +toggleDeltaIsEligible :: Int -> Int -> Bool +toggleDeltaIsEligible incoming residentRemainder = incoming <= residentRemainder `quot` 128 +{-# INLINE toggleDeltaIsEligible #-} + +removeAvailableFrom + :: Triangulation 'Unconstrained annotation () () () + -> V.Vector (Point) + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +removeAvailableFrom triangulation points = + fmap published + (withLocalSession triangulation 0 (V.any isJust <$> removeManyAt points)) + where + published (removed, revised, _) = if removed then revised else triangulation +{-# INLINE removeAvailableFrom #-} + +removeExpectedFrom + :: Triangulation 'Unconstrained annotation () () () + -> V.Vector (Point) + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +removeExpectedFrom triangulation points = + fmap (\(_, revised, _) -> revised) + (withLocalSession triangulation 0 (removeExpectedPoints points)) +{-# INLINE removeExpectedFrom #-} + +removeExpectedPoints + :: V.Vector (Point) + -> Session state annotation () () () () +removeExpectedPoints points = do + outcomes <- removeManyAt points + V.zipWithM_ + (\point outcome -> maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome) + points + outcomes +{-# INLINE removeExpectedPoints #-} + +toggleIncoming + :: Triangulation 'Unconstrained annotation () () () + -> Triangulation 'Unconstrained annotation () () () + -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) +toggleIncoming base incoming = + fmap (\(_, revised, _) -> revised) + (withLocalSession base (numVertices incoming) (toggleIncomingVertices incoming)) +{-# INLINE toggleIncoming #-} + +toggleIncomingVertices + :: Triangulation 'Unconstrained annotation () () () + -> Session state annotation () () () () +toggleIncomingVertices incoming = + traverse_ + (\vertex -> do + let point = vertexPoint incoming vertex + annotation = vertexData incoming vertex + (fresh, disposition) <- insertVertexAt point annotation + case disposition of + Inserted -> pure () + AlreadyPresent -> do + outcome <- removeAtNear fresh point + maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome + ) + (vertices incoming) +{-# INLINE toggleIncomingVertices #-} diff --git a/src-core/Moonlight/Triangulation/Internal/BoxedPaged.hs b/src-core/Moonlight/Triangulation/Internal/BoxedPaged.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/BoxedPaged.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Moonlight.Triangulation.Internal.BoxedPaged + ( BoxedPaged + , MutableBoxedPaged + , BoxedStorageError (..) + , emptyBoxedPaged + , boxedFill + , boxedPagedLength + , boxedUnsafeIndex + , boxedFromVector + , boxedToVector + , thawBoxedPaged + , readBoxedPaged + , writeBoxedPaged + , resetBoxedRange + , boxedThawPristine + , freezeBoxedPaged + , boxedUpdate + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.ST (ST) +import Data.Bits (shiftL, shiftR, (.&.)) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.List as List +import Data.STRef +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Moonlight.Triangulation.Internal.PageDirectory + +import GHC.Generics (Generic) + +-- | A paged payload store in which an absent page means every slot in it holds +-- the fill. The fill belongs to the store rather than to a thaw of it: a +-- payload component either has a default that new elements inherit — the three +-- element payloads do — or it has none and every slot must be written before it +-- is read, which is the vertex component, whose payloads arrive with it. +-- +-- The near-universal instantiation is @() () ()@, and under an unconditional +-- representation that costs one pointer per directed edge, undirected edge and +-- face, all aimed at the same closure. Here it costs nothing: an element +-- created at its default writes no slot, so no page is ever materialized. +data BoxedStorage a + = DenseBoxedPages !(V.Vector (V.Vector a)) + | DefaultedBoxedPages !a !(PageDirectory (V.Vector a)) + deriving stock (Generic, Functor) + deriving anyclass (NFData) + +data BoxedPaged a = BoxedPaged + { boxedLength :: {-# UNPACK #-} !Int + , boxedStorage :: !(BoxedStorage a) + } + deriving stock (Generic, Functor) + deriving anyclass (NFData) + +data BoxedStorageError + = BoxedFreezeLengthNegative {-# UNPACK #-} !Int + | BoxedFreezeDensePageMissing {-# UNPACK #-} !Int {-# UNPACK #-} !Int + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +boxedFill :: BoxedPaged a -> Maybe a +boxedFill BoxedPaged{boxedStorage = DenseBoxedPages _} = Nothing +boxedFill BoxedPaged{boxedStorage = DefaultedBoxedPages fill _} = Just fill + +-- Structural equality would distinguish a store that materialized a page of +-- defaults from one that did not, and the two are the same store. Equality is +-- therefore what can be observed: the length, the fill every unwritten slot +-- will report, and the sequence itself. +instance Eq a => Eq (BoxedPaged a) where + left == right = + boxedLength left == boxedLength right + && boxedFill left == boxedFill right + && boxedToVector left == boxedToVector right + +instance Show a => Show (BoxedPaged a) where + showsPrec precedence paged = + showParen (precedence > 10) $ + showString "BoxedPaged " + . showsPrec 11 (boxedFill paged) + . showString " " + . showsPrec 11 (boxedToVector paged) + +data MutableBoxedPaged s a = MutableBoxedPaged + { mutableBoxedBase :: !(BoxedPaged a) + , mutableBoxedDirty :: !(STRef s (IntMap.IntMap (MV.MVector s a))) + , mutableBoxedFill :: !(Maybe a) + , -- | The thaw found no materialized page. Together with an empty dirty set + -- this says every slot in the store reports the fill, which is the state a + -- payload component nobody writes stays in for the whole transaction — + -- the near-universal @() () ()@ case. Read through 'boxedThawPristine'. + mutableBoxedPristineBase :: !Bool + } + +pageBits :: Int +pageBits = 8 +{-# INLINE pageBits #-} + +pageSize :: Int +pageSize = 1 `shiftL` pageBits +{-# INLINE pageSize #-} + +-- Every index this store decomposes is an element identifier or a walk over +-- one, so the signed division a 'quotRem' would emit corrects for a sign that +-- cannot occur. +pageOf :: Int -> Int +pageOf index = index `shiftR` pageBits +{-# INLINE pageOf #-} + +offsetOf :: Int -> Int +offsetOf index = index .&. (pageSize - 1) +{-# INLINE offsetOf #-} + +emptyBoxedPaged :: Maybe a -> BoxedPaged a +emptyBoxedPaged fill = + BoxedPaged + 0 + (case fill of + Nothing -> DenseBoxedPages V.empty + Just value -> DefaultedBoxedPages value emptyDirectory) + +boxedPagedLength :: BoxedPaged a -> Int +boxedPagedLength = boxedLength +{-# INLINE boxedPagedLength #-} + +-- | Index with a handle already admitted by the owning triangulation. Dense +-- stores carry every live page explicitly; defaulted stores can answer an +-- absent or short page from their stored default. The handle domain is owned +-- by the DCEL, so this raw kernel performs no second, disagreeing bounds check. +boxedUnsafeIndex :: BoxedPaged a -> Int -> a +boxedUnsafeIndex BoxedPaged{boxedStorage} index = + let !page = pageOf index + !offset = offsetOf index + in case boxedStorage of + DenseBoxedPages pages -> + V.unsafeIndex (V.unsafeIndex pages page) offset + DefaultedBoxedPages fill pages -> + case lookupDirectory page pages of + Just values | offset < V.length values -> V.unsafeIndex values offset + _ -> fill +{-# INLINE boxedUnsafeIndex #-} + +boxedFromVector :: Maybe a -> V.Vector a -> BoxedPaged a +boxedFromVector fill values = + BoxedPaged + { boxedLength = V.length values + , boxedStorage = + case fill of + Nothing -> DenseBoxedPages (V.fromList (map snd (go 0))) + Just value -> DefaultedBoxedPages value (directoryFromAscList (go 0)) + } + where + go !offset + | offset >= V.length values = [] + | otherwise = + let !page = pageOf offset + !count = min pageSize (V.length values - offset) + !chunk = V.slice offset count values + in (page, chunk) : go (offset + count) + +-- Resolved a page at a time. Asking the directory per element paid a descent +-- for every slot of a run the descent had already found. +boxedToVector :: BoxedPaged a -> V.Vector a +boxedToVector BoxedPaged{boxedLength, boxedStorage} + | boxedLength <= 0 = V.empty + | otherwise = case boxedStorage of + DenseBoxedPages pages -> V.take boxedLength (V.concat (V.toList pages)) + DefaultedBoxedPages fill pages -> + V.concat (map (pageRun fill pages) [0 .. pageOf (boxedLength - 1)]) + where + pageRun fill pages page = + let !base = page `shiftL` pageBits + !width = min pageSize (boxedLength - base) + in case lookupDirectory page pages of + Just values + | V.length values >= width -> V.slice 0 width values + | otherwise -> values V.++ V.replicate (width - V.length values) fill + Nothing -> V.replicate width fill + +-- The fill comes from the store, not from the caller. A thaw that took it as an +-- argument obliged every call site to name the right one, and 'boxedUpdate' — +-- which passed the value being written — named the wrong one. That was harmless +-- only while pages were never absent. +thawBoxedPaged :: BoxedPaged a -> ST s (MutableBoxedPaged s a) +thawBoxedPaged base = do + mutableBoxedDirty <- newSTRef IntMap.empty + pure + MutableBoxedPaged + { mutableBoxedBase = base + , mutableBoxedDirty + , mutableBoxedFill = boxedFill base + , mutableBoxedPristineBase = case boxedStorage base of + DenseBoxedPages pages -> V.null pages + DefaultedBoxedPages _ pages -> directorySize pages == 0 + } + +readBoxedPaged :: MutableBoxedPaged s a -> Int -> ST s a +readBoxedPaged MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} index = do + dirty <- readSTRef mutableBoxedDirty + let !page = pageOf index + !offset = offsetOf index + case IntMap.lookup page dirty of + Just values -> MV.unsafeRead values offset + Nothing -> case boxedStorage mutableBoxedBase of + DenseBoxedPages pages -> + pure (V.unsafeIndex (V.unsafeIndex pages page) offset) + DefaultedBoxedPages fill pages -> + case lookupDirectory page pages of + Just values | offset < V.length values -> pure (V.unsafeIndex values offset) + _ -> pure fill +{-# INLINE readBoxedPaged #-} + +writeBoxedPaged :: MutableBoxedPaged s a -> Int -> a -> ST s () +writeBoxedPaged paged index value = do + let !page = pageOf index + !offset = offsetOf index + values <- ensureMutableBoxedPage paged page + MV.unsafeWrite values offset value +{-# INLINE writeBoxedPaged #-} + +-- | Whether the thaw found no materialized page. With no writer into the +-- element payload planes inside a transaction — there is none; they are +-- written only through the persistent setters, outside one — this answers for +-- the whole transaction that every slot reports the fill, so a rewrite has +-- nothing to return and a relocation has nothing to move. It is why the +-- near-universal @() () ()@ mesh pays a predictable branch and no page. +boxedThawPristine :: MutableBoxedPaged s a -> Bool +boxedThawPristine = mutableBoxedPristineBase +{-# INLINE boxedThawPristine #-} + +-- | Return a contiguous run of slots to the store's fill. A slot no write has +-- reached already reports the fill, so a page absent from both the base and the +-- dirty set is left absent: recycling an element at its default keeps the store +-- sparse. Only a page holding written values is materialized and overwritten. +resetBoxedRange :: MutableBoxedPaged s a -> a -> Int -> Int -> ST s () +resetBoxedRange paged@MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} fill start count + | count <= 0 = pure () + | otherwise = go start + where + !end = start + count + go !index + | index >= end = pure () + | otherwise = do + dirty <- readSTRef mutableBoxedDirty + let !page = pageOf index + !offset = offsetOf index + !width = min (pageSize - offset) (end - index) + !written = + IntMap.member page dirty + || case boxedStorage mutableBoxedBase of + DenseBoxedPages pages -> + page < V.length pages + && offset < V.length (V.unsafeIndex pages page) + DefaultedBoxedPages _ pages -> + case lookupDirectory page pages of + Just values -> offset < V.length values + Nothing -> False + if written + then do + values <- ensureMutableBoxedPage paged page + MV.set (MV.slice offset width values) fill + go (index + width) + else go (index + width) + +ensureMutableBoxedPage :: MutableBoxedPaged s a -> Int -> ST s (MV.MVector s a) +ensureMutableBoxedPage MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty, mutableBoxedFill} page = do + dirty <- readSTRef mutableBoxedDirty + case IntMap.lookup page dirty of + Just values -> pure values + Nothing -> do + -- Copying a page slot by slot writes every element twice — once to + -- establish the fill and once to overwrite it — and pays a write barrier + -- per store. A full page is one thaw; a short tail page fills only the + -- slots the base does not reach. This is the same shape the unboxed + -- store already uses. + values <- case boxedStorage mutableBoxedBase of + DenseBoxedPages pages + | page < V.length pages -> copyExisting (V.unsafeIndex pages page) + | otherwise -> MV.new pageSize + DefaultedBoxedPages fill pages -> + case lookupDirectory page pages of + Just old -> copyExisting old + Nothing -> MV.replicate pageSize fill + writeSTRef mutableBoxedDirty $! IntMap.insert page values dirty + pure values + where + copyExisting old + | V.length old == pageSize = V.thaw old + | otherwise = do + vector <- case mutableBoxedFill of + Just fill -> MV.replicate pageSize fill + Nothing -> MV.new pageSize + V.copy (MV.slice 0 (V.length old) vector) old + pure vector + +freezeBoxedPaged :: Int -> MutableBoxedPaged s a -> ST s (Either BoxedStorageError (BoxedPaged a)) +freezeBoxedPaged length' MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} + | length' < 0 = pure (Left (BoxedFreezeLengthNegative length')) + | otherwise = do + dirty <- readSTRef mutableBoxedDirty + frozenDirty <- traverse V.unsafeFreeze dirty + pure $ case boxedStorage mutableBoxedBase of + DenseBoxedPages basePages -> do + pages <- + traverse + (densePage frozenDirty basePages) + [0 .. pageCount - 1] + pure + BoxedPaged + { boxedLength = length' + , boxedStorage = DenseBoxedPages (V.fromList pages) + } + DefaultedBoxedPages fill basePages -> + let !merged = + List.foldl' + (\pages (page, values) -> insertDirectory page values pages) + basePages + (IntMap.toAscList frozenDirty) + !kept = directoryRestrict pageCount merged + !trimmed = case directoryLookupMax kept of + Nothing -> kept + Just (lastPage, values) -> + let !lastLength = length' - lastPage * pageSize + in if lastLength < V.length values + then insertDirectory lastPage (V.take lastLength values) kept + else kept + in Right + BoxedPaged + { boxedLength = length' + , boxedStorage = DefaultedBoxedPages fill trimmed + } + where + !pageCount = if length' <= 0 then 0 else pageOf (length' + pageSize - 1) + + densePage frozenDirty basePages page = + let !width = min pageSize (length' - page * pageSize) + in case IntMap.lookup page frozenDirty of + Just values -> Right (V.take width values) + Nothing -> case basePages V.!? page of + Just values -> Right (V.take width values) + Nothing -> Left (BoxedFreezeDensePageMissing page pageCount) + +boxedUpdate :: Int -> a -> BoxedPaged a -> BoxedPaged a +boxedUpdate index value source@BoxedPaged{boxedStorage} = + source{boxedStorage = updateStorage boxedStorage} + where + !page = pageOf index + !offset = offsetOf index + + updateStorage (DenseBoxedPages pages) = + let !values = V.unsafeIndex pages page + !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values + in DenseBoxedPages (V.modify (\mutable -> MV.unsafeWrite mutable page updated) pages) + updateStorage (DefaultedBoxedPages fill pages) = + let !values = case lookupDirectory page pages of + Just existing + | V.length existing == pageSize -> existing + | otherwise -> existing V.++ V.replicate (pageSize - V.length existing) fill + Nothing -> V.replicate pageSize fill + !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values + in DefaultedBoxedPages fill (insertDirectory page updated pages) diff --git a/src-core/Moonlight/Triangulation/Internal/Dyadic.hs b/src-core/Moonlight/Triangulation/Internal/Dyadic.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/Dyadic.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Moonlight.Triangulation.Internal.Dyadic + ( exactOrientDet + , exactOrientSignDouble + , exactInCircleDet + , exactBarycentricDeterminants + , exactDiametralDot + , integerRatioToDouble + ) where + +import Data.Bits (shiftL, shiftR) +#if WORD_SIZE_IN_BITS == 64 +import GHC.Exts + ( Double (D#) + , Double# + , Int# + , Word# + , and# + , castDoubleToWord64# + , eqWord# + , gtWord# + , int2Word# + , isTrue# + , or# + , plusWord# + , plusWord2# + , subWordC# + , timesWord2# + , uncheckedShiftL# + , uncheckedShiftRL# + , word2Int# + , word64ToWord# + , (*#) + , (+#) + , (-#) + , (<=#) + , (==#) + , (>#) + , (>=#) + ) +#endif + +-- Every finite binary64 value is a dyadic rational. Aligning all mantissas to +-- one exponent gives exact integer predicates without constructing Rational +-- expression trees. +type Decoded = (Integer, Int) + +commonExponent :: [Decoded] -> Int +commonExponent = foldl' step 0 + where + step :: Int -> Decoded -> Int + step !current (!mantissa, !power) + | mantissa == 0 = current + | otherwise = min current power +{-# INLINE commonExponent #-} + +alignDecoded :: Int -> Decoded -> Integer +alignDecoded !power (!mantissa, !sourcePower) + | mantissa == 0 = 0 + | otherwise = mantissa `shiftL` (sourcePower - power) +{-# INLINE alignDecoded #-} + +aligned6 + :: Double -> Double -> Double -> Double -> Double -> Double + -> (Integer, Integer, Integer, Integer, Integer, Integer) +aligned6 a b c d e f = + let !da = decodeFloat a + !db = decodeFloat b + !dc = decodeFloat c + !dd = decodeFloat d + !de = decodeFloat e + !df = decodeFloat f + !power = commonExponent [da, db, dc, dd, de, df] + in ( alignDecoded power da + , alignDecoded power db + , alignDecoded power dc + , alignDecoded power dd + , alignDecoded power de + , alignDecoded power df + ) + +aligned8 + :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double + -> (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer) +aligned8 a b c d e f g h = + let !da = decodeFloat a + !db = decodeFloat b + !dc = decodeFloat c + !dd = decodeFloat d + !de = decodeFloat e + !df = decodeFloat f + !dg = decodeFloat g + !dh = decodeFloat h + !power = commonExponent [da, db, dc, dd, de, df, dg, dh] + in ( alignDecoded power da + , alignDecoded power db + , alignDecoded power dc + , alignDecoded power dd + , alignDecoded power de + , alignDecoded power df + , alignDecoded power dg + , alignDecoded power dh + ) + +exactOrientDet + :: Double -> Double -> Double -> Double -> Double -> Double -> Integer +exactOrientDet ax ay bx by cx cy = + let (!iax, !iay, !ibx, !iby, !icx, !icy) = aligned6 ax ay bx by cx cy + !acx = iax - icx + !acy = iay - icy + !bcx = ibx - icx + !bcy = iby - icy + in acx * bcy - acy * bcx + +exactInCircleDet + :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double + -> Integer +exactInCircleDet ax ay bx by cx cy dx dy = + let (!iax, !iay, !ibx, !iby, !icx, !icy, !idx, !idy) = + aligned8 ax ay bx by cx cy dx dy + !adx = iax - idx + !ady = iay - idy + !bdx = ibx - idx + !bdy = iby - idy + !cdx = icx - idx + !cdy = icy - idy + !abdet = adx * bdy - bdx * ady + !bcdet = bdx * cdy - cdx * bdy + !cadet = cdx * ady - adx * cdy + !alift = adx * adx + ady * ady + !blift = bdx * bdx + bdy * bdy + !clift = cdx * cdx + cdy * cdy + in alift * bcdet + blift * cadet + clift * abdet + +exactDiametralDot + :: Double -> Double -> Double -> Double -> Double -> Double -> Integer +exactDiametralDot ax ay bx by px py = + let (!iax, !iay, !ibx, !iby, !ipx, !ipy) = aligned6 ax ay bx by px py + !pax = ipx - iax + !pay = ipy - iay + !pbx = ipx - ibx + !pby = ipy - iby + in pax * pbx + pay * pby + +exactBarycentricDeterminants + :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double + -> (Integer, Integer, Integer, Integer) +exactBarycentricDeterminants ax ay bx by cx cy qx qy = + let (!iax, !iay, !ibx, !iby, !icx, !icy, !iqx, !iqy) = + aligned8 ax ay bx by cx cy qx qy + determinant :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer + determinant px py rx ry sx sy = + let !psx = px - sx + !psy = py - sy + !rsx = rx - sx + !rsy = ry - sy + in psx * rsy - psy * rsx + !denominator = determinant iax iay ibx iby icx icy + !weightA = determinant iqx iqy ibx iby icx icy + !weightB = determinant iax iay iqx iqy icx icy + !weightC = determinant iax iay ibx iby iqx iqy + in (denominator, weightA, weightB, weightC) + +integerRatioToDouble :: Integer -> Integer -> Double +integerRatioToDouble numerator denominator + | denominator == 0 = 0 / 0 + | numerator == 0 = 0 + | otherwise = + let !precision = floatDigits (0 :: Double) + !numeratorMagnitude = abs numerator + !denominatorMagnitude = abs denominator + !numeratorBits = integerBitLength numeratorMagnitude + !denominatorBits = integerBitLength denominatorMagnitude + !numeratorShift = max 0 (numeratorBits - precision) + !denominatorShift = max 0 (denominatorBits - precision) + !scaledNumerator = fromInteger (numeratorMagnitude `shiftR` numeratorShift) + !scaledDenominator = fromInteger (denominatorMagnitude `shiftR` denominatorShift) + !magnitude = scaleFloat (numeratorShift - denominatorShift) (scaledNumerator / scaledDenominator) + !sameSign = (numerator < 0) == (denominator < 0) + in if sameSign then magnitude else negate magnitude + +integerBitLength :: Integer -> Int +integerBitLength = go 0 + where + go !bits value + | value <= 0xffffffff = bits + wordBitLength value + | otherwise = go (bits + 32) (value `shiftR` 32) + + wordBitLength = count 0 + count :: Int -> Integer -> Int + count !bits 0 = bits + count !bits value = count (bits + 1) (value `shiftR` 1) + +-- --------------------------------------------------------------------------- +-- Fixed-precision exact orient sign for Double. +-- +-- The generic dyadic path answers every exact query with arbitrary-precision +-- Integers: six decodes, one alignment, and two multiplies, each allocating. +-- Practical inputs have an exponent spread small enough that the determinant's +-- exact sign is decided by 128-bit differences and 256-bit products in machine +-- words, without a single heap object. 'exactOrientSignDouble' takes that path +-- and falls back to 'exactOrientDet' the moment an operand is non-finite or an +-- alignment shift would outgrow the fixed width. The two agree by +-- construction: both compute the sign of the same integer determinant. +-- +-- The fixed-width worker reads a Double as one machine word and aligns +-- mantissas across a 128-bit pair, so it is only meaningful where a machine +-- word is 64 bits wide. On a narrower target the same sign is taken from the +-- arbitrary-precision determinant directly, which is the branch this path +-- already falls back to whenever an alignment shift would outgrow the width. + +#if WORD_SIZE_IN_BITS == 64 + +exactOrientSignDouble + :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering +exactOrientSignDouble ax ay bx by cx cy = + case ax of + D# axw -> + case ay of + D# ayw -> + case bx of + D# bxw -> + case by of + D# byw -> + case cx of + D# cxw -> + case cy of + D# cyw -> + case orientSignWorker axw ayw bxw byw cxw cyw of + 2# -> compare (exactOrientDet ax ay bx by cx cy) 0 + 0# -> EQ + sign -> + case sign ># 0# of + 1# -> GT + _ -> LT +{-# NOINLINE exactOrientSignDouble #-} + +-- Decode a Double into sign bit (0/1), mantissa, and power-of-two exponent +-- with value = (-1)^sign * mantissa * 2^exponent. Zero decodes to a zero +-- mantissa; subnormals decode without a hidden bit. The fourth component is 1 +-- when the value is finite and 0 when it is not. +decodeExact :: Double# -> (# Int#, Word#, Int#, Int# #) +decodeExact d = + case word64ToWord# (castDoubleToWord64# d) of + bits -> + let neg = word2Int# (uncheckedShiftRL# bits 63#) + exponentField = word2Int# (and# (uncheckedShiftRL# bits 52#) 2047##) + mantissaField = and# bits 4503599627370495## + in case exponentField of + 0# -> (# neg, mantissaField, -1074#, 1# #) + 2047# -> (# neg, mantissaField, 0#, 0# #) + raw -> (# neg, or# mantissaField 4503599627370496##, raw -# 1075#, 1# #) + +-- A mantissa of at most 53 bits shifted left by at most 73 bits: the pair +-- (high, low) of a value below 2^126. +shiftMantissa :: Word# -> Int# -> (# Word#, Word# #) +shiftMantissa mantissa k = + case k >=# 64# of + 1# -> (# uncheckedShiftL# mantissa (k -# 64#), 0## #) + _ -> + case k ==# 0# of + 1# -> (# 0##, mantissa #) + _ -> + (# + uncheckedShiftRL# mantissa (64# -# k), + uncheckedShiftL# mantissa k + #) + +-- The exact sign and 128-bit magnitude of sa*ma*2^ea - sc*mc*2^ec, aligned +-- to the caller-supplied floor exponent, as (sign, high, low, status) with +-- sign in {-1, 0, 1} and status 1 when an alignment shift outgrows the fixed +-- width. The floor never exceeds the exponent of a nonzero operand, so every +-- shift is non-negative; one shared floor is what makes the four differences +-- of one determinant comparable after multiplication. +differenceExact + :: Int# -> Word# -> Int# -> Int# -> Word# -> Int# -> Int# -> (# Int#, Word#, Word#, Int# #) +differenceExact nega ma ea negc mc ec emin = + case ma of + 0## -> + case mc of + 0## -> (# 0#, 0##, 0##, 0# #) + _ -> aligned (negateSign (positiveSign negc)) mc (ec -# emin) + _ -> + case mc of + 0## -> aligned (positiveSign nega) ma (ea -# emin) + _ -> + case ea -# emin of + da -> + case da ># 73# of + 1# -> (# 0#, 0##, 0##, 1# #) + _ -> + case ec -# emin of + dc -> + case dc ># 73# of + 1# -> (# 0#, 0##, 0##, 1# #) + _ -> + case shiftMantissa ma da of + (# ahi, alo #) -> + case shiftMantissa mc dc of + (# chi, clo #) -> + case nega ==# negc of + 1# -> + -- Same operand signs: subtract magnitudes. + case compareWord2 ahi alo chi clo of + 0# -> (# 0#, 0##, 0##, 0# #) + 1# -> + case subtractWord2 ahi alo chi clo of + (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #) + _ -> + case subtractWord2 chi clo ahi alo of + (# hi, lo #) -> (# negateSign (positiveSign nega), hi, lo, 0# #) + _ -> + -- Opposite operand signs: add magnitudes. + case addWord2 ahi alo chi clo of + (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #) + where + aligned sign mantissa k = + case k ># 73# of + 1# -> (# 0#, 0##, 0##, 1# #) + _ -> + case shiftMantissa mantissa k of + (# hi, lo #) -> (# sign, hi, lo, 0# #) + positiveSign neg = case neg of + 1# -> -1# + _ -> 1# + negateSign sign = case sign of + 1# -> -1# + _ -> 1# + +-- Lexicographic comparison of 128-bit magnitudes: 1, 0, or -1. +compareWord2 :: Word# -> Word# -> Word# -> Word# -> Int# +compareWord2 ahi alo chi clo = + case eqWord# ahi chi of + 1# -> + case eqWord# alo clo of + 1# -> 0# + _ -> + case gtWord# alo clo of + 1# -> 1# + _ -> -1# + _ -> + case gtWord# ahi chi of + 1# -> 1# + _ -> -1# + +-- 128-bit difference of magnitudes, first operand at least the second. +subtractWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #) +subtractWord2 ahi alo chi clo = + case subWordC# alo clo of + (# low, borrow #) -> + case subWordC# ahi chi of + (# high0, _ #) -> + case subWordC# high0 (int2Word# borrow) of + (# high, _ #) -> (# high, low #) + +-- 128-bit sum of magnitudes each below 2^126: the total stays below 2^127 and +-- the final carry is empty by the shift bound. +addWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #) +addWord2 ahi alo chi clo = + case plusWord2# alo clo of + (# carry0, low #) -> + case plusWord2# ahi chi of + (# _, high0 #) -> + case plusWord2# high0 carry0 of + (# _, high #) -> (# high, low #) + +-- 128-bit by 128-bit exact product, (r3, r2, r1, r0), most significant first. +-- Each factor stays below 2^127, so the product stays below 2^254 and the top +-- accumulation cannot overflow. +multiplyWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word#, Word#, Word# #) +multiplyWord2 ahi alo bhi blo = + case timesWord2# alo blo of + (# h00, l00 #) -> + case timesWord2# alo bhi of + (# h01, l01 #) -> + case timesWord2# ahi blo of + (# h10, l10 #) -> + case timesWord2# ahi bhi of + (# h11, l11 #) -> + case plusWord2# h00 l01 of + (# carryA, sumA #) -> + case plusWord2# sumA l10 of + (# carryB, r1 #) -> + case plusWord# carryA carryB of + carry2 -> + case plusWord2# h01 h10 of + (# carryC, sumC #) -> + case plusWord2# sumC l11 of + (# carryD, sumD #) -> + case plusWord2# sumD carry2 of + (# carryE, r2 #) -> + case plusWord# (plusWord# carryC carryD) carryE of + carry3 -> + case plusWord# h11 carry3 of + r3 -> (# r3, r2, r1, l00 #) + +-- Lexicographic comparison of 256-bit magnitudes: 1, 0, or -1. +compareWord4 + :: Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Int# +compareWord4 a3 a2 a1 a0 b3 b2 b1 b0 = + case compareWord2 a3 a2 b3 b2 of + 0# -> compareWord2 a1 a0 b1 b0 + answer -> answer + +-- The exponent a mantissa contributes to the alignment floor: a zero +-- mantissa is exact at any floor and votes for the impossibly high sentinel. +floorExp :: Word# -> Int# -> Int# +floorExp mantissa power = + case mantissa of + 0## -> 2000000# + _ -> power + +minExp :: Int# -> Int# -> Int# +minExp a b = if isTrue# (a <=# b) then a else b + +orientSignWorker :: Double# -> Double# -> Double# -> Double# -> Double# -> Double# -> Int# +orientSignWorker ax ay bx by cx cy = + case decodeExact ax of + (# negax, max_, eax, okax #) -> + case decodeExact ay of + (# negay, may, eay, okay #) -> + case decodeExact bx of + (# negbx, mbx, ebx, okbx #) -> + case decodeExact by of + (# negby, mby, eby, okby #) -> + case decodeExact cx of + (# negcx, mcx, ecx, okcx #) -> + case decodeExact cy of + (# negcy, mcy, ecy, okcy #) -> + case okax +# okay +# okbx +# okby +# okcx +# okcy of + 6# -> + -- The alignment floor is the least exponent + -- among nonzero mantissas; a zero mantissa is + -- exact at any floor and must not drag it down. + case floorExp max_ eax `minExp` floorExp may eay `minExp` floorExp mbx ebx `minExp` floorExp mby eby `minExp` floorExp mcx ecx `minExp` floorExp mcy ecy of + emin -> + case differenceExact negax max_ eax negcx mcx ecx emin of + (# s1, d1hi, d1lo, f1 #) -> + case differenceExact negby mby eby negcy mcy ecy emin of + (# s2, d2hi, d2lo, f2 #) -> + case differenceExact negay may eay negcy mcy ecy emin of + (# s3, d3hi, d3lo, f3 #) -> + case differenceExact negbx mbx ebx negcx mcx ecx emin of + (# s4, d4hi, d4lo, f4 #) -> + case f1 +# f2 +# f3 +# f4 of + 0# -> + combineSigns + (s1 *# s2) d1hi d1lo d2hi d2lo + (s3 *# s4) d3hi d3lo d4hi d4lo + _ -> 2# + _ -> 2# + where + -- det = leftSign * leftProduct - rightSign * rightProduct + combineSigns leftSign d1hi d1lo d2hi d2lo rightSign d3hi d3lo d4hi d4lo = + case leftSign of + 0# -> + case rightSign of + 0# -> 0# + _ -> 0# -# rightSign + _ -> + case rightSign of + 0# -> leftSign + _ -> + case leftSign ==# rightSign of + 1# -> + case multiplyWord2 d1hi d1lo d2hi d2lo of + (# p3, p2, p1, p0 #) -> + case multiplyWord2 d3hi d3lo d4hi d4lo of + (# q3, q2, q1, q0 #) -> + case compareWord4 p3 p2 p1 p0 q3 q2 q1 q0 of + 0# -> 0# + 1# -> leftSign + _ -> 0# -# leftSign + _ -> leftSign + +#else + +-- The narrow-word answer to the same question. 'exactOrientDet' is the +-- determinant the fixed-width worker exists to avoid allocating, not a +-- different quantity, so the two branches agree by construction. +exactOrientSignDouble + :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering +exactOrientSignDouble ax ay bx by cx cy = + compare (exactOrientDet ax ay bx by cx cy) 0 +{-# NOINLINE exactOrientSignDouble #-} + +#endif diff --git a/src-core/Moonlight/Triangulation/Internal/FaceQueue.hs b/src-core/Moonlight/Triangulation/Internal/FaceQueue.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/FaceQueue.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | The set of faces still owed a refinement decision. +module Moonlight.Triangulation.Internal.FaceQueue + ( FaceQueue + , newFaceQueue + , pushFace + , popFace + ) where + +import Control.Monad.ST (ST) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Internal.PackedIndex (packIndex) + +-- A worst-first heap has to be told a score for every face it is offered, so +-- the caller derives one — circumradius, area, the encroachment verdict — for +-- faces that are then found acceptable and dropped. Ruppert's termination does +-- not rest on that order; it rests on every bad face being reached before the +-- run ends. So this only has to be a set with a discipline for draining it. +-- +-- A stack is that, and it makes membership O(1) with nothing to compute. The +-- pending flags are what keep it a set: a face touched by several insertions +-- before it is drained is decided once, not once per touch. +-- +-- The size lives in an unboxed cell for the reason the growable stack's does: +-- it is written on every push and every pop, and a boxed counter allocates a +-- box per write once the size leaves the shared small-'Int' range. +data FaceQueue s = FaceQueue + { fqFaces :: !(MUV.MVector s Word32) + , fqPending :: !(MUV.MVector s Bool) + , fqSize :: !(MUV.MVector s Int) + } + +newFaceQueue :: Int -> ST s (FaceQueue s) +newFaceQueue capacity = do + let size = max 1 capacity + fqFaces <- MUV.new size + fqPending <- MUV.replicate size False + fqSize <- MUV.replicate 1 0 + pure FaceQueue{..} + +-- The checked read of the pending flag is the one bound this module does not +-- establish itself: the face arrives from mesh topology. Once it succeeds, +-- uniqueness proves the stack write: at most one slot exists for each pending +-- flag, and the two vectors have the same length. +pushFace :: FaceQueue s -> Int -> ST s () +pushFace FaceQueue{fqFaces, fqPending, fqSize} face = do + pending <- MUV.read fqPending face + if pending + then pure () + else do + size <- MUV.unsafeRead fqSize 0 + MUV.unsafeWrite fqFaces size (packIndex face) + MUV.unsafeWrite fqPending face True + MUV.unsafeWrite fqSize 0 (size + 1) + +popFace :: FaceQueue s -> ST s (Maybe Int) +popFace FaceQueue{fqFaces, fqPending, fqSize} = do + size <- MUV.unsafeRead fqSize 0 + if size == 0 + then pure Nothing + else do + let !index = size - 1 + face <- fromIntegral <$> MUV.unsafeRead fqFaces index + MUV.unsafeWrite fqPending face False + MUV.unsafeWrite fqSize 0 index + pure (Just face) diff --git a/src-core/Moonlight/Triangulation/Internal/Growable.hs b/src-core/Moonlight/Triangulation/Internal/Growable.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/Growable.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , newGrowableWord32 + , clearGrowable + , growableLength + , pushGrowable + , popGrowableOr + , readGrowable + , writeGrowable + ) where + +import Control.Monad (when) +import Control.Monad.ST (ST) +import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) + +-- | Transaction-local vector. It starts small and grows only with the local +-- frontier; no operation allocates scratch memory proportional to mesh size. +-- The size lives in an unboxed cell: the stack is popped and pushed inside +-- every legalization drain, and a boxed counter would allocate on each step. +data GrowableWord32 s = GrowableWord32 + { growableVector :: !(STRef s (MUV.MVector s Word32)) + , growableSize :: !(MUV.MVector s Int) + } + +newGrowableWord32 :: Int -> ST s (GrowableWord32 s) +newGrowableWord32 requested = do + vector <- MUV.new (max 8 requested) + growableVector <- newSTRef vector + growableSize <- MUV.replicate 1 0 + pure GrowableWord32{growableVector, growableSize} + +clearGrowable :: GrowableWord32 s -> ST s () +clearGrowable GrowableWord32{growableSize} = MUV.unsafeWrite growableSize 0 0 +{-# INLINE clearGrowable #-} + +growableLength :: GrowableWord32 s -> ST s Int +growableLength GrowableWord32{growableSize} = MUV.unsafeRead growableSize 0 +{-# INLINE growableLength #-} + +pushGrowable :: GrowableWord32 s -> Word32 -> ST s () +pushGrowable growable@GrowableWord32{growableSize} value = do + index <- MUV.unsafeRead growableSize 0 + vector <- ensureCapacity growable (index + 1) + MUV.unsafeWrite vector index value + MUV.unsafeWrite growableSize 0 (index + 1) +{-# INLINE pushGrowable #-} + +-- | Pop, answering the caller's sentinel on emptiness instead of allocating a +-- 'Maybe' per step. Sound only against a sentinel no push can store. +popGrowableOr :: Word32 -> GrowableWord32 s -> ST s Word32 +popGrowableOr sentinel GrowableWord32{growableVector, growableSize} = do + size <- MUV.unsafeRead growableSize 0 + if size <= 0 + then pure sentinel + else do + let !index = size - 1 + vector <- readSTRef growableVector + value <- MUV.unsafeRead vector index + MUV.unsafeWrite growableSize 0 index + pure value +{-# INLINE popGrowableOr #-} + +readGrowable :: GrowableWord32 s -> Int -> ST s Word32 +readGrowable GrowableWord32{growableVector} index = do + vector <- readSTRef growableVector + MUV.unsafeRead vector index +{-# INLINE readGrowable #-} + +writeGrowable :: GrowableWord32 s -> Int -> Word32 -> ST s () +writeGrowable growable@GrowableWord32{growableSize} index value = do + vector <- ensureCapacity growable (index + 1) + MUV.unsafeWrite vector index value + size <- MUV.unsafeRead growableSize 0 + when (index >= size) (MUV.unsafeWrite growableSize 0 (index + 1)) +{-# INLINE writeGrowable #-} + +-- Answering with the vector is what keeps a push to one cell read: the caller +-- would otherwise re-read the reference this just proved current. +ensureCapacity :: GrowableWord32 s -> Int -> ST s (MUV.MVector s Word32) +ensureCapacity GrowableWord32{growableVector} required = do + vector <- readSTRef growableVector + let !current = MUV.length vector + if required <= current + then pure vector + else do + let !next = until (>= required) (* 2) current + grown <- MUV.grow vector (next - current) + writeSTRef growableVector grown + pure grown diff --git a/src-core/Moonlight/Triangulation/Internal/PackedIndex.hs b/src-core/Moonlight/Triangulation/Internal/PackedIndex.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/PackedIndex.hs @@ -0,0 +1,34 @@ +module Moonlight.Triangulation.Internal.PackedIndex + ( noIndex + , indexLimit + , packIndex + , unpackIndex + , unpackOptionalIndex + ) where + +import Data.Word (Word32) + +noIndex :: Word32 +noIndex = maxBound + +indexLimit :: Int +indexLimit = fromIntegral (maxBound - 1 :: Word32) + +-- | Pack an admitted arena handle. The build boundary limits vertex capacity +-- so the mutable topology reservation, @8n + 16@, stays below 'indexLimit'; +-- every caller supplies a non-negative handle or worklist position derived +-- from those arenas. Optional @-1@ handles are represented separately by +-- 'noIndex' before this function is reached. +packIndex :: Int -> Word32 +packIndex = fromIntegral +{-# INLINE packIndex #-} + +unpackIndex :: Word32 -> Int +unpackIndex = fromIntegral +{-# INLINE unpackIndex #-} + +unpackOptionalIndex :: Word32 -> Maybe Int +unpackOptionalIndex value + | value == noIndex = Nothing + | otherwise = Just (unpackIndex value) +{-# INLINE unpackOptionalIndex #-} diff --git a/src-core/Moonlight/Triangulation/Internal/PageDirectory.hs b/src-core/Moonlight/Triangulation/Internal/PageDirectory.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/PageDirectory.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | The map from page number to page, for the paged stores. +module Moonlight.Triangulation.Internal.PageDirectory + ( PageDirectory + , emptyDirectory + , lookupDirectory + , insertDirectory + , directoryFromAscList + , directoryToAscList + , directorySize + , directoryLookupMax + , directoryRestrict + ) where + +import Control.DeepSeq (NFData) +import Data.Bits (shiftL, shiftR, (.&.)) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import GHC.Generics (Generic) + +-- Page numbers are small, dense and non-negative, and the read path resolves +-- one on every field access that misses its owner's current page. An ordered +-- map answers that with a chain of prefix comparisons whose length grows with +-- the mesh; a 32-way radix answers it with two indexed loads at every size the +-- meshes reach, and the arithmetic is shifts and masks rather than branches. +-- +-- Absence is representable because the boxed payload store leaves a page out +-- entirely when every slot in it still holds the fill. +data Slot a + = Absent + | Page !a + | Fanout !(V.Vector (Slot a)) + deriving stock (Generic, Functor) + deriving anyclass (NFData) + +-- | @directoryHeight@ counts the fanout levels below the root: at height 0 the +-- root's children are pages, at height 1 they are fanouts of pages, and so on. +data PageDirectory a = PageDirectory + { directoryHeight :: {-# UNPACK #-} !Int + , directoryRoot :: !(Slot a) + , directorySize :: {-# UNPACK #-} !Int + } + deriving stock (Generic, Functor) + deriving anyclass (NFData) + +fanout :: Int +fanout = 32 +{-# INLINE fanout #-} + +slotBits :: Int +slotBits = 5 +{-# INLINE slotBits #-} + +-- Path copying replaces one slot per level, and the bulk-update operator would +-- route that through a list of one pair. This is the copy the level needs and +-- nothing besides. +updateSlot :: V.Vector (Slot a) -> Int -> Slot a -> V.Vector (Slot a) +updateSlot children index child = + V.modify (\node -> MV.unsafeWrite node index child) children +{-# INLINE updateSlot #-} + +-- | The first page number a directory of this height cannot address. +capacity :: Int -> Int +capacity height = 1 `shiftL` (slotBits * (height + 1)) +{-# INLINE capacity #-} + +emptyDirectory :: PageDirectory a +emptyDirectory = PageDirectory 0 Absent 0 + +lookupDirectory :: Int -> PageDirectory a -> Maybe a +lookupDirectory key PageDirectory{directoryHeight, directoryRoot} + | key < 0 || key >= capacity directoryHeight = Nothing + | otherwise = go directoryHeight directoryRoot + where + go !height slot = case slot of + Absent -> Nothing + Page value -> Just value + Fanout children -> + go (height - 1) (V.unsafeIndex children ((key `shiftR` (slotBits * height)) .&. (fanout - 1))) +{-# INLINE lookupDirectory #-} + +insertDirectory :: Int -> a -> PageDirectory a -> PageDirectory a +insertDirectory key value directory + | key >= capacity (directoryHeight directory) = insertDirectory key value (grow directory) + | otherwise = + let (!root, !added) = write (directoryHeight directory) (directoryRoot directory) + in directory + { directoryRoot = root + , directorySize = directorySize directory + if added then 1 else 0 + } + where + write !height slot + | height < 0 = (Page value, case slot of Page _ -> False; _ -> True) + | otherwise = + let !index = (key `shiftR` (slotBits * height)) .&. (fanout - 1) + !children = case slot of + Fanout existing -> existing + _ -> V.replicate fanout Absent + (!child, !added) = write (height - 1) (V.unsafeIndex children index) + in (Fanout (updateSlot children index child), added) + +-- A directory that has run out of addressable pages gains a level, and its +-- whole former extent becomes child zero of the new root. +grow :: PageDirectory a -> PageDirectory a +grow directory@PageDirectory{directoryHeight, directoryRoot} = + directory + { directoryHeight = directoryHeight + 1 + , directoryRoot = case directoryRoot of + Absent -> Absent + occupied -> Fanout (updateSlot (V.replicate fanout Absent) 0 occupied) + } + +-- | Build from ascending, distinct page numbers in one descent. +-- +-- Every dense transaction ends by publishing a whole directory, so this is on +-- the freeze path of bulk load, constraint recovery and refinement alike. +-- Folding 'insertDirectory' over the list would copy each root path once per +-- page; laying the levels down directly touches each node once. +directoryFromAscList :: [(Int, a)] -> PageDirectory a +directoryFromAscList [] = emptyDirectory +directoryFromAscList entries@((firstKey, _) : remainingEntries) = + PageDirectory + { directoryHeight = height + , directoryRoot = fst (build height 0 entries) + , directorySize = length entries + } + where + !largest = foldl' (\largestKey (key, _) -> max largestKey key) firstKey remainingEntries + !height = heightFor 0 + heightFor !candidate + | largest < capacity candidate = candidate + | otherwise = heightFor (candidate + 1) + + build :: Int -> Int -> [(Int, b)] -> (Slot b, [(Int, b)]) + build !level !base remaining = case remaining of + [] -> (Absent, []) + ((key, value) : rest) + | key >= base + capacity level -> (Absent, remaining) + | level < 0 -> (Page value, rest) + | otherwise -> + let !childSpan = capacity (level - 1) + step (children, unconsumed) index = + let (!child, !beyond) = build (level - 1) (base + index * childSpan) unconsumed + in (child : children, beyond) + (!reversed, !left) = foldl' step ([], remaining) [0 .. fanout - 1] + in (Fanout (V.fromListN fanout (reverse reversed)), left) + +directoryToAscList :: PageDirectory a -> [(Int, a)] +directoryToAscList PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot [] + where + go :: Int -> Int -> Slot b -> [(Int, b)] -> [(Int, b)] + go !height !prefix slot rest = case slot of + Absent -> rest + Page value -> (prefix, value) : rest + Fanout children -> + foldr + (\index accumulated -> + go + (height - 1) + (prefix + (index `shiftL` (slotBits * height))) + (V.unsafeIndex children index) + accumulated + ) + rest + [0 .. fanout - 1] + +directoryLookupMax :: PageDirectory a -> Maybe (Int, a) +directoryLookupMax PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot + where + go :: Int -> Int -> Slot b -> Maybe (Int, b) + go !height !prefix slot = case slot of + Absent -> Nothing + Page value -> Just (prefix, value) + Fanout children -> descend (fanout - 1) + where + descend !index + | index < 0 = Nothing + | otherwise = + case go (height - 1) (prefix + (index `shiftL` (slotBits * height))) (V.unsafeIndex children index) of + Nothing -> descend (index - 1) + found -> found + +-- | Keep only the pages a directory of the given page count can hold. The +-- common case is that every page is already within the count, and that is +-- settled by one descent rather than a rebuild. +directoryRestrict :: Int -> PageDirectory a -> PageDirectory a +directoryRestrict pageCount directory + | pageCount <= 0 = emptyDirectory + | otherwise = case directoryLookupMax directory of + Nothing -> directory + Just (largest, _) + | largest < pageCount -> directory + | otherwise -> + directoryFromAscList (filter ((< pageCount) . fst) (directoryToAscList directory)) diff --git a/src-core/Moonlight/Triangulation/Internal/Paged.hs b/src-core/Moonlight/Triangulation/Internal/Paged.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Internal/Paged.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Triangulation.Internal.Paged + ( Paged + , MutablePaged + , emptyPaged + , fromVector + , fromLocalVector + , toVector + , pagedLength + , pagedUnsafeIndex + , pagedFoldl' + , newMutablePaged + , newLocalMutablePaged + , TransactionShape (..) + , thawPaged + , thawPagedDense + , thawPagedShaped + , readPaged + , writePaged + , freezePaged + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Monad.ST (ST, runST) +import Data.Bits (shiftL, shiftR, (.&.)) +import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MUV + +-- | One physical store with two lawful local sections. A bulk constructor +-- publishes one contiguous plane for hot traversal. A persistent edit derives +-- fixed-size shared pages from that plane without copying and republishes only +-- pages it wrote. Both constructors denote exactly the same indexed sequence; +-- equality, serialization, and compaction descend through that sequence. +data Paged a + = FlatPaged {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(U.Vector a) + | SharedPaged {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(V.Vector (U.Vector a)) + +-- | A fresh build owns a contiguous arena. A transaction over a published +-- value owns only its mutable page table and clones a page before its first +-- write. No mutable page or state token can escape this module. +data MutablePaged s a + = MutableFlatPaged {-# UNPACK #-} !Int !(MUV.MVector s a) + | MutableSharedPaged + {-# UNPACK #-} !Int + !(Paged a) + !(V.Vector (U.Vector a)) + !(MV.MVector s (MUV.MVector s a)) + !(MUV.MVector s Bool) + !(STRef s Int) + +localPageBits :: Int +localPageBits = 8 +{-# INLINE localPageBits #-} + +-- A published plane's page geometry is the clone quantum of every +-- copy-on-write transaction opened on it. Full ladder 2026-08-06 on the +-- star-local excise (persistent-removal 10k/2.5k, min of 4 interleaved +-- rounds): 62.6ms at 12 bits, 57.2ms at 10, 83.2ms at 8 — reproducing the +-- 2026-08-05 finding that at 8 bits the per-transaction table build and +-- freeze scan outweigh the smaller clones (profiled there at 61% of the +-- lane), while at 12 the scattered-touch clones dominate instead. 10 is the +-- measured saddle between the two taxes. +traversalPageBits :: Int +traversalPageBits = 10 +{-# INLINE traversalPageBits #-} + +pageSize :: Int -> Int +pageSize bits = 1 `shiftL` bits +{-# INLINE pageSize #-} + +pageOf :: Int -> Int -> Int +pageOf bits index = index `shiftR` bits +{-# INLINE pageOf #-} + +offsetOf :: Int -> Int -> Int +offsetOf bits index = index .&. (pageSize bits - 1) +{-# INLINE offsetOf #-} + +pagesFor :: Int -> Int -> Int +pagesFor bits count + | count <= 0 = 0 + | otherwise = pageOf bits (count + pageSize bits - 1) +{-# INLINE pagesFor #-} + +pagedLength :: Paged a -> Int +pagedLength paged = + case paged of + FlatPaged count _ _ -> count + SharedPaged count _ _ -> count +{-# INLINE pagedLength #-} + +pagedBits :: Paged a -> Int +pagedBits paged = case paged of + FlatPaged _ bits _ -> bits + SharedPaged _ bits _ -> bits +{-# INLINE pagedBits #-} + +pageVector :: U.Unbox a => Paged a -> V.Vector (U.Vector a) +pageVector source = case source of + FlatPaged count bits values -> + V.generate + (pagesFor bits count) + (\index -> + let !offset = index `shiftL` bits + !width = min (pageSize bits) (count - offset) + in U.unsafeSlice offset width values + ) + SharedPaged _ _ pages -> pages +{-# INLINE pageVector #-} + +instance (U.Unbox a, Eq a) => Eq (Paged a) where + left == right = + pagedLength left == pagedLength right + && case (left, right) of + (FlatPaged _ _ leftValues, FlatPaged _ _ rightValues) -> + leftValues == rightValues + _ -> pagedChunksEqual left right + +-- Structural equality is a join shortcut and must not materialize either +-- operand. Chunks are compared over the overlap of the two page geometries, +-- so operands with different page widths still compare slice against slice. +pagedChunksEqual :: (U.Unbox a, Eq a) => Paged a -> Paged a -> Bool +pagedChunksEqual left right = walk 0 + where + !count = pagedLength left + !leftBits = pagedBits left + !rightBits = pagedBits right + leftPages = pageVector left + rightPages = pageVector right + walk !offset + | offset >= count = True + | otherwise = + let !leftPage = V.unsafeIndex leftPages (pageOf leftBits offset) + !leftOffset = offsetOf leftBits offset + !rightPage = V.unsafeIndex rightPages (pageOf rightBits offset) + !rightOffset = offsetOf rightBits offset + !width = + min + (count - offset) + ( min + (U.length leftPage - leftOffset) + (U.length rightPage - rightOffset) + ) + in U.unsafeSlice leftOffset width leftPage + == U.unsafeSlice rightOffset width rightPage + && walk (offset + width) + +instance (U.Unbox a, Show a) => Show (Paged a) where + showsPrec precedence = showsPrec precedence . U.toList . toVector + +instance NFData (Paged a) where + rnf paged = + case paged of + FlatPaged count bits values -> count `seq` bits `seq` values `seq` () + SharedPaged count bits pages -> + count `seq` bits `seq` V.foldl' (\() page -> page `seq` ()) () pages + +emptyPaged :: Paged a +emptyPaged = SharedPaged 0 traversalPageBits V.empty + +-- The padding belongs to page publication rather than dense ingress. A dense +-- plane stores exactly its live sequence and therefore needs no tail value. +fromVector :: U.Unbox a => a -> U.Vector a -> Paged a +fromVector _padding values = FlatPaged (U.length values) traversalPageBits values + +-- | Dense ingress whose future edits are expected to be local. The value is +-- still one flat plane until a transaction publishes a changed leaf. +fromLocalVector :: U.Unbox a => a -> U.Vector a -> Paged a +fromLocalVector _padding values = FlatPaged (U.length values) localPageBits values + +toVector :: U.Unbox a => Paged a -> U.Vector a +toVector paged = + case paged of + FlatPaged _ _ values -> values + SharedPaged count bits pages + | count <= 0 -> U.empty + | otherwise -> runST $ do + output <- MUV.new count + let copyPage !pageIndex !offset + | offset >= count = pure () + | otherwise = do + let !width = min (pageSize bits) (count - offset) + U.copy + (MUV.unsafeSlice offset width output) + (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex)) + copyPage (pageIndex + 1) (offset + width) + copyPage 0 0 + U.unsafeFreeze output + +pagedUnsafeIndex :: U.Unbox a => Paged a -> Int -> a +pagedUnsafeIndex paged index = + case paged of + FlatPaged _ _ values -> U.unsafeIndex values index + SharedPaged _ bits pages -> + U.unsafeIndex (V.unsafeIndex pages (pageOf bits index)) (offsetOf bits index) +{-# INLINE pagedUnsafeIndex #-} + +pagedFoldl' :: U.Unbox a => (b -> a -> b) -> b -> Paged a -> b +pagedFoldl' step initial paged = + case paged of + FlatPaged _ _ values -> U.foldl' step initial values + SharedPaged count bits pages -> foldPages 0 0 initial + where + foldPages !pageIndex !offset !accumulated + | offset >= count = accumulated + | otherwise = + let !width = min (pageSize bits) (count - offset) + !next = + U.foldl' + step + accumulated + (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex)) + in foldPages (pageIndex + 1) (offset + width) next +{-# INLINE pagedFoldl' #-} + +-- | Allocate the one contiguous mutable arena owned by a fresh constructor. +newMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a) +newMutablePaged capacity = MutableFlatPaged traversalPageBits <$> MUV.new (max 0 capacity) + +newLocalMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a) +newLocalMutablePaged capacity = MutableFlatPaged localPageBits <$> MUV.new (max 0 capacity) + +-- | Derive a copy-on-write page table from a published plane. Flat bases +-- become zero-copy slices of their one ByteArray; already shared bases reuse +-- their page vectors. Capacity-only tail pages all point to one empty sentinel +-- and acquire storage only when an append first writes them. Reads stay one +-- direct page-table access — 2026-08-05, measured: routing reads through a +-- dirty-map overlay instead taxed every walk and regressed the local verbs by +-- 2x, so the table is built eagerly and only publication consults ownership. +thawPaged :: U.Unbox a => Int -> Paged a -> ST s (MutablePaged s a) +thawPaged requestedCapacity paged = do + let !count = pagedLength paged + !capacity = max requestedCapacity count + !bits = pagedBits paged + !basePages = pageVector paged + !basePageCount = V.length basePages + !pageCount = pagesFor bits capacity + pages <- MV.new pageCount + owned <- MUV.replicate pageCount False + ownedCount <- newSTRef 0 + sentinel <- MUV.new 0 + V.imapM_ + (\index immutablePage -> + U.unsafeThaw immutablePage >>= MV.unsafeWrite pages index + ) + basePages + MV.set + (MV.unsafeSlice basePageCount (pageCount - basePageCount) pages) + sentinel + pure (MutableSharedPaged bits paged basePages pages owned ownedCount) + +-- | The two lawful physical sections of one transaction boundary. Both +-- publish the same canonical sequence; they differ in what the transaction +-- pays for. The choice belongs to the operation that knows its own edit +-- volume, never to a public caller. +data TransactionShape = DenseTransaction | LocalTransaction + +thawPagedShaped :: U.Unbox a => TransactionShape -> Int -> Paged a -> ST s (MutablePaged s a) +thawPagedShaped shape = case shape of + DenseTransaction -> thawPagedDense + LocalTransaction -> thawPaged +{-# INLINE thawPagedShaped #-} + +-- | Materialize one dense mutable arena from a published value. A batch +-- transaction amortizes this single copy over many edits and then reads and +-- writes flat storage with no page bookkeeping; the copy-on-write 'thawPaged' +-- remains the local-edit section whose publication is proportional to dirty +-- pages. Both freeze to the same canonical sequence. +thawPagedDense :: U.Unbox a => Int -> Paged a -> ST s (MutablePaged s a) +thawPagedDense requestedCapacity paged = do + let !count = pagedLength paged + !capacity = max requestedCapacity count + values <- MUV.new capacity + case paged of + FlatPaged _ _ source -> + U.copy (MUV.unsafeSlice 0 count values) source + SharedPaged _ bits pages -> + let copyPage !pageIndex !offset + | offset >= count = pure () + | otherwise = do + let !width = min (pageSize bits) (count - offset) + U.copy + (MUV.unsafeSlice offset width values) + (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex)) + copyPage (pageIndex + 1) (offset + width) + in copyPage 0 0 + pure (MutableFlatPaged (pagedBits paged) values) + +readPaged :: U.Unbox a => MutablePaged s a -> Int -> ST s a +readPaged mutable index = + case mutable of + MutableFlatPaged _ values -> MUV.unsafeRead values index + MutableSharedPaged bits _ _ pages _ _ -> do + page <- MV.unsafeRead pages (pageOf bits index) + MUV.unsafeRead page (offsetOf bits index) +{-# INLINE readPaged #-} + +writePaged :: U.Unbox a => MutablePaged s a -> Int -> a -> ST s () +writePaged mutable index value = + case mutable of + MutableFlatPaged _ values -> MUV.unsafeWrite values index value + MutableSharedPaged bits _ _ pages owned ownedCount -> do + let !slot = pageOf bits index + mine <- MUV.unsafeRead owned slot + page <- + if mine + then MV.unsafeRead pages slot + else acquireSharedWritablePage (pageSize bits) pages owned ownedCount slot + MUV.unsafeWrite page (offsetOf bits index) value +{-# INLINE writePaged #-} + +-- Keep the once-per-page copy-on-write transition behind one compiled +-- boundary. Both steady-state write paths remain inline; dependent modules do +-- not repeatedly simplify page cloning into every element write. +acquireSharedWritablePage + :: U.Unbox a + => Int + -> MV.MVector s (MUV.MVector s a) + -> MUV.MVector s Bool + -> STRef s Int + -> Int + -> ST s (MUV.MVector s a) +acquireSharedWritablePage width pages owned ownedCount slot = do + shared <- MV.unsafeRead pages slot + copy <- + if MUV.length shared == width + then MUV.clone shared + else do + copy <- MUV.new width + MUV.copy (MUV.unsafeSlice 0 (MUV.length shared) copy) shared + pure copy + MV.unsafeWrite pages slot copy + MUV.unsafeWrite owned slot True + modifySTRef' ownedCount (+ 1) + pure copy +{-# INLINE[0] acquireSharedWritablePage #-} + +freezePaged :: U.Unbox a => Int -> MutablePaged s a -> ST s (Paged a) +freezePaged count mutable + | count <= 0 = pure emptyPaged + | otherwise = + case mutable of + -- 'U.take' is an O(1) slice, so freezing that way republishes the whole + -- growth reservation and holds it for the lifetime of the value. The + -- arena is deliberately loose during construction; carrying that slack + -- past publication is not the same decision. Above an eighth the copy + -- is paid once and the dead tail is released, which is also what the + -- shared branch below already does by generating exactly its pages. + MutableFlatPaged bits values + | MUV.length values <= count + (count `quot` 8) -> + FlatPaged count bits . U.take count <$> U.unsafeFreeze values + | otherwise -> + FlatPaged count bits <$> U.freeze (MUV.unsafeSlice 0 count values) + MutableSharedPaged bits base basePages pages owned ownedCount -> do + dirtyPages <- readSTRef ownedCount + if dirtyPages == 0 && count == pagedLength base + -- An untouched plane republishes as the value it opened on. + then pure base + else + SharedPaged count bits + <$> V.generateM + (pagesFor bits count) + (\index -> do + mine <- MUV.unsafeRead owned index + if mine + then MV.unsafeRead pages index >>= U.unsafeFreeze + else + if index >= V.length basePages + -- A clean slot past the base geometry still holds + -- the zero-length sentinel; publish allocated + -- storage instead, matching the flat arena's + -- answer to an unwritten tail. + then MUV.new (pageSize bits) >>= U.unsafeFreeze + else pure (V.unsafeIndex basePages index) + ) diff --git a/src-core/Moonlight/Triangulation/LineSideInfo.hs b/src-core/Moonlight/Triangulation/LineSideInfo.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/LineSideInfo.hs @@ -0,0 +1,55 @@ +-- | Which side of a directed line a point falls on, as a total three-valued +-- answer that carries the collinear case rather than rounding it away. +module Moonlight.Triangulation.LineSideInfo + ( LineSideInfo + , fromDeterminant + , fromOrdering + , sideOrdering + , isOnLeftSide + , isOnRightSide + , isOnLine + , isOnLeftSideOrLine + , isOnRightSideOrLine + , reverseSide + ) where + +-- | A three-valued side: the collinear case is a value, not a rounding. +newtype LineSideInfo = LineSideInfo Ordering + deriving stock (Show) + deriving newtype (Eq, Ord) + +-- | The side an orientation determinant's sign names. +fromDeterminant :: Double -> LineSideInfo +fromDeterminant value = LineSideInfo (compare value 0) +{-# INLINE fromDeterminant #-} + +-- | The side an 'Ordering' names. +fromOrdering :: Ordering -> LineSideInfo +fromOrdering = LineSideInfo +{-# INLINE fromOrdering #-} + +-- | The underlying 'Ordering'. +sideOrdering :: LineSideInfo -> Ordering +sideOrdering (LineSideInfo ordering) = ordering +{-# INLINE sideOrdering #-} + +-- | The five side tests; the @OrLine@ pair admit the collinear case. +isOnLeftSide, isOnRightSide, isOnLine, isOnLeftSideOrLine, isOnRightSideOrLine :: LineSideInfo -> Bool +isOnLeftSide (LineSideInfo ordering) = ordering == GT +isOnRightSide (LineSideInfo ordering) = ordering == LT +isOnLine (LineSideInfo ordering) = ordering == EQ +isOnLeftSideOrLine side = not (isOnRightSide side) +isOnRightSideOrLine side = not (isOnLeftSide side) +{-# INLINE isOnLeftSide #-} +{-# INLINE isOnRightSide #-} +{-# INLINE isOnLine #-} +{-# INLINE isOnLeftSideOrLine #-} +{-# INLINE isOnRightSideOrLine #-} + +-- | The same point, seen along the reversed line. +reverseSide :: LineSideInfo -> LineSideInfo +reverseSide (LineSideInfo ordering) = LineSideInfo $ case ordering of + LT -> GT + EQ -> EQ + GT -> LT +{-# INLINE reverseSide #-} diff --git a/src-core/Moonlight/Triangulation/Scalar.hs b/src-core/Moonlight/Triangulation/Scalar.hs new file mode 100644 --- /dev/null +++ b/src-core/Moonlight/Triangulation/Scalar.hs @@ -0,0 +1,127 @@ +-- | The binary64 coordinate kernel and exact predicate boundary. +module Moonlight.Triangulation.Scalar + ( scalarName + , scalarByteSize + , scalarBinaryFormat + , scalarEpsilon + , scalarUnitRoundoff + , scalarCcwErrorBound + , scalarInCircleErrorBound + , orient2dCoordinates + , inCircleCoordinates + , BinaryFormat + , formatRadix + , formatMantissaDigits + , formatExponentRange + , minimumAllowedCoordinate + , maximumAllowedCoordinate + , canonicalScalarZero + ) where + +import Moonlight.Triangulation.Internal.Dyadic (exactInCircleDet, exactOrientSignDouble) + +-- | The coordinate component of canonical point identity. IEEE signed zeros +-- compare equal but hash differently by bits; every coordinate-keyed owner +-- therefore normalizes them before storage or hashing. +canonicalScalarZero :: Double -> Double +canonicalScalarZero value + | value == 0 = 0 + | otherwise = value +{-# INLINE canonicalScalarZero #-} + +data BinaryFormat = BinaryFormat + { formatRadix :: !Integer + , formatMantissaDigits :: !Int + , formatExponentRange :: !(Int, Int) + } + deriving stock (Eq, Show) + +scalarName :: String +scalarName = "binary64" + +scalarByteSize :: Int +scalarByteSize = 8 + +scalarBinaryFormat :: BinaryFormat +scalarBinaryFormat = + BinaryFormat + { formatRadix = floatRadix (0 :: Double) + , formatMantissaDigits = floatDigits (0 :: Double) + , formatExponentRange = floatRange (0 :: Double) + } + +scalarEpsilon :: Double +scalarEpsilon = 2.220446049250313e-16 + +scalarUnitRoundoff :: Double +scalarUnitRoundoff = 1.1102230246251565e-16 + +scalarCcwErrorBound :: Double +scalarCcwErrorBound = 3.3306690738754716e-16 + +scalarInCircleErrorBound :: Double +scalarInCircleErrorBound = 1.1102230246251577e-15 + +orient2dCoordinates + :: Double -> Double -> Double -> Double -> Double -> Double + -> Ordering +orient2dCoordinates = filteredOrient2dDouble + +inCircleCoordinates + :: Double -> Double -> Double -> Double + -> Double -> Double -> Double -> Double + -> Ordering +inCircleCoordinates = filteredInCircle scalarInCircleErrorBound + +-- The binary64 kernel pairs the approximation test with the +-- fixed-precision exact sign, which answers the dyadic determinant's sign in +-- machine words rather than allocated Integers whenever the exponent spread +-- allows, and defers to the dyadic determinant when it does not. +filteredOrient2dDouble + :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering +filteredOrient2dDouble ax ay bx by cx cy + | abs determinant > errorBound * determinantSum = compare determinant 0 + | otherwise = exactOrientSignDouble ax ay bx by cx cy + where + errorBound = 3.3306690738754716e-16 + !left = (ax - cx) * (by - cy) + !right = (ay - cy) * (bx - cx) + !determinant = left - right + !determinantSum = abs left + abs right +{-# INLINE filteredOrient2dDouble #-} + +filteredInCircle + :: Double + -> Double -> Double -> Double -> Double + -> Double -> Double -> Double -> Double + -> Ordering +filteredInCircle errorBound ax ay bx by cx cy dx dy + | abs determinant > errorBound * permanent = compare determinant 0 + | otherwise = compare (exactInCircleDet ax ay bx by cx cy dx dy) 0 + where + !adx = ax - dx + !ady = ay - dy + !bdx = bx - dx + !bdy = by - dy + !cdx = cx - dx + !cdy = cy - dy + !abdet = adx * bdy - bdx * ady + !bcdet = bdx * cdy - cdx * bdy + !cadet = cdx * ady - adx * cdy + !alift = adx * adx + ady * ady + !blift = bdx * bdx + bdy * bdy + !clift = cdx * cdx + cdy * cdy + !determinant = alift * bcdet + blift * cadet + clift * abdet + !permanent = + (abs (bdx * cdy) + abs (cdx * bdy)) * alift + + (abs (cdx * ady) + abs (adx * cdy)) * blift + + (abs (adx * bdy) + abs (bdx * ady)) * clift +{-# INLINE filteredInCircle #-} + +-- | The smallest coordinate magnitude the exact predicates accept. +minimumAllowedCoordinate :: Double +minimumAllowedCoordinate = 1.793662034335766e-43 + +-- | The largest coordinate magnitude the exact predicates accept. +maximumAllowedCoordinate :: Double +maximumAllowedCoordinate = 3.2138760885179806e60 diff --git a/src-dcel/Moonlight/Triangulation/Dcel.hs b/src-dcel/Moonlight/Triangulation/Dcel.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Dcel.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +-- | Constant-time observations and persistent payload updates over the +-- immutable DCEL. +module Moonlight.Triangulation.Dcel + ( outerFace + , numVertices + , numDirectedEdges + , numUndirectedEdges + , numFaces + , numInnerFaces + , vertexPoint + , vertexPoints + , vertexData + , directedEdgeData + , undirectedEdgeData + , faceData + , setVertexData + , setDirectedEdgeData + , setUndirectedEdgeData + , setFaceData + , mapVertices + , mapDirectedEdges + , mapUndirectedEdges + , mapFaces + , vertexOutEdge + , adjacentEdge + , origin + , destination + , next + , previous + , incidentFace + , isOuterDirectedEdge + , isBoundaryEdge + , isConstraintEdge + , numConstraints + , undirectedEndpoints + , faceDirectedEdges + , faceVertices + , innerFaceDirectedEdges + , innerFaceVertices + , innerFaceVertexTriples + , vertexOutgoingEdges + , clockwise + , counterClockwise + , foldFaceDirectedEdges' + , foldVertexOutgoingEdges' + , topologyIndexBytes + , geometryTopologyBytes + ) where + +import qualified Data.Vector as V +import Data.Word (Word8) +import GHC.Exts (build) +import Moonlight.Triangulation.Internal.BoxedPaged (boxedUnsafeIndex, boxedUpdate) +import Moonlight.Triangulation.Internal.Paged (pagedLength, pagedUnsafeIndex) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.PackedIndex (unpackOptionalIndex) +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Scalar (scalarByteSize) + +-- | The unique unbounded face, always stored at index zero. +outerFace :: FaceId +outerFace = FaceId 0 + +-- | Number of vertices in the mesh. +numVertices :: Triangulation mode vertex directed undirected face -> Int +numVertices = pagedLength . triPointX +{-# INLINE numVertices #-} + +numDirectedEdges :: Triangulation mode vertex directed undirected face -> Int +numDirectedEdges = (`quot` 4) . pagedLength . triHalfTopology +{-# INLINE numDirectedEdges #-} + +-- | Number of twin pairs in the mesh. +numUndirectedEdges :: Triangulation mode vertex directed undirected face -> Int +numUndirectedEdges triangulation = numDirectedEdges triangulation `quot` 2 +{-# INLINE numUndirectedEdges #-} + +-- | Number of faces, including 'outerFace'. +numFaces :: Triangulation mode vertex directed undirected face -> Int +numFaces = pagedLength . triFaceEdge +{-# INLINE numFaces #-} + +numInnerFaces :: Triangulation mode vertex directed undirected face -> Int +numInnerFaces triangulation = max 0 (numFaces triangulation - 1) +{-# INLINE numInnerFaces #-} + +-- | Authoritative geometric position of an admitted vertex handle. +vertexPoint :: Triangulation mode vertex directed undirected face -> VertexId -> Point +vertexPoint triangulation (VertexId vertex) = + let !index = fromIntegral vertex + in Point (pagedUnsafeIndex (triPointX triangulation) index) (pagedUnsafeIndex (triPointY triangulation) index) +{-# INLINE vertexPoint #-} + +vertexPoints :: Triangulation mode vertex directed undirected face -> V.Vector Point +vertexPoints triangulation = + V.generate (numVertices triangulation) (vertexPoint triangulation . VertexId . fromIntegral) +{-# INLINE vertexPoints #-} + +-- | Annotation carried by an admitted vertex handle. +vertexData :: Triangulation mode vertex directed undirected face -> VertexId -> vertex +vertexData triangulation (VertexId vertex) = + boxedUnsafeIndex (triVertexData triangulation) (fromIntegral vertex) +{-# INLINE vertexData #-} + +directedEdgeData :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> directed +directedEdgeData triangulation (DirectedEdgeId edge) = + boxedUnsafeIndex (triDirectedData triangulation) (fromIntegral edge) +{-# INLINE directedEdgeData #-} + +undirectedEdgeData :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> undirected +undirectedEdgeData triangulation (UndirectedEdgeId edge) = + boxedUnsafeIndex (triUndirectedData triangulation) (fromIntegral edge) +{-# INLINE undirectedEdgeData #-} + +faceData :: Triangulation mode vertex directed undirected face -> FaceId -> face +faceData triangulation (FaceId face) = + boxedUnsafeIndex (triFaceData triangulation) (fromIntegral face) +{-# INLINE faceData #-} + +-- | Replace one vertex annotation without changing geometry or topology. +setVertexData + :: Triangulation mode vertex directed undirected face + -> VertexId + -> vertex + -> Triangulation mode vertex directed undirected face +setVertexData triangulation (VertexId vertex) payload = + triangulation{triVertexData = boxedUpdate (fromIntegral vertex) payload (triVertexData triangulation)} + +setDirectedEdgeData + :: Triangulation mode vertex directed undirected face + -> DirectedEdgeId + -> directed + -> Triangulation mode vertex directed undirected face +setDirectedEdgeData triangulation (DirectedEdgeId edge) payload = + triangulation{triDirectedData = boxedUpdate (fromIntegral edge) payload (triDirectedData triangulation)} + +setUndirectedEdgeData + :: Triangulation mode vertex directed undirected face + -> UndirectedEdgeId + -> undirected + -> Triangulation mode vertex directed undirected face +setUndirectedEdgeData triangulation (UndirectedEdgeId edge) payload = + triangulation{triUndirectedData = boxedUpdate (fromIntegral edge) payload (triUndirectedData triangulation)} + +setFaceData + :: Triangulation mode vertex directed undirected face + -> FaceId + -> face + -> Triangulation mode vertex directed undirected face +setFaceData triangulation (FaceId face) payload = + triangulation{triFaceData = boxedUpdate (fromIntegral face) payload (triFaceData triangulation)} + +vertexOutEdge :: Triangulation mode vertex directed undirected face -> VertexId -> Maybe DirectedEdgeId +vertexOutEdge triangulation (VertexId vertex) = + DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triVertexOut triangulation) (fromIntegral vertex)) +{-# INLINE vertexOutEdge #-} + +adjacentEdge :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe DirectedEdgeId +adjacentEdge triangulation (FaceId face) = + DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triFaceEdge triangulation) (fromIntegral face)) +{-# INLINE adjacentEdge #-} + +-- | Origin vertex of an admitted directed edge. +origin :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId +origin triangulation (DirectedEdgeId edge) = + VertexId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge)) +{-# INLINE origin #-} + +-- | Destination vertex of an admitted directed edge. +destination :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId +destination triangulation = origin triangulation . reverseEdge +{-# INLINE destination #-} + +next :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId +next triangulation (DirectedEdgeId edge) = + DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 1)) +{-# INLINE next #-} + +previous :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId +previous triangulation (DirectedEdgeId edge) = + DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 2)) +{-# INLINE previous #-} + +-- | Face on the left of an admitted directed edge. +incidentFace :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> FaceId +incidentFace triangulation (DirectedEdgeId edge) = + FaceId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 3)) +{-# INLINE incidentFace #-} + +isOuterDirectedEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Bool +isOuterDirectedEdge triangulation edge = incidentFace triangulation edge == outerFace +{-# INLINE isOuterDirectedEdge #-} + +-- | Whether either orientation is incident to the outer face. +isBoundaryEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool +isBoundaryEdge triangulation edge = + let (forward, backward) = directedPair edge + in isOuterDirectedEdge triangulation forward || isOuterDirectedEdge triangulation backward +{-# INLINE isBoundaryEdge #-} + +-- | Whether the edge belongs to the constrained-edge section. +isConstraintEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool +isConstraintEdge triangulation (UndirectedEdgeId edge) = + pagedUnsafeIndex (triConstraint triangulation) (fromIntegral edge) /= (0 :: Word8) +{-# INLINE isConstraintEdge #-} + +numConstraints :: Triangulation mode vertex directed undirected face -> Int +numConstraints = triConstraintCount +{-# INLINE numConstraints #-} + +-- | Endpoints in the normalized orientation. +undirectedEndpoints :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> (VertexId, VertexId) +undirectedEndpoints triangulation edge = + let forward = normalizedDirected edge + in (origin triangulation forward, destination triangulation forward) +{-# INLINE undirectedEndpoints #-} + +-- | Boundary cycle of a face in traversal order. +faceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> [DirectedEdgeId] +faceDirectedEdges triangulation face = + case adjacentEdge triangulation face of + Nothing -> [] + Just start -> circularWalk triangulation start (next triangulation) +{-# INLINE faceDirectedEdges #-} + +-- | Origins along a face boundary cycle, in traversal order. +faceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> [VertexId] +faceVertices triangulation = map (origin triangulation) . faceDirectedEdges triangulation +{-# INLINE faceVertices #-} + +innerFaceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (DirectedEdgeId, DirectedEdgeId, DirectedEdgeId) +innerFaceDirectedEdges triangulation face + | face == outerFace = Nothing + | otherwise = do + e0 <- adjacentEdge triangulation face + let !e1 = next triangulation e0 + !e2 = next triangulation e1 + if next triangulation e2 == e0 + then Just (e0, e1, e2) + else Nothing +{-# INLINE innerFaceDirectedEdges #-} + +innerFaceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (VertexId, VertexId, VertexId) +innerFaceVertices triangulation face = do + (e0, e1, e2) <- innerFaceDirectedEdges triangulation face + pure (origin triangulation e0, origin triangulation e1, origin triangulation e2) +{-# INLINE innerFaceVertices #-} + +innerFaceVertexTriples + :: Triangulation mode vertex directed undirected face + -> V.Vector (VertexId, VertexId, VertexId) +innerFaceVertexTriples triangulation = + V.generate (numInnerFaces triangulation) $ \innerFaceIndex -> + let !faceIndex = innerFaceIndex + 1 + !firstEdge = + DirectedEdgeId + (pagedUnsafeIndex (triFaceEdge triangulation) faceIndex) + !secondEdge = next triangulation firstEdge + !thirdEdge = next triangulation secondEdge + in ( origin triangulation firstEdge + , origin triangulation secondEdge + , origin triangulation thirdEdge + ) +{-# INLINE innerFaceVertexTriples #-} + +-- | Counter-clockwise ring of directed edges originating at a vertex. +vertexOutgoingEdges :: Triangulation mode vertex directed undirected face -> VertexId -> [DirectedEdgeId] +vertexOutgoingEdges triangulation vertex = + case vertexOutEdge triangulation vertex of + Nothing -> [] + Just start -> circularWalk triangulation start (counterClockwise triangulation) +{-# INLINE vertexOutgoingEdges #-} + +clockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId +clockwise triangulation edge = next triangulation (reverseEdge edge) +{-# INLINE clockwise #-} + +counterClockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId +counterClockwise triangulation edge = reverseEdge (previous triangulation edge) +{-# INLINE counterClockwise #-} + +foldFaceDirectedEdges' + :: Triangulation mode vertex directed undirected face -> FaceId + -> (a -> DirectedEdgeId -> a) + -> a + -> a +foldFaceDirectedEdges' triangulation face step initial = + case adjacentEdge triangulation face of + Nothing -> initial + Just start -> circularFold triangulation start (next triangulation) step initial +{-# INLINE foldFaceDirectedEdges' #-} + +foldVertexOutgoingEdges' + :: Triangulation mode vertex directed undirected face -> VertexId + -> (a -> DirectedEdgeId -> a) + -> a + -> a +foldVertexOutgoingEdges' triangulation vertex step initial = + case vertexOutEdge triangulation vertex of + Nothing -> initial + Just start -> circularFold triangulation start (counterClockwise triangulation) step initial +{-# INLINE foldVertexOutgoingEdges' #-} + +-- Constraint bytes are intentionally reported separately by the CDT layer. +topologyIndexBytes :: Triangulation mode vertex directed undirected face -> Integer +topologyIndexBytes triangulation = + 4 * toInteger + ( pagedLength (triVertexOut triangulation) + + pagedLength (triHalfTopology triangulation) + + pagedLength (triFaceEdge triangulation) + ) + +geometryTopologyBytes :: Triangulation mode vertex directed undirected face -> Integer +geometryTopologyBytes triangulation = + 2 * toInteger scalarByteSize * toInteger (numVertices triangulation) + + topologyIndexBytes triangulation + +-- | The cycle reached from an edge by repeated advance, in visit order. +-- +-- Emitted forwards. Consing in reverse and reversing at the end is the right +-- shape for a strict accumulator, and the wrong one for a producer: it built +-- the ring twice and handed back a list no consumer could fuse with. The +-- guard bound is on the steps taken, which is what it was before — the two +-- forms stop after the same edges. +circularWalk + :: Triangulation mode vertex directed undirected face -> DirectedEdgeId + -> (DirectedEdgeId -> DirectedEdgeId) + -> [DirectedEdgeId] +circularWalk triangulation start advance = + build + ( \link stop -> + let go !remaining !current !visited + | remaining <= 0 = stop + | visited && current == start = stop + | otherwise = link current (go (remaining - 1) (advance current) True) + in go (numDirectedEdges triangulation + 1) start False + ) +{-# INLINE circularWalk #-} + +circularFold + :: Triangulation mode vertex directed undirected face -> DirectedEdgeId + -> (DirectedEdgeId -> DirectedEdgeId) + -> (a -> DirectedEdgeId -> a) + -> a + -> a +circularFold triangulation start advance step = + go (numDirectedEdges triangulation + 1) start False + where + go !remaining !current !visited !accumulator + | remaining <= 0 = accumulator + | visited && current == start = accumulator + | otherwise = + let !nextAccumulator = step accumulator current + in go (remaining - 1) (advance current) True nextAccumulator +{-# INLINE circularFold #-} diff --git a/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs b/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Moonlight.Triangulation.FloodFillIterator + ( DistanceMetric (..) + , CircleMetric + , CircleMetricError (..) + , RectangleMetric + , RectangleMetricError (..) + , circleMetric + , rectangleMetric + , edgesInShape + , verticesInShape + , edgesInCircle + , verticesInCircle + , edgesInRectangle + , verticesInRectangle + , floodFillFaces + , outerFaceFloodFill + , facesAtEvenBarrierDepth + ) where + +import qualified Data.IntSet as IntSet +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges) +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Types +class DistanceMetric metric where + metricContainsPoint :: metric -> Point -> Bool + metricIntersectsEdge :: metric -> Point -> Point -> Bool + metricStartPoint :: metric -> QueryPoint + +data CircleMetric = CircleMetric !(QueryPoint) !Double + deriving stock (Eq, Ord, Show) + +data CircleMetricError + = InvalidCircleCenter !PointValidationError + | NonFiniteRadiusSquared !NonFiniteValue + | NegativeRadiusSquared !Double + deriving stock (Eq, Ord, Show) + +data RectangleMetric = RectangleMetric !(QueryPoint) !(QueryPoint) !(QueryPoint) + deriving stock (Eq, Ord, Show) + +data RectangleMetricError + = InvalidRectangleLower !PointValidationError + | InvalidRectangleUpper !PointValidationError + | InvalidRectangleCenter !PointValidationError + deriving stock (Eq, Ord, Show) + +-- | A circle metric, or why the radius is unusable. +circleMetric :: Point -> Double -> Either CircleMetricError CircleMetric +circleMetric center radiusSquared = do + queryCenter <- either (Left . InvalidCircleCenter) Right (mkQueryPoint center) + case classifyNonFinite radiusSquared of + Just nonFinite -> Left (NonFiniteRadiusSquared nonFinite) + Nothing + | radiusSquared < 0 -> Left (NegativeRadiusSquared radiusSquared) + | otherwise -> Right (CircleMetric queryCenter radiusSquared) + +-- | An axis-aligned rectangle metric, or why the corners are unusable. +rectangleMetric :: Point -> Point -> Either RectangleMetricError RectangleMetric +rectangleMetric lower@(Point lowerX lowerY) upper@(Point upperX upperY) = do + queryLower <- either (Left . InvalidRectangleLower) Right (mkQueryPoint lower) + queryUpper <- either (Left . InvalidRectangleUpper) Right (mkQueryPoint upper) + queryCenter <- + either + (Left . InvalidRectangleCenter) + Right + (mkQueryPoint (Point ((lowerX + upperX) * 0.5) ((lowerY + upperY) * 0.5))) + Right (RectangleMetric queryLower queryUpper queryCenter) + +instance DistanceMetric CircleMetric where + metricContainsPoint (CircleMetric center radiusSquared) point = + squaredDistanceWide (queryPointValue center) point <= radiusSquared + metricIntersectsEdge (CircleMetric center radiusSquared) from to = + segmentDistanceSquaredWide from to (queryPointValue center) <= radiusSquared + metricStartPoint (CircleMetric center _) = center + +instance DistanceMetric RectangleMetric where + metricContainsPoint (RectangleMetric lower upper _) (Point x y) = + lowerX <= upperX && lowerY <= upperY && x >= lowerX && x <= upperX && y >= lowerY && y <= upperY + where + Point lowerX lowerY = queryPointValue lower + Point upperX upperY = queryPointValue upper + metricIntersectsEdge rectangle from to = + metricContainsPoint rectangle from + || metricContainsPoint rectangle to + || segmentRectangleIntersection rectangle from to + metricStartPoint (RectangleMetric _ _ center) = center + +-- | Edges meeting a circle. +edgesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [UndirectedEdgeId] +edgesInCircle triangulation center radiusSquared = + edgesInShape triangulation <$> circleMetric center radiusSquared + +-- | Vertices inside a circle. +verticesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [VertexId] +verticesInCircle triangulation center radiusSquared = + verticesInShape triangulation <$> circleMetric center radiusSquared + +-- | Edges meeting an axis-aligned rectangle. +edgesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [UndirectedEdgeId] +edgesInRectangle triangulation lower upper = edgesInShape triangulation <$> rectangleMetric lower upper + +-- | Vertices inside an axis-aligned rectangle. +verticesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [VertexId] +verticesInRectangle triangulation lower upper = verticesInShape triangulation <$> rectangleMetric lower upper + +-- | Edges meeting any metric shape. +edgesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [UndirectedEdgeId] +edgesInShape triangulation metric + | numVertices triangulation <= 1 = [] + | numInnerFaces triangulation == 0 = + [edge | edge <- undirectedEdges triangulation, edgeInside edge] + | otherwise = + let starts = shapeStartFaces triangulation metric + (_, accepted) = floodFillFacesWithEdges triangulation starts edgeInside + in map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList accepted) + where + edgeInside edge = + let (fromVertex, toVertex) = undirectedEndpoints triangulation edge + in metricIntersectsEdge metric (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex) + +-- | Vertices inside any metric shape. +verticesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [VertexId] +verticesInShape triangulation metric = + [ vertex + | vertex <- candidateVertices + , metricContainsPoint metric (vertexPoint triangulation vertex) + ] + where + edges = edgesInShape triangulation metric + set = foldl' addEndpoints IntSet.empty edges + addEndpoints acc edge = + let (VertexId from, VertexId to) = undirectedEndpoints triangulation edge + in IntSet.insert (fromIntegral from) (IntSet.insert (fromIntegral to) acc) + candidateVertices + | numVertices triangulation == 1 = [VertexId 0] + | otherwise = map (VertexId . fromIntegral) (IntSet.toAscList set) + +floodFillFaces + :: Triangulation mode vertex directed undirected face -> [FaceId] + -> (UndirectedEdgeId -> Bool) + -> [FaceId] +floodFillFaces triangulation starts canCross = + fst (floodFillFacesWithEdges triangulation starts canCross) + +floodFillFacesWithEdges + :: Triangulation mode vertex directed undirected face -> [FaceId] + -> (UndirectedEdgeId -> Bool) + -> ([FaceId], IntSet.IntSet) +floodFillFacesWithEdges triangulation starts canCross = + let (faces, accepted, _) = go initialStack initialVisited IntSet.empty IntSet.empty [] + in (reverse faces, accepted) + where + valid face@(FaceId value) = face /= outerFace && fromIntegral value < numFaces triangulation + (initialStack, initialVisited) = foldl' enqueueStart ([], IntSet.empty) starts + + enqueueStart state face + | valid face = enqueue face state + | otherwise = state + + go [] _ accepted rejected result = (result, accepted, rejected) + go (face : stack) visited accepted rejected result = + let (stack', visited', accepted', rejected') = + foldl' expand (stack, visited, accepted, rejected) (faceDirectedEdges triangulation face) + in go stack' visited' accepted' rejected' (face : result) + + expand (stack, visited, accepted, rejected) edge = + let undirected@(UndirectedEdgeId raw) = asUndirected edge + edgeIndex = fromIntegral raw + adjacent = incidentFace triangulation (reverseEdge edge) + edgeAdmission + | IntSet.member edgeIndex accepted = (True, accepted, rejected) + | IntSet.member edgeIndex rejected = (False, accepted, rejected) + | canCross undirected = (True, IntSet.insert edgeIndex accepted, rejected) + | otherwise = (False, accepted, IntSet.insert edgeIndex rejected) + (crosses, accepted', rejected') = edgeAdmission + (stack', visited') = + if crosses && valid adjacent + then enqueue adjacent (stack, visited) + else (stack, visited) + in (stack', visited', accepted', rejected') + + enqueue face@(FaceId value) (stack, visited) + | IntSet.member index visited = (stack, visited) + | otherwise = (face : stack, IntSet.insert index visited) + where + index = fromIntegral value + +-- | Inner faces separated from the outer face by an even minimum number of +-- barriers. A 0–1 BFS floods freely within one depth before crossing a barrier, +-- so a free-ended barrier can be walked around at depth zero while nested +-- closed barriers alternate outside and inside. +facesAtEvenBarrierDepth + :: Triangulation mode vertex directed undirected face + -> (UndirectedEdgeId -> Bool) + -> [FaceId] +facesAtEvenBarrierDepth triangulation isBarrier = + concat (evenLayers (barrierDepthLayers triangulation isBarrier)) + where + evenLayers :: [[FaceId]] -> [[FaceId]] + evenLayers (outsideLayer : _insideLayer : deeper) = + outsideLayer : evenLayers deeper + evenLayers shallow = shallow + +barrierDepthLayers + :: Triangulation mode vertex directed undirected face + -> (UndirectedEdgeId -> Bool) + -> [[FaceId]] +barrierDepthLayers triangulation isBarrier = + map (filter (/= outerFace)) (layers IntSet.empty [outerFace]) + where + known (FaceId value) = fromIntegral value < numFaces triangulation + key :: FaceId -> Int + key (FaceId value) = fromIntegral value + + layers visited frontier = case flood visited [] frontier of + ([], _) -> [] + (layer, visited') -> layer : layers visited' (concatMap (neighbours isBarrier) layer) + + flood visited acc [] = (reverse acc, visited) + flood visited acc (face : rest) + | not (known face) || IntSet.member (key face) visited = flood visited acc rest + | otherwise = + flood + (IntSet.insert (key face) visited) + (face : acc) + (neighbours (not . isBarrier) face <> rest) + + neighbours admit face = + [ incidentFace triangulation (reverseEdge edge) + | edge <- faceDirectedEdges triangulation face + , admit (asUndirected edge) + ] + +-- | Faces reachable from the outer face without crossing a barrier edge. +outerFaceFloodFill :: Triangulation mode vertex directed undirected face -> (UndirectedEdgeId -> Bool) -> [FaceId] +outerFaceFloodFill triangulation canCross = floodFillFaces triangulation starts canCross + where + starts = + [ face + | outerEdge <- faceDirectedEdges triangulation outerFace + , let edge = asUndirected outerEdge + , canCross edge + , let face = incidentFace triangulation (reverseEdge outerEdge) + , face /= outerFace + ] + +-- | The faces a shape's start point lands in. +shapeStartFaces :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [FaceId] +shapeStartFaces triangulation metric = + case locatePoint triangulation (metricStartPoint metric) of + InFace face -> [face] + OnEdge edge -> filter (/= outerFace) [incidentFace triangulation edge, incidentFace triangulation (reverseEdge edge)] + OnVertex vertex -> + intSetToFaces + (foldl' (\set edge -> let FaceId value = incidentFace triangulation edge in if value == 0 then set else IntSet.insert (fromIntegral value) set) IntSet.empty (vertexOutgoingEdges triangulation vertex)) + OutsideConvexHull _ -> + [ incidentFace triangulation (reverseEdge edge) + | edge <- faceDirectedEdges triangulation outerFace + , let from = vertexPoint triangulation (origin triangulation edge) + , let to = vertexPoint triangulation (destination triangulation edge) + , metricIntersectsEdge metric from to + , incidentFace triangulation (reverseEdge edge) /= outerFace + ] + EmptyTriangulation -> [] + where + intSetToFaces = map (FaceId . fromIntegral) . IntSet.toAscList + +segmentRectangleIntersection :: RectangleMetric -> Point -> Point -> Bool +segmentRectangleIntersection (RectangleMetric lowerQuery upperQuery _) from to + | lx > ux || ly > uy = False + | lower == upper = onClosedSegment from to lower + | otherwise = any (uncurry (segmentsIntersect from to)) boundaries + where + lower@(Point lx ly) = queryPointValue lowerQuery + upper@(Point ux uy) = queryPointValue upperQuery + boundaries = + [ (Point lx ly, Point lx uy) + , (Point lx uy, Point ux uy) + , (Point ux uy, Point ux ly) + , (Point ux ly, Point lx ly) + ] diff --git a/src-dcel/Moonlight/Triangulation/Handles.hs b/src-dcel/Moonlight/Triangulation/Handles.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles.hs @@ -0,0 +1,11 @@ +-- | The handle surface as one import: identifiers, their dynamic views, and +-- the iterator family. +module Moonlight.Triangulation.Handles + ( module Moonlight.Triangulation.Handles.HandleDefs + , module Moonlight.Triangulation.Handles.Dynamic + , module Moonlight.Triangulation.Handles.Iterators + ) where + +import Moonlight.Triangulation.Handles.Dynamic +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators diff --git a/src-dcel/Moonlight/Triangulation/Handles/Dynamic.hs b/src-dcel/Moonlight/Triangulation/Handles/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Dynamic.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RoleAnnotations #-} + +module Moonlight.Triangulation.Handles.Dynamic + ( InnerTag + , PossiblyOuterTag + , FixedFaceHandle + , asPossiblyOuter + , fixedFaceId + , VertexHandle + , DirectedEdgeHandle + , UndirectedEdgeHandle + , FaceHandle + , vertexHandle + , directedEdgeHandle + , undirectedEdgeHandle + , faceHandle + , innerFaceHandle + , outerFaceHandle + , fixVertex + , fixDirectedEdge + , fixUndirectedEdge + , fixFace + , vertexHandleData + , vertexHandlePosition + , vertexHandleOutEdge + , vertexHandleOutEdges + , directedEdgeDataH + , directedEdgeFrom + , directedEdgeTo + , directedEdgeVertices + , directedEdgePositions + , directedEdgeReverse + , directedEdgeNext + , directedEdgePrevious + , directedEdgeClockwise + , directedEdgeCounterClockwise + , directedEdgeFace + , directedEdgeAsUndirected + , directedEdgeIsOuter + , directedEdgeSideQuery + , directedEdgeOppositeVertex + , directedEdgeOppositePosition + , directedEdgeProjectionFactor + , directedEdgeNearestPoint + , undirectedEdgeDataH + , undirectedEdgeAsDirected + , undirectedEdgeVertices + , undirectedEdgeIsConstraint + , undirectedEdgeIsBoundary + , faceDataH + , faceIsOuter + , faceAsInner + , faceAdjacentEdge + , faceAdjacentEdges + , innerFaceVertices + , innerFaceCircumcenter + , innerFacePositions + , innerFaceBarycentric + ) where + +import Moonlight.Triangulation.Dcel qualified as Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.LineSideInfo (LineSideInfo) +import Moonlight.Triangulation.Math qualified as Math +import Moonlight.Triangulation.Types + +-- | A face handle that is statically known not to denote the outer face. +data InnerTag + +-- | A face handle that may denote the unique outer face. +data PossiblyOuterTag + +type role FixedFaceHandle nominal +newtype FixedFaceHandle tag = FixedFaceHandle { unFixedFaceHandle :: FaceId } + deriving stock (Show) + deriving newtype (Eq, Ord) + +asPossiblyOuter :: FixedFaceHandle InnerTag -> FixedFaceHandle PossiblyOuterTag +asPossiblyOuter (FixedFaceHandle face) = FixedFaceHandle face +{-# INLINE asPossiblyOuter #-} + +fixedFaceId :: FixedFaceHandle tag -> FaceId +fixedFaceId (FixedFaceHandle face) = face +{-# INLINE fixedFaceId #-} + +data VertexHandle mode vertex directed undirected face = VertexHandle + !(Triangulation mode vertex directed undirected face) + !VertexId + +data DirectedEdgeHandle mode vertex directed undirected face = DirectedEdgeHandle + !(Triangulation mode vertex directed undirected face) + !DirectedEdgeId + +data UndirectedEdgeHandle mode vertex directed undirected face = UndirectedEdgeHandle + !(Triangulation mode vertex directed undirected face) + !UndirectedEdgeId + +data FaceHandle tag mode vertex directed undirected face = FaceHandle + !(Triangulation mode vertex directed undirected face) + !(FixedFaceHandle tag) + +instance Show (VertexHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixVertex + +instance Show (DirectedEdgeHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixDirectedEdge + +instance Show (UndirectedEdgeHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixUndirectedEdge + +instance Show (FaceHandle tag mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixFace + +vertexHandle + :: Triangulation mode vertex directed undirected face + -> VertexId + -> Maybe (VertexHandle mode vertex directed undirected face) +vertexHandle triangulation vertex@(VertexId raw) + | fromIntegral raw < Dcel.numVertices triangulation = Just (VertexHandle triangulation vertex) + | otherwise = Nothing + +directedEdgeHandle + :: Triangulation mode vertex directed undirected face + -> DirectedEdgeId + -> Maybe (DirectedEdgeHandle mode vertex directed undirected face) +directedEdgeHandle triangulation edge@(DirectedEdgeId raw) + | fromIntegral raw < Dcel.numDirectedEdges triangulation = Just (DirectedEdgeHandle triangulation edge) + | otherwise = Nothing + +undirectedEdgeHandle + :: Triangulation mode vertex directed undirected face + -> UndirectedEdgeId + -> Maybe (UndirectedEdgeHandle mode vertex directed undirected face) +undirectedEdgeHandle triangulation edge@(UndirectedEdgeId raw) + | fromIntegral raw < Dcel.numUndirectedEdges triangulation = Just (UndirectedEdgeHandle triangulation edge) + | otherwise = Nothing + +faceHandle + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Maybe (FaceHandle PossiblyOuterTag mode vertex directed undirected face) +faceHandle triangulation face@(FaceId raw) + | fromIntegral raw < Dcel.numFaces triangulation = Just (FaceHandle triangulation (FixedFaceHandle face)) + | otherwise = Nothing + +innerFaceHandle + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Maybe (FaceHandle InnerTag mode vertex directed undirected face) +innerFaceHandle triangulation face + | face == Dcel.outerFace = Nothing + | otherwise = do + FaceHandle _ (FixedFaceHandle valid) <- faceHandle triangulation face + pure (FaceHandle triangulation (FixedFaceHandle valid)) + +outerFaceHandle + :: Triangulation mode vertex directed undirected face + -> FaceHandle PossiblyOuterTag mode vertex directed undirected face +outerFaceHandle triangulation = FaceHandle triangulation (FixedFaceHandle Dcel.outerFace) + +fixVertex :: VertexHandle mode vertex directed undirected face -> VertexId +fixVertex (VertexHandle _ vertex) = vertex +{-# INLINE fixVertex #-} + +fixDirectedEdge :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeId +fixDirectedEdge (DirectedEdgeHandle _ edge) = edge +{-# INLINE fixDirectedEdge #-} + +fixUndirectedEdge :: UndirectedEdgeHandle mode vertex directed undirected face -> UndirectedEdgeId +fixUndirectedEdge (UndirectedEdgeHandle _ edge) = edge +{-# INLINE fixUndirectedEdge #-} + +fixFace :: FaceHandle tag mode vertex directed undirected face -> FixedFaceHandle tag +fixFace (FaceHandle _ face) = face +{-# INLINE fixFace #-} + +vertexHandleData :: VertexHandle mode vertex directed undirected face -> vertex +vertexHandleData (VertexHandle triangulation vertex) = Dcel.vertexData triangulation vertex +{-# INLINE vertexHandleData #-} + +vertexHandlePosition + :: VertexHandle mode vertex directed undirected face + -> Point +vertexHandlePosition (VertexHandle triangulation vertex) = (Dcel.vertexPoint triangulation vertex) +{-# INLINE vertexHandlePosition #-} + +vertexHandleOutEdge + :: VertexHandle mode vertex directed undirected face + -> Maybe (DirectedEdgeHandle mode vertex directed undirected face) +vertexHandleOutEdge (VertexHandle triangulation vertex) = DirectedEdgeHandle triangulation <$> Dcel.vertexOutEdge triangulation vertex + +vertexHandleOutEdges + :: VertexHandle mode vertex directed undirected face + -> [DirectedEdgeHandle mode vertex directed undirected face] +vertexHandleOutEdges (VertexHandle triangulation vertex) = map (DirectedEdgeHandle triangulation) (Dcel.vertexOutgoingEdges triangulation vertex) + +directedEdgeDataH :: DirectedEdgeHandle mode vertex directed undirected face -> directed +directedEdgeDataH (DirectedEdgeHandle triangulation edge) = Dcel.directedEdgeData triangulation edge +{-# INLINE directedEdgeDataH #-} + +directedEdgeFrom :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face +directedEdgeFrom (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.origin triangulation edge) +{-# INLINE directedEdgeFrom #-} + +directedEdgeTo :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face +directedEdgeTo (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.destination triangulation edge) +{-# INLINE directedEdgeTo #-} + +directedEdgeVertices + :: DirectedEdgeHandle mode vertex directed undirected face + -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face) +directedEdgeVertices edge = (directedEdgeFrom edge, directedEdgeTo edge) + +directedEdgePositions + :: DirectedEdgeHandle mode vertex directed undirected face + -> (Point, Point) +directedEdgePositions edge = (vertexHandlePosition (directedEdgeFrom edge), vertexHandlePosition (directedEdgeTo edge)) +{-# INLINE directedEdgePositions #-} + +directedEdgeReverse :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face +directedEdgeReverse (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (reverseEdge edge) +{-# INLINE directedEdgeReverse #-} + +directedEdgeNext :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face +directedEdgeNext (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.next triangulation edge) +{-# INLINE directedEdgeNext #-} + +directedEdgePrevious :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face +directedEdgePrevious (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.previous triangulation edge) +{-# INLINE directedEdgePrevious #-} + +directedEdgeClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face +directedEdgeClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.clockwise triangulation edge) +{-# INLINE directedEdgeClockwise #-} + +directedEdgeCounterClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face +directedEdgeCounterClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.counterClockwise triangulation edge) +{-# INLINE directedEdgeCounterClockwise #-} + +directedEdgeFace + :: DirectedEdgeHandle mode vertex directed undirected face + -> FaceHandle PossiblyOuterTag mode vertex directed undirected face +directedEdgeFace (DirectedEdgeHandle triangulation edge) = FaceHandle triangulation (FixedFaceHandle (Dcel.incidentFace triangulation edge)) + +directedEdgeAsUndirected + :: DirectedEdgeHandle mode vertex directed undirected face + -> UndirectedEdgeHandle mode vertex directed undirected face +directedEdgeAsUndirected (DirectedEdgeHandle triangulation edge) = UndirectedEdgeHandle triangulation (asUndirected edge) + +directedEdgeIsOuter :: DirectedEdgeHandle mode vertex directed undirected face -> Bool +directedEdgeIsOuter = faceIsOuter . directedEdgeFace + +directedEdgeSideQuery + :: DirectedEdgeHandle mode vertex directed undirected face + -> Point + -> LineSideInfo +directedEdgeSideQuery edge query = + let (from, to) = directedEdgePositions edge + in Math.sideQuery from to query + +undirectedEdgeDataH :: UndirectedEdgeHandle mode vertex directed undirected face -> undirected +undirectedEdgeDataH (UndirectedEdgeHandle triangulation edge) = Dcel.undirectedEdgeData triangulation edge +{-# INLINE undirectedEdgeDataH #-} + +undirectedEdgeAsDirected + :: UndirectedEdgeHandle mode vertex directed undirected face + -> DirectedEdgeHandle mode vertex directed undirected face +undirectedEdgeAsDirected (UndirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (normalizedDirected edge) + +undirectedEdgeVertices + :: UndirectedEdgeHandle mode vertex directed undirected face + -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face) +undirectedEdgeVertices = directedEdgeVertices . undirectedEdgeAsDirected + +faceDataH :: FaceHandle tag mode vertex directed undirected face -> face +faceDataH (FaceHandle triangulation (FixedFaceHandle face)) = Dcel.faceData triangulation face +{-# INLINE faceDataH #-} + +faceIsOuter :: FaceHandle tag mode vertex directed undirected face -> Bool +faceIsOuter (FaceHandle _ (FixedFaceHandle face)) = face == Dcel.outerFace +{-# INLINE faceIsOuter #-} + +faceAsInner + :: FaceHandle PossiblyOuterTag mode vertex directed undirected face + -> Maybe (FaceHandle InnerTag mode vertex directed undirected face) +faceAsInner handle@(FaceHandle triangulation (FixedFaceHandle face)) + | faceIsOuter handle = Nothing + | otherwise = Just (FaceHandle triangulation (FixedFaceHandle face)) + +faceAdjacentEdge + :: FaceHandle tag mode vertex directed undirected face + -> Maybe (DirectedEdgeHandle mode vertex directed undirected face) +faceAdjacentEdge (FaceHandle triangulation (FixedFaceHandle face)) = DirectedEdgeHandle triangulation <$> Dcel.adjacentEdge triangulation face + +faceAdjacentEdges + :: FaceHandle tag mode vertex directed undirected face + -> [DirectedEdgeHandle mode vertex directed undirected face] +faceAdjacentEdges (FaceHandle triangulation (FixedFaceHandle face)) = map (DirectedEdgeHandle triangulation) (Dcel.faceDirectedEdges triangulation face) + +innerFaceVertices + :: FaceHandle InnerTag mode vertex directed undirected face + -> Maybe + ( VertexHandle mode vertex directed undirected face + , VertexHandle mode vertex directed undirected face + , VertexHandle mode vertex directed undirected face + ) +innerFaceVertices (FaceHandle triangulation (FixedFaceHandle face)) = + (\(a, b, c) -> (VertexHandle triangulation a, VertexHandle triangulation b, VertexHandle triangulation c)) + <$> Dcel.innerFaceVertices triangulation face + +innerFaceCircumcenter + :: FaceHandle InnerTag mode vertex directed undirected face + -> Maybe (Point) +innerFaceCircumcenter face = do + (a, b, c) <- innerFaceVertices face + Math.circumcenter (vertexHandlePosition a) (vertexHandlePosition b) (vertexHandlePosition c) + +directedEdgeOppositeVertex + :: DirectedEdgeHandle mode vertex directed undirected face + -> Maybe (VertexHandle mode vertex directed undirected face) +directedEdgeOppositeVertex (DirectedEdgeHandle triangulation edge) + | Dcel.incidentFace triangulation edge == Dcel.outerFace = Nothing + | otherwise = + Just (VertexHandle triangulation (Dcel.destination triangulation (Dcel.next triangulation edge))) + +directedEdgeOppositePosition + :: DirectedEdgeHandle mode vertex directed undirected face + -> Maybe (Point) +directedEdgeOppositePosition = fmap vertexHandlePosition . directedEdgeOppositeVertex +{-# INLINE directedEdgeOppositePosition #-} + +directedEdgeProjectionFactor + :: DirectedEdgeHandle mode vertex directed undirected face + -> Point + -> Double +directedEdgeProjectionFactor edge query = + let (from, to) = directedEdgePositions edge + in Math.projectionFactor from to query + +directedEdgeNearestPoint + :: DirectedEdgeHandle mode vertex directed undirected face + -> Point + -> Point +directedEdgeNearestPoint edge query = + let (from@(Point ax ay), to@(Point bx by)) = directedEdgePositions edge + factor = max 0 (min 1 (Math.projectionFactor from to query)) + in Point (ax + factor * (bx - ax)) (ay + factor * (by - ay)) + +undirectedEdgeIsConstraint + :: UndirectedEdgeHandle mode vertex directed undirected face + -> Bool +undirectedEdgeIsConstraint (UndirectedEdgeHandle triangulation edge) = + Dcel.isConstraintEdge triangulation edge + +undirectedEdgeIsBoundary + :: UndirectedEdgeHandle mode vertex directed undirected face + -> Bool +undirectedEdgeIsBoundary (UndirectedEdgeHandle triangulation edge) = + Dcel.isBoundaryEdge triangulation edge + +innerFacePositions + :: FaceHandle InnerTag mode vertex directed undirected face + -> Maybe (Point, Point, Point) +innerFacePositions face = do + (a, b, c) <- innerFaceVertices face + pure (vertexHandlePosition a, vertexHandlePosition b, vertexHandlePosition c) +{-# INLINE innerFacePositions #-} + +innerFaceBarycentric + :: FaceHandle InnerTag mode vertex directed undirected face + -> Point + -> Maybe (Double, Double, Double) +innerFaceBarycentric face query = do + (a, b, c) <- innerFacePositions face + Math.barycentricCoordinates a b c query diff --git a/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs b/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | The identifier family and the arithmetic on it: a directed edge's twin is +-- its index complement, so orientation is a bit rather than a lookup. +module Moonlight.Triangulation.Handles.HandleDefs + ( VertexId (..) + , FaceId (..) + , DirectedEdgeId (..) + , UndirectedEdgeId (..) + , reverseEdge + , asUndirected + , normalizedDirected + , reversedDirected + , directedPair + , isNormalized + ) where + +import Control.DeepSeq (NFData) +import Data.Bits (shiftL, shiftR, xor, (.&.)) +import Data.Word (Word32) + +-- | Index of a vertex in the immutable DCEL. +newtype VertexId = VertexId { unVertexId :: Word32 } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +-- | Index of a face in the immutable DCEL; zero denotes the outer face. +newtype FaceId = FaceId { unFaceId :: Word32 } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +-- | Oriented half-edge index. Twin orientations differ only in the low bit. +newtype DirectedEdgeId = DirectedEdgeId { unDirectedEdgeId :: Word32 } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +-- | Index of a twin pair, with orientation forgotten. +newtype UndirectedEdgeId = UndirectedEdgeId { unUndirectedEdgeId :: Word32 } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +-- | Select the opposite orientation of the same undirected edge. +reverseEdge :: DirectedEdgeId -> DirectedEdgeId +reverseEdge (DirectedEdgeId edge) = DirectedEdgeId (edge `xor` 1) +{-# INLINE reverseEdge #-} + +-- | Forget a directed edge's orientation. +asUndirected :: DirectedEdgeId -> UndirectedEdgeId +asUndirected (DirectedEdgeId edge) = UndirectedEdgeId (edge `shiftR` 1) +{-# INLINE asUndirected #-} + +-- | Select the even-indexed orientation of an undirected edge. +normalizedDirected :: UndirectedEdgeId -> DirectedEdgeId +normalizedDirected (UndirectedEdgeId edge) = DirectedEdgeId (edge `shiftL` 1) +{-# INLINE normalizedDirected #-} + +-- | Select the odd-indexed orientation of an undirected edge. +reversedDirected :: UndirectedEdgeId -> DirectedEdgeId +reversedDirected edge = reverseEdge (normalizedDirected edge) +{-# INLINE reversedDirected #-} + +-- | Both orientations, normalized first and reversed second. +directedPair :: UndirectedEdgeId -> (DirectedEdgeId, DirectedEdgeId) +directedPair edge = (normalizedDirected edge, reversedDirected edge) +{-# INLINE directedPair #-} + +-- | Whether a directed edge is the normalized orientation of its pair. +isNormalized :: DirectedEdgeId -> Bool +isNormalized (DirectedEdgeId edge) = edge .&. 1 == 0 +{-# INLINE isNormalized #-} diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs @@ -0,0 +1,13 @@ +-- | The iterator family over a mesh: whole-mesh ranges, incidence fans, the +-- circular walk they are built from, and the hull. +module Moonlight.Triangulation.Handles.Iterators + ( module Moonlight.Triangulation.Handles.Iterators.CircularIterator + , module Moonlight.Triangulation.Handles.Iterators.DynamicIterators + , module Moonlight.Triangulation.Handles.Iterators.FixedIterators + , module Moonlight.Triangulation.Handles.Iterators.HullIterator + ) where + +import Moonlight.Triangulation.Handles.Iterators.CircularIterator +import Moonlight.Triangulation.Handles.Iterators.DynamicIterators +import Moonlight.Triangulation.Handles.Iterators.FixedIterators +import Moonlight.Triangulation.Handles.Iterators.HullIterator diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators/CircularIterator.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators/CircularIterator.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Iterators/CircularIterator.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Triangulation.Handles.Iterators.CircularIterator + ( circularList + , foldCircular' + ) where + +import GHC.Exts (build) + +-- | The cycle reached from a start by repeated advance, in visit order. +-- +-- Emitted forwards, for the reason 'Moonlight.Triangulation.Dcel.circularWalk' +-- is: accumulating in reverse and reversing at the end builds the ring twice +-- and hands back a list no consumer can fuse with. +circularList :: Eq a => Int -> (a -> a) -> a -> [a] +circularList limit advance start = + build + ( \link stop -> + let go !remaining !current !visited + | remaining <= 0 = stop + | visited && current == start = stop + | otherwise = link current (go (remaining - 1) (advance current) True) + in go limit start False + ) +{-# INLINE circularList #-} + +foldCircular' :: Eq a => Int -> (a -> a) -> a -> (b -> a -> b) -> b -> b +foldCircular' limit advance start step = go limit start False + where + go !remaining !current !visited !accumulator + | remaining <= 0 = accumulator + | visited && current == start = accumulator + | otherwise = go (remaining - 1) (advance current) True (step accumulator current) diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators/DynamicIterators.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators/DynamicIterators.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Iterators/DynamicIterators.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +module Moonlight.Triangulation.Handles.Iterators.DynamicIterators + ( vertexHandles + , directedEdgeHandles + , undirectedEdgeHandles + , allFaceHandles + , innerFaceHandles + , hullEdgeHandles + , hullVertexHandles + , foldVertexHandles' + , foldDirectedEdgeHandles' + , foldUndirectedEdgeHandles' + , foldAllFaceHandles' + , foldInnerFaceHandles' + , foldHullEdgeHandles' + , foldHullVertexHandles' + ) where + +import Moonlight.Triangulation.Handles.Dynamic +import Moonlight.Triangulation.Handles.Iterators.FixedIterators qualified as Fixed +import Moonlight.Triangulation.Handles.Iterators.HullIterator qualified as Hull +import Moonlight.Triangulation.Types + +-- | Dynamic handles in fixed-index order. The list spine is lazy; use the +-- strict folds below for allocation-free traversal in hot paths. +vertexHandles + :: Triangulation mode vertex directed undirected face + -> [VertexHandle mode vertex directed undirected face] +vertexHandles triangulation = + mapValid (vertexHandle triangulation) (Fixed.vertices triangulation) + +directedEdgeHandles + :: Triangulation mode vertex directed undirected face + -> [DirectedEdgeHandle mode vertex directed undirected face] +directedEdgeHandles triangulation = + mapValid (directedEdgeHandle triangulation) (Fixed.directedEdges triangulation) + +undirectedEdgeHandles + :: Triangulation mode vertex directed undirected face + -> [UndirectedEdgeHandle mode vertex directed undirected face] +undirectedEdgeHandles triangulation = + mapValid (undirectedEdgeHandle triangulation) (Fixed.undirectedEdges triangulation) + +allFaceHandles + :: Triangulation mode vertex directed undirected face + -> [FaceHandle PossiblyOuterTag mode vertex directed undirected face] +allFaceHandles triangulation = + mapValid (faceHandle triangulation) (Fixed.allFaces triangulation) + +innerFaceHandles + :: Triangulation mode vertex directed undirected face + -> [FaceHandle InnerTag mode vertex directed undirected face] +innerFaceHandles triangulation = + mapValid (innerFaceHandle triangulation) (Fixed.innerFaces triangulation) + +hullEdgeHandles + :: Triangulation mode vertex directed undirected face + -> [DirectedEdgeHandle mode vertex directed undirected face] +hullEdgeHandles triangulation = + mapValid (directedEdgeHandle triangulation) (Hull.hullEdges triangulation) + +hullVertexHandles + :: Triangulation mode vertex directed undirected face + -> [VertexHandle mode vertex directed undirected face] +hullVertexHandles triangulation = + map directedEdgeFrom (hullEdgeHandles triangulation) + +foldVertexHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldVertexHandles' triangulation step = + Fixed.foldVertices' triangulation (applyValid (vertexHandle triangulation) step) + +foldDirectedEdgeHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldDirectedEdgeHandles' triangulation step = + Fixed.foldDirectedEdges' triangulation (applyValid (directedEdgeHandle triangulation) step) + +foldUndirectedEdgeHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> UndirectedEdgeHandle mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldUndirectedEdgeHandles' triangulation step = + Fixed.foldUndirectedEdges' triangulation (applyValid (undirectedEdgeHandle triangulation) step) + +foldAllFaceHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> FaceHandle PossiblyOuterTag mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldAllFaceHandles' triangulation step = + Fixed.foldAllFaces' triangulation (applyValid (faceHandle triangulation) step) + +foldInnerFaceHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> FaceHandle InnerTag mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldInnerFaceHandles' triangulation step = + Fixed.foldInnerFaces' triangulation (applyValid (innerFaceHandle triangulation) step) + +foldHullEdgeHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldHullEdgeHandles' triangulation step = + Hull.foldHullEdges' triangulation (applyValid (directedEdgeHandle triangulation) step) + +foldHullVertexHandles' + :: Triangulation mode vertex directed undirected face + -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator) + -> accumulator + -> accumulator +foldHullVertexHandles' triangulation step = + foldHullEdgeHandles' triangulation (\accumulator edge -> step accumulator (directedEdgeFrom edge)) + +mapValid :: (fixed -> Maybe dynamic) -> [fixed] -> [dynamic] +mapValid make = foldr collect [] + where + collect fixed rest = case make fixed of + Just dynamic -> dynamic : rest + Nothing -> rest + +applyValid + :: (fixed -> Maybe dynamic) + -> (accumulator -> dynamic -> accumulator) + -> accumulator + -> fixed + -> accumulator +applyValid make step !accumulator fixed = case make fixed of + Just dynamic -> step accumulator dynamic + Nothing -> accumulator diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators/FixedIterators.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators/FixedIterators.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Iterators/FixedIterators.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Whole-mesh traversal by identifier range, each range paired with the +-- strict fold that consumes it. +module Moonlight.Triangulation.Handles.Iterators.FixedIterators + ( vertices + , directedEdges + , undirectedEdges + , allFaces + , innerFaces + , foldVertices' + , foldDirectedEdges' + , foldUndirectedEdges' + , foldAllFaces' + , foldInnerFaces' + ) where + +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Types + +-- | Every vertex identifier, ascending. +-- +-- The enumerators are producers, so their bodies have to reach the consumer's +-- module: a fold over one of these should be a loop over an index, not a walk +-- over cons cells built by a call it could not see into. +vertices :: Triangulation mode vertex directed undirected face -> [VertexId] +vertices triangulation = [VertexId (fromIntegral index) | index <- [0 .. numVertices triangulation - 1]] +{-# INLINE vertices #-} + +-- | Every directed-edge identifier, ascending. +directedEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId] +directedEdges triangulation = [DirectedEdgeId (fromIntegral index) | index <- [0 .. numDirectedEdges triangulation - 1]] +{-# INLINE directedEdges #-} + +-- | Every undirected-edge identifier, ascending. +undirectedEdges :: Triangulation mode vertex directed undirected face -> [UndirectedEdgeId] +undirectedEdges triangulation = [UndirectedEdgeId (fromIntegral index) | index <- [0 .. numUndirectedEdges triangulation - 1]] +{-# INLINE undirectedEdges #-} + +-- | Every face identifier, the outer face first. +allFaces :: Triangulation mode vertex directed undirected face -> [FaceId] +allFaces triangulation = [FaceId (fromIntegral index) | index <- [0 .. numFaces triangulation - 1]] +{-# INLINE allFaces #-} + +-- | Every face identifier except the outer face. +innerFaces :: Triangulation mode vertex directed undirected face -> [FaceId] +innerFaces triangulation = [FaceId (fromIntegral index) | index <- [1 .. numFaces triangulation - 1]] +{-# INLINE innerFaces #-} + +-- | Strict fold over 'vertices'; the rest of the family follows. +foldVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a +foldVertices' triangulation step = foldRange (numVertices triangulation) (VertexId . fromIntegral) step +{-# INLINE foldVertices' #-} + +foldDirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a +foldDirectedEdges' triangulation step = foldRange (numDirectedEdges triangulation) (DirectedEdgeId . fromIntegral) step +{-# INLINE foldDirectedEdges' #-} + +foldUndirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> UndirectedEdgeId -> a) -> a -> a +foldUndirectedEdges' triangulation step = foldRange (numUndirectedEdges triangulation) (UndirectedEdgeId . fromIntegral) step +{-# INLINE foldUndirectedEdges' #-} + +foldAllFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a +foldAllFaces' triangulation step = foldRange (numFaces triangulation) (FaceId . fromIntegral) step +{-# INLINE foldAllFaces' #-} + +foldInnerFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a +foldInnerFaces' triangulation step initial = go 1 initial + where + !end = numFaces triangulation + go !index !accumulator + | index >= end = accumulator + | otherwise = go (index + 1) (step accumulator (FaceId (fromIntegral index))) +{-# INLINE foldInnerFaces' #-} + +foldRange :: Int -> (Int -> b) -> (a -> b -> a) -> a -> a +foldRange end make step = go 0 + where + go !index !accumulator + | index >= end = accumulator + | otherwise = go (index + 1) (step accumulator (make index)) +{-# INLINE foldRange #-} diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators/HullIterator.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators/HullIterator.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Iterators/HullIterator.hs @@ -0,0 +1,29 @@ +-- | The convex hull, walked as its edges or as its vertices. +module Moonlight.Triangulation.Handles.Iterators.HullIterator + ( hullEdges + , hullVertices + , foldHullEdges' + , foldHullVertices' + ) where + +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Types + +-- | The convex hull as directed edges, in order. +hullEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId] +hullEdges triangulation = faceDirectedEdges triangulation outerFace +{-# INLINE hullEdges #-} + +-- | The convex hull as vertices, in order. +hullVertices :: Triangulation mode vertex directed undirected face -> [VertexId] +hullVertices triangulation = map (origin triangulation) (hullEdges triangulation) +{-# INLINE hullVertices #-} + +-- | Strict fold over 'hullEdges'. +foldHullEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a +foldHullEdges' triangulation = foldFaceDirectedEdges' triangulation outerFace + +-- | Strict fold over 'hullVertices'. +foldHullVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a +foldHullVertices' triangulation step = foldHullEdges' triangulation (\acc edge -> step acc (origin triangulation edge)) diff --git a/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs b/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Canonical.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Canonical publication: the same triangulation, renumbered so that its +-- representation is a function of its geometry alone. +module Moonlight.Triangulation.Internal.Canonical + ( canonicalize + ) where + +import Control.Monad (when) +import Control.Monad.ST (runST) +import qualified Data.Vector.Algorithms.Intro as Intro +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.Dcel (numFaces, numUndirectedEdges, numVertices, vertexData) +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Internal.Mutable +import Moonlight.Triangulation.Internal.Paged (Paged, pagedUnsafeIndex) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Types (BuildError) + +-- | Renumber a triangulation into its canonical representation. +-- +-- Two triangulations of the same sites are the same triangulation — Delaunay +-- uniqueness says so, and the tie-break on an exactly cocircular quadrilateral +-- is keyed on coordinates rather than on identifiers so that it stays true. +-- What differs between two builds of one site set is only /numbering/: which +-- vertex got index 0, which half-edge got the even slot, where a face's cycle +-- was anchored. All of that records the schedule the value was constructed by, +-- and none of it is geometry. +-- +-- This is what removes it. Every identifier is assigned from the geometry: +-- +-- * vertices in lexicographic coordinate rank; +-- * undirected edges in lexicographic rank of their endpoint pair, each +-- taken low first, so the pair is an unordered pair by construction; +-- * of a pair's two half-edges, the even slot is the one leaving the +-- lower-ranked endpoint, which keeps twinning an @xor@ with one; +-- * inner faces in order of the least half-edge on their boundary, which +-- is a single index rather than a vertex tuple and so needs no special +-- case for a cycle that is not a triangle; +-- * every anchor — each vertex's outgoing edge, each face's edge — set to +-- the least admissible half-edge. +-- +-- Construction therefore need not run in canonical order. Local insertion and +-- seam fusion may preserve their cheaper schedule-specific numbering; callers +-- invoke this operation only when they require the construction-independent +-- physical representative used to observe the finite-set laws. +-- +-- Element payloads are @()@ because a renumbering is a bijection and could +-- carry them, but nothing that wants that exists; the writers a general form +-- would need were retired when their last caller went. Vertex payloads travel +-- with their vertices, and constraint flags with their edges, so a constrained +-- triangulation canonicalizes as readily as an unconstrained one. +canonicalize + :: Triangulation mode vertex () () () + -> Either BuildError (Triangulation mode vertex () () ()) +canonicalize source = runST $ do + mutable <- newMutableDcel (triElementDefaults source) (max 1 vertexTotal) + forRange 0 vertexTotal $ \canonical -> do + let !old = vertexOrder `U.unsafeIndex` canonical + _ <- + appendVertexCoordinates + mutable + (coordinateX `pagedUnsafeIndex` old) + (coordinateY `pagedUnsafeIndex` old) + (vertexData source (VertexId (fromIntegral old))) + pure () + _ <- addEdgeBlock mutable edgeTotal + _ <- addFaceBlock mutable (faceTotal - 1) + forRange 0 directedTotal $ \canonical -> do + let !old = directedFromCanonical `U.unsafeIndex` canonical + writeOrigin mutable canonical (vertexRank `U.unsafeIndex` originOf old) + writeNext mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 1)) + writePrevious mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 2)) + writeFace mutable canonical (faceRank `U.unsafeIndex` topology (4 * old + 3)) + forRange 0 vertexTotal $ \canonical -> do + let !least = leastOutgoing `U.unsafeIndex` canonical + if least == absent + then writeVertexOut mutable canonical (-1) + else markConnected mutable canonical least + forRange 0 faceTotal $ \canonical -> do + let !least = leastOnFace `U.unsafeIndex` oldFaceOf canonical + writeFaceEdge mutable canonical (if least == absent then -1 else least) + forRange 0 edgeTotal $ \canonicalUndirected -> + when (constraintFlag `pagedUnsafeIndex` (edgeOrder `U.unsafeIndex` canonicalUndirected) /= 0) $ + () <$ setConstraint mutable (2 * canonicalUndirected) + freezeTriangulation mutable + where + !vertexTotal = numVertices source + !edgeTotal = numUndirectedEdges source + !faceTotal = numFaces source + !directedTotal = 2 * edgeTotal + + -- Read the arenas rather than the handle accessors. Every one of these is + -- indexed a few times per element, and the accessors would box a t'Point' or + -- an identifier newtype at each of them. + !coordinateX = triPointX source + !coordinateY = triPointY source + !topologyArena = triHalfTopology source + !constraintFlag = triConstraint source + topology slot = fromIntegral (topologyArena `pagedUnsafeIndex` slot) :: Int + originOf directed = topology (4 * directed) + + -- Vertices, in lexicographic coordinate rank. Sorting a vector of keys with + -- the type's own ordering rather than an index vector under a closure: the + -- comparison then specializes instead of being an unknown call per step. + -- + -- Sortedness is checked first, because a great many of the meshes handed to + -- this function already have it and the check costs one linear scan against a + -- sort's @n log n@. A seam merge is the reason: it copies two canonically + -- numbered operands into one arena, lower abscissa first, and the sites of + -- the result are then already in rank order by construction. Nothing about + -- the schedule is assumed here — the coordinates are simply read and + -- believed, so a mesh that arrives sorted for any other reason is served just + -- as well. + !alreadyRanked = coordinatesAscend vertexTotal coordinateX coordinateY + !vertexOrder + | alreadyRanked = U.enumFromN 0 vertexTotal + | otherwise = + thirdColumn $ + sortedVector + ( U.generate + vertexTotal + ( \index -> + ( coordinateX `pagedUnsafeIndex` index + , coordinateY `pagedUnsafeIndex` index + , index + ) + ) + ) + !vertexRank + | alreadyRanked = vertexOrder + | otherwise = invertPermutation vertexTotal vertexOrder + + -- Undirected edges, in lexicographic rank of their endpoint pair. + -- + -- Both components of the key are vertex ranks, so they are already dense + -- indices into a range this function knows: comparing them is a counting + -- sort's job, not a comparison sort's. Two stable passes — the high endpoint + -- first, then the low one — leave the pairs in lexicographic order, in time + -- linear in the edges and the vertices rather than @E log E@. + !edgeLow = + U.generate edgeTotal $ \index -> + min + (vertexRank `U.unsafeIndex` originOf (2 * index)) + (vertexRank `U.unsafeIndex` originOf (2 * index + 1)) + !edgeHigh = + U.generate edgeTotal $ \index -> + max + (vertexRank `U.unsafeIndex` originOf (2 * index)) + (vertexRank `U.unsafeIndex` originOf (2 * index + 1)) + !edgeOrder = + countingSortOn vertexTotal edgeLow $ + countingSortOn vertexTotal edgeHigh (U.enumFromN 0 edgeTotal) + + -- The even half of each canonical pair leaves the lower-ranked endpoint. + !directedFromCanonical = + U.generate directedTotal $ \canonical -> + let !oldEdge = edgeOrder `U.unsafeIndex` (canonical `quot` 2) + !evenHalf = 2 * oldEdge + !leavesLower = + vertexRank `U.unsafeIndex` originOf evenHalf + <= vertexRank `U.unsafeIndex` originOf (evenHalf + 1) + in if even canonical == leavesLower then evenHalf else evenHalf + 1 + !directedToCanonical = invertPermutation directedTotal directedFromCanonical + + -- The least canonical half-edge on each old face and leaving each canonical + -- vertex, in one pass. Anchors have to be a function of the geometry too, or + -- two builds of one site set would publish the same cycles anchored in + -- different places. + (!leastOnFace, !leastOutgoing) = runST $ do + faces <- MUV.replicate (max 1 faceTotal) absent + vertices <- MUV.replicate (max 1 vertexTotal) absent + forRange 0 directedTotal $ \canonical -> do + let !old = directedFromCanonical `U.unsafeIndex` canonical + !face = topology (4 * old + 3) + !rank = vertexRank `U.unsafeIndex` originOf old + onFace <- MUV.unsafeRead faces face + when (canonical < onFace) (MUV.unsafeWrite faces face canonical) + leaving <- MUV.unsafeRead vertices rank + when (canonical < leaving) (MUV.unsafeWrite vertices rank canonical) + (,) <$> U.unsafeFreeze faces <*> U.unsafeFreeze vertices + + -- Inner faces, in order of the least canonical half-edge on their boundary. + -- The outer face keeps index zero, which the arena reserves for it anyway. + -- + -- No two faces share a least half-edge, so this key is injective and the + -- ordering can be read off by inverting it: mark each face at its own least + -- half-edge, then scan the half-edges in order. That is one linear pass and + -- no comparisons at all. A face the scan never reaches has no boundary — only + -- reachable in a mesh with no edges — and follows in old index order so that + -- the result stays a permutation whatever it is handed. + !innerFaceOrder = U.create $ do + owner <- MUV.replicate (max 1 directedTotal) absent + forRange 1 faceTotal $ \face -> do + let !least = leastOnFace `U.unsafeIndex` face + when (least /= absent) (MUV.unsafeWrite owner least face) + emitted <- MUV.replicate (max 1 faceTotal) False + out <- MUV.new (max 0 (faceTotal - 1)) + let scan !slot !filled + | slot >= directedTotal = pure filled + | otherwise = do + !face <- MUV.unsafeRead owner slot + if face == absent + then scan (slot + 1) filled + else do + MUV.unsafeWrite out filled face + MUV.unsafeWrite emitted face True + scan (slot + 1) (filled + 1) + sweep !face !filled + | face >= faceTotal = pure () + | otherwise = do + !done <- MUV.unsafeRead emitted face + if done + then sweep (face + 1) filled + else do + MUV.unsafeWrite out filled face + sweep (face + 1) (filled + 1) + scan 0 0 >>= sweep 1 + pure out + !faceRank = U.create $ do + ranks <- MUV.replicate (max 1 faceTotal) 0 + U.iforM_ innerFaceOrder $ \rank old -> MUV.unsafeWrite ranks old (rank + 1) + pure ranks + oldFaceOf canonical + | canonical == 0 = 0 + | otherwise = innerFaceOrder `U.unsafeIndex` (canonical - 1) + + +-- | No half-edge reaches this face or vertex. A one-site mesh has such a +-- vertex and an edgeless outer face; the arena spells the same absence as a +-- packed sentinel, which is not a value an index may take. +absent :: Int +absent = maxBound + +-- | @[from, to)@, without materializing the range as a list. +forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m () +forRange from to action = go from + where + go !index + | index >= to = pure () + | otherwise = action index >> go (index + 1) +{-# INLINE forRange #-} + +sortedVector :: (U.Unbox key, Ord key) => U.Vector key -> U.Vector key +sortedVector = U.modify Intro.sort +{-# INLINE sortedVector #-} + +-- | Stably reorder @items@ by a key that is already a dense index below +-- @range@, in time linear in both. +-- +-- Applied least-significant key first, repeated application leaves the items in +-- lexicographic order of the whole key — which is what makes a two-component +-- ordering over vertex ranks cost @O(V + E)@ instead of @O(E log E)@. +countingSortOn :: Int -> U.Vector Int -> U.Vector Int -> U.Vector Int +countingSortOn range keys items = U.create $ do + counts <- MUV.replicate (range + 1) 0 + U.forM_ items $ \item -> + MUV.unsafeModify counts (+ 1) (keys `U.unsafeIndex` item) + let prefix !key !running + | key > range = pure () + | otherwise = do + !count <- MUV.unsafeRead counts key + MUV.unsafeWrite counts key running + prefix (key + 1) (running + count) + prefix 0 0 + out <- MUV.new (max 1 (U.length items)) + U.forM_ items $ \item -> do + let !key = keys `U.unsafeIndex` item + !slot <- MUV.unsafeRead counts key + MUV.unsafeWrite counts key (slot + 1) + MUV.unsafeWrite out slot item + pure (MUV.slice 0 (U.length items) out) + +thirdColumn :: (U.Unbox a, U.Unbox b) => U.Vector (a, b, Int) -> U.Vector Int +thirdColumn = U.map (\(_, _, index) -> index) +{-# INLINE thirdColumn #-} + +-- | Whether the stored sites are already in strict lexicographic order, in +-- which case ranking them is the identity and both permutations are free. +-- +-- Strict rather than non-strict: a triangulation stores each site once, so +-- equal adjacent coordinates would mean a mesh this function has no ordering +-- for, and it is the sort's business to say so rather than this predicate's. +coordinatesAscend :: Int -> Paged Double -> Paged Double -> Bool +coordinatesAscend total x y = go 1 + where + go !index + | index >= total = True + | otherwise = + let !previousX = x `pagedUnsafeIndex` (index - 1) + !currentX = x `pagedUnsafeIndex` index + in case compare previousX currentX of + LT -> go (index + 1) + GT -> False + EQ -> + y `pagedUnsafeIndex` (index - 1) < y `pagedUnsafeIndex` index + && go (index + 1) + +-- | @inverse ! (order ! i) == i@: the rank each element was given. +invertPermutation :: Int -> U.Vector Int -> U.Vector Int +invertPermutation count order = U.create $ do + inverse <- MUV.replicate (max 1 count) 0 + U.iforM_ order $ \rank element -> MUV.unsafeWrite inverse element rank + pure inverse diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The topology-mutating primitives, gathered from their role modules. +module Moonlight.Triangulation.Internal.DcelOperations + ( setupFirstVertex + , setupSecondVertex + , splitLineEdge + , extendLine + , lineToArea + , insertIntoFace + , insertOnEdge + , insertOutsideHull + , insertOutsideHullBetween + , closeOuterTurn + , fixHullConvexity + , flipEdge + , legalizeScratch + , legalizeEdges + , legalizeCavityFanScratch + , LegalizationLaw (..) + , seedStarScratch + , seedGenericEdges + , drainLegalization + , noStarVertex + , isFlippableEdge + , collectLineChain + ) where + +import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + ( noStarVertex + , seedGenericEdges + , seedStarScratch + ) +import Moonlight.Triangulation.Internal.DcelOperations.Chain + ( collectLineChain + , extendLine + , lineToArea + , setupFirstVertex + , setupSecondVertex + , splitLineEdge + ) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRule + ( LegalizationLaw (..) + , isFlippableEdge + ) +import Moonlight.Triangulation.Internal.DcelOperations.Hull + ( closeOuterTurn + , fixHullConvexity + , insertOutsideHull + , insertOutsideHullBetween + ) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize + ( legalizeCavityFanScratch + , legalizeEdges + , legalizeScratch + ) +import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization) +import Moonlight.Triangulation.Internal.DcelOperations.Subdivide + ( insertIntoFace + , insertOnEdge + ) diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The legalization candidate stack: tagging, growth, and seeding. +module Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + ( starCandidate + , genericCandidate + , growLegalizationArena + , seedStarScratch + , seedGenericEdges + , noStarVertex + ) where + +import Control.Monad (forM_, when) +import Control.Monad.ST (ST) +import Data.Word (Word32) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.Internal.OperationState + ( OperationState + , legalizationArena + , readScratch + , storeLegalizationArena + ) +import Moonlight.Triangulation.Internal.PackedIndex (packIndex) + +-- A candidate carries the discipline under which it must be tested. One +-- seeded from an insertion star names an edge that has to be re-oriented so +-- the inserted vertex is opposite it; one seeded generically already names the +-- edge to test. Building a geometric patch used to start and drain the work +-- stack once per primitive because the two could not share it — the fan, then +-- every closed hull turn separately, each re-reading the same neighbourhood. +-- With the discipline travelling on the candidate they share one drain. +starCandidate :: Int -> Int +starCandidate edge = edge * 2 +{-# INLINE starCandidate #-} + +genericCandidate :: Int -> Int +genericCandidate edge = edge * 2 + 1 +{-# INLINE genericCandidate #-} + +-- | Seed candidates from the scratch arena, returning the new stack top. +-- Transaction-sized preallocation covers the normal path; rare adversarial +-- overflow grows the operation-owned vector without changing LIFO order. +seedStarScratch :: OperationState s -> Int -> Int -> ST s Int +seedStarScratch operation top candidateCount = do + initialArena <- legalizationArena operation + arena <- growLegalizationArena initialArena (top + candidateCount) + when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena) + forM_ [0 .. candidateCount - 1] $ \index -> do + edge <- readScratch operation index + MUV.unsafeWrite arena (top + index) (packIndex (starCandidate edge)) + pure (top + candidateCount) + +-- | Seed generic candidates from a list, returning the new stack top. +seedGenericEdges :: OperationState s -> Int -> [Int] -> ST s Int +seedGenericEdges operation top edges = do + initialArena <- legalizationArena operation + let !count = length edges + arena <- growLegalizationArena initialArena (top + count) + when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena) + forM_ (zip [0 ..] edges) $ \(!index, !edge) -> + MUV.unsafeWrite arena (top + index) (packIndex (genericCandidate edge)) + pure (top + count) + +growLegalizationArena :: MUV.MVector s Word32 -> Int -> ST s (MUV.MVector s Word32) +growLegalizationArena arena required + | required <= current = pure arena + | otherwise = MUV.grow arena (max (required - current) (max 1 current)) + where + !current = MUV.length arena +{-# INLINE growLegalizationArena #-} + +-- | No star candidate can be seeded against this, so a drain given it must +-- have been seeded generically throughout. +noStarVertex :: Int +noStarVertex = -1 + diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Chain.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Chain.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Chain.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The degenerate dimensions: a point, a segment chain, and its promotion. +module Moonlight.Triangulation.Internal.DcelOperations.Chain + ( setupFirstVertex + , setupSecondVertex + , splitLineEdge + , extendLine + , collectLineChain + , lineToArea + ) where + +import Control.Monad (forM_, when) +import Control.Monad.ST (ST) +import Data.STRef (writeSTRef) +import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel (..) + , addEdge + , addEdgeBlock + , addFaceBlock + , directedEdgeCount + , edgeOriginPoint + , ensureCellCapacity + , isConnected + , linkEdges + , markConnected + , pointAt + , pointCount + , readConstraint + , readNext + , readOrigin + , readPrevious + , readVertexOut + , resetEdgeData + , setConstraint + , setCycle3 + , writeFace + , writeFaceEdge + , writeOrigin + , writeVertexOut + ) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.Probe (KnownProbe) +import Moonlight.Triangulation.Internal.Types (BuildError (..)) +import Moonlight.Triangulation.Math (orient2d) + +setupFirstVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s () +setupFirstVertex mutable vertex = markConnected mutable vertex (-1) + +setupSecondVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ()) +setupSecondVertex mutable vertex = do + vertices <- pointCount mutable + connected <- findConnected mutable vertices 0 + case connected of + Left obstruction -> pure (Left obstruction) + Right first -> do + capacity <- ensureCellCapacity mutable 1 0 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + (edge, reverseEdgeEdge) <- addEdge mutable first vertex + linkEdges mutable edge reverseEdgeEdge + linkEdges mutable reverseEdgeEdge edge + writeFace mutable edge 0 + writeFace mutable reverseEdgeEdge 0 + writeFaceEdge mutable 0 edge + writeVertexOut mutable first edge + markConnected mutable vertex reverseEdgeEdge + pure (Right ()) + +splitLineEdge :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +splitLineEdge mutable operation edge vertex = do + capacity <- ensureCellCapacity mutable 1 0 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + protected <- readConstraint mutable edge + let !reverseEdgeEdge = reverseIndex edge + destinationVertex <- readOrigin mutable reverseEdgeEdge + oldNextEdge <- readNext mutable edge + oldPreviousTwin <- readPrevious mutable reverseEdgeEdge + oldNextTwin <- readNext mutable reverseEdgeEdge + writeOrigin mutable reverseEdgeEdge vertex + (newEdge, newTwin) <- addEdge mutable vertex destinationVertex + writeFace mutable newEdge 0 + writeFace mutable newTwin 0 + if oldNextEdge == reverseEdgeEdge + then do + -- The split segment reaches a line endpoint. Its forward edge and twin + -- are adjacent, so the replacement is one contiguous four-edge run. + -- This also covers the initial two-vertex topology. + linkEdges mutable edge newEdge + linkEdges mutable newEdge newTwin + linkEdges mutable newTwin reverseEdgeEdge + linkEdges mutable reverseEdgeEdge oldNextTwin + else do + -- Replace the two occurrences independently: [edge] becomes + -- [edge,newEdge], while [twin] becomes [newTwin,twin]. + linkEdges mutable edge newEdge + linkEdges mutable newEdge oldNextEdge + linkEdges mutable oldPreviousTwin newTwin + linkEdges mutable newTwin reverseEdgeEdge + writeVertexOut mutable destinationVertex newTwin + markConnected mutable vertex newEdge + -- AB became AV. The new half is a fresh slot and already carries the + -- default; the truncated half is a different edge in an old slot. + resetEdgeData mutable (edge `quot` 2) + when protected $ do + _ <- setConstraint mutable newEdge + pure () + addCounter operation CounterLineSplits 1 + pure (Right ()) + +extendLine :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +extendLine mutable operation endpoint vertex = do + outgoing <- readVertexOut mutable endpoint + if outgoing < 0 + then pure (Left (DegenerateLineEndpointMissingOutgoing (VertexId (fromIntegral endpoint)))) + else do + capacity <- ensureCellCapacity mutable 1 0 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + let !incoming = reverseIndex outgoing + (newEdge, newTwin) <- addEdge mutable endpoint vertex + writeFace mutable newEdge 0 + writeFace mutable newTwin 0 + linkEdges mutable incoming newEdge + linkEdges mutable newEdge newTwin + linkEdges mutable newTwin outgoing + writeVertexOut mutable endpoint newEdge + markConnected mutable vertex newTwin + addCounter operation CounterLineExtensions 1 + pure (Right ()) + +collectLineChain :: MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either BuildError Int) +collectLineChain mutable operation = do + halfEdges <- directedEdgeCount mutable + turn <- findTurn halfEdges 0 + case turn of + Left obstruction -> pure (Left obstruction) + Right incoming -> do + let !first = reverseIndex incoming + go !count !edge = do + writeScratch operation count edge + edgeNext <- readNext mutable edge + if edgeNext == reverseIndex edge + then pure (Right (count + 1)) + else go (count + 1) edgeNext + go 0 first + where + findTurn halfEdges !edge + | edge >= halfEdges = pure (Left (DegenerateLineEndpointTurnMissing halfEdges)) + | otherwise = do + edgeNext <- readNext mutable edge + if edgeNext == reverseIndex edge then pure (Right edge) else findTurn halfEdges (edge + 1) + +lineToArea :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s (Either BuildError ()) +lineToArea mutable operation vertex = do + collected <- collectLineChain mutable operation + case collected of + Left obstruction -> pure (Left obstruction) + Right segmentCount -> lineToAreaCollected @p mutable operation vertex segmentCount + +lineToAreaCollected :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +lineToAreaCollected mutable@MutableDcel{mdLastFace} operation vertex segmentCount = do + capacity <- ensureCellCapacity mutable (segmentCount + 1) segmentCount + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> lineToAreaWithCapacity + where + lineToAreaWithCapacity = do + firstSegment <- readScratch operation 0 + lastSegment <- readScratch operation (segmentCount - 1) + firstPoint <- edgeOriginPoint mutable firstSegment + lastPoint <- edgeOriginPoint mutable (reverseIndex lastSegment) + insertedPoint <- pointAt mutable vertex + when (orient2d firstPoint lastPoint insertedPoint == LT) $ reverseScratchDirections operation segmentCount + spokeBase <- addEdgeBlock mutable (segmentCount + 1) + faceBase <- addFaceBlock mutable segmentCount + forM_ [0 .. segmentCount] $ \index -> do + chainVertex <- + if index < segmentCount + then readScratch operation index >>= readOrigin mutable + else readScratch operation (segmentCount - 1) >>= readOrigin mutable . reverseIndex + let !forward = spokeBase + 2 * index + !backward = forward + 1 + writeOrigin mutable forward chainVertex + writeOrigin mutable backward vertex + forM_ [0 .. segmentCount - 1] $ \index -> do + segment <- readScratch operation index + let !face = faceBase + index + !nextSpoke = spokeBase + 2 * (index + 1) + !previousSpoke = spokeBase + 2 * index + 1 + setCycle3 mutable face segment nextSpoke previousSpoke + lastInnerSegment <- readScratch operation (segmentCount - 1) + let !outerStart = reverseIndex lastInnerSegment + !firstOuterSpoke = spokeBase + !lastOuterSpoke = spokeBase + 2 * segmentCount + 1 + linkOuterTwins mutable operation segmentCount + firstInnerSegment <- readScratch operation 0 + linkEdges mutable (reverseIndex firstInnerSegment) firstOuterSpoke + linkEdges mutable firstOuterSpoke lastOuterSpoke + linkEdges mutable lastOuterSpoke outerStart + writeFace mutable firstOuterSpoke 0 + writeFace mutable lastOuterSpoke 0 + writeFaceEdge mutable 0 outerStart + forM_ [0 .. segmentCount - 1] $ \index -> do + segment <- readScratch operation index + chainVertex <- readOrigin mutable segment + writeVertexOut mutable chainVertex segment + finalVertex <- readOrigin mutable (reverseIndex lastInnerSegment) + writeVertexOut mutable finalVertex (spokeBase + 2 * segmentCount) + markConnected mutable vertex (spokeBase + 1) + writeSTRef mdLastFace faceBase + addCounter operation CounterLineToAreaTransitions 1 + legalizeScratch @p mutable operation vertex segmentCount + pure (Right ()) + + linkOuterTwins :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s () + linkOuterTwins target ops count = + let go !index + | index <= 0 = pure () + | otherwise = do + right <- readScratch ops index + left <- readScratch ops (index - 1) + linkEdges target (reverseIndex right) (reverseIndex left) + writeFace target (reverseIndex right) 0 + go (index - 1) + in do + go (count - 1) + first <- readScratch ops 0 + writeFace target (reverseIndex first) 0 + +reverseScratchDirections :: OperationState s -> Int -> ST s () +reverseScratchDirections operation count = do + forM_ [0 .. count `quot` 2 - 1] $ \left -> do + let !right = count - 1 - left + leftEdge <- readScratch operation left + rightEdge <- readScratch operation right + writeScratch operation left (reverseIndex rightEdge) + writeScratch operation right (reverseIndex leftEdge) + when (odd count) $ do + let !middle = count `quot` 2 + edge <- readScratch operation middle + writeScratch operation middle (reverseIndex edge) + +findConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Either BuildError Int) +findConnected mutable limit !vertex + | vertex >= limit = pure (Left (DegenerateLineConnectedVertexMissing limit)) + | otherwise = do + connected <- isConnected mutable vertex + if connected then pure (Right vertex) else findConnected mutable limit (vertex + 1) diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The flip rewrite itself, on a quadrilateral. +module Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite + ( flipEdge + , applyFlip + ) where + +import Control.Monad (unless) +import Control.Monad.ST (ST) +import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..)) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel + , payloadsPristine + , readConstraint + , readFace + , readNext + , readOrigin + , readPrevious + , resetEdgeData + , resetFaceData + , setCycle3 + , writeOrigin + , writeVertexOut + ) +import Moonlight.Triangulation.Internal.Types (BuildError (ConstrainedEdgeFlipRefused)) + +flipEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ()) +flipEdge mutable edge = do + protected <- readConstraint mutable edge + if protected + then pure (Left (ConstrainedEdgeFlipRefused (UndirectedEdgeId (fromIntegral (edge `quot` 2))))) + else do + let !twin = reverseIndex edge + edgeNext <- readNext mutable edge + edgePrevious <- readPrevious mutable edge + twinNext <- readNext mutable twin + twinPrevious <- readPrevious mutable twin + leftFace <- readFace mutable edge + rightFace <- readFace mutable twin + a <- readOrigin mutable edge + b <- readOrigin mutable twin + c <- readOrigin mutable edgePrevious + d <- readOrigin mutable twinPrevious + applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d + pure (Right ()) + +-- | The rewrite itself, from a quadrilateral the caller already holds. The +-- decision that licenses a flip reads the same two half-edge records the +-- rewrite consumes, so the drain hands its neighbourhood straight here rather +-- than making 'flipEdge' fetch it a second time; 'flipEdge' is that fetch, for +-- callers arriving with nothing but an index. +applyFlip + :: MutableDcel s vertex directed undirected face + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> Int + -> ST s () +applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d = do + writeOrigin mutable edge c + writeOrigin mutable twin d + setCycle3 mutable leftFace edge twinPrevious edgeNext + setCycle3 mutable rightFace twin edgePrevious twinNext + -- The diagonal AB is gone and CD stands in its slot; both triangles have + -- swapped a corner. Three elements changed what they are, so three labels go. + -- Each reset carries the same test; a site doing several states it once. + unless (payloadsPristine mutable) $ do + resetEdgeData mutable (edge `quot` 2) + resetFaceData mutable leftFace + resetFaceData mutable rightFace + writeVertexOut mutable a twinNext + writeVertexOut mutable b edgeNext + writeVertexOut mutable c edge + writeVertexOut mutable d twin +{-# INLINE applyFlip #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The firing condition of the flip rule, and the laws restricting it. +module Moonlight.Triangulation.Internal.DcelOperations.FlipRule + ( LegalizationLaw (..) + , diagonalFires + , illegalDiagonal + , isFlippableEdge + , orderedPair + ) where + +import Control.Monad.ST (ST) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel + , readConstraint + , readFace + , readOrigin + , readPointX + , readPointY + , readPrevious + ) +import Moonlight.Triangulation.Scalar (inCircleCoordinates, orient2dCoordinates) + +-- | Whether the flip rule may fire on a quadrilateral @a b c d@ under a law, +-- where @ab@ is the diagonal and @c@, @d@ the apexes opposite it. The +-- coordinates arrive raw, in the order the mutable accessors carry. +-- +-- '&&' gives 'ValidMesh' its short-circuit past the incircle determinant, and +-- 'CavityRepair' never names the convexity test whose premise it denies. The +-- drain reaches this with the quadrilateral already in hand; the firing +-- condition itself has one owner. +diagonalFires + :: LegalizationLaw + -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double + -> Bool +diagonalFires law ax ay bx by cx cy dx dy = + case law of + ValidMesh -> + orient2dCoordinates cx cy dx dy bx by == GT + && orient2dCoordinates dx dy cx cy ax ay == GT + && illegalDiagonal ax ay bx by cx cy dx dy + CavityRepair _ -> illegalDiagonal ax ay bx by cx cy dx dy +{-# INLINE diagonalFires #-} + +-- | Whether a diagonal is locally illegal — the firing condition of the flip +-- rule @drainLegalization@ normalizes under, and the step at which its +-- potential strictly decreases. +-- +-- Lift the quadrilateral to @z = x² + y²@ and the in-circle sign is the +-- orientation of the lifted tetrahedron: 'GT' says the fourth point is below +-- the plane of the other three, so the current diagonal spans a fold the flip +-- pushes downward. 'EQ' says the four lifted points are coplanar and the flip +-- changes nothing about the surface — so the ordering on diagonal keys stands +-- in as the potential, and the rule fires only downward in it. That tie-break +-- is not a convention for picking among equals; it is what stops a cocircular +-- quadrilateral from flipping forever. +illegalDiagonal + :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Bool +illegalDiagonal ax ay bx by cx cy dx dy = + case inCircleCoordinates ax ay bx by cx cy dx dy of + GT -> True + LT -> False + EQ -> orderedPair (cx, cy) (dx, dy) < orderedPair (ax, ay) (bx, by) +{-# INLINE illegalDiagonal #-} + +isFlippableEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool +isFlippableEdge mutable edge = do + protected <- readConstraint mutable edge + if protected + then pure False + else do + let !reverseEdgeEdge = reverseIndex edge + leftFace <- readFace mutable edge + rightFace <- readFace mutable reverseEdgeEdge + if leftFace == 0 || rightFace == 0 + then pure False + else do + edgePrevious <- readPrevious mutable edge + reverseEdgePrevious <- readPrevious mutable reverseEdgeEdge + a <- readOrigin mutable edge + b <- readOrigin mutable reverseEdgeEdge + c <- readOrigin mutable edgePrevious + d <- readOrigin mutable reverseEdgePrevious + ax <- readPointX mutable a + ay <- readPointY mutable a + bx <- readPointX mutable b + by <- readPointY mutable b + cx <- readPointX mutable c + cy <- readPointY mutable c + dx <- readPointX mutable d + dy <- readPointY mutable d + pure + ( orient2dCoordinates cx cy dx dy bx by == GT + && orient2dCoordinates dx dy cx cy ax ay == GT + ) +{-# INLINE isFlippableEdge #-} + +-- | The rewrite strategy: which candidates the flip rule is allowed to fire +-- on. Both laws leave the normal form alone — they restrict where the rule may +-- be applied, never what a legal diagonal is. +-- +-- 'ValidMesh' legalizes a mesh that is already a triangulation. There a +-- non-convex quadrilateral's diagonal is necessarily locally Delaunay, so +-- testing convexity first is a free short-circuit around the incircle +-- determinant — it can only decline flips the determinant would have declined. +-- +-- 'CavityRepair' legalizes the fan that fills a removed vertex's hole, which is +-- not yet a triangulation. That implication fails on an inverted quadrilateral, +-- and the inverted one is exactly the one that must flip, so the short-circuit +-- becomes a refusal to perform the repair. The carried index is the undirected +-- edge count taken before the fan was built: every edge at or above it was +-- appended by the fan, and only those may flip, so a transiently inverted +-- neighbourhood cannot flip the cavity's border away. +data LegalizationLaw + = ValidMesh + | CavityRepair {-# UNPACK #-} !Int + +orderedPair :: Ord a => a -> a -> (a, a) +orderedPair left right + | left <= right = (left, right) + | otherwise = (right, left) +{-# INLINE orderedPair #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Growth outside the hull: visible ranges, turn closure, and convexity repair. +module Moonlight.Triangulation.Internal.DcelOperations.Hull + ( insertOutsideHull + , insertOutsideHullBetween + , closeOuterTurn + , fixHullConvexity + ) where + +import Control.Monad (forM_) +import Control.Monad.ST (ST) +import Data.STRef (writeSTRef) +import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..)) +import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + ( noStarVertex + , seedGenericEdges + ) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (LegalizationLaw (..)) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch) +import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel (..) + , addEdge + , addEdgeBlock + , addFaceBlock + , directedEdgeCount + , ensureCellCapacity + , linkEdges + , markConnected + , pointAt + , readFace + , readFaceEdge + , readNext + , readOrigin + , readPointX + , readPointY + , readPrevious + , setCycle3 + , writeFace + , writeFaceEdge + , writeOrigin + , writeVertexOut + ) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , readScratch + , writeScratch + ) +import Moonlight.Triangulation.Internal.Probe (KnownProbe) +import Moonlight.Triangulation.Types (BuildError (..), Point (..)) +import Moonlight.Triangulation.Scalar (orient2dCoordinates) + +insertOutsideHull :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +insertOutsideHull mutable operation start vertex = do + query <- pointAt mutable vertex + visibleStart <- visibleOuter mutable start query + if not visibleStart + then pure (Left (HullStartNotVisible (DirectedEdgeId (fromIntegral start)))) + else do + halfEdges <- directedEdgeCount mutable + left <- expandPrevious halfEdges start start query + right <- expandNext halfEdges start left query + collected <- collectOuterChain mutable operation left right + case collected of + Left obstruction -> pure (Left obstruction) + Right chainCount -> do + inserted <- insertOutsideHullCollected @p mutable operation vertex chainCount + case inserted of + Left obstruction -> pure (Left obstruction) + Right _ -> do + -- The regular insertion path owns its own hull-insertion count; the sweep + -- path through 'insertOutsideHullBetween' counts its own instead. + addCounter operation CounterHullInsertions 1 + pure (Right ()) + where + expandPrevious !bound !stopAt !current !query + | bound <= 0 = pure current + | otherwise = do + candidate <- readPrevious mutable current + if candidate == stopAt + then pure current + else do + visible <- visibleOuter mutable candidate query + if visible then expandPrevious (bound - 1) stopAt candidate query else pure current + + expandNext !bound !current !left !query + | bound <= 0 = pure current + | otherwise = do + candidate <- readNext mutable current + if candidate == left + then pure current + else do + visible <- visibleOuter mutable candidate query + if visible then expandNext (bound - 1) candidate left query else pure current + +-- | Insert a vertex outside an explicitly selected contiguous outer-face range. +-- The range, rather than a convexity policy, is the primitive: regular +-- insertion supplies the complete visible range, while circle sweep may supply +-- one edge and defer the remaining hull turns. Topology mutation has one owner. +insertOutsideHullBetween + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> Int + -> ST s (Either BuildError (Int, Int)) +insertOutsideHullBetween mutable operation left right vertex = do + collected <- collectOuterChain mutable operation left right + case collected of + Left obstruction -> pure (Left obstruction) + Right chainCount -> insertOutsideHullCollected @p mutable operation vertex chainCount + +collectOuterChain + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> ST s (Either BuildError Int) +collectOuterChain mutable operation left right = do + halfEdges <- directedEdgeCount mutable + go (halfEdges + 1) left 0 + where + go !remaining !current !count + | remaining <= 0 = + pure + ( Left + ( OuterRangeDidNotTerminate + (DirectedEdgeId (fromIntegral left)) + (DirectedEdgeId (fromIntegral right)) + count + ) + ) + | otherwise = do + incident <- readFace mutable current + if incident /= 0 + then + pure + ( Left + ( OuterRangeContainsInnerEdge + (DirectedEdgeId (fromIntegral current)) + (FaceId (fromIntegral incident)) + ) + ) + else do + writeScratch operation count current + if current == right + then pure (Right (count + 1)) + else readNext mutable current >>= \following -> go (remaining - 1) following (count + 1) + +insertOutsideHullCollected + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> ST s (Either BuildError (Int, Int)) +insertOutsideHullCollected mutable@MutableDcel{mdLastFace} operation vertex chainCount = do + capacity <- ensureCellCapacity mutable (chainCount + 1) chainCount + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> Right <$> insertOutsideHullWithCapacity + where + insertOutsideHullWithCapacity = do + left <- readScratch operation 0 + right <- readScratch operation (chainCount - 1) + oldPrevious <- readPrevious mutable left + oldNext <- readNext mutable right + edgeBase <- addEdgeBlock mutable (chainCount + 1) + faceBase <- addFaceBlock mutable chainCount + forM_ [0 .. chainCount] $ \index -> do + chainVertex <- + if index == 0 + then readScratch operation 0 >>= readOrigin mutable + else readScratch operation (index - 1) >>= readOrigin mutable . reverseIndex + let !forward = edgeBase + 2 * index + !backward = forward + 1 + writeOrigin mutable forward chainVertex + writeOrigin mutable backward vertex + forM_ [0 .. chainCount - 1] $ \index -> do + outerEdge <- readScratch operation index + let !face = faceBase + index + !nextSpoke = edgeBase + 2 * (index + 1) + !previousSpoke = edgeBase + 2 * index + 1 + setCycle3 mutable face outerEdge nextSpoke previousSpoke + let !firstOuterSpoke = edgeBase + !lastOuterSpoke = edgeBase + 2 * chainCount + 1 + writeFace mutable firstOuterSpoke 0 + writeFace mutable lastOuterSpoke 0 + linkEdges mutable oldPrevious firstOuterSpoke + linkEdges mutable firstOuterSpoke lastOuterSpoke + linkEdges mutable lastOuterSpoke oldNext + writeFaceEdge mutable 0 firstOuterSpoke + forM_ [0 .. chainCount - 1] $ \index -> do + chainEdge <- readScratch operation index + chainVertex <- readOrigin mutable chainEdge + writeVertexOut mutable chainVertex chainEdge + lastChain <- readScratch operation (chainCount - 1) + lastVertex <- readOrigin mutable (reverseIndex lastChain) + writeVertexOut mutable lastVertex (edgeBase + 2 * chainCount) + markConnected mutable vertex lastOuterSpoke + writeSTRef mdLastFace faceBase + legalizeScratch @p mutable operation vertex chainCount + pure (firstOuterSpoke, lastOuterSpoke) + +-- | Replace two consecutive outer edges @a->b, b->c@ by @a->c@ and +-- materialize the triangle they bound. The returned edge is the new outer +-- diagonal. This is the sole turn-closing primitive used both by deferred +-- circle sweep and the final Graham repair. Topology mutation only: the +-- caller owns the legalization epoch, and seeds the two closed edges itself +-- once the replacement's links are in place. +closeOuterTurn + :: MutableDcel s vertex directed undirected face + -> Int + -> ST s (Either BuildError Int) +closeOuterTurn mutable first = do + capacity <- ensureCellCapacity mutable 1 1 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + second <- readNext mutable first + oldPrevious <- readPrevious mutable first + oldNext <- readNext mutable second + from <- readOrigin mutable first + to <- readOrigin mutable (reverseIndex second) + (outer, inner) <- addEdge mutable from to + newFace <- addFaceBlock mutable 1 + writeFace mutable outer 0 + setCycle3 mutable newFace first second inner + linkEdges mutable oldPrevious outer + linkEdges mutable outer oldNext + writeFaceEdge mutable 0 outer + writeVertexOut mutable from outer + writeVertexOut mutable to inner + pure (Right outer) +{-# INLINE closeOuterTurn #-} + +-- | Close every remaining left turn of the star-shaped sweep hull in one +-- Graham-style pass. Each closure strictly decreases the outer-edge count, so +-- the pass is linear in the visited hull plus the local Delaunay legalization +-- work it causes. Turn closures are seeded into one shared epoch as they +-- happen and drained once at the end: closure never deletes an edge and never +-- touches the outer cycle's legality, so which turns close does not depend on +-- when the interior is repaired. The pass counts its own closures and returns +-- the drain's tallies; nothing is reported behind its back. +fixHullConvexity + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> ST s (Either BuildError (Int, Int, Int)) +fixHullConvexity mutable operation = do + start <- readFaceEdge mutable 0 + if start < 0 + then pure (Right (0, 0, 0)) + else do + walked <- walk start start 0 0 0 0 + case walked of + Left obstruction -> pure (Left obstruction) + Right (top, closures) -> do + (flips, maxDepth) <- drainLegalization @p mutable operation top noStarVertex ValidMesh + pure (Right (closures, flips, maxDepth)) + where + walk !start !current !stackSize !steps !top !closures = do + halfEdges <- directedEdgeCount mutable + if steps > halfEdges + 2 + then + pure + ( Left + ( OuterCycleDidNotTerminate + (DirectedEdgeId (fromIntegral start)) + (DirectedEdgeId (fromIntegral current)) + steps + ) + ) + else do + following <- readNext mutable current + writeScratch operation stackSize current + reduction <- reduce (stackSize + 1) top closures + case reduction of + Left obstruction -> pure (Left obstruction) + Right (reduced, nextTop, nextClosures) -> do + finished <- + if reduced < 2 + then pure False + else (== following) <$> readScratch operation 1 + if finished + then pure (Right (nextTop, nextClosures)) + else walk start following reduced (steps + 1) nextTop nextClosures + + reduce !count !top !closures + | count < 2 = pure (Right (count, top, closures)) + | otherwise = do + first <- readScratch operation (count - 2) + second <- readScratch operation (count - 1) + fromVertex <- readOrigin mutable first + middleVertex <- readOrigin mutable (reverseIndex first) + targetVertex <- readOrigin mutable (reverseIndex second) + fromX <- readPointX mutable fromVertex + fromY <- readPointY mutable fromVertex + middleX <- readPointX mutable middleVertex + middleY <- readPointY mutable middleVertex + targetX <- readPointX mutable targetVertex + targetY <- readPointY mutable targetVertex + if orient2dCoordinates fromX fromY middleX middleY targetX targetY == GT + then do + closed <- closeOuterTurn mutable first + case closed of + Left obstruction -> pure (Left obstruction) + Right replacement -> do + writeScratch operation (count - 2) replacement + nextTop <- seedGenericEdges operation top [first, second] + reduce (count - 1) nextTop (closures + 1) + else pure (Right (count, top, closures)) + +visibleOuter :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s Bool +visibleOuter mutable edge query = do + fromVertex <- readOrigin mutable edge + toVertex <- readOrigin mutable (reverseIndex edge) + case query of + Point queryX queryY -> do + fromX <- readPointX mutable fromVertex + fromY <- readPointY mutable fromVertex + toX <- readPointX mutable toVertex + toY <- readPointY mutable toVertex + pure (orient2dCoordinates fromX fromY toX toY queryX queryY == GT) +{-# INLINE visibleOuter #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The seeding entry points that drive one legalization epoch. +module Moonlight.Triangulation.Internal.DcelOperations.Legalize + ( legalizeScratch + , legalizeEdges + , legalizeCavityFanScratch + ) where + +import Control.Monad (when) +import Control.Monad.ST (ST) +import Data.Foldable (traverse_) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + ( genericCandidate + , growLegalizationArena + , noStarVertex + , seedGenericEdges + , seedStarScratch + ) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (LegalizationLaw (..)) +import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization) +import Moonlight.Triangulation.Internal.Mutable (MutableDcel) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , legalizationArena + , maxCounter + , readScratch + , storeLegalizationArena + ) +import Moonlight.Triangulation.Internal.PackedIndex (packIndex) +import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..)) + +legalizeEdges :: MutableDcel s vertex directed undirected face -> OperationState s -> [Int] -> ST s () +legalizeEdges mutable operation initial = do + top <- seedGenericEdges operation 0 initial + (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation top noStarVertex ValidMesh + addCounter operation CounterEdgeFlips flips + maxCounter operation CounterLegalizationMaxStack maxDepth + +-- | Repair the fan that fills a removed vertex's hole, draining cavity +-- candidates already written into the operation-owned scratch section. The +-- fan is a valid combinatorial filling but not yet a triangulation — a link +-- polygon that is non-convex at the fan origin yields an inverted triangle — +-- so this drain carries 'CavityRepair' rather than the insertion law: it +-- flips on the incircle determinant alone, and only the fan's own edges may +-- flip. Removal discovers and constructs the cavity inside that same +-- transaction; materializing a list merely to seed the legalization arena +-- would duplicate the local program. +legalizeCavityFanScratch + :: MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> Int + -> ST s () +legalizeCavityFanScratch mutable operation cavityFloor scratchOffset candidateCount = do + initialArena <- legalizationArena operation + arena <- growLegalizationArena initialArena candidateCount + when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena) + traverse_ + (\index -> do + edge <- readScratch operation (scratchOffset + index) + MUV.unsafeWrite arena index (packIndex (genericCandidate edge)) + ) + [0 .. candidateCount - 1] + (flips, maxDepth) <- + drainLegalization + @'ProbeOff + mutable + operation + candidateCount + noStarVertex + (CavityRepair cavityFloor) + addCounter operation CounterEdgeFlips flips + maxCounter operation CounterLegalizationMaxStack maxDepth + +legalizeScratch :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s () +legalizeScratch mutable operation vertex candidateCount = do + top <- seedStarScratch operation 0 candidateCount + (flips, maxDepth) <- drainLegalization @p mutable operation top vertex ValidMesh + addCounter operation CounterEdgeFlips flips + maxCounter operation CounterLegalizationMaxStack maxDepth diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The normalization procedure of the flip rewrite system. +module Moonlight.Triangulation.Internal.DcelOperations.Normalize + ( drainLegalization + ) where + +import Control.Monad (when) +import Control.Monad.ST (ST) +import Data.Bits ((.&.), shiftR) +import Data.STRef (readSTRef) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena + ( genericCandidate + , growLegalizationArena + , starCandidate + ) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (applyFlip) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRule + ( LegalizationLaw (..) + , diagonalFires + ) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel (..) + , readConstraint + , readFace + , readNext + , readOrigin + , readPointX + , readPointY + , readPrevious + ) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , legalizationArena + , storeLegalizationArena + ) +import Moonlight.Triangulation.Internal.PackedIndex (packIndex) +import Moonlight.Triangulation.Internal.Probe (KnownProbe (..)) + +-- | The normalization procedure of a confluent terminating rewrite system, and +-- one canonical legalization engine because a normalization procedure is what +-- it is. +-- +-- The objects are the triangulations of a fixed point set. The single rule is +-- the Lawson flip: a locally illegal diagonal is replaced by the other +-- diagonal of its quadrilateral. A normal form is a mesh with no illegal +-- diagonal left to fire on. +-- +-- /Termination/ is by the lifted-paraboloid potential. Send each point to +-- @(x, y, x² + y²)@ and read a triangulation as a piecewise-linear surface +-- over the point set; @illegalDiagonal@ is exactly the test that the flip +-- lowers that surface, so every rewrite strictly decreases it, and a finite +-- point set has finitely many triangulations. Exact cocircularity is the one +-- case where the surface does not move — the four lifted points are coplanar +-- and both diagonals give the same surface — so there the potential is the +-- diagonal's own key order, and the rule fires only downward in it. Without +-- that tie-break a cocircular quadrilateral flips forever. +-- +-- /Confluence/ is Delaunay's theorem, in its strong form: a triangulation with +-- no locally illegal diagonal is globally Delaunay. Local normality is thus +-- global normality, the normal form is unique, and every rewrite order reaches +-- it. That is what licenses the arena below to be a LIFO stack rather than a +-- priority queue, and it is why callers may seed it in whatever order is +-- cheapest to produce — the fan first, or the hull turns first, or both +-- interleaved — without any of them changing the mesh that comes out. +-- +-- All callers differ only in how they seed the arena; topology mutation and +-- propagation have exactly one owner. +-- The stack top, the maximum top, and the flip count are strict loop +-- variables, returned once when the drain finishes — the mesh reports nothing +-- per candidate, and 'applyFlip' reports nothing at all. The phantom +-- 'KnownProbe' parameter counts popped candidates for the instrumented lane +-- and is erased everywhere else. +-- +-- A popped candidate is read once. Turning it against the star vertex, judging +-- it, and rewriting it are three questions about the same two half-edge +-- records, and the apex the turn looks for is the apex the judgement needs, so +-- one pass over the quadrilateral answers all three. +drainLegalization + :: forall p s vertex directed undirected face + . KnownProbe p + => MutableDcel s vertex directed undirected face + -> OperationState s + -> Int + -> Int + -> LegalizationLaw + -> ST s (Int, Int) +drainLegalization mutable operation seededTop starVertex law = do + -- No constraint can appear during a drain, so a mesh holding none at entry + -- never needs the per-candidate protection read. + constrained <- readSTRef (mdConstraintCount mutable) + initialArena <- legalizationArena operation + -- A star candidate is turned so that the inserted vertex is the apex + -- opposite the diagonal, so that apex is the same vertex on every star + -- candidate the drain pops and its two coordinates are read once here + -- instead of once per candidate. + starX <- if starVertex < 0 then pure 0 else readPointX mutable starVertex + starY <- if starVertex < 0 then pure 0 else readPointY mutable starVertex + let !guarded = constrained /= 0 + -- Everything the cavity fan did not create is pinned. The border loop's + -- legality is already decided by the outside triangle it keeps, and + -- testing it against a neighbourhood that is still inverted could only + -- produce a spurious verdict. 'ValidMesh' pins nothing, which is the + -- floor no undirected index falls below. + !floorPair = case law of + ValidMesh -> 0 + CavityRepair floorEdge -> floorEdge + + loop !arena !top !maxTop !flips !candidates + | top <= 0 = pure (flips, maxTop, candidates, arena) + | otherwise = do + let !nextTop = top - 1 + packedWord <- MUV.unsafeRead arena nextTop + let !packed = fromIntegral packedWord :: Int + !rawEdge = packed `shiftR` 1 + !isStar = packed .&. 1 == 0 + eligible <- + if rawEdge `shiftR` 1 < floorPair + then pure False + else if guarded then not <$> readConstraint mutable rawEdge else pure True + if not eligible + then loop arena nextTop maxTop flips (probeBump @p candidates) + else do + let !rawTwin = reverseIndex rawEdge + rawFace <- readFace mutable rawEdge + rawTwinFace <- readFace mutable rawTwin + if rawFace == 0 || rawTwinFace == 0 + then loop arena nextTop maxTop flips (probeBump @p candidates) + else do + rawBefore <- readPrevious mutable rawEdge + rawTwinBefore <- readPrevious mutable rawTwin + rawApex <- readOrigin mutable rawBefore + rawTwinApex <- readOrigin mutable rawTwinBefore + -- A star candidate names an undirected edge and has to be + -- turned so the inserted vertex is the apex opposite it; a + -- generic one already names the direction to test. Both + -- want the same two apexes, so the one read that settles + -- the turn is also the one that supplies the quadrilateral. + let !turned = isStar && rawApex /= starVertex + if turned && rawTwinApex /= starVertex + then loop arena nextTop maxTop flips (probeBump @p candidates) + else do + let !edge = if turned then rawTwin else rawEdge + !twin = if turned then rawEdge else rawTwin + !leftFace = if turned then rawTwinFace else rawFace + !rightFace = if turned then rawFace else rawTwinFace + !edgePrevious = if turned then rawTwinBefore else rawBefore + !twinPrevious = if turned then rawBefore else rawTwinBefore + !c = if turned then rawTwinApex else rawApex + !d = if turned then rawApex else rawTwinApex + a <- readOrigin mutable edge + b <- readOrigin mutable twin + ax <- readPointX mutable a + ay <- readPointY mutable a + bx <- readPointX mutable b + by <- readPointY mutable b + cx <- if isStar then pure starX else readPointX mutable c + cy <- if isStar then pure starY else readPointY mutable c + dx <- readPointX mutable d + dy <- readPointY mutable d + if not (diagonalFires law ax ay bx by cx cy dx dy) + then loop arena nextTop maxTop flips (probeBump @p candidates) + else do + -- The neighbourhood is complete before the rewrite + -- consumes it, and the pushes carry the same edges + -- in the same order they always did. + edgeNext <- readNext mutable edge + twinNext <- readNext mutable twin + applyFlip + mutable + edge + twin + edgeNext + edgePrevious + twinNext + twinPrevious + leftFace + rightFace + a + b + c + d + if isStar + then do + let !addedTop = nextTop + 2 + grown <- growLegalizationArena arena addedTop + MUV.unsafeWrite grown nextTop (packIndex (starCandidate twinPrevious)) + MUV.unsafeWrite grown (nextTop + 1) (packIndex (starCandidate twinNext)) + loop + grown + addedTop + (max maxTop addedTop) + (flips + 1) + (probeBump @p candidates) + else do + let !addedTop = nextTop + 4 + grown <- growLegalizationArena arena addedTop + MUV.unsafeWrite grown nextTop (packIndex (genericCandidate edgeNext)) + MUV.unsafeWrite grown (nextTop + 1) (packIndex (genericCandidate edgePrevious)) + MUV.unsafeWrite grown (nextTop + 2) (packIndex (genericCandidate twinNext)) + MUV.unsafeWrite grown (nextTop + 3) (packIndex (genericCandidate twinPrevious)) + loop + grown + addedTop + (max maxTop addedTop) + (flips + 1) + (probeBump @p candidates) + (flips, maxTop, candidates, finalArena) <- + loop initialArena seededTop seededTop 0 (probeZero @p) + when (MUV.length finalArena /= MUV.length initialArena) $ + storeLegalizationArena operation finalArena + probeCharge @p operation CounterDiagLegalizationCandidates candidates + pure (flips, maxTop) +{-# INLINE drainLegalization #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Subdivide.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Subdivide.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Subdivide.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Insertion into an existing element: face split and edge split. +module Moonlight.Triangulation.Internal.DcelOperations.Subdivide + ( insertIntoFace + , insertOnEdge + ) where + +import Control.Monad (unless, when) +import Control.Monad.ST (ST) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) +import Moonlight.Triangulation.Internal.Mutable + ( MutableDcel + , addEdgeBlock + , addFaceBlock + , ensureCellCapacity + , faceEdges + , linkEdges + , markConnected + , payloadsPristine + , readConstraint + , readFace + , readNext + , readOrigin + , readPrevious + , resetEdgeData + , resetFaceData + , setConstraint + , setCycle3 + , writeFace + , writeFaceEdge + , writeOrigin + , writeVertexOut + ) +import Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , addCounter + , writeScratch + ) +import Moonlight.Triangulation.Internal.Probe (KnownProbe) +import Moonlight.Triangulation.Internal.Types (BuildError) + +insertIntoFace :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +insertIntoFace mutable operation face vertex = do + capacity <- ensureCellCapacity mutable 3 2 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + insertIntoFaceWithCapacity @p mutable operation face vertex + pure (Right ()) + +insertIntoFaceWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s () +insertIntoFaceWithCapacity mutable operation face vertex = do + (eAB, eBC, eCA) <- faceEdges mutable face + a <- readOrigin mutable eAB + b <- readOrigin mutable eBC + c <- readOrigin mutable eCA + edgeBase <- addEdgeBlock mutable 3 + let !eAV = edgeBase + !eVA = edgeBase + 1 + !eBV = edgeBase + 2 + !eVB = edgeBase + 3 + !eCV = edgeBase + 4 + !eVC = edgeBase + 5 + writeOrigin mutable eAV a + writeOrigin mutable eVA vertex + writeOrigin mutable eBV b + writeOrigin mutable eVB vertex + writeOrigin mutable eCV c + writeOrigin mutable eVC vertex + faceBase <- addFaceBlock mutable 2 + setCycle3 mutable face eAB eBV eVA + setCycle3 mutable faceBase eBC eCV eVB + setCycle3 mutable (faceBase + 1) eCA eAV eVC + writeVertexOut mutable a eAB + writeVertexOut mutable b eBC + writeVertexOut mutable c eCA + markConnected mutable vertex eVA + -- ABC has become ABV; the other two thirds of it are fresh faces. The three + -- boundary edges keep their endpoints and so keep their labels. + resetFaceData mutable face + writeScratch operation 0 eAB + writeScratch operation 1 eBC + writeScratch operation 2 eCA + addCounter operation CounterFaceSplits 1 + legalizeScratch @p mutable operation vertex 3 + +insertOnEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +insertOnEdge mutable operation suppliedEdge vertex = do + suppliedFace <- readFace mutable suppliedEdge + reverseFace <- readFace mutable (reverseIndex suppliedEdge) + if suppliedFace == 0 || reverseFace == 0 + then splitBoundaryEdge @p mutable operation suppliedEdge vertex + else splitInteriorEdge @p mutable operation suppliedEdge vertex + +splitInteriorEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +splitInteriorEdge mutable operation suppliedEdge vertex = do + capacity <- ensureCellCapacity mutable 3 2 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + splitInteriorEdgeWithCapacity @p mutable operation suppliedEdge vertex + pure (Right ()) + +splitInteriorEdgeWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s () +splitInteriorEdgeWithCapacity mutable operation suppliedEdge vertex = do + protected <- readConstraint mutable suppliedEdge + suppliedFace <- readFace mutable suppliedEdge + let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge + !reverseEdgeEdge = reverseIndex edge + leftFace <- readFace mutable edge + rightFace <- readFace mutable reverseEdgeEdge + eBC <- readNext mutable edge + eCA <- readPrevious mutable edge + eAD <- readNext mutable reverseEdgeEdge + eDB <- readPrevious mutable reverseEdgeEdge + a <- readOrigin mutable edge + b <- readOrigin mutable reverseEdgeEdge + c <- readOrigin mutable eCA + d <- readOrigin mutable eDB + writeOrigin mutable reverseEdgeEdge vertex + edgeBase <- addEdgeBlock mutable 3 + let !eVB = edgeBase + !eBV = edgeBase + 1 + !eVC = edgeBase + 2 + !eCV = edgeBase + 3 + !eVD = edgeBase + 4 + !eDV = edgeBase + 5 + writeOrigin mutable eVB vertex + writeOrigin mutable eBV b + writeOrigin mutable eVC vertex + writeOrigin mutable eCV c + writeOrigin mutable eVD vertex + writeOrigin mutable eDV d + faceBase <- addFaceBlock mutable 2 + setCycle3 mutable leftFace edge eVC eCA + setCycle3 mutable faceBase eVB eBC eCV + setCycle3 mutable rightFace eBV eVD eDB + setCycle3 mutable (faceBase + 1) reverseEdgeEdge eAD eDV + writeVertexOut mutable a edge + writeVertexOut mutable b eBC + writeVertexOut mutable c eCA + writeVertexOut mutable d eDB + markConnected mutable vertex reverseEdgeEdge + -- AB became AV, and both incident triangles lost a corner to the new vertex. + unless (payloadsPristine mutable) $ do + resetEdgeData mutable (edge `quot` 2) + resetFaceData mutable leftFace + resetFaceData mutable rightFace + when protected $ do + _ <- setConstraint mutable eVB + pure () + writeScratch operation 0 eCA + writeScratch operation 1 eBC + writeScratch operation 2 eDB + writeScratch operation 3 eAD + addCounter operation CounterInteriorEdgeSplits 1 + legalizeScratch @p mutable operation vertex 4 + +splitBoundaryEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ()) +splitBoundaryEdge mutable operation suppliedEdge vertex = do + capacity <- ensureCellCapacity mutable 2 1 + case capacity of + Left obstruction -> pure (Left obstruction) + Right () -> do + splitBoundaryEdgeWithCapacity @p mutable operation suppliedEdge vertex + pure (Right ()) + +splitBoundaryEdgeWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s () +splitBoundaryEdgeWithCapacity mutable operation suppliedEdge vertex = do + protected <- readConstraint mutable suppliedEdge + suppliedFace <- readFace mutable suppliedEdge + let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge + !outerEdge = reverseIndex edge + innerFace <- readFace mutable edge + eBC <- readNext mutable edge + eCA <- readPrevious mutable edge + a <- readOrigin mutable edge + b <- readOrigin mutable outerEdge + c <- readOrigin mutable eCA + oldOuterPrevious <- readPrevious mutable outerEdge + oldOuterNext <- readNext mutable outerEdge + writeOrigin mutable outerEdge vertex + edgeBase <- addEdgeBlock mutable 2 + let !eVB = edgeBase + !eBV = edgeBase + 1 + !eVC = edgeBase + 2 + !eCV = edgeBase + 3 + writeOrigin mutable eVB vertex + writeOrigin mutable eBV b + writeOrigin mutable eVC vertex + writeOrigin mutable eCV c + newFace <- addFaceBlock mutable 1 + setCycle3 mutable innerFace edge eVC eCA + setCycle3 mutable newFace eVB eBC eCV + writeFace mutable outerEdge 0 + writeFace mutable eBV 0 + linkEdges mutable oldOuterPrevious eBV + linkEdges mutable eBV outerEdge + linkEdges mutable outerEdge oldOuterNext + writeFaceEdge mutable 0 outerEdge + writeVertexOut mutable a edge + writeVertexOut mutable b eBC + writeVertexOut mutable c eCA + markConnected mutable vertex eVB + -- AB became AV and the one interior triangle lost a corner. The outer face + -- is not an element and keeps nothing to lose. + unless (payloadsPristine mutable) $ do + resetEdgeData mutable (edge `quot` 2) + resetFaceData mutable innerFace + when protected $ do + _ <- setConstraint mutable eVB + pure () + writeScratch operation 0 eCA + writeScratch operation 1 eBC + addCounter operation CounterBoundaryEdgeSplits 1 + legalizeScratch @p mutable operation vertex 2 diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Twin.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Twin.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Twin.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | The pairing involution on half-edge indices. +module Moonlight.Triangulation.Internal.DcelOperations.Twin + ( reverseIndex + ) where + +import Data.Bits (xor) + +reverseIndex :: Int -> Int +reverseIndex edge = edge `xor` 1 +{-# INLINE reverseIndex #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/FaceProbe.hs b/src-dcel/Moonlight/Triangulation/Internal/FaceProbe.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/FaceProbe.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Triangulation.Internal.FaceProbe + ( BoundaryProbe (..) + , probeBoundary + ) where + +import Moonlight.Triangulation.Math (onClosedSegment, orient2d) +import Moonlight.Triangulation.Types (Point) + +-- | Classification of one oriented boundary of a triangular face. A +-- 'BoundaryCrossing' carries the half-edge whose incident face is the +-- destination of the walk; consumers must not reverse it again. +data BoundaryProbe edge vertex + = BoundaryClear + | BoundaryOnVertex !vertex + | BoundaryOnEdge !edge + | BoundaryCrossing !edge + deriving stock (Eq, Ord, Show) + +probeBoundary + :: (edge -> edge) + -> Point + -> edge + -> vertex + -> Point + -> vertex + -> Point + -> BoundaryProbe edge vertex +probeBoundary reverseBoundary query edge fromVertex from toVertex to + | query == from = BoundaryOnVertex fromVertex + | query == to = BoundaryOnVertex toVertex + | otherwise = + case orient2d from to query of + EQ + | onClosedSegment from to query -> BoundaryOnEdge edge + | otherwise -> BoundaryClear + LT -> BoundaryCrossing (reverseBoundary edge) + GT -> BoundaryClear +{-# INLINE probeBoundary #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs b/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs @@ -0,0 +1,1060 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Moonlight.Triangulation.Internal.Mutable + ( MutableDcel (..) + , newMutableDcel + , thawTriangulation + , thawTriangulationDense + , freezeTriangulation + , pointCapacity + , halfEdgeCapacity + , pointCount + , connectedCount + , directedEdgeCount + , faceCount + , pointAt + , lookupPointVertex + , activatePointIndex + , activateBatchPointIndex + , discardBatchPointIndex + , identityIndexActive + , readPointX + , readPointY + , writePoint + , vertexDataAt + , writeVertexData + , payloadsPristine + , resetEdgeData + , resetFaceData + , edgeOriginPoint + , appendVertex + , appendVertexCoordinates + , ensurePointCapacity + , markConnected + , isConnected + , addEdge + , addEdgeBlock + , addFace + , addFaceBlock + , ensureCellCapacity + , truncatePoints + , truncateDirectedEdges + , truncateFaces + , swapRemoveUndirectedEdge + , swapRemoveFace + , swapRemoveVertex + , linkEdges + , setCycle3 + , faceEdges + , readOrigin + , writeOrigin + , readNext + , writeNext + , readPrevious + , writePrevious + , readFace + , writeFace + , readVertexOut + , writeVertexOut + , readFaceEdge + , writeFaceEdge + , readConstraint + , setConstraint + , clearConstraint + ) where + +import Control.Monad (foldM, forM_, unless, when) +import Data.Bits (xor) +import Control.Monad.ST (ST) +import qualified Data.IntSet as IntSet +import Data.STRef + ( STRef + , modifySTRef' + , newSTRef + , readSTRef + , writeSTRef + ) +import Data.Word (Word8, Word32) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId (..) + , FaceId (..) + , UndirectedEdgeId (..) + , VertexId (..) + ) +import Moonlight.Triangulation.Internal.BoxedPaged +import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex) +import Moonlight.Triangulation.Internal.Paged +import Moonlight.Triangulation.Internal.PointIndex + ( MutablePointIndex + , MutablePointIndexUpdate (..) + , PointIndex + , buildPointIndex + , emptyPointIndex + , insertPointIndex + , lookupMutablePoint + , newMutablePointIndex + , pointIndexCandidates + , relocateMutablePoint + , relocatePointIndex + , removeMutablePoint + , removePointIndex + , seedMutablePointIndex + ) +import Moonlight.Triangulation.Math (canonicalPoint) +import Moonlight.Triangulation.Internal.Representation (Triangulation (..)) +import Moonlight.Triangulation.Internal.Types (BuildError (..), ElementDefaults (..), Point (..)) +-- | Dormant carries the inherited index through mutations as unforced pure +-- updates; persistent Active is the same index forced and kept strict because +-- a singleton lookup already proved someone is asking. Batch Active is the +-- existing open-addressed owner scoped to one dense identity program. Missing +-- means publication owes a lazy whole-mesh rebuild to any eventual asker. +data MutablePointIndexState s + = DormantPointIndex PointIndex + | ActivePersistentPointIndex !PointIndex + | ActiveBatchPointIndex !(MutablePointIndex s) + | MissingPointIndex + +data MutableDcel s vertex directed undirected face = MutableDcel + { mdPointX :: !(MutablePaged s Double) + , mdPointY :: !(MutablePaged s Double) + , mdPointIndex :: !(STRef s (MutablePointIndexState s)) + , mdVertexOut :: !(MutablePaged s Word32) + , mdVertexData :: !(MutableBoxedPaged s vertex) + , mdNewConnected :: !(MutablePaged s Word8) + , mdRecycledNew :: !(STRef s IntSet.IntSet) + , mdHalfTopology :: !(MutablePaged s Word32) + , mdDirectedData :: !(MutableBoxedPaged s directed) + , mdUndirectedData :: !(MutableBoxedPaged s undirected) + , mdConstraint :: !(MutablePaged s Word8) + , mdFaceEdge :: !(MutablePaged s Word32) + , mdFaceData :: !(MutableBoxedPaged s face) + , mdPointCount :: !(STRef s Int) + , mdConnectedCount :: !(STRef s Int) + , mdHalfCount :: !(STRef s Int) + , mdFaceCount :: !(STRef s Int) + , mdConstraintCount :: !(STRef s Int) + , mdConstraintEdges :: !(STRef s IntSet.IntSet) + , mdLastFace :: !(STRef s Int) + , mdInitialPointCount :: {-# UNPACK #-} !Int + , mdPointCapacity :: {-# UNPACK #-} !Int + , mdHalfCapacity :: {-# UNPACK #-} !Int + , mdFaceCapacity :: {-# UNPACK #-} !Int + , -- | No element payload plane held a materialized page at thaw. Nothing + -- inside a transaction can write one: the three planes are written only + -- through the persistent setters, which run outside one, and both the + -- rewrite reset and the swap-compaction relocation below are no-ops while + -- this holds. So it is constant for the transaction's whole life, and a + -- rewrite decides in a predictable branch that it has no label to move. + mdPayloadsPristine :: !Bool + , mdElementDefaults :: !(ElementDefaults directed undirected face) + } + +newMutableDcel :: ElementDefaults directed undirected face -> Int -> ST s (MutableDcel s vertex directed undirected face) +newMutableDcel defaults maximumVertices = newMutableDcelFrom DenseTransaction defaults maximumVertices Nothing + +-- | Open a local-edit transaction: copy-on-write pages, publication +-- proportional to dirtied pages. The section for singleton persistent verbs. +thawTriangulation + :: Int + -> Triangulation mode vertex directed undirected face + -> ST s (MutableDcel s vertex directed undirected face) +thawTriangulation maximumVertices triangulation = + newMutableDcelFrom + LocalTransaction + (triElementDefaults triangulation) + maximumVertices + (Just triangulation) + +-- | Open a batch transaction: one dense copy up front, flat reads and writes +-- thereafter. The section for sessions and every other many-edit operation. +thawTriangulationDense + :: Int + -> Triangulation mode vertex directed undirected face + -> ST s (MutableDcel s vertex directed undirected face) +thawTriangulationDense maximumVertices triangulation = + newMutableDcelFrom + DenseTransaction + (triElementDefaults triangulation) + maximumVertices + (Just triangulation) + +newMutableDcelFrom + :: TransactionShape + -> ElementDefaults directed undirected face + -> Int + -> Maybe (Triangulation mode vertex directed undirected face) + -> ST s (MutableDcel s vertex directed undirected face) +newMutableDcelFrom shape mdElementDefaults maximumVertices source = do + let !existingVertices = maybe 0 (pagedLength . triPointX) source + !existingHalfEdges = maybe 0 ((`quot` 4) . pagedLength . triHalfTopology) source + !existingFaces = maybe 1 (pagedLength . triFaceEdge) source + !growthVertexCapacity = max 1 (max existingVertices maximumVertices) + !vertexCapacity = growthVertexCapacity + -- Euler bounds a planar triangulation's LIVE cells at 3n - 6 undirected + -- edges and 2n - 4 faces, but these arenas are append-only with no free + -- list, so what must be reserved is CUMULATIVE allocation, not the live + -- maximum. Measured: a complete 5-vertex triangulation (9 edges, 6 faces, + -- V - E + F = 2) requests a seventh face without gaining a vertex, so + -- some operation abandons a slot it will never reclaim. The slack below + -- is headroom over that leakage, not a bound derived from it. + !halfCapacity = max existingHalfEdges (max 2 (8 * growthVertexCapacity + 16)) + !faceCapacity = max existingFaces (max 1 (3 * growthVertexCapacity + 8)) + vertexDataBase = maybe (emptyBoxedPaged Nothing) triVertexData source + directedDataBase = maybe (emptyBoxedPaged (Just (defaultDirectedEdgeData mdElementDefaults))) triDirectedData source + undirectedDataBase = maybe (emptyBoxedPaged (Just (defaultUndirectedEdgeData mdElementDefaults))) triUndirectedData source + faceDataBase = maybe (emptyBoxedPaged (Just (defaultFaceData mdElementDefaults))) triFaceData source + constraintBaseCount = maybe 0 triConstraintCount source + constraintBaseEdges = maybe IntSet.empty triConstraintEdges source + pointIndexBase = maybe MissingPointIndex (DormantPointIndex . triPointIndex) source + mdPointX <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointX) source + mdPointY <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointY) source + mdVertexOut <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triVertexOut) source + mdVertexData <- thawBoxedPaged vertexDataBase + mdNewConnected <- newLocalMutablePaged (vertexCapacity - existingVertices) + mdRecycledNew <- newSTRef IntSet.empty + mdHalfTopology <- maybe (newMutablePaged (4 * halfCapacity)) (thawPagedShaped shape (4 * halfCapacity) . triHalfTopology) source + mdDirectedData <- thawBoxedPaged directedDataBase + mdUndirectedData <- thawBoxedPaged undirectedDataBase + mdConstraint <- maybe (newMutablePaged (halfCapacity `quot` 2)) (thawPagedShaped shape (halfCapacity `quot` 2) . triConstraint) source + mdFaceEdge <- + case source of + Just triangulation -> thawPagedShaped shape faceCapacity (triFaceEdge triangulation) + Nothing -> do + freshFaceEdges <- newLocalMutablePaged faceCapacity + writePaged freshFaceEdges 0 noIndex + pure freshFaceEdges + mdFaceData <- thawBoxedPaged faceDataBase + mdPointCount <- newSTRef existingVertices + mdPointIndex <- newSTRef pointIndexBase + mdConnectedCount <- newSTRef existingVertices + mdHalfCount <- newSTRef existingHalfEdges + mdFaceCount <- newSTRef existingFaces + mdConstraintCount <- newSTRef constraintBaseCount + mdConstraintEdges <- newSTRef constraintBaseEdges + mdLastFace <- newSTRef (if existingFaces > 1 then 1 else 0) + let !mdPayloadsPristine = + boxedThawPristine mdDirectedData + && boxedThawPristine mdUndirectedData + && boxedThawPristine mdFaceData + pure + MutableDcel + { mdInitialPointCount = existingVertices + , mdPointCapacity = vertexCapacity + , mdHalfCapacity = halfCapacity + , mdFaceCapacity = faceCapacity + , .. + } + +freezeTriangulation :: MutableDcel s vertex directed undirected face -> ST s (Either BuildError (Triangulation mode vertex directed undirected face)) +freezeTriangulation MutableDcel + { mdPointX + , mdPointY + , mdPointIndex + , mdVertexOut + , mdVertexData + , mdHalfTopology + , mdDirectedData + , mdUndirectedData + , mdConstraint + , mdFaceEdge + , mdFaceData + , mdPointCount + , mdHalfCount + , mdFaceCount + , mdConstraintCount + , mdConstraintEdges + , mdElementDefaults + } = do + vertices <- readSTRef mdPointCount + halfEdges <- readSTRef mdHalfCount + faces <- readSTRef mdFaceCount + triConstraintCount <- readSTRef mdConstraintCount + triConstraintEdges <- readSTRef mdConstraintEdges + vertexDataOutcome <- freezeBoxedPaged vertices mdVertexData + directedDataOutcome <- freezeBoxedPaged halfEdges mdDirectedData + undirectedDataOutcome <- freezeBoxedPaged (halfEdges `quot` 2) mdUndirectedData + faceDataOutcome <- freezeBoxedPaged faces mdFaceData + case + (,,,) + <$> vertexDataOutcome + <*> directedDataOutcome + <*> undirectedDataOutcome + <*> faceDataOutcome + of + Left obstruction -> pure (Left (PayloadStorageFailure obstruction)) + Right (triVertexData, triDirectedData, triUndirectedData, triFaceData) -> do + triPointX <- freezePaged vertices mdPointX + triPointY <- freezePaged vertices mdPointY + pointIndexState <- readSTRef mdPointIndex + let triPointIndex = + case pointIndexState of + DormantPointIndex residentIndex -> residentIndex + ActivePersistentPointIndex residentIndex -> residentIndex + ActiveBatchPointIndex _ -> buildPointIndex triPointX triPointY + MissingPointIndex -> buildPointIndex triPointX triPointY + triVertexOut <- freezePaged vertices mdVertexOut + triHalfTopology <- freezePaged (4 * halfEdges) mdHalfTopology + triConstraint <- freezePaged (halfEdges `quot` 2) mdConstraint + triFaceEdge <- freezePaged faces mdFaceEdge + let triElementDefaults = mdElementDefaults + pure (Right Triangulation{..}) + +pointCapacity :: MutableDcel s vertex directed undirected face -> Int +pointCapacity = mdPointCapacity +{-# INLINE pointCapacity #-} + +halfEdgeCapacity :: MutableDcel s vertex directed undirected face -> Int +halfEdgeCapacity = mdHalfCapacity +{-# INLINE halfEdgeCapacity #-} + +pointCount :: MutableDcel s vertex directed undirected face -> ST s Int +pointCount = readSTRef . mdPointCount +{-# INLINE pointCount #-} + +connectedCount :: MutableDcel s vertex directed undirected face -> ST s Int +connectedCount = readSTRef . mdConnectedCount +{-# INLINE connectedCount #-} + +directedEdgeCount :: MutableDcel s vertex directed undirected face -> ST s Int +directedEdgeCount = readSTRef . mdHalfCount +{-# INLINE directedEdgeCount #-} + +faceCount :: MutableDcel s vertex directed undirected face -> ST s Int +faceCount = readSTRef . mdFaceCount +{-# INLINE faceCount #-} + +pointAt :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point) +pointAt MutableDcel{mdPointX, mdPointY} index = + Point <$> readPaged mdPointX index <*> readPaged mdPointY index +{-# INLINE pointAt #-} + +-- | Resolve a canonical site through the derived handle index, confirming +-- every hash candidate against the authoritative coordinate planes. A mesh +-- created from scratch derives the index only if a caller actually asks; a +-- thawed published mesh inherits its structurally shared index. +lookupPointVertex + :: MutableDcel s vertex directed undirected face + -> Point + -> ST s (Maybe Int) +lookupPointVertex mutable@MutableDcel{mdPointIndex} rawPoint = do + indexState <- readSTRef mdPointIndex + case canonicalPoint rawPoint of + Point x y -> + case indexState of + ActiveBatchPointIndex table -> + lookupMutablePoint table (readPointX mutable) (readPointY mutable) x y + ActivePersistentPointIndex residentIndex -> + resolvePersistent x y residentIndex + DormantPointIndex residentIndex -> do + writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex) + resolvePersistent x y residentIndex + MissingPointIndex -> do + derived <- deriveMutablePointIndex mutable + writeSTRef mdPointIndex (ActivePersistentPointIndex derived) + resolvePersistent x y derived + where + resolvePersistent x y pointIndex = + foldM + (confirmCandidate mutable x y) + Nothing + (pointIndexCandidates x y pointIndex) + +-- | Whether the transaction has already committed to incremental identity +-- transport. Answering does not force a dormant index's lazy rebuild, which +-- is the point: a per-question caller must not buy a whole-mesh build. +identityIndexActive :: MutableDcel s vertex directed undirected face -> ST s Bool +identityIndexActive MutableDcel{mdPointIndex} = do + indexState <- readSTRef mdPointIndex + pure $ case indexState of + ActivePersistentPointIndex _ -> True + ActiveBatchPointIndex _ -> True + _ -> False +{-# INLINE identityIndexActive #-} + +-- | Declare that a singleton handle-keyed rewrite must transport the resident +-- immutable identity section strictly. Dense point-keyed removal uses +-- 'activateBatchPointIndex' instead, so it neither forces nor incrementally +-- allocates the published 'PointIndex'. +activatePointIndex + :: MutableDcel s vertex directed undirected face + -> ST s () +activatePointIndex mutable@MutableDcel{mdPointIndex} = do + indexState <- readSTRef mdPointIndex + case indexState of + ActivePersistentPointIndex _ -> pure () + ActiveBatchPointIndex _ -> pure () + DormantPointIndex residentIndex -> + writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex) + MissingPointIndex -> do + derived <- deriveMutablePointIndex mutable + writeSTRef mdPointIndex (ActivePersistentPointIndex derived) + +-- | Open an identity section for one dense removal program. The table derives +-- only from coordinate authority, and its extent is deliberately narrower +-- than the surrounding session: publication returns to the lazy immutable +-- derivation instead of retaining a second mutable identity owner. +activateBatchPointIndex + :: MutableDcel s vertex directed undirected face + -> ST s (Either BuildError ()) +activateBatchPointIndex mutable@MutableDcel{mdPointIndex} = do + vertices <- pointCount mutable + table <- newMutablePointIndex vertices + seeded <- + seedMutablePointIndex + table + vertices + (readPointX mutable) + (readPointY mutable) + case seeded of + Left failure -> pure (Left failure) + Right () -> do + writeSTRef mdPointIndex (ActiveBatchPointIndex table) + pure (Right ()) +-- | Close the batch-local identity section after its removal program. Its +-- contents cannot escape @ST@; marking the cache missing makes freeze glue a +-- lazy immutable derivation from the final coordinate arenas. +discardBatchPointIndex + :: MutableDcel s vertex directed undirected face + -> ST s () +discardBatchPointIndex MutableDcel{mdPointIndex} = + modifySTRef' + mdPointIndex + (\indexState -> + case indexState of + ActiveBatchPointIndex _ -> MissingPointIndex + retained -> retained + ) + +deriveMutablePointIndex + :: MutableDcel s vertex directed undirected face + -> ST s PointIndex +deriveMutablePointIndex mutable = do + vertices <- pointCount mutable + foldM insertResident emptyPointIndex [0 .. vertices - 1] + where + insertResident pointIndex vertex = do + x <- readPointX mutable vertex + y <- readPointY mutable vertex + pure (insertPointIndex x y vertex pointIndex) + +confirmCandidate + :: MutableDcel s vertex directed undirected face + -> Double + -> Double + -> Maybe Int + -> Int + -> ST s (Maybe Int) +confirmCandidate _ _ _ resident@(Just _) _ = pure resident +confirmCandidate mutable x y Nothing candidate = do + heldX <- readPointX mutable candidate + heldY <- readPointY mutable candidate + pure (if heldX == x && heldY == y then Just candidate else Nothing) +{-# INLINE confirmCandidate #-} + +-- | Read one stored coordinate without building a t'Point'. Coordinates are +-- the authoritative state owned by 'mdPointX'/'mdPointY'; the t'Point' +-- constructor is the cold accessor's packaging, and the construction kernel +-- reads these arenas directly so a specialized sweep never boxes one. +readPointX :: MutableDcel s vertex directed undirected face -> Int -> ST s Double +readPointX MutableDcel{mdPointX} index = readPaged mdPointX index +{-# INLINE readPointX #-} + +readPointY :: MutableDcel s vertex directed undirected face -> Int -> ST s Double +readPointY MutableDcel{mdPointY} index = readPaged mdPointY index +{-# INLINE readPointY #-} + +writePoint :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s () +writePoint MutableDcel{mdPointX, mdPointY} index rawPoint = + case canonicalPoint rawPoint of + Point x y -> do + writePaged mdPointX index x + writePaged mdPointY index y +{-# INLINE writePoint #-} + +vertexDataAt :: MutableDcel s vertex directed undirected face -> Int -> ST s vertex +vertexDataAt MutableDcel{mdVertexData} = readBoxedPaged mdVertexData +{-# INLINE vertexDataAt #-} + +writeVertexData :: MutableDcel s vertex directed undirected face -> Int -> vertex -> ST s () +writeVertexData MutableDcel{mdVertexData} = writeBoxedPaged mdVertexData +{-# INLINE writeVertexData #-} + +-- | Whether no element payload plane can be holding anything. Constant for the +-- transaction: see 'mdPayloadsPristine'. A rewrite site that performs several +-- resets together tests this once rather than paying the test inside each. +payloadsPristine :: MutableDcel s vertex directed undirected face -> Bool +payloadsPristine = mdPayloadsPristine +{-# INLINE payloadsPristine #-} + +-- | Return one undirected edge and both its half-edges to the element +-- defaults. A payload labels the element occupying a slot, and an element is +-- its geometry: a rewrite that gives a slot new endpoints has put a different +-- edge there, and the label the old one carried does not describe it. Leaving +-- it would also make the payload plane depend on the flip order that reached +-- the normal form, while the topology does not. +-- +-- The constraint flag is deliberately not reset with it. A flag states that a +-- segment of the input is present, and a segment that gets split is still +-- present as its two halves; a payload states what an element is. +resetEdgeData :: MutableDcel s vertex directed undirected face -> Int -> ST s () +resetEdgeData MutableDcel{mdDirectedData, mdUndirectedData, mdPayloadsPristine, mdElementDefaults} pair = + unless mdPayloadsPristine $ do + resetBoxedRange mdDirectedData (defaultDirectedEdgeData mdElementDefaults) (2 * pair) 2 + resetBoxedRange mdUndirectedData (defaultUndirectedEdgeData mdElementDefaults) pair 1 +{-# INLINE resetEdgeData #-} + +-- | Return one face to the element default. See 'resetEdgeData'. +resetFaceData :: MutableDcel s vertex directed undirected face -> Int -> ST s () +resetFaceData MutableDcel{mdFaceData, mdPayloadsPristine, mdElementDefaults} face = + unless mdPayloadsPristine (resetBoxedRange mdFaceData (defaultFaceData mdElementDefaults) face 1) +{-# INLINE resetFaceData #-} + +edgeOriginPoint :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point) +edgeOriginPoint mutable edge = readOrigin mutable edge >>= pointAt mutable +{-# INLINE edgeOriginPoint #-} + +appendVertex + :: MutableDcel s vertex directed undirected face + -> Point + -> vertex + -> ST s Int +appendVertex mutable rawPoint vertexData = + case canonicalPoint rawPoint of + Point x y -> appendVertexCoordinates mutable x y vertexData +{-# INLINE appendVertex #-} + +-- | Append a vertex whose coordinates are already canonical, by components. +-- This is the one owner of the append record; 'appendVertex' is its +-- t'Point'-carrying form for callers holding a point. Raw capacity means the +-- appender initializes every field of the record it exposes. +appendVertexCoordinates + :: MutableDcel s vertex directed undirected face + -> Double + -> Double + -> vertex + -> ST s Int +appendVertexCoordinates mutable@MutableDcel{mdPointCount, mdPointX, mdPointY, mdPointIndex, mdNewConnected, mdRecycledNew} x y vertexData = do + vertex <- readSTRef mdPointCount + writePaged mdPointX vertex x + writePaged mdPointY vertex y + writeVertexData mutable vertex vertexData + writeVertexOut mutable vertex (-1) + if vertex >= mdInitialPointCount mutable + then writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 0 + else modifySTRef' mdRecycledNew (IntSet.insert vertex) + modifySTRef' + mdPointIndex + (\pointIndexState -> + case pointIndexState of + ActivePersistentPointIndex pointIndex -> + ActivePersistentPointIndex (insertPointIndex x y vertex pointIndex) + -- The batch table is only lawful over the removal subprogram that + -- opened it. An insertion before that scope is closed invalidates the + -- derived cache rather than pretending an unregistered handle exists. + ActiveBatchPointIndex _ -> MissingPointIndex + -- Transported lazily: the field holds a pure update thunk, so a batch + -- that never asks an identity question pays one allocation per append, + -- while a persistent chain that asks every publication forces a + -- depth-one thunk instead of rebuilding the index over the whole mesh. + DormantPointIndex pointIndex -> + DormantPointIndex (insertPointIndex x y vertex pointIndex) + MissingPointIndex -> MissingPointIndex + ) + writeSTRef mdPointCount (vertex + 1) + pure vertex + +-- | Check the point arena before a local rewrite materializes vertices. The +-- caller performs this before the first write, so refusal needs no rollback. +ensurePointCapacity + :: MutableDcel s vertex directed undirected face + -> Int + -> ST s (Either BuildError ()) +ensurePointCapacity MutableDcel{mdPointCount, mdPointCapacity} additional + | additional < 0 = pure (Left (CapacityExceeded additional)) + | otherwise = do + current <- readSTRef mdPointCount + let !required = current + additional + pure $ + if required > mdPointCapacity + then Left (CapacityExceeded required) + else Right () +{-# INLINE ensurePointCapacity #-} + +markConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +markConnected mutable@MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew, mdConnectedCount} vertex outgoing = do + if vertex >= mdInitialPointCount + then do + let !newVertex = vertex - mdInitialPointCount + connected <- readPaged mdNewConnected newVertex + unless (connected /= 0) $ do + writePaged mdNewConnected newVertex 1 + modifySTRef' mdConnectedCount (+ 1) + else do + recycled <- readSTRef mdRecycledNew + when (IntSet.member vertex recycled) $ do + writeSTRef mdRecycledNew (IntSet.delete vertex recycled) + modifySTRef' mdConnectedCount (+ 1) + writeVertexOut mutable vertex outgoing +{-# INLINE markConnected #-} + +isConnected :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool +isConnected MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew} vertex + | vertex < mdInitialPointCount = IntSet.notMember vertex <$> readSTRef mdRecycledNew + | otherwise = (/= 0) <$> readPaged mdNewConnected (vertex - mdInitialPointCount) +{-# INLINE isConnected #-} + +addEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Int, Int) +addEdge mutable from to = do + base <- addEdgeBlock mutable 1 + writeOrigin mutable base from + writeOrigin mutable (base + 1) to + pure (base, base + 1) +{-# INLINE addEdge #-} + +-- Each appended pair owns the initialization of its exposed topology and +-- constraint records; reserved capacity remains untouched. +addEdgeBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +addEdgeBlock mutable@MutableDcel{mdHalfCount, mdConstraint} pairs = do + base <- readSTRef mdHalfCount + let !required = base + 2 * pairs + !firstUndirected = base `quot` 2 + !lastUndirected = firstUndirected + pairs - 1 + forM_ [4 * base .. 4 * required - 1] $ \slot -> + writePaged (mdHalfTopology mutable) slot noIndex + forM_ [firstUndirected .. lastUndirected] $ \edge -> writePaged mdConstraint edge 0 + writeSTRef mdHalfCount required + pure base +{-# INLINE addEdgeBlock #-} + +addFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +addFace mutable anchor = do + base <- addFaceBlock mutable 1 + writeFaceEdge mutable base anchor + pure base +{-# INLINE addFace #-} + +addFaceBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +addFaceBlock mutable@MutableDcel{mdFaceCount} count = do + base <- readSTRef mdFaceCount + let !required = base + count + mapM_ (\face -> writeFaceEdge mutable face (-1)) [base .. required - 1] + writeSTRef mdFaceCount required + pure base +{-# INLINE addFaceBlock #-} + +-- | Check the local allocation section before any topology rewrite begins. +-- A refusal leaves every mutable plane untouched, so the enclosing transaction +-- can abandon publication without rollback machinery. +ensureCellCapacity + :: MutableDcel s vertex directed undirected face + -> Int + -> Int + -> ST s (Either BuildError ()) +ensureCellCapacity MutableDcel{mdHalfCount, mdHalfCapacity, mdFaceCount, mdFaceCapacity} additionalPairs additionalFaces + | additionalPairs < 0 = pure (Left (HalfEdgeCapacityExceeded additionalPairs mdHalfCapacity)) + | additionalFaces < 0 = pure (Left (FaceCapacityExceeded additionalFaces mdFaceCapacity)) + | otherwise = do + currentHalfEdges <- readSTRef mdHalfCount + currentFaces <- readSTRef mdFaceCount + let !requiredHalfEdges = currentHalfEdges + 2 * additionalPairs + !requiredFaces = currentFaces + additionalFaces + if requiredHalfEdges > mdHalfCapacity + then pure (Left (HalfEdgeCapacityExceeded requiredHalfEdges mdHalfCapacity)) + else + if requiredFaces > mdFaceCapacity + then pure (Left (FaceCapacityExceeded requiredFaces mdFaceCapacity)) + else pure (Right ()) +{-# INLINE ensureCellCapacity #-} + +truncatePoints :: MutableDcel s vertex directed undirected face -> Int -> ST s () +truncatePoints MutableDcel{mdPointCount, mdConnectedCount} count = do + writeSTRef mdPointCount count + connected <- readSTRef mdConnectedCount + when (connected > count) (writeSTRef mdConnectedCount count) + +truncateDirectedEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s () +truncateDirectedEdges MutableDcel{mdHalfCount} = writeSTRef mdHalfCount + +truncateFaces :: MutableDcel s vertex directed undirected face -> Int -> ST s () +truncateFaces MutableDcel{mdFaceCount, mdLastFace} count = do + writeSTRef mdFaceCount count + lastFace <- readSTRef mdLastFace + when (lastFace >= count) (writeSTRef mdLastFace (if count > 1 then 1 else 0)) + +-- | Remove one undirected edge by moving the last pair into its slot. Only the +-- two neighboring links, one vertex representative, and one face +-- representative per moved half-edge can reference the old handles. +-- +-- The slot the tail vacates is returned to the defaults here rather than when +-- the allocator hands it back out. That keeps one invariant — every slot at or +-- above the live count holds the fill — which the thaw establishes, this +-- preserves, and 'addEdgeBlock' may therefore assume without testing anything. +-- The cost lands on removal, which is where the element was retired, instead of +-- on every allocation a pure insertion makes. +swapRemoveUndirectedEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ()) +swapRemoveUndirectedEdge mutable@MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} pair = do + halfEdges <- directedEdgeCount mutable + let !pairs = halfEdges `quot` 2 + !lastPair = pairs - 1 + if pair < 0 || pair > lastPair + then + pure + ( Left + ( RemovalEdgeOutOfRange + (UndirectedEdgeId (fromIntegral pair)) + pairs + ) + ) + else do + swapRemoveUndirectedEdgeInRange lastPair + pure (Right ()) + where + swapRemoveUndirectedEdgeInRange lastPair = do + removedFlag <- readPaged mdConstraint pair + lastFlag <- readPaged mdConstraint lastPair + when (removedFlag /= 0) (modifySTRef' mdConstraintCount (subtract 1)) + when (pair /= lastPair) $ do + let !oldBase = 2 * lastPair + !newBase = 2 * pair + remap !handle + | handle == oldBase = newBase + | handle == oldBase + 1 = newBase + 1 + | otherwise = handle + -- Both records are taken before either is republished: the pair's two + -- half-edges can name each other, so a read after the first write would + -- see the new handle where the old one belongs. + !forwardOrigin <- readOrigin mutable oldBase + !forwardNext <- remap <$> readNext mutable oldBase + !forwardPrevious <- remap <$> readPrevious mutable oldBase + !forwardFace <- readFace mutable oldBase + !backwardOrigin <- readOrigin mutable (oldBase + 1) + !backwardNext <- remap <$> readNext mutable (oldBase + 1) + !backwardPrevious <- remap <$> readPrevious mutable (oldBase + 1) + !backwardFace <- readFace mutable (oldBase + 1) + writePaged mdConstraint pair lastFlag + unless (mdPayloadsPristine mutable) $ do + readBoxedPaged (mdUndirectedData mutable) lastPair >>= writeBoxedPaged (mdUndirectedData mutable) pair + readBoxedPaged (mdDirectedData mutable) oldBase >>= writeBoxedPaged (mdDirectedData mutable) newBase + readBoxedPaged (mdDirectedData mutable) (oldBase + 1) >>= writeBoxedPaged (mdDirectedData mutable) (newBase + 1) + writeOrigin mutable newBase forwardOrigin + writeNext mutable newBase forwardNext + writePrevious mutable newBase forwardPrevious + writeFace mutable newBase forwardFace + writeOrigin mutable (newBase + 1) backwardOrigin + writeNext mutable (newBase + 1) backwardNext + writePrevious mutable (newBase + 1) backwardPrevious + writeFace mutable (newBase + 1) backwardFace + writeNext mutable forwardPrevious newBase + writePrevious mutable forwardNext newBase + writeVertexOut mutable forwardOrigin newBase + writeFaceEdge mutable forwardFace newBase + writeNext mutable backwardPrevious (newBase + 1) + writePrevious mutable backwardNext (newBase + 1) + writeVertexOut mutable backwardOrigin (newBase + 1) + writeFaceEdge mutable backwardFace (newBase + 1) + modifySTRef' + mdConstraintEdges + (\edges -> + let withoutRetired = IntSet.delete pair (IntSet.delete lastPair edges) + in if pair /= lastPair && lastFlag /= 0 + then IntSet.insert pair withoutRetired + else withoutRetired + ) + resetEdgeData mutable lastPair + truncateDirectedEdges mutable (2 * lastPair) + +swapRemoveFace :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ()) +swapRemoveFace mutable face = do + faces <- faceCount mutable + let !lastFace = faces - 1 + if face <= 0 || face > lastFace + then + pure + ( Left + (RemovalFaceOutOfRange (FaceId (fromIntegral face)) faces) + ) + else do + relocated <- + if face == lastFace + then pure (Right ()) + else relocateLastFace lastFace + case relocated of + Left obstruction -> pure (Left obstruction) + Right () -> do + resetFaceData mutable lastFace + truncateFaces mutable lastFace + pure (Right ()) + where + relocateLastFace lastFace = do + start <- readFaceEdge mutable lastFace + writeFaceEdge mutable face start + -- Swap-compaction moves the last face's index, not the face. When the + -- locator's cached start is that face, following it here is the difference + -- between a batch of removals resuming where the previous one settled and + -- 'truncateFaces' finding the cached index out of range and resetting it to + -- the first inner face. The cache is a start, never an answer. + cachedFace <- readSTRef (mdLastFace mutable) + when (cachedFace == lastFace) (writeSTRef (mdLastFace mutable) face) + unless (mdPayloadsPristine mutable) $ + readBoxedPaged (mdFaceData mutable) lastFace >>= writeBoxedPaged (mdFaceData mutable) face + halfEdges <- directedEdgeCount mutable + let go !remaining !current !seen + | remaining <= 0 = + pure + ( Left + ( RemovalFaceCycleDidNotTerminate + (FaceId (fromIntegral lastFace)) + (DirectedEdgeId (fromIntegral current)) + (halfEdges + 1) + ) + ) + | seen && current == start = pure (Right ()) + | otherwise = do + writeFace mutable current face + nextEdge <- readNext mutable current + go (remaining - 1) nextEdge True + go (halfEdges + 1) start False + +-- | Retire a vertex by moving the arena's last into its slot. The relocation is +-- reported as the slot together with the position now standing in it: the two +-- are one fact, and a caller told only the slot has to consult the mesh to +-- learn what landed there. +swapRemoveVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point))) +swapRemoveVertex mutable@MutableDcel{mdConnectedCount, mdPointIndex, mdRecycledNew, mdNewConnected} vertex = do + vertices <- pointCount mutable + let !lastVertex = vertices - 1 + if vertex < 0 || vertex > lastVertex + then + pure + ( Left + (RemovalVertexOutOfRange (VertexId (fromIntegral vertex)) vertices) + ) + else swapRemoveVertexInRange lastVertex + where + swapRemoveVertexInRange lastVertex = do + removedPoint <- pointAt mutable vertex + removedPayload <- vertexDataAt mutable vertex + movedOutcome <- + if vertex == lastVertex + then pure (Right Nothing) + else moveTailVertex lastVertex + case movedOutcome of + Left obstruction -> pure (Left obstruction) + Right moved -> do + indexState <- readSTRef mdPointIndex + updatedIndexState <- + updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved + writeSTRef mdPointIndex updatedIndexState + -- The connectivity companions must agree with the aggregate assertion two + -- lines down: after a swap removal every surviving vertex is connected. The + -- retired slot's entry and the relocated occupant's old entry are both + -- stale, and a relocated occupant landing in the appended region must read + -- connected through the offset store, not through its predecessor's bit. + modifySTRef' mdRecycledNew (IntSet.delete vertex . IntSet.delete lastVertex) + case moved of + Just _ + | vertex >= mdInitialPointCount mutable -> + writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 1 + _ -> pure () + truncatePoints mutable lastVertex + writeSTRef mdConnectedCount lastVertex + pure (Right (removedPoint, removedPayload, moved)) + + moveTailVertex lastVertex = do + movedPoint <- pointAt mutable lastVertex + movedPayload <- vertexDataAt mutable lastVertex + movedOut <- readVertexOut mutable lastVertex + writePoint mutable vertex movedPoint + writeVertexData mutable vertex movedPayload + writeVertexOut mutable vertex movedOut + relocated <- + if movedOut < 0 + then pure (Right ()) + else relocateOutgoingCycle lastVertex movedOut + pure (Just (vertex, movedPoint) <$ relocated) + + relocateOutgoingCycle lastVertex movedOut = do + halfEdges <- directedEdgeCount mutable + let go !remaining !current !seen + | remaining <= 0 = + pure + ( Left + ( RemovalOutgoingCycleDidNotTerminate + (VertexId (fromIntegral lastVertex)) + (DirectedEdgeId (fromIntegral current)) + (halfEdges + 1) + ) + ) + | seen && current == movedOut = pure (Right ()) + | otherwise = do + writeOrigin mutable current vertex + previousEdge <- readPrevious mutable current + go (remaining - 1) (previousEdge `xor` 1) True + go (halfEdges + 1) movedOut False + +-- | Transport the identity view across one vertex swap. Persistent sections +-- retain their existing pure update law. A batch table mutates in place, then +-- deliberately falls back to @MissingPointIndex@ if either local proof cannot +-- be completed; geometry remains authoritative and subsequent operations walk +-- rather than observe a stale cache. +updatePointIndexAfterSwap + :: MutableDcel s vertex directed undirected face + -> MutablePointIndexState s + -> Point + -> Int + -> Int + -> Maybe (Int, Point) + -> ST s (MutablePointIndexState s) +updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved = + case indexState of + DormantPointIndex pointIndex -> + pure (DormantPointIndex (updatePersistentPointIndex pointIndex)) + ActivePersistentPointIndex pointIndex -> + pure (ActivePersistentPointIndex (updatePersistentPointIndex pointIndex)) + ActiveBatchPointIndex table -> + transportBatchPointIndex table + MissingPointIndex -> pure MissingPointIndex + where + updatePersistentPointIndex pointIndex = + case removedPoint of + Point removedX removedY -> + let withoutRemoved = removePointIndex removedX removedY vertex pointIndex + in case moved of + Nothing -> withoutRemoved + Just (_, Point movedX movedY) -> + relocatePointIndex movedX movedY lastVertex vertex withoutRemoved + + transportBatchPointIndex table = + case removedPoint of + Point removedX removedY -> do + removed <- + removeMutablePoint + table + (readPointX mutable) + (readPointY mutable) + removedX + removedY + vertex + case (removed, moved) of + (MutablePointIndexUpdated, Nothing) -> + pure (ActiveBatchPointIndex table) + (MutablePointIndexUpdated, Just (_, Point movedX movedY)) -> do + relocated <- relocateMutablePoint table movedX movedY lastVertex vertex + pure $ + case relocated of + MutablePointIndexUpdated -> ActiveBatchPointIndex table + MutablePointIndexInvalidated -> MissingPointIndex + (MutablePointIndexInvalidated, _) -> pure MissingPointIndex + + -- 'swapRemoveVertex' calls us before truncation. The tail's coordinate cells + -- still carry the moved point, so backward-shift repair can derive every + -- occupant home from the same canonical storage that the table indexes. +linkEdges :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +linkEdges mutable left right = do + writeNext mutable left right + writePrevious mutable right left +{-# INLINE linkEdges #-} + +setCycle3 :: MutableDcel s vertex directed undirected face -> Int -> Int -> Int -> Int -> ST s () +setCycle3 mutable face e0 e1 e2 = do + writeNext mutable e0 e1 + writeNext mutable e1 e2 + writeNext mutable e2 e0 + writePrevious mutable e0 e2 + writePrevious mutable e1 e0 + writePrevious mutable e2 e1 + writeFace mutable e0 face + writeFace mutable e1 face + writeFace mutable e2 face + writeFaceEdge mutable face e0 +{-# INLINE setCycle3 #-} + +faceEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s (Int, Int, Int) +faceEdges mutable face = do + e0 <- readFaceEdge mutable face + e1 <- readNext mutable e0 + e2 <- readNext mutable e1 + pure (e0, e1, e2) +{-# INLINE faceEdges #-} + +readOrigin :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readOrigin MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index) +readNext :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readNext MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 1) +readPrevious :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readPrevious MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 2) +readFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readFace MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 3) +{-# INLINE readOrigin #-} +{-# INLINE readNext #-} +{-# INLINE readPrevious #-} +{-# INLINE readFace #-} + +writeOrigin :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writeOrigin MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index) (packIndex value) +writeNext :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writeNext MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 1) (packIndex value) +writePrevious :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writePrevious MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 2) (packIndex value) +writeFace :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writeFace MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 3) (packIndex value) +{-# INLINE writeOrigin #-} +{-# INLINE writeNext #-} +{-# INLINE writePrevious #-} +{-# INLINE writeFace #-} + +readVertexOut :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readVertexOut MutableDcel{mdVertexOut} index = do + value <- readPaged mdVertexOut index + pure (if value == noIndex then -1 else fromIntegral value) +{-# INLINE readVertexOut #-} + +writeVertexOut :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writeVertexOut MutableDcel{mdVertexOut} index value = + writePaged mdVertexOut index (if value < 0 then noIndex else packIndex value) +{-# INLINE writeVertexOut #-} + +readFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Int +readFaceEdge MutableDcel{mdFaceEdge} index = do + value <- readPaged mdFaceEdge index + pure (if value == noIndex then -1 else fromIntegral value) +{-# INLINE readFaceEdge #-} + +writeFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s () +writeFaceEdge MutableDcel{mdFaceEdge} index value = + writePaged mdFaceEdge index (if value < 0 then noIndex else packIndex value) +{-# INLINE writeFaceEdge #-} + +readConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool +readConstraint MutableDcel{mdConstraint} directed = (/= 0) <$> readPaged mdConstraint (directed `quot` 2) +{-# INLINE readConstraint #-} + +setConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool +setConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do + let !index = directed `quot` 2 + current <- readPaged mdConstraint index + if current /= 0 + then pure False + else do + writePaged mdConstraint index 1 + modifySTRef' mdConstraintCount (+ 1) + modifySTRef' mdConstraintEdges (IntSet.insert index) + pure True +{-# INLINE setConstraint #-} + +clearConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool +clearConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do + let !index = directed `quot` 2 + current <- readPaged mdConstraint index + if current == 0 + then pure False + else do + writePaged mdConstraint index 0 + modifySTRef' mdConstraintCount (subtract 1) + modifySTRef' mdConstraintEdges (IntSet.delete index) + pure True +{-# INLINE clearConstraint #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs b/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | The state one operation owns while it works: the legalization arena, the +-- shared scratch arena, and the instrumentation cells. None of it is +-- topology, so none of it lives on @MutableDcel@ — a transaction allocates +-- this record when it thaws, hands it down to the operations it runs, and +-- reads the counters back once when it freezes. The hot loops thread their +-- stack top, maximum depth and flip count as strict loop variables and charge +-- these cells once per drain; cold events (one per insertion, one per walk +-- probe) charge them where they happen. +module Moonlight.Triangulation.Internal.OperationState + ( Counter (..) + , OperationState + , newOperationState + , legalizationArena + , storeLegalizationArena + , writeScratch + , readScratch + , addCounter + , setCounter + , maxCounter + , readCounter + , freezeBuildStats + ) where + +import Control.Monad (when) +import Control.Monad.ST (ST) +import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef) +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32, Word64) +import Moonlight.Triangulation.Internal.Growable + ( GrowableWord32 + , newGrowableWord32 + , readGrowable + , writeGrowable + ) +import Moonlight.Triangulation.Internal.PackedIndex (packIndex) +import Moonlight.Triangulation.Internal.Types (BuildStats (..)) + +-- | Instrumentation cells. The first twenty constructors are exactly the +-- t'BuildStats' fields, in t'BuildStats' order; anything after +-- 'CounterRefinementQueuePops' is a diagnostic with no t'BuildStats' field and +-- is read only by instrumented entries, so 'freezeBuildStats' enumerates the +-- leading block and never sees the rest. +data Counter + = CounterInputPoints + | CounterUniquePoints + | CounterExistingPoints + | CounterDuplicatePoints + | CounterSpatialSeedPoints + | CounterFaceSplits + | CounterInteriorEdgeSplits + | CounterBoundaryEdgeSplits + | CounterHullInsertions + | CounterLineSplits + | CounterLineExtensions + | CounterLineToAreaTransitions + | CounterEdgeFlips + | CounterLocationWalkSteps + | CounterLocationFallbacks + | CounterLocationMaxWalk + | CounterLegalizationMaxStack + | CounterSteinerPoints + | CounterRefinementFaceChecks + | CounterRefinementQueuePops + | CounterSweepFastPoints + | CounterSweepSkippedPoints + | CounterDiagLegalizationCandidates + | CounterDiagHullBucketProbeSteps + | CounterDiagHullKeyRebuilds + | CounterCount + deriving stock (Eq, Ord, Enum, Bounded, Show) + +-- | One operation's working state. Scratch is fixed and raw: writes always +-- precede reads within an epoch. The legalization vector is held behind one +-- reference solely so an adversarial generic drain can grow it without +-- reintroducing mesh-global work state. A drain reads that reference once, +-- carries the vector and all stack metrics strictly, and stores it once when +-- finished; there is no per-candidate reference traffic. +data OperationState s = OperationState + { osLegalizationArena :: !(STRef s (MUV.MVector s Word32)) + , osScratchArena :: !(GrowableWord32 s) + , osCounters :: !(MUV.MVector s Word64) + } + +-- | Allocate transaction-sized working state. The legalization reservation is a +-- starting size, not a semantic limit: a generic flip pops one candidate and may +-- push four, no linear worst-case depth follows from the input size, and +-- overflow grows the operation-owned vector by doubling. So the reservation is +-- capped. A transaction-sized one charges every singleton verb a fresh block +-- group whose tail no drain reaches, and the doublings that reach a real peak +-- copy less in total than reserving that tail costs. +-- +-- Scratch retains four disjoint half-edge sections as its semantic limit: the +-- removal kernel locally glues border, retired-edge, retired-face, and new-fan +-- sections there. Its physical storage still grows only with the star or strip +-- actually observed. Reserving the full mesh bound made every singleton +-- persistent edit allocate an arena whose untouched tail was orders of +-- magnitude larger than the edit. +newOperationState :: Int -> ST s (OperationState s) +newOperationState halfEdgeCapacity = do + initialArena <- MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation) + arena <- newSTRef initialArena + scratch <- newGrowableWord32 (min 64 (halfEdgeCapacity + 8)) + counters <- MUV.replicate (fromEnum CounterCount) 0 + pure + OperationState + { osLegalizationArena = arena + , osScratchArena = scratch + , osCounters = counters + } + +-- | Ordinary cavities are tiny; exceptional stars and recovered strips grow +-- geometrically behind the sealed arena rather than taxing every singleton +-- edit for a pathological frontier it never visits. +initialLegalizationReservation :: Int +initialLegalizationReservation = 64 + +legalizationArena :: OperationState s -> ST s (MUV.MVector s Word32) +legalizationArena = readSTRef . osLegalizationArena +{-# INLINE legalizationArena #-} + +storeLegalizationArena :: OperationState s -> MUV.MVector s Word32 -> ST s () +storeLegalizationArena = writeSTRef . osLegalizationArena +{-# INLINE storeLegalizationArena #-} + +-- | Write a scratch cell. Collection walks carry their topology-derived +-- termination budgets; the growable arena is physical storage, not a second +-- semantic bound capable of disagreeing with those typed obstructions. +writeScratch :: OperationState s -> Int -> Int -> ST s () +writeScratch OperationState{osScratchArena} index value = + writeGrowable osScratchArena index (packIndex value) +{-# INLINE writeScratch #-} + +readScratch :: OperationState s -> Int -> ST s Int +readScratch OperationState{osScratchArena} index = fromIntegral <$> readGrowable osScratchArena index +{-# INLINE readScratch #-} + +addCounter :: OperationState s -> Counter -> Int -> ST s () +addCounter OperationState{osCounters} counter amount = do + let !index = fromEnum counter + current <- MUV.unsafeRead osCounters index + MUV.unsafeWrite osCounters index (current + fromIntegral amount) +{-# INLINE addCounter #-} + +setCounter :: OperationState s -> Counter -> Int -> ST s () +setCounter OperationState{osCounters} counter value = + MUV.unsafeWrite osCounters (fromEnum counter) (fromIntegral value) +{-# INLINE setCounter #-} + +maxCounter :: OperationState s -> Counter -> Int -> ST s () +maxCounter OperationState{osCounters} counter value = do + let !index = fromEnum counter + current <- MUV.unsafeRead osCounters index + when (fromIntegral value > current) (MUV.unsafeWrite osCounters index (fromIntegral value)) +{-# INLINE maxCounter #-} + +readCounter :: OperationState s -> Counter -> ST s Int +readCounter OperationState{osCounters} counter = + fromIntegral <$> MUV.unsafeRead osCounters (fromEnum counter) +{-# INLINE readCounter #-} + +-- | Materialize the public statistics once, at freeze time, from the cells the +-- operation's subsystems charged while it ran. Diagnostic cells past +-- 'CounterRefinementQueuePops' have no t'BuildStats' field and are not read +-- here. +freezeBuildStats :: OperationState s -> ST s BuildStats +freezeBuildStats operation = + BuildStats + <$> readCounter operation CounterInputPoints + <*> readCounter operation CounterUniquePoints + <*> readCounter operation CounterExistingPoints + <*> readCounter operation CounterDuplicatePoints + <*> readCounter operation CounterSpatialSeedPoints + <*> readCounter operation CounterFaceSplits + <*> readCounter operation CounterInteriorEdgeSplits + <*> readCounter operation CounterBoundaryEdgeSplits + <*> readCounter operation CounterHullInsertions + <*> readCounter operation CounterLineSplits + <*> readCounter operation CounterLineExtensions + <*> readCounter operation CounterLineToAreaTransitions + <*> readCounter operation CounterEdgeFlips + <*> readCounter operation CounterLocationWalkSteps + <*> readCounter operation CounterLocationFallbacks + <*> readCounter operation CounterLocationMaxWalk + <*> readCounter operation CounterLegalizationMaxStack + <*> readCounter operation CounterSteinerPoints + <*> readCounter operation CounterRefinementFaceChecks + <*> readCounter operation CounterRefinementQueuePops + <*> readCounter operation CounterSweepFastPoints + <*> readCounter operation CounterSweepSkippedPoints +{-# INLINE freezeBuildStats #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/PointIndex.hs b/src-dcel/Moonlight/Triangulation/Internal/PointIndex.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/PointIndex.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | The one derived identity index from canonical position hashes to the +-- vertices holding them. Geometry remains solely in the coordinate arenas: +-- both forms store handles only, and every hit is confirmed against those +-- authoritative coordinates. The persistent form follows a published mesh; +-- the open-addressed form is the denser ingress representation used while a +-- bulk load is still claiming its vertices. +module Moonlight.Triangulation.Internal.PointIndex + ( PointIndex + , emptyPointIndex + , buildPointIndex + , pointIndexCandidates + , lookupPointIndex + , insertPointIndex + , removePointIndex + , relocatePointIndex + , MutablePointIndex + , MutablePointIndexUpdate (..) + , newMutablePointIndex + , seedMutablePointIndex + , lookupMutablePoint + , removeMutablePoint + , relocateMutablePoint + , resolveMutablePoint + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Monad.ST (ST) +import Data.Bits (shiftR, xor, (.&.)) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32, Word64) +import GHC.Float (castDoubleToWord64) +import Moonlight.Triangulation.Internal.Types (BuildError (PointIndexCapacityExhausted), Point (..)) +import Moonlight.Triangulation.Internal.Paged + ( Paged + , pagedUnsafeIndex + , toVector + ) +import Moonlight.Triangulation.Scalar (canonicalScalarZero) +import qualified Data.Vector.Unboxed as U + +-- | Hash buckets containing only vertex handles. Callers confirm candidates +-- against the authoritative coordinate planes. +newtype PointIndex = PointIndex (IntMap.IntMap [Int]) + deriving stock (Eq, Show) + +-- A point index is a memoized derived view. Forcing a triangulation forces the +-- geometry and topology that determine it, not a cache no read has demanded. +-- This is the same semantic boundary as omitting the cache from serialization. +instance NFData PointIndex where + rnf _ = () + +emptyPointIndex :: PointIndex +emptyPointIndex = PointIndex IntMap.empty + +-- | Derive an index from the authoritative structure-of-arrays geometry. +buildPointIndex :: Paged Double -> Paged Double -> PointIndex +buildPointIndex pointXs pointYs = + U.ifoldl' + (\index vertex x -> + insertPointIndex x (pagedUnsafeIndex pointYs vertex) vertex index + ) + emptyPointIndex + (toVector pointXs) + +-- | Candidate vertices sharing a position hash. Exact coordinate comparison +-- belongs to the caller that owns the coordinate reader. +pointIndexCandidates :: Double -> Double -> PointIndex -> [Int] +pointIndexCandidates x y (PointIndex buckets) = + IntMap.findWithDefault [] (pointHash x y) buckets +{-# INLINE pointIndexCandidates #-} + +-- | Resolve one exact position against the authoritative coordinate planes. +-- Hashes reject; coordinates prove. Keeping this here makes the persistent +-- removal and constraint schedules consume the same identity law as a mutable +-- session instead of paying a topological point-location walk for a key lookup. +lookupPointIndex + :: Paged Double + -> Paged Double + -> PointIndex + -> Point + -> Maybe Int +lookupPointIndex pointXs pointYs pointIndex (Point x y) = + foldr confirm Nothing (pointIndexCandidates x y pointIndex) + where + confirm candidate resolved + | pagedUnsafeIndex pointXs candidate == x + && pagedUnsafeIndex pointYs candidate == y = Just candidate + | otherwise = resolved + +insertPointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex +insertPointIndex x y vertex (PointIndex buckets) = + PointIndex (IntMap.insertWith (++) (pointHash x y) [vertex] buckets) +{-# INLINE insertPointIndex #-} + +-- | Forget one proved handle without touching geometry. Empty collision +-- buckets disappear, so the index remains a derived finite view rather than a +-- history of retired sites. +removePointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex +removePointIndex x y vertex (PointIndex buckets) = + PointIndex (IntMap.update retainOthers (pointHash x y) buckets) + where + retainOthers candidates = case candidates of + [candidate] + | candidate == vertex -> Nothing + _ -> + case removeCandidate candidates of + [] -> Nothing + remaining -> Just remaining + + removeCandidate [] = [] + removeCandidate (candidate : remaining) + | candidate == vertex = remaining + | otherwise = candidate : removeCandidate remaining +{-# INLINE removePointIndex #-} + +-- | Transport the tail vertex into the slot vacated by swap compaction. +-- Coordinate storage remains authoritative; this updates handles only. +relocatePointIndex + :: Double + -> Double + -> Int + -> Int + -> PointIndex + -> PointIndex +relocatePointIndex x y previousVertex currentVertex (PointIndex buckets) = + PointIndex + (IntMap.alter (Just . relocateCandidate . maybe [] id) (pointHash x y) buckets) + where + relocateCandidate [] = [currentVertex] + relocateCandidate (candidate : remaining) + | candidate == previousVertex = currentVertex : remaining + | otherwise = candidate : relocateCandidate remaining +{-# INLINE relocatePointIndex #-} + +-- The arena already holds every key, so a slot is the vertex that owns the +-- position and nothing else. Every lookup rechecks coordinates; a failed local +-- transport invalidates the table rather than letting it outlive that proof. +data MutablePointIndex s = MutablePointIndex + { tableSlots :: !(MUV.MVector s Word32) + , tableMask :: {-# UNPACK #-} !Int + } + +-- | A local cache transport either preserves the proof that every slot agrees +-- with the coordinate arenas, or explicitly gives that proof up. Callers must +-- fall back to the lazy immutable derivation after 'MutablePointIndexInvalidated'; +-- they never publish a table whose handle correspondence was not established. +data MutablePointIndexUpdate + = MutablePointIndexUpdated + | MutablePointIndexInvalidated + +vacant :: Word32 +vacant = maxBound + +-- | Size a table for a stated number of distinct positions. +newMutablePointIndex :: Int -> ST s (MutablePointIndex s) +newMutablePointIndex expected = do + tableSlots <- MUV.replicate capacity vacant + pure MutablePointIndex{tableSlots, tableMask = capacity - 1} + where + -- Two slots per key, rounded up to a power of two: linear probing stays in a + -- short run and the mask stands in for a division. + !capacity = grow 16 + !wanted = 2 * max 1 expected + grow !size + | size >= wanted = size + | otherwise = grow (size * 2) + +-- | Seed the open-addressed section from authoritative coordinates. This is +-- the shared ingress/batch operation: no point payload or parallel identity +-- store crosses the boundary. +seedMutablePointIndex + :: MutablePointIndex s + -> Int + -> (Int -> ST s Double) + -> (Int -> ST s Double) + -> ST s (Either BuildError ()) +seedMutablePointIndex table count readX readY = seed 0 + where + seed !vertex + | vertex >= count = pure (Right ()) + | otherwise = do + x <- readX vertex + y <- readY vertex + claimed <- resolveMutablePoint table readX readY x y vertex + case claimed of + Left failure -> pure (Left failure) + Right _ -> seed (vertex + 1) + +-- | Look up a canonical position in the mutable section. A vacant slot proves +-- absence; all occupied candidates are confirmed against coordinate authority. +lookupMutablePoint + :: MutablePointIndex s + -> (Int -> ST s Double) + -> (Int -> ST s Double) + -> Double + -> Double + -> ST s (Maybe Int) +lookupMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y = + probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1) + where + probe !slot !budget + | budget <= 0 = pure Nothing + | otherwise = do + occupant <- MUV.unsafeRead tableSlots slot + if occupant == vacant + then pure Nothing + else do + heldX <- readX (fromIntegral occupant) + heldY <- readY (fromIntegral occupant) + if heldX == x && heldY == y + then pure (Just (fromIntegral occupant)) + else probe ((slot + 1) .&. tableMask) (budget - 1) +{-# INLINE lookupMutablePoint #-} + +-- | Forget a retired handle and repair its linear-probe cluster by backward +-- shifting only entries whose home run crosses the resulting hole. The reader +-- is needed for the surviving entries' homes; the retiring entry itself is +-- identified by handle because swap compaction may already have overwritten +-- its coordinate slot. An exhausted or absent proof invalidates the derived +-- cache instead of manufacturing a lookup result. +removeMutablePoint + :: MutablePointIndex s + -> (Int -> ST s Double) + -> (Int -> ST s Double) + -> Double + -> Double + -> Int + -> ST s MutablePointIndexUpdate +removeMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y retiredVertex = + findRetired (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1) + where + findRetired !slot !budget + | budget <= 0 = pure MutablePointIndexInvalidated + | otherwise = do + occupant <- MUV.unsafeRead tableSlots slot + if occupant == vacant + then pure MutablePointIndexInvalidated + else + if fromIntegral occupant == retiredVertex + then do + MUV.unsafeWrite tableSlots slot vacant + closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1) + else findRetired ((slot + 1) .&. tableMask) (budget - 1) + + closeProbeHole !hole !slot !budget + | budget <= 0 = + MutablePointIndexInvalidated <$ MUV.unsafeWrite tableSlots hole vacant + | otherwise = do + occupant <- MUV.unsafeRead tableSlots slot + if occupant == vacant + then MutablePointIndexUpdated <$ MUV.unsafeWrite tableSlots hole vacant + else do + heldX <- readX (fromIntegral occupant) + heldY <- readY (fromIntegral occupant) + let !home = fromIntegral (mixCoordinates heldX heldY) .&. tableMask + !distanceToHole = (hole - home) .&. tableMask + !distanceToSlot = (slot - home) .&. tableMask + if distanceToHole < distanceToSlot + then do + MUV.unsafeWrite tableSlots hole occupant + closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1) + else closeProbeHole hole ((slot + 1) .&. tableMask) (budget - 1) +{-# INLINE removeMutablePoint #-} + +-- | Rename the tail handle after DCEL swap compaction. Failure remains a +-- typed cache obstruction, so its caller drops the table and later identity +-- questions descend from geometry rather than trusting an unproved cache. +relocateMutablePoint + :: MutablePointIndex s + -> Double + -> Double + -> Int + -> Int + -> ST s MutablePointIndexUpdate +relocateMutablePoint MutablePointIndex{tableSlots, tableMask} x y previousVertex currentVertex = + findPrevious (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1) + where + findPrevious !slot !budget + | budget <= 0 = pure MutablePointIndexInvalidated + | otherwise = do + occupant <- MUV.unsafeRead tableSlots slot + if occupant == vacant + then pure MutablePointIndexInvalidated + else + if fromIntegral occupant == previousVertex + then + MutablePointIndexUpdated + <$ MUV.unsafeWrite tableSlots slot (fromIntegral currentVertex) + else findPrevious ((slot + 1) .&. tableMask) (budget - 1) +{-# INLINE relocateMutablePoint #-} + +-- | Answer the vertex already holding a canonical position, or claim the +-- position for @candidate@ and answer 'Nothing'. The position travels as raw +-- coordinates — the v'Point' constructor is the cold boundary's packaging and +-- has no business on the ingress path. The caller supplies the arena's +-- coordinate reader, so a claim is only sound if @candidate@ is the very next +-- vertex the arena will append. +resolveMutablePoint + :: MutablePointIndex s + -> (Int -> ST s Double) + -> (Int -> ST s Double) + -> Double + -> Double + -> Int + -> ST s (Either BuildError (Maybe Int)) +resolveMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y candidate = + probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1) + where + probe !slot !budget + | budget <= 0 = pure (Left (PointIndexCapacityExhausted (MUV.length tableSlots))) + | otherwise = do + occupant <- MUV.unsafeRead tableSlots slot + if occupant == vacant + then Right Nothing <$ MUV.unsafeWrite tableSlots slot (fromIntegral candidate) + else do + heldX <- readX (fromIntegral occupant) + heldY <- readY (fromIntegral occupant) + if heldX == x && heldY == y + then pure (Right (Just (fromIntegral occupant))) + else probe ((slot + 1) .&. tableMask) (budget - 1) + +-- Inlined rather than merely specialized: the coordinate reader arrives as an +-- argument, so until the probe loop lands at its call site every collision pays +-- an unknown call and a boxed pair for a read the caller could have made +-- directly. +{-# INLINE resolveMutablePoint #-} + +mixCoordinates :: Double -> Double -> Word64 +mixCoordinates x y = + mix + ( castDoubleToWord64 (canonicalScalarZero x) + `xor` mix (castDoubleToWord64 (canonicalScalarZero y)) + ) +{-# INLINE mixCoordinates #-} + +mix :: Word64 -> Word64 +mix raw = + let !z0 = raw + 0x9e3779b97f4a7c15 + !z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xbf58476d1ce4e5b9 + !z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb + in z2 `xor` (z2 `shiftR` 31) +{-# INLINE mix #-} + +pointHash :: Double -> Double -> Int +pointHash x y = fromIntegral (mixCoordinates x y) +{-# INLINE pointHash #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/Probe.hs b/src-dcel/Moonlight/Triangulation/Internal/Probe.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Probe.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Compile-time instrumentation switch. The bulk board is the measuring +-- instrument, so per-candidate probe counters must not exist on its path at +-- all: gating behind a flag the compiler can eliminate is the only honest way +-- to have both one sweep implementation and an undistorted measurement. The +-- flag is a type, not a value: at 'ProbeOff the counter type is @()@, so no +-- arithmetic on it can survive in the worker — erasure is a property of the +-- kind, not of the optimizer's mood. The instrumented entry instantiates the +-- same code at 'ProbeOn and pays the cold counter writes itself. +module Moonlight.Triangulation.Internal.Probe + ( Probe (..) + , ProbeCounter + , KnownProbe (..) + ) where + +import Control.Monad.ST (ST) +import Data.Kind (Type) +import Moonlight.Triangulation.Internal.OperationState + ( Counter + , OperationState + , addCounter + ) + +-- | The instrumentation switch, promoted to a kind by @DataKinds@. +data Probe = ProbeOff | ProbeOn + +-- | The counter a probe site threads. At 'ProbeOff there is nothing to +-- thread; at 'ProbeOn it is a strict @Int@. +type family ProbeCounter (probe :: Probe) = (counter :: Type) | counter -> probe where + ProbeCounter 'ProbeOff = () + ProbeCounter 'ProbeOn = Int + +class KnownProbe probe where + probeZero :: ProbeCounter probe + probeBump :: ProbeCounter probe -> ProbeCounter probe + -- | Charge one finished counter to the operation's diagnostic cell. At + -- 'ProbeOff this is @pure ()@ and disappears with the dictionary; at + -- 'ProbeOn it is one cold vector write per drain or probe site, on the + -- instrumented entry that asked for it. + probeCharge :: OperationState s -> Counter -> ProbeCounter probe -> ST s () + +instance KnownProbe 'ProbeOff where + probeZero = () + probeBump = id + probeCharge _ _ _ = pure () + {-# INLINE probeZero #-} + {-# INLINE probeBump #-} + {-# INLINE probeCharge #-} + +instance KnownProbe 'ProbeOn where + probeZero = 0 + probeBump counter = counter + 1 + probeCharge operation counter value = addCounter operation counter value + {-# INLINE probeZero #-} + {-# INLINE probeBump #-} + {-# INLINE probeCharge #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/Representation.hs b/src-dcel/Moonlight/Triangulation/Internal/Representation.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Representation.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} + +-- | The stored representation: the structure-of-arrays mesh, the payload +-- traversals that reach its four free parameters, and the records that carry a +-- built mesh beside its telemetry. +module Moonlight.Triangulation.Internal.Representation + ( Triangulation (..) + , promoteConstrained + , PayloadTraversal + , vertexPayloads + , directedPayloads + , undirectedPayloads + , facePayloads + , mapVertices + , mapDirectedEdges + , mapUndirectedEdges + , mapFaces + , DelaunayTriangulation + , ConstrainedDelaunayTriangulation + , BuildResult (..) + , InsertionResult (..) + , RefinementReceipt (..) + , RefinementDomainResult (..) + , RefinementResult (..) + ) where + +import Control.DeepSeq (NFData) +import qualified Data.IntSet as IntSet +import Data.Primitive.PrimArray (PrimArray) +import Data.Traversable (foldMapDefault) +import qualified Data.Vector as V +import Data.Word (Word8, Word32) +import Moonlight.Triangulation.Handles.HandleDefs (FaceId, UndirectedEdgeId, VertexId) +import Moonlight.Triangulation.Internal.BoxedPaged (BoxedPaged, boxedFromVector, boxedToVector) +import Moonlight.Triangulation.Internal.Paged (Paged) +import Moonlight.Triangulation.Internal.PointIndex (PointIndex) +import Moonlight.Triangulation.Internal.Types + ( BuildStats + , ConstraintMode (..) + , ElementDefaults (..) + , InsertionDisposition + ) +import GHC.Generics (Generic) + +-- | Immutable finite DCEL. The coordinate pages own the geometry; vertex +-- payloads are free annotations carried alongside it. +-- 'Moonlight.Triangulation.Internal.Types.HasPosition' is how a point is read +-- out of a payload at the moment of +-- ingestion and is not consulted again, so a payload whose instance later +-- disagrees with where its vertex sits is not a corrupt triangulation — it is a +-- payload nobody asks about position. Half-edge topology is one interleaved +-- arena: edge @e@ owns slots @4e..4e+3@ holding origin, next, previous and +-- face, so a twin pair is one contiguous eight-word record. +-- Directed edges are adjacent twin pairs, so reversal is an XOR with one. +-- Face zero is the unique outer face. Constraint flags are stored once per +-- undirected edge and are zero for ordinary Delaunay triangulations. +-- All four payload components are therefore representational: coercing a +-- newtype through any of them is a coercion, not a rebuild. +type role Triangulation nominal representational representational representational representational + +data Triangulation (mode :: ConstraintMode) vertex directed undirected face = Triangulation + { triPointX :: !(Paged Double) + , triPointY :: !(Paged Double) + , -- | Derived position-hash buckets containing vertex handles only. This is + -- deliberately lazy: geometry is authoritative, so a workload that never + -- asks an identity question owes no cache construction. + triPointIndex :: PointIndex + , triVertexOut :: !(Paged Word32) + , triVertexData :: !(BoxedPaged vertex) + , triHalfTopology :: !(Paged Word32) + , triDirectedData :: !(BoxedPaged directed) + , triUndirectedData :: !(BoxedPaged undirected) + , triFaceEdge :: !(Paged Word32) + , triFaceData :: !(BoxedPaged face) + , triConstraint :: !(Paged Word8) + , triConstraintCount :: {-# UNPACK #-} !Int + , -- | Derived exact membership for the sparse constrained edge section. + -- The flag plane remains authoritative and serializable; this index is + -- transported with edge rewrites so constraint-only queries need not scan + -- every ordinary Delaunay edge. + triConstraintEdges :: !IntSet.IntSet + , triElementDefaults :: !(ElementDefaults directed undirected face) + } + deriving stock (Show, Generic) + deriving anyclass (NFData) + +-- The point index is a derived cache and therefore not an observable part of +-- the mesh value. Structural equality compares every semantic plane and +-- default while deliberately refusing to construct or compare that cache. +instance + ( Eq vertex + , Eq directed + , Eq undirected + , Eq face + ) => Eq (Triangulation mode vertex directed undirected face) where + left == right = + triPointX left == triPointX right + && triPointY left == triPointY right + && triVertexOut left == triVertexOut right + && triVertexData left == triVertexData right + && triHalfTopology left == triHalfTopology right + && triDirectedData left == triDirectedData right + && triUndirectedData left == triUndirectedData right + && triFaceEdge left == triFaceEdge right + && triFaceData left == triFaceData right + && triConstraint left == triConstraint right + && triConstraintCount left == triConstraintCount right + && triElementDefaults left == triElementDefaults right + +promoteConstrained + :: Triangulation 'Unconstrained vertex directed undirected face + -> Triangulation 'Constrained vertex directed undirected face +promoteConstrained Triangulation{ + triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology, + triDirectedData, triUndirectedData, triFaceEdge, triFaceData, + triConstraint, triConstraintCount, triConstraintEdges, triElementDefaults + } = + Triangulation{ + triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology, + triDirectedData, triUndirectedData, triFaceEdge, triFaceData, + triConstraint, triConstraintCount, triConstraintEdges, triElementDefaults + } + +-- | A traversal of every occurrence of one payload parameter, in the van +-- Laarhoven encoding: an effectful visit that may change the payload's type. +-- The 'Applicative' belongs to the caller, so one traversal per parameter +-- serves relabeling, collection and genuinely effectful annotation alike +-- instead of a separate function for each. +type PayloadTraversal source target payload payload' = + forall f. Applicative f => (payload -> f payload') -> source -> f target + +-- | Every stored vertex payload, in vertex order. +-- +-- The vertex store carries no fill — a vertex's payload arrives with the +-- vertex, and no slot is read before it is written — so the visits are exactly +-- the stored payloads and nothing besides. +vertexPayloads + :: PayloadTraversal + (Triangulation mode vertex directed undirected face) + (Triangulation mode vertex' directed undirected face) + vertex + vertex' +vertexPayloads visit triangulation = + (\payloads -> triangulation{triVertexData = boxedFromVector Nothing payloads}) + <$> traverse visit (boxedToVector (triVertexData triangulation)) + +-- | Every stored directed-edge payload, then the default a later directed edge +-- will inherit. +-- +-- The default is visited because it is a payload the structure carries, and it +-- is visited /once/: its single image is written both to t'ElementDefaults' and +-- to the store's fill, which every slot of an unmaterialized page reports. +-- Visiting the two positions separately would let an effect with more than one +-- answer hand them different values, and a triangulation whose future elements +-- disagree with its present ones is not a triangulation anyone asked for. +directedPayloads + :: PayloadTraversal + (Triangulation mode vertex directed undirected face) + (Triangulation mode vertex directed' undirected face) + directed + directed' +directedPayloads visit triangulation = + (\payloads fallback -> + triangulation + { triDirectedData = boxedFromVector (Just fallback) payloads + , triElementDefaults = defaults{defaultDirectedEdgeData = fallback} + }) + <$> traverse visit (boxedToVector (triDirectedData triangulation)) + <*> visit (defaultDirectedEdgeData defaults) + where + defaults = triElementDefaults triangulation + +-- | Every stored undirected-edge payload, then the default a later undirected +-- edge will inherit. +undirectedPayloads + :: PayloadTraversal + (Triangulation mode vertex directed undirected face) + (Triangulation mode vertex directed undirected' face) + undirected + undirected' +undirectedPayloads visit triangulation = + (\payloads fallback -> + triangulation + { triUndirectedData = boxedFromVector (Just fallback) payloads + , triElementDefaults = defaults{defaultUndirectedEdgeData = fallback} + }) + <$> traverse visit (boxedToVector (triUndirectedData triangulation)) + <*> visit (defaultUndirectedEdgeData defaults) + where + defaults = triElementDefaults triangulation + +-- | Every stored face payload, then the default a later face will inherit. +facePayloads + :: PayloadTraversal + (Triangulation mode vertex directed undirected face) + (Triangulation mode vertex directed undirected face') + face + face' +facePayloads visit triangulation = + (\payloads fallback -> + triangulation + { triFaceData = boxedFromVector (Just fallback) payloads + , triElementDefaults = defaults{defaultFaceData = fallback} + }) + <$> traverse visit (boxedToVector (triFaceData triangulation)) + <*> visit (defaultFaceData defaults) + where + defaults = triElementDefaults triangulation + +-- | Ranges over the face payload, which is the last parameter and so the only +-- one a class of this kind can reach. The other three payloads have exactly +-- the same structure under 'vertexPayloads', 'directedPayloads' and +-- 'undirectedPayloads'; they are simply not spellable as instances here. +-- +-- 'mapFaces' rather than the traversal, because it leaves an unmaterialized +-- page unmaterialized. The two agree on everything a 'BoxedPaged' lets anyone +-- observe, which is what the coherence law asks and all it asks. +instance Functor (Triangulation mode vertex directed undirected) where + fmap = mapFaces + {-# INLINE fmap #-} + +-- | Folds the stored face payloads and then the default, so 'length' is one +-- greater than the number of stored faces. A fold that skipped the default +-- would report a triangulation as holding a value it does hold. +instance Foldable (Triangulation mode vertex directed undirected) where + foldMap = foldMapDefault + {-# INLINE foldMap #-} + +instance Traversable (Triangulation mode vertex directed undirected) where + traverse = facePayloads + {-# INLINE traverse #-} + +-- | An element payload map carries the element defaults with it. A new +-- insertion hands its new elements the default, so a map that reindexed the +-- stored payloads and left the default behind would produce a triangulation +-- whose future elements disagree with its present ones. The type system very +-- nearly forces this on its own — the image type is inhabited here only +-- through the mapping function — but only a test can insist the argument is +-- the /default/ rather than some other payload of the right type. +mapDirectedEdges + :: (directed -> directed') + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed' undirected face +mapDirectedEdges f triangulation = + triangulation + { triDirectedData = fmap f (triDirectedData triangulation) + , triElementDefaults = defaults{defaultDirectedEdgeData = f (defaultDirectedEdgeData defaults)} + } + where + defaults = triElementDefaults triangulation + +mapUndirectedEdges + :: (undirected -> undirected') + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed undirected' face +mapUndirectedEdges f triangulation = + triangulation + { triUndirectedData = fmap f (triUndirectedData triangulation) + , triElementDefaults = defaults{defaultUndirectedEdgeData = f (defaultUndirectedEdgeData defaults)} + } + where + defaults = triElementDefaults triangulation + +mapFaces + :: (face -> face') + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex directed undirected face' +mapFaces f triangulation = + triangulation + { triFaceData = fmap f (triFaceData triangulation) + , triElementDefaults = defaults{defaultFaceData = f (defaultFaceData defaults)} + } + where + defaults = triElementDefaults triangulation + +-- | The vertex component is free, like the other three. Geometry owns the +-- points, so a payload map cannot move one — the image type need not even have +-- a position to speak of. There is no vertex default to carry: vertices arrive +-- with their payloads. +mapVertices + :: (vertex -> vertex') + -> Triangulation mode vertex directed undirected face + -> Triangulation mode vertex' directed undirected face +mapVertices f triangulation = + triangulation{triVertexData = fmap f (triVertexData triangulation)} + +-- | Geometry-only unconstrained Delaunay triangulation. +type DelaunayTriangulation vertex = Triangulation 'Unconstrained vertex () () () + +-- | Geometry-only constrained Delaunay triangulation. +type ConstrainedDelaunayTriangulation vertex = Triangulation 'Constrained vertex () () () + +-- | A constructed triangulation and the canonical handle chosen for each input. +-- +-- The result is a value, not a history: derived 'Eq'/'Show' would observe +-- 'buildStats' through a facade that hides it, so neither instance exists. +data BuildResult mode vertex directed undirected face = BuildResult + { -- | The immutable constructed mesh. + buildTriangulation :: !(Triangulation mode vertex directed undirected face) + , -- | Canonical vertex handle for each input position, including duplicates. + buildInputVertices :: !(PrimArray Word32) + , buildStats :: !BuildStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +data InsertionResult mode vertex directed undirected face = InsertionResult + { insertionTriangulation :: !(Triangulation mode vertex directed undirected face) + , insertionVertex :: !VertexId + , insertionDisposition :: !InsertionDisposition + , insertionStats :: !BuildStats + } + deriving stock (Generic) + deriving anyclass (NFData) + +deriving stock instance + (Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (InsertionResult mode vertex directed undirected face) +deriving stock instance + (Show vertex, Show directed, Show undirected, Show face) + => Show (InsertionResult mode vertex directed undirected face) + +-- | Exact support touched by one refinement publication. Checked local +-- refinement uses this as the positive receipt accompanying its typed +-- obstruction surface; unrestricted refinement deliberately avoids the +-- additional support scan. +data RefinementReceipt = RefinementReceipt + { refinementVisitedJoinFaces :: !(V.Vector FaceId) + , refinementVisitedProtectedFaces :: !(V.Vector FaceId) + , refinementCreatedFaces :: !(V.Vector FaceId) + , refinementTouchedEdges :: !(V.Vector UndirectedEdgeId) + , refinementRemovedEdges :: !(V.Vector UndirectedEdgeId) + , refinementInterfaceBoundaryReads :: {-# UNPACK #-} !Int + , refinementAttemptedBoundaryCrossings :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | A locally refined section paired with the proof of what the checked +-- interpreter observed and rewrote. Ordinary refinement does not pay to +-- construct this proof. +data RefinementDomainResult mode vertex directed undirected face = RefinementDomainResult + { refinementDomainResult :: !(RefinementResult mode vertex directed undirected face) + , refinementDomainReceipt :: !RefinementReceipt + } + deriving stock (Generic) + deriving anyclass (NFData) + +-- | Refined mesh together with the budget, exclusion, and support outcome. +data RefinementResult mode vertex directed undirected face = RefinementResult + { -- | The immutable mesh after all admitted refinement steps. + refinedTriangulation :: !(Triangulation mode vertex directed undirected face) + , refinementStats :: !BuildStats + , refinementAddedVertices :: {-# UNPACK #-} !Int + -- | Whether the quality worklist drained. 'False' means the vertex budget + -- stopped the run with work outstanding. A drained worklist can still leave + -- faces the quality bounds condemn but no admissible Steiner point can fix; + -- auditing the result is the caller's to ask for, not a cost every run pays. + , refinementComplete :: !Bool + , -- | Faces deliberately excluded by barrier-depth policy. + refinementExcludedFaces :: !(V.Vector FaceId) + } + deriving stock (Generic) + deriving anyclass (NFData) diff --git a/src-dcel/Moonlight/Triangulation/Internal/Types.hs b/src-dcel/Moonlight/Triangulation/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Types.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The vocabulary: the types the surface names, none of which mentions the +-- stored representation. +module Moonlight.Triangulation.Internal.Types + ( Point (..) + , SiteRelation (..) + , QueryPoint (..) + , PointValidationError (..) + , HasPosition (..) + , ElementDefaults (..) + , unitElementDefaults + , ConstraintMode (..) + , KnownConstraintMode (..) + , InsertionDisposition (..) + , BuildStats (..) + , emptyBuildStats + , CoordinateError (..) + , NonFiniteValue (..) + , classifyNonFinite + , BuildError (..) + , Location (..) + , LocationHint (..) + , LocationStats (..) + , emptyLocationStats + , NearestStats (..) + , RefinementParameters (..) + , defaultRefinementParameters + , InvariantViolation (..) + ) where + +import Control.DeepSeq (NFData) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId + , FaceId + , UndirectedEdgeId + , VertexId + ) +import Data.Word (Word8) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable (..), peekElemOff, pokeElemOff) +import GHC.Generics (Generic) +import Moonlight.Triangulation.Internal.BoxedPaged (BoxedStorageError) + +-- | Type-level witness for whether constraint flags may be present. +data ConstraintMode = Unconstrained | Constrained + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +class KnownConstraintMode (mode :: ConstraintMode) where + constraintModeValue :: proxy mode -> ConstraintMode + +instance KnownConstraintMode 'Unconstrained where + constraintModeValue _ = Unconstrained + +instance KnownConstraintMode 'Constrained where + constraintModeValue _ = Constrained + +-- | Cartesian binary64 point. +data Point = Point + { pointX :: !Double + , pointY :: !Double + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Exact geometric relation between two finite coordinate supports. The +-- overlap count is strictly positive in 'PartialOverlap'; equality, subset and +-- disjointness have already been excluded before that constructor is chosen. +data SiteRelation + = -- | Both supports contain exactly the same coordinates. + EqualSites + | -- | Every left coordinate occurs on the right, which has at least one more. + LeftProperSubset + | -- | Every right coordinate occurs on the left, which has at least one more. + RightProperSubset + | -- | The supports share no coordinate. + DisjointSites + | -- | Neither support contains the other; the field is the positive number + -- of coordinates they share. + PartialOverlap {-# UNPACK #-} !Int + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | A coordinate pair admitted to the exact-predicate domain and normalized +-- at its construction boundary. Query algorithms consume this phase rather +-- than each inventing a fallback for invalid floating-point input. +newtype QueryPoint = QueryPoint + { -- | The admitted, canonically normalized point. + queryPointValue :: Point + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Coordinate axis and reason that kept a point outside the query domain. +data PointValidationError + = InvalidPointX !CoordinateError + | InvalidPointY !CoordinateError + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +instance Storable (Point) where + sizeOf _ = 2 * sizeOf (0 :: Double) + alignment _ = alignment (0 :: Double) + peek pointer = do + x <- peekElemOff (castPtr pointer) 0 + y <- peekElemOff (castPtr pointer) 1 + pure (Point x y) + poke pointer (Point x y) = do + pokeElemOff (castPtr pointer) 0 x + pokeElemOff (castPtr pointer) 1 y + +-- | Extract a vertex's position once, at the construction boundary. +class HasPosition vertex where + position :: vertex -> Point + +instance HasPosition (Point) where + position = id + +-- | Payloads inherited by topology elements created after initial loading. +data ElementDefaults directed undirected face = ElementDefaults + { defaultDirectedEdgeData :: !directed + , defaultUndirectedEdgeData :: !undirected + , defaultFaceData :: !face + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Payload defaults for geometry-only triangulations. +unitElementDefaults :: ElementDefaults () () () +unitElementDefaults = ElementDefaults () () () + +data BuildStats = BuildStats + { statInputPoints :: {-# UNPACK #-} !Int + , statUniquePoints :: {-# UNPACK #-} !Int + , statExistingPoints :: {-# UNPACK #-} !Int + , statDuplicatePoints :: {-# UNPACK #-} !Int + , statSpatialSeedPoints :: {-# UNPACK #-} !Int + , statFaceSplits :: {-# UNPACK #-} !Int + , statInteriorEdgeSplits :: {-# UNPACK #-} !Int + , statBoundaryEdgeSplits :: {-# UNPACK #-} !Int + , statHullInsertions :: {-# UNPACK #-} !Int + , statLineSplits :: {-# UNPACK #-} !Int + , statLineExtensions :: {-# UNPACK #-} !Int + , statLineToAreaTransitions :: {-# UNPACK #-} !Int + , statEdgeFlips :: {-# UNPACK #-} !Int + , statLocationWalkSteps :: {-# UNPACK #-} !Int + , statLocationFallbacks :: {-# UNPACK #-} !Int + , statLocationMaxWalk :: {-# UNPACK #-} !Int + , statLegalizationMaxStack :: {-# UNPACK #-} !Int + , statSteinerPoints :: {-# UNPACK #-} !Int + , statRefinementFaceChecks :: {-# UNPACK #-} !Int + , statRefinementQueuePops :: {-# UNPACK #-} !Int + , statSweepFastPoints :: {-# UNPACK #-} !Int + , statSweepSkippedPoints :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Show, Read, Generic) + deriving anyclass (NFData) + +emptyBuildStats :: BuildStats +emptyBuildStats = + BuildStats + { statInputPoints = 0 + , statUniquePoints = 0 + , statExistingPoints = 0 + , statDuplicatePoints = 0 + , statSpatialSeedPoints = 0 + , statFaceSplits = 0 + , statInteriorEdgeSplits = 0 + , statBoundaryEdgeSplits = 0 + , statHullInsertions = 0 + , statLineSplits = 0 + , statLineExtensions = 0 + , statLineToAreaTransitions = 0 + , statEdgeFlips = 0 + , statLocationWalkSteps = 0 + , statLocationFallbacks = 0 + , statLocationMaxWalk = 0 + , statLegalizationMaxStack = 0 + , statSteinerPoints = 0 + , statRefinementFaceChecks = 0 + , statRefinementQueuePops = 0 + , statSweepFastPoints = 0 + , statSweepSkippedPoints = 0 + } + +data InsertionDisposition = Inserted | AlreadyPresent + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Reason a floating-point coordinate cannot enter the exact-predicate domain. +data CoordinateError + = CoordinateNaN + | CoordinateInfinite + | CoordinateTooSmall + | CoordinateTooLarge + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Classification retained when a numeric parameter is not finite. +data NonFiniteValue + = ValueNaN + | ValuePositiveInfinity + | ValueNegativeInfinity + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +classifyNonFinite :: Double -> Maybe NonFiniteValue +classifyNonFinite value + | isNaN value = Just ValueNaN + | isInfinite value && value < 0 = Just ValueNegativeInfinity + | isInfinite value = Just ValuePositiveInfinity + | otherwise = Nothing + +-- | Total construction and rewrite obstruction surface. +data BuildError + = InvalidCoordinate !(Maybe Int) {-# UNPACK #-} !Double !CoordinateError + | PointLocationFailed !(Point) + | LocationWalkExhausted !(Point) {-# UNPACK #-} !Int + | RefinementInputTopologyInvalid !InvariantViolation + | FreshInsertionMatchedExistingVertex !VertexId !VertexId + | DegenerateLineEndpointMissingOutgoing !VertexId + | DegenerateLineEndpointTurnMissing {-# UNPACK #-} !Int + | DegenerateLineConnectedVertexMissing {-# UNPACK #-} !Int + | HullStartNotVisible !DirectedEdgeId + | OuterRangeDidNotTerminate !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int + | OuterRangeContainsInnerEdge !DirectedEdgeId !FaceId + | ConstrainedEdgeFlipRefused !UndirectedEdgeId + | RemovalVertexOutOfRange !VertexId {-# UNPACK #-} !Int + | RemovalEdgeOutOfRange !UndirectedEdgeId {-# UNPACK #-} !Int + | RemovalFaceOutOfRange !FaceId {-# UNPACK #-} !Int + | RemovalFaceCycleDidNotTerminate + !FaceId + !DirectedEdgeId + {-# UNPACK #-} !Int + | RemovalEmptyTriangulation !VertexId + | RemovalTwoPointDegreeMismatch !VertexId {-# UNPACK #-} !Int + | RemovalCollinearDegreeMismatch !VertexId {-# UNPACK #-} !Int + | RemovalBorderTooShort {-# UNPACK #-} !Int + | RemovalBorderArityMismatch {-# UNPACK #-} !Int + | RemovalOutgoingCycleDidNotTerminate + !VertexId + !DirectedEdgeId + {-# UNPACK #-} !Int + | CircleSweepHullEmpty + | OuterCycleDidNotTerminate + !DirectedEdgeId + !DirectedEdgeId + {-# UNPACK #-} !Int + | HierarchyLevelPopulationMismatch + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + | HierarchyInsertionHandleMismatch !VertexId !VertexId + | PointIndexCapacityExhausted {-# UNPACK #-} !Int + | RefinementMinimumAngleNotFinite !NonFiniteValue + | RefinementMinimumAngleOutOfRange {-# UNPACK #-} !Double + | RefinementMinimumAngleDerivedRatioNotFinite !NonFiniteValue + | RefinementMaximumAdditionalVerticesNegative {-# UNPACK #-} !Int + | RefinementMinimumAreaNotFinite !NonFiniteValue + | RefinementMinimumAreaNegative {-# UNPACK #-} !Double + | RefinementMaximumAreaNotFinite !NonFiniteValue + | RefinementMaximumAreaNotPositive {-# UNPACK #-} !Double + | RefinementMaximumRadiusEdgeRatioNotFinite !NonFiniteValue + | RefinementMaximumRadiusEdgeRatioNotPositive {-# UNPACK #-} !Double + | RefinementMinimumAreaExceedsMaximum + {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + | RefinementSeedFaceNotActive !FaceId {-# UNPACK #-} !Int + | RefinementDomainInterfaceEdgeNotActive !UndirectedEdgeId {-# UNPACK #-} !Int + | RefinementDomainInterfaceMissing !UndirectedEdgeId + | RefinementDomainInterfaceExtraneous !UndirectedEdgeId + | RefinementDomainTopologyChanged + | RefinementDomainRequiresConvexHullPreservation + | RefinementDomainRequiresConstraintPreservation + | RefinementDomainForbidsOuterFaceExclusion + | RefinementDomainWouldCrossInterface !UndirectedEdgeId !FaceId + | RefinementDomainWouldRewriteProtectedFace !FaceId + | RefinementDomainProtectedFaceChanged !FaceId + | CapacityExceeded {-# UNPACK #-} !Int + | HalfEdgeCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | FaceCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | PayloadStorageFailure !BoxedStorageError + | CoordinatePayloadCountMismatch + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data Location + = EmptyTriangulation + | OnVertex !VertexId + | OnEdge !DirectedEdgeId + | InFace !FaceId + | OutsideConvexHull !(Maybe DirectedEdgeId) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Optional starting cell for point-location descent. +data LocationHint + = VertexHint !VertexId + | FaceHint !FaceId + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data LocationStats = LocationStats + { locationWalkSteps :: {-# UNPACK #-} !Int + , locationUsedFallback :: !Bool + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +emptyLocationStats :: LocationStats +emptyLocationStats = LocationStats 0 False + +-- | Work performed by a nearest-neighbor query. +data NearestStats = NearestStats + { nearestWalkSteps :: {-# UNPACK #-} !Int + , nearestDistanceTests :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Independent quality bounds and a finite Steiner-vertex budget. +data RefinementParameters = RefinementParameters + { refineMaxAdditionalVertices :: !(Maybe Int) + , refineMinArea :: !(Maybe Double) + , refineMaxArea :: !(Maybe Double) + , refineMaxRadiusEdgeRatio :: !(Maybe Double) + , refinePreserveConvexHull :: !Bool + , refineKeepConstraintEdges :: !Bool + , refineExcludeOuterFaces :: !Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Conservative refinement defaults with no explicit area bounds. +defaultRefinementParameters :: RefinementParameters +defaultRefinementParameters = + RefinementParameters + { refineMaxAdditionalVertices = Nothing + , refineMinArea = Nothing + , refineMaxArea = Nothing + , refineMaxRadiusEdgeRatio = Just 1 + , refinePreserveConvexHull = True + , refineKeepConstraintEdges = False + , refineExcludeOuterFaces = False + } + +-- | A concrete witness that an immutable DCEL law does not hold. +data InvariantViolation + = CoordinatePlaneLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | VertexOutgoingLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | VertexPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | TopologyArenaLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | DirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | UndirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | DirectedEdgeCountOdd {-# UNPACK #-} !Int + | ConstraintLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | NonCanonicalConstraintFlag !UndirectedEdgeId !Word8 + | CachedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | CachedConstraintIndexMismatch + | MissingOuterFace + | FacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | EdgeOriginOutOfRange !DirectedEdgeId !VertexId {-# UNPACK #-} !Int + | EdgeNextOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int + | EdgePreviousOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int + | EdgeFaceOutOfRange !DirectedEdgeId !FaceId {-# UNPACK #-} !Int + | VertexOutgoingOutOfRange !VertexId !DirectedEdgeId {-# UNPACK #-} !Int + | FaceAdjacentOutOfRange !FaceId !DirectedEdgeId {-# UNPACK #-} !Int + | EdgeNextPreviousMismatch !DirectedEdgeId !DirectedEdgeId + | EdgePreviousNextMismatch !DirectedEdgeId !DirectedEdgeId + | EdgeDoubleReversalMismatch !DirectedEdgeId + | EdgeSelfLinkedNext !DirectedEdgeId + | EdgeSelfLinkedPrevious !DirectedEdgeId + | InnerFaceNotTriangularAtEdge !DirectedEdgeId + | FaceMissingAdjacentEdge !FaceId + | FaceRepresentativeMismatch !FaceId !DirectedEdgeId !FaceId + | InnerFaceVertexCardinalityMismatch !FaceId {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | ConnectedVertexMissingOutgoing !VertexId + | VertexOutgoingOriginMismatch !VertexId !DirectedEdgeId !VertexId + | CollinearEdgeCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | EulerCharacteristicMismatch {-# UNPACK #-} !Int + | InnerFaceNotCounterClockwise !FaceId + | LocallyIllegalDelaunayEdge !UndirectedEdgeId + | DelaunayIncidentFaceNotTriangular !UndirectedEdgeId + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) diff --git a/src-dcel/Moonlight/Triangulation/Interop.hs b/src-dcel/Moonlight/Triangulation/Interop.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Interop.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Moonlight.Triangulation.Interop + ( Coordinate2 (..) + , mapCoordinate2 + ) where + +import Data.Complex (Complex ((:+))) +import Moonlight.Triangulation.Types (Point (..)) + +-- | Minimal mint-like interchange class. It owns no geometry and introduces no +-- second point representation inside the triangulation; conversion happens only +-- at an ecosystem boundary. +class Coordinate2 value where + toPoint :: value -> Point + fromPoint :: Point -> value + +instance Coordinate2 (Point) where + toPoint = id + fromPoint = id + +instance Coordinate2 (Double, Double) where + toPoint (x, y) = Point x y + fromPoint (Point x y) = (x, y) + +instance Coordinate2 (Complex Double) where + toPoint (x :+ y) = Point x y + fromPoint (Point x y) = x :+ y + +mapCoordinate2 + :: (Coordinate2 input, Coordinate2 output) + => (Point -> Point) + -> input + -> output +mapCoordinate2 transform = fromPoint . transform . toPoint diff --git a/src-dcel/Moonlight/Triangulation/IntersectionIterator.hs b/src-dcel/Moonlight/Triangulation/IntersectionIterator.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/IntersectionIterator.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BangPatterns #-} + +module Moonlight.Triangulation.IntersectionIterator + ( Intersection (..) + , lineIntersections + , lineIntersectionsBetweenVertices + , foldCorridorBetweenPoints + , foldCorridorBetweenVertices + , conflictingEdges + , segmentIntersectsNonCollinear + ) where + +import Data.List (sortBy) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Data.Void (Void, absurd) +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges, vertices) +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Types + +-- | One crossing: an edge cut, a vertex hit, or a collinear overlap. +data Intersection + = EdgeIntersection !DirectedEdgeId + | VertexIntersection !VertexId + | EdgeOverlap !DirectedEdgeId + deriving stock (Eq, Ord, Show) + +-- | Every crossing between two points, ordered along the segment. +lineIntersections + :: Triangulation mode vertex directed undirected face + -> QueryPoint + -> QueryPoint + -> [Intersection] +lineIntersections triangulation queryFrom queryTo = + let !from = queryPointValue queryFrom + !to = queryPointValue queryTo + in case firstIntersection triangulation queryFrom queryTo of + Nothing -> [] + Just first -> walkIntersections triangulation from to first + +-- | 'lineIntersections' between two existing vertices. +lineIntersectionsBetweenVertices :: Triangulation mode vertex directed undirected face -> VertexId -> VertexId -> [Intersection] +lineIntersectionsBetweenVertices triangulation fromVertex toVertex = + let from = vertexPoint triangulation fromVertex + to = vertexPoint triangulation toVertex + in walkIntersections triangulation from to (VertexIntersection fromVertex) + +-- | The directed edges a crossing list cuts. +conflictingEdges :: [Intersection] -> [DirectedEdgeId] +conflictingEdges = mapMaybe asConflict + where + asConflict (EdgeIntersection edge) = Just edge + asConflict _ = Nothing + +-- | Fold the corridor one crossing at a time, stopping the instant the step +-- function answers. +-- +-- The list-producing walks cannot stop early: their step budget is only known +-- to have been respected once the walk ends, so the whole corridor is +-- materialized before the first event is visible. A caller whose answer is +-- settled by a prefix — anything asking whether some crossing exists — should +-- not pay for the suffix. 'Nothing' reports a walk that outran its budget and +-- is the caller's signal to fall back to the materialized walk, which +-- substitutes the exact scan. +foldCorridorBetweenVertices + :: Triangulation mode vertex directed undirected face + -> VertexId + -> VertexId + -> (state -> Intersection -> Either answer state) + -> state + -> Maybe (Either answer state) +foldCorridorBetweenVertices triangulation fromVertex toVertex = + foldCorridor + triangulation + (vertexPoint triangulation fromVertex) + (vertexPoint triangulation toVertex) + (VertexIntersection fromVertex) + +-- | As 'foldCorridorBetweenVertices', for a corridor given by its endpoints. +-- A segment that meets nothing at all folds to the initial state. +foldCorridorBetweenPoints + :: Triangulation mode vertex directed undirected face + -> QueryPoint + -> QueryPoint + -> (state -> Intersection -> Either answer state) + -> state + -> Maybe (Either answer state) +foldCorridorBetweenPoints triangulation queryFrom queryTo step state = + case firstIntersection triangulation queryFrom queryTo of + Nothing -> Just (Right state) + Just first -> + foldCorridor + triangulation + (queryPointValue queryFrom) + (queryPointValue queryTo) + first + step + state + +foldCorridor + :: Triangulation mode vertex directed undirected face + -> Point + -> Point + -> Intersection + -> (state -> Intersection -> Either answer state) + -> state + -> Maybe (Either answer state) +foldCorridor triangulation from to first step = + go (2 * numDirectedEdges triangulation + numVertices triangulation + 8) first + where + go !remaining !current !state + | remaining <= 0 = Nothing + | otherwise = case step state current of + Left answer -> Just (Left answer) + Right advanced -> + case nextIntersection triangulation from to current of + Nothing -> Just (Right advanced) + Just following -> go (remaining - 1) following advanced +-- The early-answer 'Either' exists to let a caller stop at the first event it +-- cares about; it should not survive to runtime. Inlining the non-recursive +-- wrapper puts the worker at each call site with 'step' statically known, so +-- the constructor is matched where it is built — and at 'walkIntersections', +-- where the answer is 'Void', the left branch is erased outright. +{-# INLINE foldCorridor #-} + +walkIntersections :: Triangulation mode vertex directed undirected face -> Point -> Point -> Intersection -> [Intersection] +walkIntersections triangulation from to first = + case foldCorridor triangulation from to first collect [] of + Nothing -> exactIntersectionScan triangulation from to + Just (Left impossible) -> absurd impossible + Just (Right events) -> reverse events + where + collect :: [Intersection] -> Intersection -> Either Void [Intersection] + collect accumulated event = Right (event : accumulated) + +nextIntersection :: Triangulation mode vertex directed undirected face -> Point -> Point -> Intersection -> Maybe Intersection +nextIntersection triangulation lineFrom lineTo current = case current of + EdgeIntersection edge -> case traceDirectionOutOfEdge triangulation edge lineFrom lineTo of + EdgeOutHull -> Nothing + EdgeOutVertex vertex -> Just (VertexIntersection vertex) + EdgeOutEdge nextEdge -> Just (EdgeIntersection nextEdge) + EdgeOutNone -> Nothing + VertexIntersection vertex + | vertexPoint triangulation vertex == lineTo -> Nothing + | otherwise -> case traceDirectionOutOfVertex triangulation vertex lineTo of + VertexOutHull -> Nothing + VertexOutOverlap edge -> Just (EdgeOverlap edge) + VertexOutEdge edge -> + let from = vertexPoint triangulation (origin triangulation edge) + to = vertexPoint triangulation (destination triangulation edge) + in if orient2d from to lineTo == LT then Nothing else Just (EdgeIntersection edge) + EdgeOverlap edge + | lineFrom == lineTo -> Nothing + | onClosedSegment lineFrom lineTo (vertexPoint triangulation (destination triangulation edge)) -> + Just (VertexIntersection (destination triangulation edge)) + | otherwise -> Nothing + +firstIntersection :: Triangulation mode vertex directed undirected face -> QueryPoint -> QueryPoint -> Maybe Intersection +firstIntersection triangulation queryFrom queryTo = + case locatePoint triangulation queryFrom of + EmptyTriangulation -> singleVertexHit + OnVertex vertex -> Just (VertexIntersection vertex) + OnEdge edge -> Just (classifyStartingEdge edge) + InFace face -> firstFromFace face + OutsideConvexHull entry -> firstFromOutside entry + where + !lineFrom = queryPointValue queryFrom + !lineTo = queryPointValue queryTo + singleVertexHit = case vertices triangulation of + [vertex] + | onClosedSegment lineFrom lineTo (vertexPoint triangulation vertex) -> Just (VertexIntersection vertex) + _ -> Nothing + + classifyStartingEdge edge = + let a = vertexPoint triangulation (origin triangulation edge) + b = vertexPoint triangulation (destination triangulation edge) + in if orient2d lineFrom lineTo a == EQ && orient2d lineFrom lineTo b == EQ + then EdgeOverlap (orientAlongLine edge) + else EdgeIntersection (orientTowardTarget edge) + + firstFromFace face = firstEdgeFromRing (faceDirectedEdges triangulation face) + + firstEdgeFromRing [] = Nothing + firstEdgeFromRing (edge : remaining) = + let a = vertexPoint triangulation (origin triangulation edge) + b = vertexPoint triangulation (destination triangulation edge) + in if segmentIntersectsNonCollinear lineFrom lineTo a b + then + if orient2d lineFrom lineTo a == EQ + then Just (VertexIntersection (origin triangulation edge)) + else + if orient2d lineFrom lineTo b == EQ + then Just (VertexIntersection (destination triangulation edge)) + else Just (EdgeIntersection (reverseEdge edge)) + else firstEdgeFromRing remaining + + -- Outside the region the segment's first contact with it lies on the ring + -- the locator's edge sits on, so only that ring can carry the earliest + -- event. A ring that outran its budget, an absent locator edge, and + -- endpoints that leave the parameter comparison without a total order all + -- keep the exact scan. + firstFromOutside (Just edge) + | finiteEndpoint lineFrom && finiteEndpoint lineTo = + case ringEntryEvent triangulation lineFrom lineTo edge of + Just entry -> eventValue <$> entry + Nothing -> firstFromScan + firstFromOutside _ = firstFromScan + + firstFromScan = case exactIntersectionScan triangulation lineFrom lineTo of + event : _ -> Just event + [] -> Nothing + + orientAlongLine edge = + let a = vertexPoint triangulation (origin triangulation edge) + b = vertexPoint triangulation (destination triangulation edge) + in if projectionFactor lineFrom lineTo a <= projectionFactor lineFrom lineTo b then edge else reverseEdge edge + + orientTowardTarget edge = + let a = vertexPoint triangulation (origin triangulation edge) + b = vertexPoint triangulation (destination triangulation edge) + in if orient2d a b lineTo == LT then reverseEdge edge else edge + +data VertexOut + = VertexOutHull + | VertexOutOverlap !DirectedEdgeId + | VertexOutEdge !DirectedEdgeId + +data EdgeOut + = EdgeOutHull + | EdgeOutVertex !VertexId + | EdgeOutEdge !DirectedEdgeId + | EdgeOutNone + +traceDirectionOutOfVertex :: Triangulation mode vertex directed undirected face -> VertexId -> Point -> VertexOut +traceDirectionOutOfVertex triangulation vertex target = + case vertexOutEdge triangulation vertex of + Nothing -> VertexOutHull + Just start -> + let !startSide = sideOf start + !rotateCounterClockwise = startSide == GT + in go rotateCounterClockwise (numDirectedEdges triangulation + 1) start startSide + where + go !rotateCounterClockwise !remaining !current !currentSide + | remaining <= 0 = VertexOutHull + | currentSide == EQ && projectionFactor currentPoint (edgeTarget current) target >= 0 = + VertexOutOverlap current + | otherwise = + let following = if rotateCounterClockwise then counterClockwise triangulation current else clockwise triangulation current + followingSide = sideOf following + in if followingSide == EQ && projectionFactor currentPoint (edgeTarget following) target >= 0 + then VertexOutOverlap following + else + let faceBetween = if rotateCounterClockwise then incidentFace triangulation current else incidentFace triangulation following + in if faceBetween == outerFace + then VertexOutHull + else + if rotateCounterClockwise == (followingSide == LT) + then + let segment = if rotateCounterClockwise then next triangulation current else previous triangulation (reverseEdge current) + in VertexOutEdge (reverseEdge segment) + else go rotateCounterClockwise (remaining - 1) following followingSide + + currentPoint = vertexPoint triangulation vertex + edgeTarget edge = vertexPoint triangulation (destination triangulation edge) + sideOf edge = orient2d currentPoint (edgeTarget edge) target + +traceDirectionOutOfEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Point -> Point -> EdgeOut +traceDirectionOutOfEdge triangulation edge lineFrom lineTo + | incidentFace triangulation edge == outerFace = EdgeOutHull + | otherwise = + case (previousIntersects, nextIntersects) of + (True, False) -> EdgeOutEdge (reverseEdge edgePrevious) + (False, True) -> EdgeOutEdge (reverseEdge edgeNext) + (True, True) -> EdgeOutVertex (origin triangulation edgePrevious) + (False, False) -> EdgeOutNone + where + edgePrevious = previous triangulation edge + edgeNext = next triangulation edge + + -- The face runs @edge@ A->B, @edgeNext@ B->C, @edgePrevious@ C->A, so the + -- two candidates share C and each vertex's side of the line is read once + -- rather than once per candidate. Whether the segment reaches a candidate is + -- then asked only of one the line already separates, and a walk that entered + -- across A->B leaves that true for exactly one of the two. + pointA = vertexPoint triangulation (origin triangulation edge) + pointB = vertexPoint triangulation (origin triangulation edgeNext) + pointC = vertexPoint triangulation (origin triangulation edgePrevious) + + sideA = orient2d lineFrom lineTo pointA + sideB = orient2d lineFrom lineTo pointB + sideC = orient2d lineFrom lineTo pointC + + previousIntersects = sideC /= sideA && reaches pointC pointA + nextIntersects = sideB /= sideC && reaches pointB pointC + + reaches from to = orient2d from to lineFrom /= orient2d from to lineTo + +-- | Whether two segments properly cross; collinear touching does not. +segmentIntersectsNonCollinear :: Point -> Point -> Point -> Point -> Bool +segmentIntersectsNonCollinear p0 p1 q0 q1 = + -- Equality admits an endpoint on the opposite segment; four equal sides + -- reject the collinear case without recomputing either orientation pair. + p0Side /= p1Side + && q0Side /= q1Side + where + !p0Side = orient2d q0 q1 p0 + !p1Side = orient2d q0 q1 p1 + !q0Side = orient2d p0 p1 q0 + !q1Side = orient2d p0 p1 q1 +{-# INLINE segmentIntersectsNonCollinear #-} + +exactIntersectionScan :: Triangulation mode vertex directed undirected face -> Point -> Point -> [Intersection] +exactIntersectionScan triangulation lineFrom lineTo = + map eventValue . sortBy compareEvent $ vertexEvents ++ edgeEvents + where + vertexEvents = mapMaybe (vertexEvent triangulation lineFrom lineTo) (vertices triangulation) + edgeEvents = mapMaybe (edgeEvent triangulation lineFrom lineTo) (undirectedEdges triangulation) + +data Event = Event + { eventParameter :: !Double + , eventPriority :: {-# UNPACK #-} !Int + , eventValue :: !Intersection + } + +compareEvent :: Event -> Event -> Ordering +compareEvent = comparing (\event -> (eventParameter event, eventPriority event, eventValue event)) + +-- Ties in this order are the same 'Intersection', so a traversal that reaches +-- the minimum by a different route still reports the value the sorted scan's +-- head reports. +vertexEvent + :: Triangulation mode vertex directed undirected face + -> Point + -> Point + -> VertexId + -> Maybe (Event) +vertexEvent triangulation lineFrom lineTo vertex + | onClosedSegment lineFrom lineTo point = Just (Event (projectionFactor lineFrom lineTo point) 0 (VertexIntersection vertex)) + | otherwise = Nothing + where + point = vertexPoint triangulation vertex + +edgeEvent + :: Triangulation mode vertex directed undirected face + -> Point + -> Point + -> UndirectedEdgeId + -> Maybe (Event) +edgeEvent triangulation lineFrom lineTo edge + | oa == EQ && ob == EQ = + if low < high + then Just (Event low 1 (EdgeOverlap (if projectedA <= projectedB then directed else reverseEdge directed))) + else Nothing + | segmentsIntersect lineFrom lineTo a b && oa /= EQ && ob /= EQ = + Just (Event (segmentIntersectionParameter lineFrom lineTo a b) 2 (EdgeIntersection oriented)) + | otherwise = Nothing + where + directed = normalizedDirected edge + a = vertexPoint triangulation (origin triangulation directed) + b = vertexPoint triangulation (destination triangulation directed) + oa = orient2d lineFrom lineTo a + ob = orient2d lineFrom lineTo b + projectedA = projectionFactor lineFrom lineTo a + projectedB = projectionFactor lineFrom lineTo b + low = max 0 (min projectedA projectedB) + high = min 1 (max projectedA projectedB) + oriented = if orient2d a b lineTo == LT then reverseEdge directed else directed + +-- | The earliest event carried by the outer-face ring the given edge sits on, +-- walked from that edge. 'Nothing' reports a ring that outran its budget. +ringEntryEvent + :: Triangulation mode vertex directed undirected face + -> Point + -> Point + -> DirectedEdgeId + -> Maybe (Maybe (Event)) +ringEntryEvent triangulation lineFrom lineTo entry = + go (numDirectedEdges triangulation + 1) entry False Nothing + where + go !remaining !edge !departed !earliest + | remaining <= 0 = Nothing + | departed && edge == entry = Just earliest + | otherwise = + let !stepped = + keepEarliest (edgeEvent triangulation lineFrom lineTo (asUndirected edge)) $ + keepEarliest (vertexEvent triangulation lineFrom lineTo (origin triangulation edge)) earliest + in go (remaining - 1) (next triangulation edge) True stepped + +keepEarliest :: Maybe (Event) -> Maybe (Event) -> Maybe (Event) +keepEarliest Nothing held = held +keepEarliest candidate Nothing = candidate +keepEarliest candidate@(Just proposed) held@(Just incumbent) + | compareEvent proposed incumbent == LT = candidate + | otherwise = held + +finiteEndpoint :: Point -> Bool +finiteEndpoint point = isFinite (pointX point) && isFinite (pointY point) + +segmentIntersectionParameter :: Point -> Point -> Point -> Point -> Double +segmentIntersectionParameter (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) + | denominator == 0 = 0 + | otherwise = ((cx - ax) * (dy - cy) - (cy - ay) * (dx - cx)) / denominator + where + denominator = (bx - ax) * (dy - cy) - (by - ay) * (dx - cx) diff --git a/src-dcel/Moonlight/Triangulation/JoinSemilattice.hs b/src-dcel/Moonlight/Triangulation/JoinSemilattice.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/JoinSemilattice.hs @@ -0,0 +1,20 @@ +-- | Payloads that can be glued coordinate-wise when triangulation site sets +-- overlap. The laws are the contract: implementations must be commutative, +-- associative, and idempotent. +module Moonlight.Triangulation.JoinSemilattice + ( JoinSemilattice (..) + ) where + +-- | A join-semilattice carried by vertex annotations. +-- +-- @ +-- joinAnnotations left right == joinAnnotations right left +-- joinAnnotations (joinAnnotations a b) c == joinAnnotations a (joinAnnotations b c) +-- joinAnnotations value value == value +-- @ +class Eq annotation => JoinSemilattice annotation where + joinAnnotations :: annotation -> annotation -> annotation + +instance JoinSemilattice () where + joinAnnotations _ _ = () + {-# INLINE joinAnnotations #-} diff --git a/src-dcel/Moonlight/Triangulation/Math.hs b/src-dcel/Moonlight/Triangulation/Math.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Math.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module Moonlight.Triangulation.Math + ( orient2d + , sideQuery + , inCircle + , orientDetApprox + , inCircleDetApprox + , onClosedSegment + , SegmentRelation (..) + , allSegmentRelations + , segmentRelation + , segmentsProperlyCross + , segmentsIntersect + , squaredDistance + , squaredDistanceWide + , segmentDistanceSquared + , segmentDistanceSquaredWide + , distance + , midpoint + , centroid + , triangleArea + , triangleRadiusEdgeRatio + , triangleRadiusEdgeRatioSquaredWithArea + , circumcenter + , barycentricCoordinates + , inDiametralCircle + , projectionFactor + , canonicalPoint + , canonicalCoordinate + , validateCoordinate + , mkQueryPoint + , validatePoint + , mitigateUnderflow + , isFinite + ) where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Moonlight.Triangulation.Internal.Dyadic + ( exactBarycentricDeterminants + , exactDiametralDot + , integerRatioToDouble + ) +import Moonlight.Triangulation.LineSideInfo (LineSideInfo, fromOrdering) +import Moonlight.Triangulation.Scalar + ( canonicalScalarZero + , inCircleCoordinates + , maximumAllowedCoordinate + , minimumAllowedCoordinate + , orient2dCoordinates + , scalarCcwErrorBound + ) +import Moonlight.Triangulation.Internal.Types + ( BuildError (..) + , CoordinateError (..) + , Point (..) + , PointValidationError (..) + , QueryPoint (..) + ) + +-- | The complete exact-predicate relation between two closed segments. There +-- is one vocabulary owner; traversal and constrained-union consumers derive +-- their booleans and obstruction policy from it rather than cloning slightly +-- different orientation formulae. +data SegmentRelation + = SegmentsDisjoint + | SegmentsDuplicate + | SegmentsShareEndpoint + | SegmentsProperlyCross + | SegmentEndpointTouchesInterior + | SegmentsCollinearlyOverlap + deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +allSegmentRelations :: [SegmentRelation] +allSegmentRelations = [minBound .. maxBound] + +segmentRelation + :: Point + -> Point + -> Point + -> Point + -> SegmentRelation +segmentRelation a b c d + | sameUndirectedSegment = SegmentsDuplicate + | sharesEndpoint = SegmentsShareEndpoint + | opposite abC abD && opposite cdA cdB = SegmentsProperlyCross + | abC == EQ && abD == EQ && cdA == EQ && cdB == EQ = collinearRelation + | endpointTouches = SegmentEndpointTouchesInterior + | otherwise = SegmentsDisjoint + where + !abC = orient2d a b c + !abD = orient2d a b d + !cdA = orient2d c d a + !cdB = orient2d c d b + sameUndirectedSegment = (a == c && b == d) || (a == d && b == c) + sharesEndpoint = a == c || a == d || b == c || b == d + endpointTouches = + (abC == EQ && onClosedSegment a b c) + || (abD == EQ && onClosedSegment a b d) + || (cdA == EQ && onClosedSegment c d a) + || (cdB == EQ && onClosedSegment c d b) + collinearRelation = + let !overlapLower = max (min a b) (min c d) + !overlapUpper = min (max a b) (max c d) + in case compare overlapLower overlapUpper of + LT -> SegmentsCollinearlyOverlap + EQ -> SegmentEndpointTouchesInterior + GT -> SegmentsDisjoint + opposite left right = + (left == LT && right == GT) || (left == GT && right == LT) + +segmentsIntersect + :: Point + -> Point + -> Point + -> Point + -> Bool +segmentsIntersect a b c d = segmentRelation a b c d /= SegmentsDisjoint + +-- | The proper-crossing section of 'segmentRelation'. Consumers which reject +-- only that constructor need not compute the collinear and endpoint-touch +-- distinctions required by the complete ADT after either side already proves +-- separation. +segmentsProperlyCross + :: Point + -> Point + -> Point + -> Point + -> Bool +segmentsProperlyCross a b c d = + opposite (orient2d a b c) (orient2d a b d) + && opposite (orient2d c d a) (orient2d c d b) + where + opposite LT GT = True + opposite GT LT = True + opposite _ _ = False + +validateCoordinate :: Double -> Maybe CoordinateError +validateCoordinate value + | isNaN value = Just CoordinateNaN + | isInfinite value = Just CoordinateInfinite + | value /= 0 && abs value < minimumAllowedCoordinate = Just CoordinateTooSmall + | abs value > maximumAllowedCoordinate = Just CoordinateTooLarge + | otherwise = Nothing + +-- | Admit and normalize a finite point for read-only geometric queries. +mkQueryPoint :: Point -> Either PointValidationError (QueryPoint) +mkQueryPoint point@(Point x y) = do + maybe (Right ()) (Left . InvalidPointX) (validateCoordinate x) + maybe (Right ()) (Left . InvalidPointY) (validateCoordinate y) + Right (QueryPoint (canonicalPoint point)) + +validatePoint :: Maybe Int -> Point -> Either BuildError (QueryPoint) +validatePoint slot point@(Point x y) = + case mkQueryPoint point of + Left (InvalidPointX reason) -> Left (InvalidCoordinate slot x reason) + Left (InvalidPointY reason) -> Left (InvalidCoordinate slot y reason) + Right queryPoint -> Right queryPoint + +-- | Round coordinates below the robust-predicate input floor toward zero. +-- The operation never changes a coordinate already accepted by +-- 'validateCoordinate'. +mitigateUnderflow :: Point -> Point +mitigateUnderflow (Point x y) = Point (mitigate x) (mitigate y) + where + mitigate :: Double -> Double + mitigate value + | value /= 0 && abs value < minimumAllowedCoordinate = 0 + | otherwise = value + +canonicalPoint :: Point -> Point +canonicalPoint (Point x y) = Point (canonicalCoordinate x) (canonicalCoordinate y) +{-# INLINE canonicalPoint #-} + +-- | Round a signed zero to the canonical zero. The law that makes two points +-- at the same position compare equal lives here; @canonicalPoint@ is its +-- component-wise form and coordinate-carrying callers use it directly so no +-- t'Point' is built only to be taken apart again. +canonicalCoordinate :: Double -> Double +canonicalCoordinate = canonicalScalarZero +{-# INLINE canonicalCoordinate #-} + +-- base's 'isNaN' and 'isInfinite' are FFI calls in this GHC (static +-- ccall to isDoubleNaN/isDoubleInfinite), and a circumcentre pays four of +-- them per call. @value - value == 0@ is the same predicate in pure Double +-- arithmetic: finite values subtract to zero, while NaN and the infinities +-- subtract to NaN, which never compares equal. +isFinite :: Double -> Bool +isFinite value = value - value == 0 +{-# INLINE isFinite #-} + +orientDetApprox :: Point -> Point -> Point -> Double +orientDetApprox (Point ax ay) (Point bx by) (Point cx cy) = + (ax - cx) * (by - cy) - (ay - cy) * (bx - cx) +{-# INLINE orientDetApprox #-} + +orient2d :: Point -> Point -> Point -> Ordering +orient2d (Point ax ay) (Point bx by) (Point cx cy) = + orient2dCoordinates ax ay bx by cx cy +{-# INLINE orient2d #-} + +sideQuery :: Point -> Point -> Point -> LineSideInfo +sideQuery a b point = fromOrdering (orient2d a b point) +{-# INLINE sideQuery #-} + +inCircleDetApprox + :: Point -> Point -> Point -> Point -> Double +inCircleDetApprox + (Point ax ay) + (Point bx by) + (Point cx cy) + (Point dx dy) = + alift * bcdet + blift * cadet + clift * abdet + where + !adx = ax - dx + !ady = ay - dy + !bdx = bx - dx + !bdy = by - dy + !cdx = cx - dx + !cdy = cy - dy + !abdet = adx * bdy - bdx * ady + !bcdet = bdx * cdy - cdx * bdy + !cadet = cdx * ady - adx * cdy + !alift = adx * adx + ady * ady + !blift = bdx * bdx + bdy * bdy + !clift = cdx * cdx + cdy * cdy +{-# INLINE inCircleDetApprox #-} + +-- | Ordering of the oriented incircle determinant. For a counter-clockwise +-- triangle, 'GT' means the fourth point lies strictly inside its circumcircle. +inCircle + :: Point -> Point -> Point -> Point -> Ordering +inCircle + (Point ax ay) + (Point bx by) + (Point cx cy) + (Point dx dy) = + inCircleCoordinates ax ay bx by cx cy dx dy +{-# INLINE inCircle #-} + +onClosedSegment :: Point -> Point -> Point -> Bool +onClosedSegment a@(Point ax ay) b@(Point bx by) query@(Point qx qy) = + orient2d a b query == EQ + && qx >= min ax bx + && qx <= max ax bx + && qy >= min ay by + && qy <= max ay by +{-# INLINE onClosedSegment #-} + +squaredDistance :: Point -> Point -> Double +squaredDistance (Point ax ay) (Point bx by) = + let !dx = ax - bx + !dy = ay - by + in dx * dx + dy * dy +{-# INLINE squaredDistance #-} + +-- | Squared Euclidean distance in the mesh's Binary64 coordinate domain. +squaredDistanceWide :: Point -> Point -> Double +squaredDistanceWide = squaredDistance +{-# INLINE squaredDistanceWide #-} + +segmentDistanceSquared + :: Point -> Point -> Point -> Double +segmentDistanceSquared from@(Point ax ay) to@(Point bx by) point@(Point px py) + | lengthSquared == 0 = squaredDistance from point + | factor <= 0 = squaredDistance from point + | factor >= 1 = squaredDistance to point + | otherwise = squaredDistance point (Point (ax + factor * dx) (ay + factor * dy)) + where + !dx = bx - ax + !dy = by - ay + !lengthSquared = dx * dx + dy * dy + !factor = ((px - ax) * dx + (py - ay) * dy) / lengthSquared +{-# INLINE segmentDistanceSquared #-} + +-- | Comparison form retained beside 'segmentDistanceSquared' for callers that +-- state metric intent explicitly. +segmentDistanceSquaredWide + :: Point -> Point -> Point -> Double +segmentDistanceSquaredWide = segmentDistanceSquared +{-# INLINE segmentDistanceSquaredWide #-} + +distance :: Point -> Point -> Double +distance left right = sqrt (squaredDistance left right) +{-# INLINE distance #-} + +midpoint :: Point -> Point -> Point +midpoint (Point ax ay) (Point bx by) = Point (0.5 * ax + 0.5 * bx) (0.5 * ay + 0.5 * by) +{-# INLINE midpoint #-} + +centroid :: Point -> Point -> Point -> Point +centroid (Point ax ay) (Point bx by) (Point cx cy) = + Point (ax + (bx - ax) / 3 + (cx - ax) / 3) (ay + (by - ay) / 3 + (cy - ay) / 3) +{-# INLINE centroid #-} + +triangleArea :: Point -> Point -> Point -> Double +triangleArea a b c = 0.5 * abs (orientDetApprox a b c) +{-# INLINE triangleArea #-} + +triangleRadiusEdgeRatio + :: Point -> Point -> Point -> Maybe Double +triangleRadiusEdgeRatio p0 p1 p2 + | area <= 0 || shortest <= 0 = Nothing + | not (isFinite ratio) = Nothing + | otherwise = Just ratio + where + !area = triangleArea p0 p1 p2 + !side01 = distance p0 p1 + !side12 = distance p1 p2 + !side20 = distance p2 p0 + !shortest = min side01 (min side12 side20) + !otherProduct + | side01 <= side12 && side01 <= side20 = side12 * side20 + | side12 <= side20 = side20 * side01 + | otherwise = side01 * side12 + !ratio = otherProduct / (4 * area) + +-- | The square of 'triangleRadiusEdgeRatio', for a triangle whose area the +-- caller already has. +-- +-- The ratio is only ever compared against a bound, and both sides are +-- non-negative, so the comparison can be made between squares. That is the +-- whole reason to have this: it settles the same question without the three +-- square roots the lengths would need, on the path taken by every face +-- refinement considers. +-- +-- The area is a parameter and a degenerate triangle answers with an infinity +-- rather than an absence, because the caller on that path has already computed +-- the area to ask the area question and does nothing with the absence but +-- compare an infinity in its place. +triangleRadiusEdgeRatioSquaredWithArea + :: Double -> Point -> Point -> Point -> Double +triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2 + | area <= 0 || shortest <= 0 = 1 / 0 + | not (isFinite ratio) = 1 / 0 + | otherwise = ratio + where + !side01 = squaredDistance p0 p1 + !side12 = squaredDistance p1 p2 + !side20 = squaredDistance p2 p0 + !shortest = min side01 (min side12 side20) + !otherProduct + | side01 <= side12 && side01 <= side20 = side12 * side20 + | side12 <= side20 = side20 * side01 + | otherwise = side01 * side12 + !ratio = otherProduct / (16 * area * area) + +-- The scale the determinants are divided by cancels out of the quotient +-- exactly, so the computation works on the unscaled differences and divides +-- once per coordinate. Scaling would only matter against overflow, and the +-- validated coordinate domain (|x| <= 3.3e60) keeps every intermediate below +-- 1e183, five orders below the Double ceiling; the four divisions it cost +-- are the circumcentre's hot-path price. Identical points answer through the +-- denominator, which is exactly zero exactly when they are collinear. +circumcenter + :: Point -> Point -> Point -> Maybe (Point) +circumcenter (Point ax ay) (Point bx by) (Point cx cy) + | denominator == 0 = Nothing + | not (isFinite resultX && isFinite resultY) = Nothing + | otherwise = Just (canonicalPoint (Point resultX resultY)) + where + !bax = bx - ax + !bay = by - ay + !cax = cx - ax + !cay = cy - ay + !bLength = bax * bax + bay * bay + !cLength = cax * cax + cay * cay + !denominator = 2 * (bax * cay - bay * cax) + !offsetX = (cay * bLength - bay * cLength) / denominator + !offsetY = (bax * cLength - cax * bLength) / denominator + !resultX = ax + offsetX + !resultY = ay + offsetY + +barycentricCoordinates + :: Point -> Point -> Point -> Point + -> Maybe (Double, Double, Double) +barycentricCoordinates a@(Point ax ay) b@(Point bx by) c@(Point cx cy) query@(Point qx qy) + | all reliable [denominatorInfo, weightAInfo, weightBInfo, weightCInfo] = + if denominator == 0 + then Nothing + else Just (weightA / denominator, weightB / denominator, weightC / denominator) + | exactDenominator == 0 = Nothing + | otherwise = + Just + ( integerRatioToDouble exactWeightA exactDenominator + , integerRatioToDouble exactWeightB exactDenominator + , integerRatioToDouble exactWeightC exactDenominator + ) + where + !denominatorInfo@(denominator, _) = determinantInfo a b c + !weightAInfo@(weightA, _) = determinantInfo query b c + !weightBInfo@(weightB, _) = determinantInfo a query c + !weightCInfo@(weightC, _) = determinantInfo a b query + (!exactDenominator, !exactWeightA, !exactWeightB, !exactWeightC) = + exactBarycentricDeterminants ax ay bx by cx cy qx qy + + reliable (determinant, determinantSum) = + isFinite determinant && abs determinant > scalarCcwErrorBound * determinantSum + + determinantInfo :: Point -> Point -> Point -> (Double, Double) + determinantInfo (Point px py) (Point rx ry) (Point sx sy) = + let !left = (px - sx) * (ry - sy) + !right = (py - sy) * (rx - sx) + in (left - right, abs left + abs right) + +-- | Whether a point lies in the closed diametral disk of a segment, decided by +-- the sign of @(a-p)·(b-p)@. +-- +-- The approximation is two coordinate differences and one product per term +-- combined additively, which is the arithmetic shape 'orient2d' is analysed +-- under: the forward error of @fl(fl(a⊖b) ⊗ fl(c⊖d))@ combined by one rounded +-- addition does not depend on the sign of that combination. The orientation +-- coefficient therefore transfers unchanged, and the exact dot product remains +-- the oracle for the uncertain band. +inDiametralCircle :: Point -> Point -> Point -> Bool +inDiametralCircle (Point ax ay) (Point bx by) (Point px py) + | isFinite dot && abs dot > scalarCcwErrorBound * dotSum = dot < 0 + | otherwise = exactDiametralDot ax ay bx by px py <= 0 + where + !left = (ax - px) * (bx - px) + !right = (ay - py) * (by - py) + !dot = left + right + !dotSum = abs left + abs right +{-# INLINE inDiametralCircle #-} + +projectionFactor :: Point -> Point -> Point -> Double +projectionFactor (Point ax ay) (Point bx by) (Point qx qy) + | lengthSquared == 0 = 0 + | otherwise = ((qx - ax) * dx + (qy - ay) * dy) / lengthSquared + where + !dx = bx - ax + !dy = by - ay + !lengthSquared = dx * dx + dy * dy +{-# INLINE projectionFactor #-} diff --git a/src-dcel/Moonlight/Triangulation/Payload.hs b/src-dcel/Moonlight/Triangulation/Payload.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Payload.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RankNTypes #-} + +-- | The payload parameters' functorial and traversable structure: relabeling a +-- payload touches no geometry, so every law here holds for the reason that a +-- triangulation's points and its annotations are separate things. +module Moonlight.Triangulation.Payload + ( PayloadTraversal + , vertexPayloads + , directedPayloads + , undirectedPayloads + , facePayloads + , mapVertices + , mapDirectedEdges + , mapUndirectedEdges + , mapFaces + , overPayloads + , foldPayloads + , payloadList + ) where + +import Data.Functor.Const (Const (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Monoid (Endo (..)) +import Moonlight.Triangulation.Internal.Representation + ( PayloadTraversal + , directedPayloads + , facePayloads + , mapDirectedEdges + , mapFaces + , mapUndirectedEdges + , mapVertices + , undirectedPayloads + , vertexPayloads + ) + +-- | Relabel every payload a traversal reaches. +-- +-- The 'mapVertices' family is this at each parameter and cheaper: a pure map +-- leaves an unmaterialized page unmaterialized, where a traversal must visit +-- every slot the page would have reported and so materializes it. Reach for +-- this one when the traversal is chosen at runtime, and for the named map when +-- the parameter is known where you stand. +overPayloads + :: PayloadTraversal source target payload payload' + -> (payload -> payload') + -> source + -> target +overPayloads traversal relabel = runIdentity . traversal (Identity . relabel) +{-# INLINE overPayloads #-} + +-- | Summarize every payload a traversal reaches. +foldPayloads + :: Monoid summary + => PayloadTraversal source source payload payload + -> (payload -> summary) + -> source + -> summary +foldPayloads traversal measure = getConst . traversal (Const . measure) +{-# INLINE foldPayloads #-} + +-- | Every payload a traversal reaches, in visit order. Accumulated through +-- t'Endo' so the list is built by a right fold rather than by repeated append. +payloadList :: PayloadTraversal source source payload payload -> source -> [payload] +payloadList traversal source = appEndo (foldPayloads traversal (Endo . (:)) source) [] +{-# INLINE payloadList #-} diff --git a/src-dcel/Moonlight/Triangulation/PointLocation.hs b/src-dcel/Moonlight/Triangulation/PointLocation.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/PointLocation.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Walk location over the finite mesh; the hinted form takes a starting point +-- and reports the steps it spent. +module Moonlight.Triangulation.PointLocation + ( locatePoint + , locatePointWithHint + ) where + +import Data.List (find) +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators +import Moonlight.Triangulation.Internal.FaceProbe +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Types + +locatePoint :: Triangulation mode vertex directed undirected face -> QueryPoint -> Location +locatePoint triangulation query = fst (locatePointWithHint triangulation Nothing query) + +locatePointWithHint :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> QueryPoint -> (Location, LocationStats) +locatePointWithHint triangulation hint queryPoint + | numVertices triangulation == 0 = (EmptyTriangulation, emptyLocationStats) + | numInnerFaces triangulation == 0 = (locateDegenerate triangulation query, emptyLocationStats) + | otherwise = walk budget 0 startFace + where + !query = queryPointValue queryPoint + !budget = max 8 (numFaces triangulation + numUndirectedEdges triangulation + 4) + !startFace = chooseStart triangulation hint + + walk !remaining !steps !face + | remaining <= 0 = scanAll steps + | face == outerFace = + (outsideLocation triangulation query, LocationStats steps False) + | otherwise = + case probeFace triangulation face query of + FaceHit location -> (location, LocationStats (steps + 1) False) + FaceCross edge -> + let adjacent = incidentFace triangulation edge + in if adjacent == outerFace + then (OutsideConvexHull (Just edge), LocationStats (steps + 1) False) + else walk (remaining - 1) (steps + 1) adjacent + FaceMiss -> scanAll (steps + 1) + + scanAll !steps = + case findHit (innerFaces triangulation) of + Just location -> (location, LocationStats steps True) + Nothing -> (outsideLocation triangulation query, LocationStats steps True) + + findHit [] = Nothing + findHit (face : remaining) = + case probeFace triangulation face query of + FaceHit location -> Just location + _ -> findHit remaining + +data FaceProbe = FaceHit !Location | FaceCross !DirectedEdgeId | FaceMiss + +probeFace :: Triangulation mode vertex directed undirected face -> FaceId -> Point -> FaceProbe +probeFace triangulation face query = + case innerFaceDirectedEdges triangulation face of + Nothing -> FaceMiss + Just (e0, e1, e2) -> classify [e0, e1, e2] Nothing + where + classify [] Nothing = FaceHit (InFace face) + classify [] (Just edge) = FaceCross edge + classify (edge : remaining) crossing = + let fromVertex = origin triangulation edge + toVertex = destination triangulation edge + from = vertexPoint triangulation fromVertex + to = vertexPoint triangulation toVertex + in case probeBoundary reverseEdge query edge fromVertex from toVertex to of + BoundaryClear -> classify remaining crossing + BoundaryOnVertex vertex -> FaceHit (OnVertex vertex) + BoundaryOnEdge boundary -> FaceHit (OnEdge boundary) + BoundaryCrossing boundary -> classify remaining (Just boundary) + +locateDegenerate :: Triangulation mode vertex directed undirected face -> Point -> Location +locateDegenerate triangulation query = + case find ((== query) . vertexPoint triangulation) (vertices triangulation) of + Just vertex -> OnVertex vertex + Nothing -> + case find contains (undirectedEdges triangulation) of + Just edge -> OnEdge (normalizedDirected edge) + Nothing -> + case undirectedEdges triangulation of + [] -> OutsideConvexHull Nothing + edge : _ -> + let forward = normalizedDirected edge + from = vertexPoint triangulation (origin triangulation forward) + to = vertexPoint triangulation (destination triangulation forward) + directed = case orient2d from to query of + GT -> forward + LT -> reverseEdge forward + EQ -> forward + in OutsideConvexHull (Just directed) + where + contains edge = + let forward = normalizedDirected edge + in onClosedSegment + (vertexPoint triangulation (origin triangulation forward)) + (vertexPoint triangulation (destination triangulation forward)) + query + +outsideLocation :: Triangulation mode vertex directed undirected face -> Point -> Location +outsideLocation triangulation query = + OutsideConvexHull (find visible (faceDirectedEdges triangulation outerFace)) + where + visible edge = + orient2d + (vertexPoint triangulation (origin triangulation edge)) + (vertexPoint triangulation (destination triangulation edge)) + query + /= LT + +chooseStart :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> FaceId +chooseStart triangulation hint = + case hint of + Just (FaceHint face@(FaceId index)) + | index > 0 && fromIntegral index < numFaces triangulation -> face + Just (VertexHint vertex@(VertexId index)) + | toInteger index < toInteger (numVertices triangulation) -> + case [face | edge <- vertexOutgoingEdges triangulation vertex, let face = incidentFace triangulation edge, face /= outerFace] of + face : _ -> face + [] -> FaceId 1 + | otherwise -> FaceId 1 + _ -> FaceId 1 + diff --git a/src-dcel/Moonlight/Triangulation/Types.hs b/src-dcel/Moonlight/Triangulation/Types.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Types.hs @@ -0,0 +1,40 @@ +-- | The package vocabulary: sites and validated queries, the mode-indexed +-- triangulation, what construction returns, and the closed failure types. +module Moonlight.Triangulation.Types + ( Point (..) + , SiteRelation (..) + , QueryPoint + , queryPointValue + , PointValidationError (..) + , HasPosition (..) + , ElementDefaults (..) + , unitElementDefaults + , ConstraintMode (..) + , KnownConstraintMode (..) + , Triangulation + , DelaunayTriangulation + , ConstrainedDelaunayTriangulation + , BuildResult (..) + , InsertionDisposition (..) + , InsertionResult (..) + , BuildStats (..) + , emptyBuildStats + , CoordinateError (..) + , NonFiniteValue (..) + , classifyNonFinite + , BuildError (..) + , Location (..) + , LocationHint (..) + , LocationStats (..) + , emptyLocationStats + , NearestStats (..) + , RefinementParameters (..) + , defaultRefinementParameters + , RefinementReceipt (..) + , RefinementDomainResult (..) + , RefinementResult (..) + , InvariantViolation (..) + ) where + +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types diff --git a/src-dcel/Moonlight/Triangulation/Validation.hs b/src-dcel/Moonlight/Triangulation/Validation.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Validation.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Discharge: the invariants the constructors guarantee, checkable on a value +-- built by any route. +module Moonlight.Triangulation.Validation + ( validateTopology + , validateDelaunay + , validateTriangulation + , triangulationIsValid + , faceArea + , faceMinimumAngleDegrees + ) where + +import Data.List (nub) +import qualified Data.IntSet as IntSet +import Moonlight.Triangulation.Internal.BoxedPaged (boxedPagedLength) +import Moonlight.Triangulation.Internal.Paged (pagedFoldl', pagedLength, pagedUnsafeIndex) +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (allFaces, directedEdges, undirectedEdges, vertices) +import Moonlight.Triangulation.Internal.PackedIndex (noIndex) +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types + +-- | Every structural invariant violated, not the first. +validateTopology :: Triangulation mode vertex directed undirected face -> [InvariantViolation] +validateTopology triangulation = + structuralViolations ++ orientationViolations + where + verticesCount = numVertices triangulation + halfCount = numDirectedEdges triangulation + edgeCount = numUndirectedEdges triangulation + facesCount = numFaces triangulation + + -- Geometry descends only after the finite DCEL has glued structurally. + -- Reading triangle coordinates through malformed links would turn a typed + -- validation failure into an indexing crash. + structuralViolations = + cardinalityViolations + ++ rangeViolations + ++ edgeViolations + ++ faceViolations + ++ vertexViolations + ++ eulerViolations + + orientationViolations + | not (null structuralViolations) = [] + | otherwise = + [ InnerFaceNotCounterClockwise face + | face <- allFaces triangulation + , face /= outerFace + , Just (first, second, third) <- [innerFaceVertices triangulation face] + , orient2d + (vertexPoint triangulation first) + (vertexPoint triangulation second) + (vertexPoint triangulation third) + /= GT + ] + + cardinalityViolations = + [ CoordinatePlaneLengthMismatch pointXCount pointYCount + | pointXCount /= pointYCount + ] + ++ [VertexOutgoingLengthMismatch vertexOutCount verticesCount | vertexOutCount /= verticesCount] + ++ [VertexPayloadLengthMismatch vertexPayloadCount verticesCount | vertexPayloadCount /= verticesCount] + ++ [TopologyArenaLengthMismatch topologyLength (4 * halfCount) | not halfArraysEqual] + ++ [DirectedPayloadLengthMismatch directedPayloadCount halfCount | directedPayloadCount /= halfCount] + ++ [UndirectedPayloadLengthMismatch undirectedPayloadCount edgeCount | undirectedPayloadCount /= edgeCount] + ++ [DirectedEdgeCountOdd halfCount | odd halfCount] + ++ [ConstraintLengthMismatch constraintLength edgeCount | constraintLength /= edgeCount] + ++ [ NonCanonicalConstraintFlag (UndirectedEdgeId (fromIntegral index)) flag + | index <- [0 .. pagedLength (triConstraint triangulation) - 1] + , let flag = pagedUnsafeIndex (triConstraint triangulation) index + , flag /= 0 && flag /= 1 + ] + ++ [CachedConstraintCountMismatch (triConstraintCount triangulation) actualConstraintCount | triConstraintCount triangulation /= actualConstraintCount] + ++ [CachedConstraintIndexMismatch | triConstraintEdges triangulation /= indexedConstraintEdges] + ++ [MissingOuterFace | facesCount == 0] + ++ [FacePayloadLengthMismatch facePayloadCount facesCount | facePayloadCount /= facesCount] + + pointXCount = pagedLength (triPointX triangulation) + pointYCount = pagedLength (triPointY triangulation) + vertexOutCount = pagedLength (triVertexOut triangulation) + vertexPayloadCount = boxedPagedLength (triVertexData triangulation) + topologyLength = pagedLength (triHalfTopology triangulation) + directedPayloadCount = boxedPagedLength (triDirectedData triangulation) + undirectedPayloadCount = boxedPagedLength (triUndirectedData triangulation) + constraintLength = pagedLength (triConstraint triangulation) + facePayloadCount = boxedPagedLength (triFaceData triangulation) + actualConstraintCount = pagedFoldl' (\count flag -> if flag == 1 then count + 1 else count) 0 (triConstraint triangulation) + halfArraysEqual = topologyLength == 4 * halfCount + + indexedConstraintEdges = + IntSet.fromAscList + [ index + | index <- [0 .. edgeCount - 1] + , pagedUnsafeIndex (triConstraint triangulation) index == 1 + ] + + rangeViolations = + [ EdgeOriginOutOfRange (DirectedEdgeId (fromIntegral index)) (VertexId value) verticesCount + | index <- [0 .. halfCount - 1] + , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index) + , fromIntegral value >= verticesCount + ] + ++ [ EdgeNextOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount + | index <- [0 .. halfCount - 1] + , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 1) + , fromIntegral value >= halfCount + ] + ++ [ EdgePreviousOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount + | index <- [0 .. halfCount - 1] + , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 2) + , fromIntegral value >= halfCount + ] + ++ [ EdgeFaceOutOfRange (DirectedEdgeId (fromIntegral index)) (FaceId value) facesCount + | index <- [0 .. halfCount - 1] + , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 3) + , fromIntegral value >= facesCount + ] + ++ [ VertexOutgoingOutOfRange (VertexId (fromIntegral index)) (DirectedEdgeId value) halfCount + | index <- [0 .. pagedLength (triVertexOut triangulation) - 1] + , let value = pagedUnsafeIndex (triVertexOut triangulation) index + , value /= noIndex + , fromIntegral value >= halfCount + ] + ++ [ FaceAdjacentOutOfRange (FaceId (fromIntegral index)) (DirectedEdgeId value) halfCount + | index <- [0 .. facesCount - 1] + , let value = pagedUnsafeIndex (triFaceEdge triangulation) index + , value /= noIndex + , fromIntegral value >= halfCount + ] + + edgeViolations + | not halfArraysEqual || odd halfCount = [] + | otherwise = concatMap validateEdge (directedEdges triangulation) + + validateEdge edge@(DirectedEdgeId raw) = + let index = fromIntegral raw + nextEdge = next triangulation edge + previousEdge = previous triangulation edge + twinEdge = reverseEdge edge + local = + [ EdgeNextPreviousMismatch edge nextEdge + | validEdge nextEdge && previous triangulation nextEdge /= edge + ] + ++ [ EdgePreviousNextMismatch edge previousEdge + | validEdge previousEdge && next triangulation previousEdge /= edge + ] + ++ [EdgeDoubleReversalMismatch edge | reverseEdge twinEdge /= edge] + ++ [EdgeSelfLinkedNext edge | nextEdge == edge && halfCount > 2] + ++ [EdgeSelfLinkedPrevious edge | previousEdge == edge && halfCount > 2] + innerCycle = + if incidentFace triangulation edge /= outerFace && validEdge nextEdge && validEdge previousEdge + then + [ InnerFaceNotTriangularAtEdge edge + | next triangulation (next triangulation nextEdge) /= edge + ] + else [] + in if index < halfCount then local ++ innerCycle else [] + + validEdge (DirectedEdgeId value) = fromIntegral value < halfCount + + faceViolations = concatMap validateFace (allFaces triangulation) + validateFace face@(FaceId _) = + case adjacentEdge triangulation face of + Nothing + | face == outerFace && halfCount == 0 -> [] + | otherwise -> [FaceMissingAdjacentEdge face] + Just edge -> + [ FaceRepresentativeMismatch face edge representedFace + | let representedFace = incidentFace triangulation edge + , representedFace /= face + ] + ++ [ InnerFaceVertexCardinalityMismatch face (length faceVertexIds) (length (nub faceVertexIds)) + | face /= outerFace + , let faceVertexIds = faceVertices triangulation face + , length faceVertexIds /= 3 || length (nub faceVertexIds) /= 3 + ] + + vertexViolations = concatMap validateVertex (vertices triangulation) + validateVertex vertex = case vertexOutEdge triangulation vertex of + Nothing + | verticesCount <= 1 -> [] + | otherwise -> [ConnectedVertexMissingOutgoing vertex] + Just edge -> + [ VertexOutgoingOriginMismatch vertex edge actualOrigin + | let actualOrigin = origin triangulation edge + , actualOrigin /= vertex + ] + + + eulerViolations + | not (null cardinalityViolations) || verticesCount < 2 = [] + | numInnerFaces triangulation == 0 = + [ CollinearEdgeCountMismatch (verticesCount - 1) edgeCount + | edgeCount /= verticesCount - 1 + ] + | otherwise = + [ EulerCharacteristicMismatch eulerCharacteristic + | eulerCharacteristic /= 2 + ] + where + eulerCharacteristic = verticesCount - edgeCount + facesCount + +-- | Every edge whose circumcircle is not empty. +validateDelaunay :: Triangulation mode vertex directed undirected face -> [InvariantViolation] +validateDelaunay triangulation = concatMap validateEdge (undirectedEdges triangulation) + where + validateEdge edge + | isConstraintEdge triangulation edge = [] + | isBoundaryEdge triangulation edge = [] + | otherwise = + let directed = normalizedDirected edge + twin = reverseEdge directed + in case (innerFaceDirectedEdges triangulation (incidentFace triangulation directed), innerFaceDirectedEdges triangulation (incidentFace triangulation twin)) of + (Just _, Just _) -> + let a = vertexPoint triangulation (origin triangulation directed) + b = vertexPoint triangulation (destination triangulation directed) + c = vertexPoint triangulation (origin triangulation (previous triangulation directed)) + d = vertexPoint triangulation (origin triangulation (previous triangulation twin)) + convex = orient2d c d b == GT && orient2d d c a == GT + circle = inCircle a b c d + illegal = convex && (circle == GT || (circle == EQ && orderedPair c d < orderedPair a b)) + in [LocallyIllegalDelaunayEdge edge | illegal] + _ -> [DelaunayIncidentFaceNotTriangular edge] + +-- | Topology first; the Delaunay property only if the topology holds. +validateTriangulation + :: Triangulation mode vertex directed undirected face + -> [InvariantViolation] +validateTriangulation triangulation = + let topology = validateTopology triangulation + in if null topology + then validateDelaunay triangulation + else topology + +-- | Whether 'validateTriangulation' is empty. +triangulationIsValid + :: Triangulation mode vertex directed undirected face + -> Bool +triangulationIsValid = null . validateTriangulation + +-- | Signed area, or 'Nothing' where the face is not a triangle. +faceArea :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double +faceArea triangulation face = do + (v0, v1, v2) <- innerFaceVertices triangulation face + pure (triangleArea (vertexPoint triangulation v0) (vertexPoint triangulation v1) (vertexPoint triangulation v2)) + +-- | Smallest interior angle, in degrees. +faceMinimumAngleDegrees :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double +faceMinimumAngleDegrees triangulation face = do + (v0, v1, v2) <- innerFaceVertices triangulation face + let p0 = vertexPoint triangulation v0 + p1 = vertexPoint triangulation v1 + p2 = vertexPoint triangulation v2 + a = sqrt (squaredDistance p1 p2) + b = sqrt (squaredDistance p2 p0) + c = sqrt (squaredDistance p0 p1) + if min a (min b c) <= 0 + then Nothing + else Just (minimum [angle b c a, angle c a b, angle a b c]) + where + angle left right opposite = acos (clamp ((left * left + right * right - opposite * opposite) / (2 * left * right))) * 180 / pi + clamp = max (-1) . min 1 + +orderedPair :: Ord a => a -> a -> (a, a) +orderedPair a b = if a <= b then (a, b) else (b, a) diff --git a/src-dual/Moonlight/Triangulation/HintGenerator.hs b/src-dual/Moonlight/Triangulation/HintGenerator.hs new file mode 100644 --- /dev/null +++ b/src-dual/Moonlight/Triangulation/HintGenerator.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Moonlight.Triangulation.HintGenerator + ( LastUsedHint + , emptyLastUsedHint + , lastUsedHint + , rememberVertex + , HierarchyHint + , defaultHierarchyBranchFactor + , buildHierarchyHint + , hierarchyHint + , hierarchyBranchFactor + , hierarchyBaseCount + , hierarchyLevelCount + , hierarchyVertexCount + , updateHierarchyAfterInsertion + , updateHierarchyAfterRemoval + , rebuildHierarchyHint + , removeManyWithHierarchy + ) where + +import qualified Data.Vector as V +import Control.DeepSeq (NFData) +import Data.List (sort) +import Data.Word (Word32) +import Moonlight.Triangulation.BulkLoad (delaunay, insert) +import Moonlight.Triangulation.Dcel (numUndirectedEdges, numVertices, undirectedEndpoints, vertexPoint) +import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..), VertexId (..)) +import Moonlight.Triangulation.Interpolation (nearestNeighbor) +import Moonlight.Triangulation.Math (canonicalPoint, validatePoint) +import Moonlight.Triangulation.Removal (RemovalOutcome, removalTriangulation, removeVertex) +import Moonlight.Triangulation.Session (removeManyAtNear, withSession) +import Moonlight.Triangulation.Types +import GHC.Generics (Generic) + +newtype LastUsedHint = LastUsedHint (Maybe VertexId) + deriving stock (Show) + deriving newtype (Eq, Ord) + +emptyLastUsedHint :: LastUsedHint +emptyLastUsedHint = LastUsedHint Nothing + +lastUsedHint :: LastUsedHint -> Maybe LocationHint +lastUsedHint (LastUsedHint vertex) = VertexHint <$> vertex + +rememberVertex :: VertexId -> LastUsedHint -> LastUsedHint +rememberVertex vertex _ = LastUsedHint (Just vertex) + +-- | A Delaunay hierarchy for logarithmic expected random point location. +-- The first vector element is the finest sparse level; the final element is +-- the coarsest. The base triangulation is not duplicated. +-- +-- The levels are nested by a single arithmetic law rather than by a stored +-- correspondence. Level @i@ holds every @branch^(i+1)@-th base vertex in base +-- order, so a level-local handle @j@ names handle @j * branch@ one level finer +-- — and at level 0 the finer level is the base mesh itself, under the very +-- same multiplication. Descent therefore never rediscovers a handle it has +-- already computed, and no level carries an index vector. +-- +-- 'hierarchyBaseCount' is the base cardinality the levels were sampled from. +-- It is the hierarchy's claim about which triangulation it answers for, and +-- every maintenance entry is stated against it: a base whose cardinality is not +-- the one recorded here plus the movement the operation performs is not the +-- base this hierarchy describes, and is rebuilt for rather than patched. +data HierarchyHint = HierarchyHint + { hierarchyBranchFactor :: {-# UNPACK #-} !Int + , hierarchyBaseCount :: {-# UNPACK #-} !Int + , hierarchyLevels :: !(V.Vector (Triangulation 'Unconstrained (Point) () () ())) + } + deriving stock (Generic) + deriving anyclass (NFData) + +instance Show (HierarchyHint) where + showsPrec precedence hierarchy = + showParen (precedence > 10) $ + showString "HierarchyHint " + . shows (hierarchyBranchFactor hierarchy) + . showString " " + . shows (hierarchyBaseCount hierarchy) + . showString " " + . shows (hierarchyLevelCount hierarchy) + . showString " " + . shows (hierarchyVertexCount hierarchy) + +instance Eq (HierarchyHint) where + left == right = + hierarchyBranchFactor left == hierarchyBranchFactor right + && hierarchyBaseCount left == hierarchyBaseCount right + && hierarchyLevelCount left == hierarchyLevelCount right + && V.and (V.zipWith sameSparseMesh (hierarchyLevels left) (hierarchyLevels right)) + +-- Two sparse levels are the same hint when they carry the same points and the +-- same undirected edges. Half-edge index labelling records the order +-- construction happened to visit, so a level rebuilt from scratch and a level +-- extended in place are structurally equal while their arrays are not. +sameSparseMesh + :: Triangulation 'Unconstrained (Point) () () () + -> Triangulation 'Unconstrained (Point) () () () + -> Bool +sameSparseMesh left right = + numVertices left == numVertices right + && numUndirectedEdges left == numUndirectedEdges right + && meshPoints left == meshPoints right + && meshEdges left == meshEdges right + where + meshPoints + :: Triangulation mode vertex directed undirected face + -> [Point] + meshPoints triangulation = + sort [vertexPoint triangulation (VertexId (fromIntegral index)) | index <- [0 .. numVertices triangulation - 1]] + + meshEdges + :: Triangulation mode vertex directed undirected face + -> [(Point, Point)] + meshEdges triangulation = + sort + [ if from <= to then (from, to) else (to, from) + | index <- [0 .. numUndirectedEdges triangulation - 1] + , let (fromVertex, toVertex) = undirectedEndpoints triangulation (UndirectedEdgeId (fromIntegral index)) + from = vertexPoint triangulation fromVertex + to = vertexPoint triangulation toVertex + ] + +defaultHierarchyBranchFactor :: Int +defaultHierarchyBranchFactor = 16 + +hierarchyLevelCount :: HierarchyHint -> Int +hierarchyLevelCount = V.length . hierarchyLevels + +hierarchyVertexCount :: HierarchyHint -> Int +hierarchyVertexCount = + V.foldl' (\total level -> total + numVertices level) 0 . hierarchyLevels + +-- | Build nested sparse Delaunay levels. A branch factor of 16 mirrors Spade's +-- default and gives O(log n) expected descent on uniformly distributed input. +-- +-- Each level is bulk loaded from the sampled points in base order. Base +-- vertices carry pairwise distinct positions, so the load deduplicates nothing +-- and assigns local handle @j@ to sample @j@ — which is what makes the nesting +-- law on 'hierarchyLevels' an identity rather than a lookup. +buildHierarchyHint + :: Int + -> Triangulation mode vertex directed undirected face + -> Either BuildError (HierarchyHint) +buildHierarchyHint requestedBranch triangulation = + HierarchyHint branch count <$> V.mapM buildLevel levelDivisors + where + !branch = max 2 requestedBranch + !count = numVertices triangulation + levelDivisors = + V.unfoldr + (\candidate -> + case candidate of + Nothing -> Nothing + Just divisor -> + let !population = samplePopulation count divisor + next = + if population <= 1 + then Nothing + else Just (safeMultiply divisor branch) + in Just (divisor, next) + ) + (if count <= 0 then Nothing else Just branch) + + buildLevel divisor = + buildTriangulation + <$> delaunay + unitElementDefaults + ( V.generate + (samplePopulation count divisor) + (\index -> + vertexPoint + triangulation + (VertexId (fromIntegral (index * divisor))) + ) + ) + +-- | Descend from the coarsest sparse triangulation. The handle a level returns +-- is carried to the next finer level by one multiplication, and the same +-- multiplication at level 0 names the base vertex. Nothing is relocated: the +-- coarse answer is not searched for again, it is computed. +hierarchyHint :: HierarchyHint -> QueryPoint -> Maybe LocationHint +hierarchyHint HierarchyHint{hierarchyBranchFactor, hierarchyLevels} query = + VertexHint <$> descend (V.length hierarchyLevels - 1) Nothing + where + !branch = fromIntegral hierarchyBranchFactor :: Word32 + + descend !levelIndex !coarse + | levelIndex < 0 = Nothing + | otherwise = + case nearestNeighbor (hierarchyLevels V.! levelIndex) coarse query of + Nothing -> Nothing + Just (VertexId local, _) -> + let !finer = VertexId (local * branch) + in if levelIndex == 0 then Just finer else descend (levelIndex - 1) (Just finer) + + +-- | Update the nested hierarchy from an insertion's own report: the point the +-- insertion was asked for, the handle it answered, and whether it created a +-- site. Only the levels selected by the branch divisibility rule are changed. +-- Unaffected levels are structurally shared. +-- +-- No triangulation is named. The hierarchy walks its own levels and nothing +-- else, so a base was only ever a lookup table for three facts — its +-- cardinality, the stored position of the new vertex, and the position of +-- vertex zero — and every one of them is in the report or already in the +-- levels, because level-local handle zero is base handle zero at every level. +-- A caller maintaining the hierarchy across a run of insertions therefore +-- never has to publish a mesh to be allowed to speak to it, which is the whole +-- cost of the arrangement this replaces: one full arena copy per step, paid +-- only to name the thing that was just edited. +-- +-- An insertion that found its point already present created no site, and a +-- hierarchy valid for a triangulation is valid for that same triangulation, so +-- the answer is the argument, unexamined. +updateHierarchyAfterInsertion + :: HierarchyHint + -> Point + -> VertexId + -> InsertionDisposition + -> Either BuildError (HierarchyHint) +updateHierarchyAfterInsertion hierarchy requested vertex disposition = + case disposition of + AlreadyPresent -> Right hierarchy + Inserted + | vertexIndex vertex /= baseIndex -> + Left + ( HierarchyInsertionHandleMismatch + (VertexId (fromIntegral baseIndex)) + vertex + ) + | otherwise -> do + updated <- updateLevels branch (V.toList (hierarchyLevels hierarchy)) + topped <- ensureSingletonTop updated + pure + hierarchy + { hierarchyBaseCount = baseIndex + 1 + , hierarchyLevels = V.fromList topped + } + where + !branch = hierarchyBranchFactor hierarchy + !baseIndex = hierarchyBaseCount hierarchy + -- A level holds what the mesh stores, not what the caller wrote: storage + -- rounds a signed zero, and a level built from the unrounded point would + -- settle a distance tie against a different handle. + !point = canonicalPoint requested + + -- An update is the only operation that can break the nesting law, so the law + -- is stated here as an equation rather than trusted: a level admitted to the + -- new base vertex must already hold exactly @baseIndex / divisor@ samples, + -- and must receive the vertex at its end. + updateLevels !_ [] = Right [] + updateLevels !divisor levels@(level : rest) + | baseIndex `rem` divisor /= 0 = Right levels + | safeMultiply (numVertices level) divisor /= baseIndex = + Left + ( HierarchyLevelPopulationMismatch + divisor + (numVertices level) + baseIndex + ) + | otherwise = do + inserted <- insert level point + if vertexIndex (insertionVertex inserted) /= numVertices level + then + Left + ( HierarchyInsertionHandleMismatch + (VertexId (fromIntegral (numVertices level))) + (insertionVertex inserted) + ) + else (insertionTriangulation inserted :) <$> updateLevels (safeMultiply divisor branch) rest + + -- With no levels at all the base was empty, so the vertex just appended is + -- vertex zero. Otherwise vertex zero is the finest level's local vertex + -- zero, under the same law that makes the descent a multiplication. + ensureSingletonTop [] = pure <$> singletonLevel point + ensureSingletonTop levels@(finest : _) = + case reverse levels of + top : _ + | numVertices top <= 1 -> Right levels + | otherwise -> + (\first -> levels ++ [first]) + <$> singletonLevel (vertexPoint finest (VertexId 0)) + [] -> Right levels + +-- | Repair the nested hierarchy from a removal's swap report — the slot +-- compaction freed and the position of the vertex it moved into that slot, or +-- 'Nothing' when the removal took the last vertex and compaction moved +-- nothing — rather than rebuilding because removal renumbers. +-- +-- No triangulation is named, for the reason 'updateHierarchyAfterInsertion' +-- gives: the only base position this repair cannot find in its own levels is +-- the relocated vertex's, and that is what the report carries. +-- +-- Swap compaction moves exactly one vertex — the former last one, into the slot +-- the removed vertex vacated — so a level's sample sequence changes in at most +-- one place, and which place is decided by the two divisibilities the level's +-- divisor gives the freed slot and the vacated last index: +-- +-- * neither is sampled: the level, and every coarser level above it, is +-- untouched, because a divisor that divides neither index is divided by no +-- multiple of itself either; +-- * the vacated index is sampled and the freed slot is not: the level loses its +-- last sample and nothing else; +-- * both are sampled: the level loses its last sample and that sample's point +-- lands in the freed slot's local position — which is the level's own swap +-- removal, mirroring the base's; +-- * the freed slot is sampled and the vacated index is not: the level keeps its +-- population and substitutes the relocated position at an interior local +-- slot. No removal expresses a substitution, so that level is rebuilt — from +-- its own points and the reported one, never from a mesh. +-- +-- The last case is the only one that pays a build, and it is the rarest: it +-- needs the freed slot to be sampled and the vacated index not to be. +updateHierarchyAfterRemoval + :: HierarchyHint + -> Maybe (VertexId, Point) + -> Either BuildError (HierarchyHint) +updateHierarchyAfterRemoval hierarchy swap + | baseCount <= 0 = Left (RemovalEmptyTriangulation (maybe (VertexId 0) fst swap)) + | otherwise = do + repaired <- repairLevels branch (V.toList (hierarchyLevels hierarchy)) + pure + hierarchy + { hierarchyBaseCount = surviving + , hierarchyLevels = V.fromList (levelsThroughSingleton repaired) + } + where + !branch = hierarchyBranchFactor hierarchy + !baseCount = hierarchyBaseCount hierarchy + !surviving = baseCount - 1 + -- The freed slot is the removed vertex's own index, and it is where the + -- former last vertex now stands. A removal that took the last vertex frees + -- no slot and reports none, and its removed index is that last index. + !freedSlot = maybe surviving (vertexIndex . fst) swap + !vacatedIndex = surviving + + -- The nesting law is stated here as an equation for the same reason the + -- insertion path states it: a repair is the other operation that can break + -- it. A level the removal reaches must hold exactly the samples the + -- pre-removal base owed it. + repairLevels !_ [] = Right [] + repairLevels !divisor levels@(level : rest) + | not freedSampled && not vacatedSampled = Right levels + | numVertices level /= population = + Left + ( HierarchyLevelPopulationMismatch + divisor + (numVertices level) + baseCount + ) + | otherwise = + case swap of + -- The two divisibilities differ only when the two indices do, so a + -- level reaching the substitution has a relocation to substitute: + -- the guard cannot hold while compaction moved nothing. + Just (_, relocated) + | freedSampled && not vacatedSampled -> do + substituted <- substituteSample level (freedSlot `quot` divisor) relocated + (substituted :) <$> repairLevels (safeMultiply divisor branch) rest + _ -> do + shrunk <- removeVertex level (VertexId (fromIntegral localSample)) + (removalTriangulation shrunk :) <$> repairLevels (safeMultiply divisor branch) rest + where + !freedSampled = freedSlot `rem` divisor == 0 + !vacatedSampled = vacatedIndex `rem` divisor == 0 + !population = samplePopulation baseCount divisor + !localSample + | freedSampled = freedSlot `quot` divisor + | otherwise = population - 1 + + -- A build stops at the first level holding one sample, and removal only + -- shrinks populations, so the shape a rebuild would answer with is this list + -- cut after its first singleton. + levelsThroughSingleton + :: [Triangulation mode vertex directed undirected face] + -> [Triangulation mode vertex directed undirected face] + levelsThroughSingleton [] = [] + levelsThroughSingleton (level : rest) + | numVertices level <= 0 = [] + | numVertices level <= 1 = [level] + | otherwise = level : levelsThroughSingleton rest + +-- | The coarsest level a growing hierarchy needs: one sample, the base's +-- vertex zero. +singletonLevel + :: Point + -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) +singletonLevel origin = + buildTriangulation <$> delaunay unitElementDefaults (V.singleton origin) + +-- | The level a substitution asks for: the same samples in the same local +-- order, one slot carrying the relocated position instead of the one that +-- left. Stated over the level's own points, so no mesh is consulted. +substituteSample + :: Triangulation 'Unconstrained (Point) () () () + -> Int + -> Point + -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) +substituteSample level localSlot relocated = + buildTriangulation + <$> delaunay + unitElementDefaults + ( V.generate + (numVertices level) + (\index -> + if index == localSlot + then relocated + else vertexPoint level (VertexId (fromIntegral index)) + ) + ) + +-- | Rebuild a hierarchy after an operation that may renumber vertices, such as +-- removal. The branch factor remains canonical. +rebuildHierarchyHint + :: HierarchyHint + -> Triangulation mode vertex directed undirected face + -> Either BuildError (HierarchyHint) +rebuildHierarchyHint hierarchy = buildHierarchyHint (hierarchyBranchFactor hierarchy) + +-- | Remove many points, each locate starting from the hierarchy's nearest +-- sample instead of the mesh boundary. One session publishes once; the +-- hierarchy is rebuilt against the surviving mesh and returned alongside it. +removeManyWithHierarchy + :: HierarchyHint + -> Triangulation mode vertex directed undirected face + -> V.Vector (Point) + -> Either + BuildError + ( V.Vector (Maybe (RemovalOutcome vertex)) + , Triangulation mode vertex directed undirected face + , HierarchyHint + ) +removeManyWithHierarchy hierarchy triangulation points = do + queryPoints <- traverse (validatePoint Nothing) points + let guesses = fmap hierarchyGuess queryPoints + (outcomes, surviving, _) <- + withSession triangulation 0 (removeManyAtNear guesses points) + repaired <- rebuildHierarchyHint hierarchy surviving + pure (outcomes, surviving, repaired) + where + hierarchyGuess queryPoint = + case hierarchyHint hierarchy queryPoint of + Just (VertexHint vertex) -> Just vertex + _ -> Nothing + +safeMultiply :: Int -> Int -> Int +safeMultiply left right + | left > maxBound `quot` right = maxBound + | otherwise = left * right + +-- | How many samples a divisor takes from a base of this size. Sampling takes +-- index zero and every @divisor@-th index after it; the direct +-- vector generator above states the same ceiling without constructing an +-- intermediate handle list. +samplePopulation :: Int -> Int -> Int +samplePopulation count divisor + | count <= 0 = 0 + | otherwise = 1 + (count - 1) `quot` divisor + +vertexIndex :: VertexId -> Int +vertexIndex (VertexId value) = fromIntegral value + +-- The hierarchy is consulted once per query from another package, so its +-- polymorphic entries expose their unfoldings for the same reason the search +-- itself does. +-- +-- The two level constructors are listed for a second reason, and the list is +-- not complete without them: they are overloaded and the entries call them, so +-- an entry specialised in the consumer that reaches an unspecialised +-- constructor threads the dictionary right back into the build it was +-- specialised to avoid. Only a stable unfolding is a specialisation candidate +-- across a package boundary; the optimised one GHC publishes on its own is not. +-- These two were 'where' bindings before they were named, and a 'where' binding +-- is specialised with the function that encloses it — so naming them is what +-- put the dictionary in, and this is what takes it back out. diff --git a/src-dual/Moonlight/Triangulation/Internal/InterpolationWorkspace.hs b/src-dual/Moonlight/Triangulation/Internal/InterpolationWorkspace.hs new file mode 100644 --- /dev/null +++ b/src-dual/Moonlight/Triangulation/Internal/InterpolationWorkspace.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Triangulation.Internal.InterpolationWorkspace + ( NaturalNeighborWorkspace (..) + , newNaturalNeighborWorkspace + , nextFaceGeneration + , nextOriginGeneration + , workspaceBytes + ) where + +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.ST (ST) +import Data.Primitive.MutVar +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Dcel (numDirectedEdges, numFaces, numVertices) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types (ConstraintMode) +import Moonlight.Triangulation.Scalar (scalarByteSize) + +-- | Reusable scratch space for Sibson interpolation. It borrows no mutable +-- topology: the immutable triangulation is the sole owner, while these arrays +-- are query-local marks, queues and numeric work buffers. +data NaturalNeighborWorkspace state (mode :: ConstraintMode) vertex directed undirected face = NaturalNeighborWorkspace + { nnTriangulation :: !(Triangulation mode vertex directed undirected face) + , nnFaceMarks :: !(MUV.MVector state Word32) + , nnFaceSeenMarks :: !(MUV.MVector state Word32) + -- The circumcentre plane is stamped by the same generation as the two mark + -- planes above, and that is what makes it sound: a generation is minted + -- once per Sibson query, and the circumcentre a face contributes is a + -- function of the face and the query point together. Holding the plane to + -- exactly one generation's lifetime holds the query point fixed for as long + -- as an entry can be read. + , nnCircumcenterMarks :: !(MUV.MVector state Word32) + , nnFaceGeneration :: !(MutVar state Word32) + , nnCircumcenterX :: !(MUV.MVector state Double) + , nnCircumcenterY :: !(MUV.MVector state Double) + , nnFaceQueue :: !(MUV.MVector state Word32) + , nnCavityFaces :: !(MUV.MVector state Word32) + , nnBoundaryEdges :: !(MUV.MVector state Word32) + , nnOrderedEdges :: !(MUV.MVector state Word32) + , nnOriginMarks :: !(MUV.MVector state Word32) + , nnOriginGeneration :: !(MutVar state Word32) + , nnOriginEdge :: !(MUV.MVector state Word32) + , nnInsertionX :: !(MUV.MVector state Double) + , nnInsertionY :: !(MUV.MVector state Double) + , nnWeightVertex :: !(MUV.MVector state Word32) + , nnWeightValue :: !(MUV.MVector state Double) + } + +newNaturalNeighborWorkspace + :: PrimMonad m + => Triangulation mode vertex directed undirected face + -> m (NaturalNeighborWorkspace (PrimState m) mode vertex directed undirected face) +newNaturalNeighborWorkspace triangulation = do + let !faceCapacity = max 1 (numFaces triangulation) + !edgeCapacity = max 1 (numDirectedEdges triangulation) + !vertexCapacity = max 1 (numVertices triangulation) + faceMarks <- MUV.replicate faceCapacity 0 + faceSeenMarks <- MUV.replicate faceCapacity 0 + circumcenterMarks <- MUV.replicate faceCapacity 0 + faceGeneration <- newMutVar 0 + circumcenterX <- MUV.new faceCapacity + circumcenterY <- MUV.new faceCapacity + faceQueue <- MUV.new faceCapacity + cavityFaces <- MUV.new faceCapacity + boundaryEdges <- MUV.new edgeCapacity + orderedEdges <- MUV.new edgeCapacity + originMarks <- MUV.replicate vertexCapacity 0 + originGeneration <- newMutVar 0 + originEdge <- MUV.new vertexCapacity + insertionX <- MUV.new edgeCapacity + insertionY <- MUV.new edgeCapacity + weightVertex <- MUV.new edgeCapacity + weightValue <- MUV.new edgeCapacity + pure NaturalNeighborWorkspace + { nnTriangulation = triangulation + , nnFaceMarks = faceMarks + , nnFaceSeenMarks = faceSeenMarks + , nnCircumcenterMarks = circumcenterMarks + , nnFaceGeneration = faceGeneration + , nnCircumcenterX = circumcenterX + , nnCircumcenterY = circumcenterY + , nnFaceQueue = faceQueue + , nnCavityFaces = cavityFaces + , nnBoundaryEdges = boundaryEdges + , nnOrderedEdges = orderedEdges + , nnOriginMarks = originMarks + , nnOriginGeneration = originGeneration + , nnOriginEdge = originEdge + , nnInsertionX = insertionX + , nnInsertionY = insertionY + , nnWeightVertex = weightVertex + , nnWeightValue = weightValue + } + +nextFaceGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32 +nextFaceGeneration workspace = do + current <- readMutVar (nnFaceGeneration workspace) + let !next = current + 1 + if next == 0 + then do + MUV.set (nnFaceMarks workspace) 0 + MUV.set (nnFaceSeenMarks workspace) 0 + MUV.set (nnCircumcenterMarks workspace) 0 + writeMutVar (nnFaceGeneration workspace) 1 + pure 1 + else writeMutVar (nnFaceGeneration workspace) next >> pure next + +nextOriginGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32 +nextOriginGeneration workspace = nextGeneration (nnOriginMarks workspace) (nnOriginGeneration workspace) + +nextGeneration :: MUV.MVector s Word32 -> MutVar s Word32 -> ST s Word32 +nextGeneration marks reference = do + current <- readMutVar reference + let !next = current + 1 + if next == 0 + then do + MUV.set marks 0 + writeMutVar reference 1 + pure 1 + else writeMutVar reference next >> pure next + +workspaceBytes + :: NaturalNeighborWorkspace state mode vertex directed undirected face + -> Integer +workspaceBytes workspace = + 4 * toInteger wordSlots + + toInteger scalarByteSize * toInteger scalarSlots + where + wordSlots = + MUV.length (nnFaceMarks workspace) + + MUV.length (nnFaceSeenMarks workspace) + + MUV.length (nnCircumcenterMarks workspace) + + MUV.length (nnFaceQueue workspace) + + MUV.length (nnCavityFaces workspace) + + MUV.length (nnBoundaryEdges workspace) + + MUV.length (nnOrderedEdges workspace) + + MUV.length (nnOriginMarks workspace) + + MUV.length (nnOriginEdge workspace) + + MUV.length (nnWeightVertex workspace) + scalarSlots = + MUV.length (nnCircumcenterX workspace) + + MUV.length (nnCircumcenterY workspace) + + MUV.length (nnInsertionX workspace) + + MUV.length (nnInsertionY workspace) + + MUV.length (nnWeightValue workspace) diff --git a/src-dual/Moonlight/Triangulation/Interpolation.hs b/src-dual/Moonlight/Triangulation/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src-dual/Moonlight/Triangulation/Interpolation.hs @@ -0,0 +1,889 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Nearest, barycentric, and natural-neighbor interpolation over one +-- authoritative triangulation. +module Moonlight.Triangulation.Interpolation + ( BarycentricWeights (..) + , InterpolationStats (..) + , NaturalNeighborResult (..) + , NaturalNeighborWorkspace + , newNaturalNeighborWorkspace + , workspaceBytes + , nearestNeighbor + , barycentricWeights + , naturalNeighborWeights + , foldNaturalNeighborWeights + , interpolateNearest + , interpolateBarycentric + , interpolateNaturalNeighbor + , estimateGradient + , estimateGradients + , interpolateNaturalNeighborGradient + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.ST (ST) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32) +import Moonlight.Triangulation.Dcel + ( destination + , counterClockwise + , foldVertexOutgoingEdges' + , incidentFace + , innerFaceDirectedEdges + , innerFaceVertices + , isBoundaryEdge + , next + , numConstraints + , numDirectedEdges + , numVertices + , origin + , outerFace + , vertexOutEdge + , vertexPoint + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId (..) + , asUndirected + , FaceId (..) + , VertexId (..) + , reverseEdge + ) +import Moonlight.Triangulation.Internal.InterpolationWorkspace +import Moonlight.Triangulation.Math + ( barycentricCoordinates + , circumcenter + , inCircle + , isFinite + , projectionFactor + , squaredDistanceWide + ) +import Moonlight.Triangulation.PointLocation (locatePointWithHint) +import Moonlight.Triangulation.Scalar (scalarEpsilon) +import Moonlight.Triangulation.Types + ( Location (..) + , LocationHint + , LocationStats + , NearestStats (..) + , Point (..) + , QueryPoint + , queryPointValue + , Triangulation + ) +import GHC.Generics (Generic) + +-- | Barycentric weights use the mesh's binary64 coordinate domain. +data BarycentricWeights + = NoWeights + | OneWeight !VertexId + | TwoWeights !VertexId !Double !VertexId !Double + | ThreeWeights !VertexId !Double !VertexId !Double !VertexId !Double + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data InterpolationStats = InterpolationStats + { interpolationCavityFaces :: {-# UNPACK #-} !Int + , interpolationNaturalNeighbors :: {-# UNPACK #-} !Int + , interpolationFaceTests :: {-# UNPACK #-} !Int + -- | 'True' exactly when the Sibson pipeline declined and the returned + -- weights are the barycentric coordinates of the located face instead. + -- A silent degradation from Sibson to barycentric is a defect that hides; + -- this bit is the announcement. + , interpolationUsedFallback :: !Bool + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data NaturalNeighborResult = NaturalNeighborResult + { naturalNeighborValues :: !(V.Vector (VertexId, Double)) + , naturalNeighborLocationStats :: !LocationStats + , naturalNeighborStats :: !InterpolationStats + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Nearest vertex and query work, using an optional admitted vertex as the +-- descent seed. Empty triangulations have no nearest vertex. +nearestNeighbor + :: Triangulation mode vertex directed undirected face + -> Maybe VertexId + -> QueryPoint + -> Maybe (VertexId, NearestStats) +nearestNeighbor triangulation hint queryPoint + | numVertices triangulation == 0 = Nothing + | numConstraints triangulation == 0 = Just (descend start startDistance 0 0) + | otherwise = Just (walk start startDistance 0 0) + where + !query = queryPointValue queryPoint + !start = validateHint hint + !startDistance = squaredDistanceWide query (vertexPoint triangulation start) + !bound = numDirectedEdges triangulation + numVertices triangulation + 1 + + validateHint (Just vertex@(VertexId index)) + | fromIntegral index < numVertices triangulation = vertex + validateHint _ = VertexId 0 + + -- A vertex's Voronoi cell is the intersection of the half-planes its + -- Delaunay neighbours induce, so a query outside that cell violates one of + -- them and some neighbour is strictly closer. Descending on the /first/ + -- strict improvement therefore lands on the same vertex as descending on the + -- best one, having tested about half of the star on average instead of all + -- of it. The argument needs the Delaunay property, so a constrained + -- triangulation keeps the exhaustive scan below. + descend !current !currentDistance !steps !tests + | steps >= bound = (current, NearestStats steps tests) + | otherwise = + case vertexOutEdge triangulation current of + Nothing -> (current, NearestStats steps tests) + Just ring -> revolve current currentDistance steps ring ring Nothing tests + + -- Equal-distance neighbours are not an improvement, so they cannot end the + -- revolution early; the lowest such handle is carried to the end and taken + -- only if nothing strictly closer appeared. That is the same deterministic + -- tie the exhaustive scan settles on. + revolve !current !currentDistance !steps !edge !ring !tie !tests + | candidateDistance < currentDistance = + descend candidate candidateDistance (steps + 1) nextTests + | nextEdge == ring = + case nextTie of + Just settled -> descend settled currentDistance (steps + 1) nextTests + Nothing -> (current, NearestStats steps nextTests) + | otherwise = revolve current currentDistance steps nextEdge ring nextTie nextTests + where + !candidate = destination triangulation edge + !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate) + !nextTests = tests + 1 + !nextEdge = counterClockwise triangulation edge + !nextTie + | candidateDistance == currentDistance && candidate < current = + case tie of + Just held | held <= candidate -> tie + _ -> Just candidate + | otherwise = tie + + walk !current !currentDistance !steps !tests + | steps >= bound = (current, NearestStats steps tests) + | otherwise = + let (!candidate, !candidateDistance, !newTests) = + foldVertexOutgoingEdges' + triangulation + current + inspect + (current, currentDistance, tests) + in if candidate == current + then (current, NearestStats steps newTests) + else walk candidate candidateDistance (steps + 1) newTests + + inspect (!best, !bestDistance, !tests) edge = + let !candidate = destination triangulation edge + !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate) + !isBetter = + candidateDistance < bestDistance + || (candidateDistance == bestDistance && candidate < best) + in if isBetter + then (candidate, candidateDistance, tests + 1) + else (best, bestDistance, tests + 1) + +barycentricWeights + :: Triangulation mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> (BarycentricWeights, LocationStats) +barycentricWeights triangulation hint queryPoint = + let !query = queryPointValue queryPoint + (!location, !stats) = locatePointWithHint triangulation hint queryPoint + in (weightsFor query location, stats) + where + weightsFor _ (OnVertex vertex) = OneWeight vertex + weightsFor query (OnEdge edge) = + let !from = origin triangulation edge + !to = destination triangulation edge + !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query) + in TwoWeights from (1 - factor) to factor + weightsFor query (InFace face) = + case innerFaceVertices triangulation face of + Nothing -> NoWeights + Just (a, b, c) -> + case barycentricCoordinates + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + query of + Nothing -> NoWeights + Just (wa, wb, wc) -> ThreeWeights a wa b wb c wc + weightsFor _ EmptyTriangulation = NoWeights + weightsFor _ (OutsideConvexHull _) = NoWeights + +-- | Calculate Sibson coordinates using fixed-capacity reusable scratch storage. +-- The only per-query heap object is the returned boxed vector. +naturalNeighborWeights + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> ST s (NaturalNeighborResult) +naturalNeighborWeights workspace hint queryPoint = do + (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint + values <- V.generateM count $ \index -> do + rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index + weight <- MUV.unsafeRead (nnWeightValue workspace) index + pure (VertexId rawVertex, weight) + pure NaturalNeighborResult + { naturalNeighborValues = values + , naturalNeighborLocationStats = locationStats + , naturalNeighborStats = stats + } + +-- | Strictly fold the Sibson coordinates held in a reusable workspace. Unlike +-- 'naturalNeighborWeights', this does not allocate a result vector. It is the +-- canonical path for repeated interpolation and other reductions. +foldNaturalNeighborWeights + :: (accumulator -> VertexId -> Double -> accumulator) + -> accumulator + -> NaturalNeighborWorkspace s mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> ST s (accumulator, LocationStats, InterpolationStats) +foldNaturalNeighborWeights combine initial workspace hint query = do + (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint query + value <- go 0 initial count + pure (value, locationStats, stats) + where + go !index !accumulator !count + | index >= count = pure accumulator + | otherwise = do + rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index + weight <- MUV.unsafeRead (nnWeightValue workspace) index + let !nextAccumulator = combine accumulator (VertexId rawVertex) weight + go (index + 1) nextAccumulator count + +queryNaturalNeighborWorkspace + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> ST s (Int, LocationStats, InterpolationStats) +queryNaturalNeighborWorkspace workspace hint queryPoint = do + let !triangulation = nnTriangulation workspace + !query = queryPointValue queryPoint + (!location, !locationStats) = locatePointWithHint triangulation hint queryPoint + (!count, !stats) <- case location of + OnVertex vertex -> do + writeWeight workspace 0 vertex 1 + pure (1, InterpolationStats 0 1 0 False) + OnEdge edge + | isBoundaryEdge triangulation (asUndirected edge) -> do + let !from = origin triangulation edge + !to = destination triangulation edge + !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query) + writeWeight workspace 0 from (1 - factor) + writeWeight workspace 1 to factor + pure (2, InterpolationStats 0 2 0 False) + | otherwise -> + let !left = incidentFace triangulation edge + !right = incidentFace triangulation (reverseEdge edge) + !start = if left /= outerFace then left else right + in sibsonQuery workspace query start + InFace face -> sibsonQuery workspace query face + EmptyTriangulation -> pure (0, InterpolationStats 0 0 0 False) + OutsideConvexHull _ -> pure (0, InterpolationStats 0 0 0 False) + pure (count, locationStats, stats) + +sibsonQuery + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Point + -> FaceId + -> ST s (Int, InterpolationStats) +sibsonQuery workspace query startFace = do + generation <- nextFaceGeneration workspace + (cavityCount, faceTests) <- discoverCavity workspace generation query startFace + boundaryCount <- collectBoundary workspace generation cavityCount + orderedCount <- orderBoundary workspace boundaryCount + if orderedCount < 3 + then fallbackBarycentric workspace query startFace faceTests cavityCount + else do + cellOkay <- buildInsertionCell workspace query orderedCount + if not cellOkay + then fallbackBarycentric workspace query startFace faceTests cavityCount + else do + weightCount <- buildStolenAreas workspace generation query orderedCount + normalized <- normalizeWeights workspace weightCount + if normalized + then pure (weightCount, InterpolationStats cavityCount weightCount faceTests False) + else fallbackBarycentric workspace query startFace faceTests cavityCount + +-- The query cavity is exactly the set of faces whose circumcircles contain the +-- inserted point. Generation marks make clearing O(1). +discoverCavity + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Point + -> FaceId + -> ST s (Int, Int) +discoverCavity workspace generation query (FaceId rawStart) = do + MUV.unsafeWrite (nnFaceSeenMarks workspace) (fromIntegral rawStart) generation + MUV.unsafeWrite (nnFaceQueue workspace) 0 rawStart + go 1 0 0 + where + !triangulation = nnTriangulation workspace + go !queueSize !cavitySize !tests + | queueSize <= 0 = pure (cavitySize, tests) + | otherwise = do + let !slot = queueSize - 1 + rawFace <- MUV.unsafeRead (nnFaceQueue workspace) slot + let !face = FaceId rawFace + !inside = containsQuery triangulation query face + !tests' = tests + 1 + if not inside + then go slot cavitySize tests' + else do + MUV.unsafeWrite (nnFaceMarks workspace) (fromIntegral rawFace) generation + MUV.unsafeWrite (nnCavityFaces workspace) cavitySize rawFace + nextQueue <- pushNeighbors triangulation workspace generation slot face + go nextQueue (cavitySize + 1) tests' + +containsQuery + :: Triangulation mode vertex directed undirected face + -> Point + -> FaceId + -> Bool +containsQuery triangulation query face = + case innerFaceVertices triangulation face of + Nothing -> False + Just (a, b, c) -> + -- Strictly inside, matching spade's contained_in_circumference: an + -- exactly cocircular face is NOT part of the cavity, so its opposite + -- vertex is not a natural neighbour. A '/= LT' reading would include + -- such a vertex with a zero stolen area and diverge from spade's + -- neighbour set on cocircular queries. + inCircle + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + query + == GT + +pushNeighbors + :: Triangulation mode vertex directed undirected face + -> NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Int + -> FaceId + -> ST s Int +pushNeighbors triangulation workspace generation start face = + case innerFaceDirectedEdges triangulation face of + Nothing -> pure start + Just (e0, e1, e2) -> do + size1 <- pushOne start e0 + size2 <- pushOne size1 e1 + pushOne size2 e2 + where + pushOne !size edge = + let !adjacent@(FaceId raw) = incidentFace triangulation (reverseEdge edge) + !index = fromIntegral raw + in if adjacent == outerFace + then pure size + else do + seen <- MUV.unsafeRead (nnFaceSeenMarks workspace) index + if seen == generation + then pure size + else do + MUV.unsafeWrite (nnFaceSeenMarks workspace) index generation + MUV.unsafeWrite (nnFaceQueue workspace) size raw + pure (size + 1) + +collectBoundary + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Int + -> ST s Int +collectBoundary workspace generation cavityCount = goFaces 0 0 + where + !triangulation = nnTriangulation workspace + goFaces !index !boundarySize + | index >= cavityCount = pure boundarySize + | otherwise = do + rawFace <- MUV.unsafeRead (nnCavityFaces workspace) index + nextSize <- case innerFaceDirectedEdges triangulation (FaceId rawFace) of + Nothing -> pure boundarySize + Just (e0, e1, e2) -> do + size1 <- appendIfBoundary boundarySize e0 + size2 <- appendIfBoundary size1 e1 + appendIfBoundary size2 e2 + goFaces (index + 1) nextSize + appendIfBoundary !size edge = do + let adjacent@(FaceId rawAdjacent) = incidentFace triangulation (reverseEdge edge) + outside <- if adjacent == outerFace + then pure True + else (/= generation) <$> MUV.unsafeRead (nnFaceMarks workspace) (fromIntegral rawAdjacent) + if outside + then case edge of + DirectedEdgeId raw -> MUV.unsafeWrite (nnBoundaryEdges workspace) size raw >> pure (size + 1) + else pure size + +orderBoundary + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Int + -> ST s Int +orderBoundary _ 0 = pure 0 +orderBoundary workspace count = do + generation <- nextOriginGeneration workspace + install generation 0 + firstRaw <- MUV.unsafeRead (nnBoundaryEdges workspace) 0 + follow generation firstRaw firstRaw 0 + where + !triangulation = nnTriangulation workspace + install !generation !index + | index >= count = pure () + | otherwise = do + rawEdge <- MUV.unsafeRead (nnBoundaryEdges workspace) index + let !from = vertexIndex (origin triangulation (DirectedEdgeId rawEdge)) + MUV.unsafeWrite (nnOriginMarks workspace) from generation + MUV.unsafeWrite (nnOriginEdge workspace) from rawEdge + install generation (index + 1) + follow !generation !firstRaw !currentRaw !index + | index >= count = + if currentRaw == firstRaw then pure count else pure 0 + | otherwise = do + MUV.unsafeWrite (nnOrderedEdges workspace) index currentRaw + let !to = vertexIndex (destination triangulation (DirectedEdgeId currentRaw)) + marked <- MUV.unsafeRead (nnOriginMarks workspace) to + if marked /= generation + then pure 0 + else do + nextRaw <- MUV.unsafeRead (nnOriginEdge workspace) to + if nextRaw == firstRaw && index + 1 == count + then pure count + else if nextRaw == firstRaw + then pure 0 + else follow generation firstRaw nextRaw (index + 1) + +buildInsertionCell + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Point + -> Int + -> ST s Bool +buildInsertionCell workspace query count = go 0 + where + !triangulation = nnTriangulation workspace + go !index + | index >= count = pure True + | otherwise = do + rawEdge <- MUV.unsafeRead (nnOrderedEdges workspace) index + let !edge = DirectedEdgeId rawEdge + !from = vertexPoint triangulation (origin triangulation edge) + !to = vertexPoint triangulation (destination triangulation edge) + case circumcenter (subtractPoint to query) (subtractPoint from query) (Point 0 0) of + Nothing -> pure False + Just (Point x y) + | isFinite x && isFinite y -> do + MUV.unsafeWrite (nnInsertionX workspace) index x + MUV.unsafeWrite (nnInsertionY workspace) index y + go (index + 1) + | otherwise -> pure False + +buildStolenAreas + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Point + -> Int + -> ST s Int +buildStolenAreas workspace generation query count = do + lastRaw <- MUV.unsafeRead (nnOrderedEdges workspace) (count - 1) + lastX <- MUV.unsafeRead (nnInsertionX workspace) (count - 1) + lastY <- MUV.unsafeRead (nnInsertionY workspace) (count - 1) + go 0 (DirectedEdgeId lastRaw) (Point lastX lastY) + where + !triangulation = nnTriangulation workspace + go !index !lastEdge !lastPoint + | index >= count = pure count + | otherwise = do + rawStop <- MUV.unsafeRead (nnOrderedEdges workspace) index + firstX <- MUV.unsafeRead (nnInsertionX workspace) index + firstY <- MUV.unsafeRead (nnInsertionY workspace) index + let !stopEdge = DirectedEdgeId rawStop + !first = Point firstX firstY + area <- stolenArea workspace generation query stopEdge first lastEdge lastPoint + case area of + Nothing -> pure 0 + Just polygonArea -> do + writeWeight workspace index (origin triangulation stopEdge) polygonArea + go (index + 1) stopEdge first + +stolenArea + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Point + -> DirectedEdgeId + -> Point + -> DirectedEdgeId + -> Point + -> ST s (Maybe Double) +stolenArea workspace generation query stopEdge first initialEdge initialPoint = + walk initialEdge initialPoint initialPositive initialNegative 0 + where + !triangulation = nnTriangulation workspace + -- The boundary loop runs counterclockwise around the cavity, so the fan + -- walk around each boundary vertex necessarily runs clockwise: the + -- shoelace sequence first, lastPoint, circumcenters... is the clockwise + -- traversal of the stolen polygon, and positive - negative is the + -- NEGATED twice-area. The result is negated here so the returned value is + -- the positive twice-area 'normalizeWeights' requires. (spade's identical + -- walk leaves the sum negative and cancels the sign in its total; its + -- "ordered ccw" comment is wrong.) + !initialPositive = pointX first * pointY initialPoint + !initialNegative = pointY first * pointX initialPoint + !target = reverseEdge stopEdge + !limit = numDirectedEdges triangulation + 1 + walk !lastEdge !lastPoint !positive !negative !steps + | steps >= limit = pure Nothing + | face == outerFace = pure Nothing + | otherwise = do + center <- cachedFaceCircumcenter workspace generation query face + case center of + Nothing -> pure Nothing + Just current -> + let !positive' = positive + pointX lastPoint * pointY current + !negative' = negative + pointY lastPoint * pointX current + !nextEdge = reverseEdge (next triangulation lastEdge) + in if nextEdge == target + then + let !closedPositive = positive' + pointX current * pointY first + !closedNegative = negative' + pointY current * pointX first + in pure (Just (closedNegative - closedPositive)) + else walk nextEdge current positive' negative' (steps + 1) + where + face = incidentFace triangulation lastEdge + +-- Each fan turns around the vertex two consecutive boundary edges share, so a +-- cavity face is walked once per vertex it has on the boundary loop: twice for +-- two, three times for a face whose whole triangle is on the loop, which is +-- every face of a single-face cavity. Without this plane each of those visits +-- pays two divisions and a dozen multiply-adds for a value already in hand. +-- +-- The cached value is the one 'faceCircumcenterRelative' returned, stored as +-- its own coordinates and handed back unchanged; nothing is recomputed from a +-- rearrangement, so a hit and a miss are the same bits. Soundness needs only +-- that the query point cannot change while an entry is readable, which the +-- generation supplies: it is minted once per Sibson query and every stamp from +-- an earlier query is strictly smaller. +-- +-- A 'Nothing' is not recorded. It cannot repeat: the first one aborts this +-- fan, and 'buildStolenAreas' abandons the query on the spot. +cachedFaceCircumcenter + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Word32 + -> Point + -> FaceId + -> ST s (Maybe (Point)) +cachedFaceCircumcenter workspace generation query face@(FaceId rawFace) = do + stamp <- MUV.unsafeRead (nnCircumcenterMarks workspace) slot + if stamp == generation + then do + x <- MUV.unsafeRead (nnCircumcenterX workspace) slot + y <- MUV.unsafeRead (nnCircumcenterY workspace) slot + pure (Just (Point x y)) + else case faceCircumcenterRelative (nnTriangulation workspace) query face of + Nothing -> pure Nothing + Just center@(Point x y) -> do + MUV.unsafeWrite (nnCircumcenterX workspace) slot x + MUV.unsafeWrite (nnCircumcenterY workspace) slot y + MUV.unsafeWrite (nnCircumcenterMarks workspace) slot generation + pure (Just center) + where + !slot = fromIntegral rawFace + +faceCircumcenterRelative + :: Triangulation mode vertex directed undirected face + -> Point + -> FaceId + -> Maybe (Point) +faceCircumcenterRelative triangulation query face = do + (a, b, c) <- innerFaceVertices triangulation face + center <- circumcenter + (subtractPoint (vertexPoint triangulation a) query) + (subtractPoint (vertexPoint triangulation b) query) + (subtractPoint (vertexPoint triangulation c) query) + if finitePoint center then Just center else Nothing + +normalizeWeights + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Int + -> ST s Bool +normalizeWeights _ 0 = pure False +normalizeWeights workspace count = do + (!total, !minimumWeight, !finite) <- firstPass 0 0 0 True + let !tolerance = max 1.0e-12 (128 * scalarEpsilon) + if not finite || total == 0 || minimumWeight < negate tolerance + then pure False + else do + clampedTotal <- clampPass 0 0 + if clampedTotal <= 0 || not (isFinite clampedTotal) + then pure False + else normalizePass 0 clampedTotal >> pure True + where + firstPass !index !total !minimumWeight !finite + | index >= count = pure (total, minimumWeight, finite) + | otherwise = do + weight <- MUV.unsafeRead (nnWeightValue workspace) index + let !minimumWeight' = if index == 0 then weight else min minimumWeight weight + firstPass (index + 1) (total + weight) minimumWeight' (finite && isFinite weight) + clampPass !index !total + | index >= count = pure total + | otherwise = do + weight <- MUV.unsafeRead (nnWeightValue workspace) index + let !clamped = max 0 weight + MUV.unsafeWrite (nnWeightValue workspace) index clamped + clampPass (index + 1) (total + clamped) + normalizePass !index !total + | index >= count = pure () + | otherwise = do + weight <- MUV.unsafeRead (nnWeightValue workspace) index + MUV.unsafeWrite (nnWeightValue workspace) index (weight / total) + normalizePass (index + 1) total + +fallbackBarycentric + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Point + -> FaceId + -> Int + -> Int + -> ST s (Int, InterpolationStats) +fallbackBarycentric workspace query face faceTests cavityCount = + case innerFaceVertices triangulation face of + Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True) + Just (a, b, c) -> + case barycentricCoordinates + (vertexPoint triangulation a) + (vertexPoint triangulation b) + (vertexPoint triangulation c) + query of + Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True) + Just (wa, wb, wc) -> do + writeWeight workspace 0 a wa + writeWeight workspace 1 b wb + writeWeight workspace 2 c wc + pure (3, InterpolationStats cavityCount 3 faceTests True) + where + triangulation = nnTriangulation workspace + +writeWeight + :: NaturalNeighborWorkspace s mode vertex directed undirected face + -> Int + -> VertexId + -> Double + -> ST s () +writeWeight workspace index (VertexId vertex) weight = do + MUV.unsafeWrite (nnWeightVertex workspace) index vertex + MUV.unsafeWrite (nnWeightValue workspace) index weight + +-- | Sample the nearest vertex, or return 'Nothing' for an empty mesh. +interpolateNearest + :: (VertexId -> value) + -> Triangulation mode vertex directed undirected face + -> Maybe VertexId + -> QueryPoint + -> Maybe value +interpolateNearest sample triangulation hint query = sample . fst <$> nearestNeighbor triangulation hint query + +-- | Interpolate scalar vertex samples in the cell containing the query. +interpolateBarycentric + :: (VertexId -> Double) + -> Triangulation mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> Maybe Double +interpolateBarycentric sample triangulation hint query = + case fst (barycentricWeights triangulation hint query) of + NoWeights -> Nothing + OneWeight vertex -> Just (sample vertex) + TwoWeights a wa b wb -> Just (wa * sample a + wb * sample b) + ThreeWeights a wa b wb c wc -> Just (wa * sample a + wb * sample b + wc * sample c) + +interpolateNaturalNeighbor + :: (VertexId -> Double) + -> NaturalNeighborWorkspace s mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> ST s (Maybe Double, InterpolationStats) +interpolateNaturalNeighbor sample workspace hint query = do + (total, _, stats) <- + foldNaturalNeighborWeights + (\accumulator vertex weight -> accumulator + weight * sample vertex) + 0 + workspace + hint + query + pure (if interpolationNaturalNeighbors stats == 0 then Nothing else Just total, stats) + +estimateGradient + :: (VertexId -> Double) + -> Triangulation mode vertex directed undirected face + -> VertexId + -> (Double, Double) +estimateGradient sample triangulation vertex = + case vertexOutEdge triangulation vertex of + Nothing -> (0, 0) + Just start -> + let !nextEdge = counterClockwise triangulation start + in if nextEdge == start + then (0, 0) + else + let (!nx, !ny, !nz) = walk start start 0 0 0 0 + in if nz /= 0 && isFinite nz then (-nx / nz, -ny / nz) else (0, 0) + where + Point vx vy = vertexPoint triangulation vertex + !vz = sample vertex + !bound = numDirectedEdges triangulation + 1 + + walk !start !current !steps !sumX !sumY !sumZ + | steps >= bound = (sumX, sumY, sumZ) + | otherwise = + let !nextEdge = counterClockwise triangulation current + !leftVertex = destination triangulation current + !rightVertex = destination triangulation nextEdge + (!nextX, !nextY, !nextZ) = accumulate sumX sumY sumZ leftVertex rightVertex + in if nextEdge == start + then (nextX, nextY, nextZ) + else walk start nextEdge (steps + 1) nextX nextY nextZ + + accumulate !sumX !sumY !sumZ leftVertex rightVertex = + let Point lx ly = vertexPoint triangulation leftVertex + Point rx ry = vertexPoint triangulation rightVertex + !lz = sample leftVertex + !rz = sample rightVertex + !d0x = lx - vx + !d0y = ly - vy + !d0z = lz - vz + !d1x = rx - vx + !d1y = ry - vy + !d1z = rz - vz + !normalX = d0y * d1z - d0z * d1y + !normalY = d0z * d1x - d0x * d1z + !normalZ = d0x * d1y - d0y * d1x + in if normalZ > 0 + then (sumX + normalX, sumY + normalY, sumZ + normalZ) + else (sumX, sumY, sumZ) + +estimateGradients + :: (VertexId -> Double) + -> Triangulation mode vertex directed undirected face + -> V.Vector (Double, Double) +estimateGradients sample triangulation = + V.generate (numVertices triangulation) $ \index -> + estimateGradient sample triangulation (VertexId (fromIntegral index)) + +interpolateNaturalNeighborGradient + :: (VertexId -> Double) + -> (VertexId -> (Double, Double)) + -> Double + -> NaturalNeighborWorkspace s mode vertex directed undirected face + -> Maybe LocationHint + -> QueryPoint + -> ST s (Maybe Double, InterpolationStats) +interpolateNaturalNeighborGradient sample gradient flatness workspace hint queryPoint + | flatness < 0 || not (isFinite flatness) = pure (Nothing, InterpolationStats 0 0 0 False) + | otherwise = do + (!count, _, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint + if count == 0 + then pure (Nothing, stats) + else do + accumulation <- accumulate 0 count Nothing (0, 0, 0, 0, 0) + pure (finish accumulation, stats) + where + !query = queryPointValue queryPoint + !triangulation = nnTriangulation workspace + + -- 'flatness' is 0.5 or 1 in practice and @**@ is an exp/log pair per natural + -- neighbour per query, so both are answered directly. The two shortcuts do + -- not stand on the same ground. + -- + -- The identity is exact. @x@ raised to 1 is @x@, which is already a float, + -- and rounding an exactly representable result admits only that result, so + -- any implementation faithful to within an ulp returns it. + -- + -- The square root is not exact and does not need to be. IEEE-754 mandates a + -- correctly rounded 'sqrt'; @pow@ is a recommended operation carrying no such + -- requirement. Where the two disagree it is therefore in the last ulp, and it + -- is 'sqrt' that holds the correctly rounded answer — this substitution can + -- only move the result toward it. Against this platform's libm they in fact + -- agree on every non-negative binary32 and on every non-negative binary64 + -- sampled, which is a measurement and not a proof. + -- + -- They part company at negative zero, where @pow@ answers @+0@ and 'sqrt' + -- answers @-0@. A sum of two squares is never negative zero, and were it one + -- the sole consumer below tests @== 0@, which both zeroes satisfy alike. + raiseToFlatness squared + | flatness == 0.5 = sqrt squared + | flatness == 1 = squared + | otherwise = squared ** flatness + + accumulate !index !count !exact !totals + | index >= count = pure (exact, totals) + | otherwise = do + rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index + weight <- MUV.unsafeRead (nnWeightValue workspace) index + let !vertex = VertexId rawVertex + !point = vertexPoint triangulation vertex + !exact' = + case exact of + Just _ -> exact + Nothing + | query == point -> Just (sample vertex) + | otherwise -> Nothing + !totals' = contribution totals vertex weight + accumulate (index + 1) count exact' totals' + + finish + :: (Maybe Double, (Double, Double, Double, Double, Double)) + -> Maybe Double + finish (Just value, _) = Just value + finish (Nothing, (!sumC0, !sumC1, !sumC1Weights, !alphaNumerator, !beta)) + | sumC1Weights == 0 = Just sumC0 + | otherwise = + let !alpha = alphaNumerator / sumC1Weights + !c1 = sumC1 / sumC1Weights + !denominator = alpha + beta + in if denominator == 0 || not (isFinite denominator) + then Just sumC0 + else Just ((alpha * sumC0 + beta * c1) / denominator) + + contribution (!sumC0, !sumC1, !sumC1Weights, !alpha, !beta) vertex weight = + let Point qx qy = query + Point vx vy = vertexPoint triangulation vertex + !dx = qx - vx + !dy = qy - vy + !radiusSquared = dx * dx + dy * dy + !radiusPower = raiseToFlatness radiusSquared + !c1Weight = if radiusPower == 0 then 0 else weight / radiusPower + (!gx, !gy) = gradient vertex + !height = sample vertex + !zeta = height + dx * gx + dy * gy + in ( sumC0 + height * weight + , sumC1 + zeta * c1Weight + , sumC1Weights + c1Weight + , alpha + c1Weight * radiusSquared + , beta + weight * radiusSquared + ) + +vertexIndex :: VertexId -> Int +vertexIndex (VertexId raw) = fromIntegral raw +{-# INLINE vertexIndex #-} + +subtractPoint :: Point -> Point -> Point +subtractPoint (Point ax ay) (Point bx by) = Point (ax - bx) (ay - by) +{-# INLINE subtractPoint #-} + +finitePoint :: Point -> Bool +finitePoint (Point x y) = isFinite x && isFinite y +{-# INLINE finitePoint #-} + +clamp :: Ord value => value -> value -> value -> value +clamp low high = max low . min high +{-# INLINE clamp #-} diff --git a/src-dual/Moonlight/Triangulation/Voronoi.hs b/src-dual/Moonlight/Triangulation/Voronoi.hs new file mode 100644 --- /dev/null +++ b/src-dual/Moonlight/Triangulation/Voronoi.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | The Voronoi dual, addressed by its own handle family: every cell, edge and +-- vertex is a view of the Delaunay mesh rather than a second structure. +module Moonlight.Triangulation.Voronoi + ( VoronoiFaceId (..) + , DirectedVoronoiEdgeId (..) + , UndirectedVoronoiEdgeId (..) + , VoronoiVertexId (..) + , VoronoiEdgeGeometry (..) + , voronoiFaces + , directedVoronoiEdges + , undirectedVoronoiEdges + , asDelaunayDirectedEdge + , asDelaunayUndirectedEdge + , asDirectedVoronoiEdge + , asUndirectedVoronoiEdge + , reverseVoronoiEdge + , voronoiNext + , voronoiPrevious + , voronoiFrom + , voronoiTo + , voronoiIncidentFace + , voronoiFaceSite + , voronoiFaceAdjacentEdges + , voronoiVertexPosition + , voronoiVertexOutgoingEdges + , voronoiDirectionVector + , voronoiEdgeGeometry + , faceCircumcenter + ) where + +import Control.DeepSeq (NFData) +import Moonlight.Triangulation.Dcel +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (directedEdges, undirectedEdges, vertices) +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Types + +-- The dual uses the exact same fixed-index space as the primal DCEL. These +-- newtypes add semantic separation without allocating or owning any dual mesh. +newtype VoronoiFaceId = VoronoiFaceId { unVoronoiFaceId :: VertexId } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +newtype DirectedVoronoiEdgeId = DirectedVoronoiEdgeId { unDirectedVoronoiEdgeId :: DirectedEdgeId } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +newtype UndirectedVoronoiEdgeId = UndirectedVoronoiEdgeId { unUndirectedVoronoiEdgeId :: UndirectedEdgeId } + deriving stock (Show) + deriving newtype (Eq, Ord, NFData) + +data VoronoiVertexId + = InnerVoronoiVertex !FaceId + | OuterVoronoiVertex !DirectedVoronoiEdgeId + deriving stock (Eq, Ord, Show) + +data VoronoiEdgeGeometry + = VoronoiSegment !(Point) !(Point) + | VoronoiRay !(Point) !(Point) + | VoronoiLine !(Point) !(Point) + deriving stock (Eq, Ord, Show) + +voronoiFaces :: Triangulation mode vertex directed undirected face -> [VoronoiFaceId] +voronoiFaces triangulation = map VoronoiFaceId (vertices triangulation) +{-# INLINE voronoiFaces #-} + +-- Every primal directed edge is one directed edge in the dual. Boundary +-- handles naturally represent half-infinite edges through OuterVoronoiVertex. +directedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [DirectedVoronoiEdgeId] +directedVoronoiEdges triangulation = map DirectedVoronoiEdgeId (directedEdges triangulation) +{-# INLINE directedVoronoiEdges #-} + +undirectedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [UndirectedVoronoiEdgeId] +undirectedVoronoiEdges triangulation = map UndirectedVoronoiEdgeId (undirectedEdges triangulation) +{-# INLINE undirectedVoronoiEdges #-} + +asDelaunayDirectedEdge :: DirectedVoronoiEdgeId -> DirectedEdgeId +asDelaunayDirectedEdge = unDirectedVoronoiEdgeId +{-# INLINE asDelaunayDirectedEdge #-} + +asDelaunayUndirectedEdge :: UndirectedVoronoiEdgeId -> UndirectedEdgeId +asDelaunayUndirectedEdge = unUndirectedVoronoiEdgeId +{-# INLINE asDelaunayUndirectedEdge #-} + +asDirectedVoronoiEdge :: DirectedEdgeId -> DirectedVoronoiEdgeId +asDirectedVoronoiEdge = DirectedVoronoiEdgeId +{-# INLINE asDirectedVoronoiEdge #-} + +asUndirectedVoronoiEdge :: UndirectedEdgeId -> UndirectedVoronoiEdgeId +asUndirectedVoronoiEdge = UndirectedVoronoiEdgeId +{-# INLINE asUndirectedVoronoiEdge #-} + +reverseVoronoiEdge :: DirectedVoronoiEdgeId -> DirectedVoronoiEdgeId +reverseVoronoiEdge (DirectedVoronoiEdgeId edge) = DirectedVoronoiEdgeId (reverseEdge edge) +{-# INLINE reverseVoronoiEdge #-} + +-- Dual next/previous rotate around the primal origin site. +voronoiNext + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> DirectedVoronoiEdgeId +voronoiNext triangulation (DirectedVoronoiEdgeId edge) = + DirectedVoronoiEdgeId (counterClockwise triangulation edge) +{-# INLINE voronoiNext #-} + +voronoiPrevious + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> DirectedVoronoiEdgeId +voronoiPrevious triangulation (DirectedVoronoiEdgeId edge) = + DirectedVoronoiEdgeId (clockwise triangulation edge) +{-# INLINE voronoiPrevious #-} + +voronoiFrom + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> VoronoiVertexId +voronoiFrom triangulation edge@(DirectedVoronoiEdgeId primal) + | face == outerFace = OuterVoronoiVertex edge + | otherwise = InnerVoronoiVertex face + where + face = incidentFace triangulation primal +{-# INLINE voronoiFrom #-} + +voronoiTo + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> VoronoiVertexId +voronoiTo triangulation = voronoiFrom triangulation . reverseVoronoiEdge +{-# INLINE voronoiTo #-} + +voronoiIncidentFace + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> VoronoiFaceId +voronoiIncidentFace triangulation (DirectedVoronoiEdgeId edge) = + VoronoiFaceId (origin triangulation edge) +{-# INLINE voronoiIncidentFace #-} + +voronoiFaceSite :: VoronoiFaceId -> VertexId +voronoiFaceSite = unVoronoiFaceId +{-# INLINE voronoiFaceSite #-} + +voronoiFaceAdjacentEdges + :: Triangulation mode vertex directed undirected face + -> VoronoiFaceId + -> [DirectedVoronoiEdgeId] +voronoiFaceAdjacentEdges triangulation (VoronoiFaceId site) = + map DirectedVoronoiEdgeId (vertexOutgoingEdges triangulation site) +{-# INLINE voronoiFaceAdjacentEdges #-} + +-- A caller reaches this through 'voronoiFrom' or 'voronoiTo', which build the +-- endpoint sum immediately before it is taken apart again. Only an unfolding at +-- the consumer lets the two meet, so the constructor never reaches the heap. +voronoiVertexPosition + :: Triangulation mode vertex directed undirected face + -> VoronoiVertexId + -> Maybe (Point) +voronoiVertexPosition triangulation vertex = case vertex of + InnerVoronoiVertex face -> faceCircumcenter triangulation face + OuterVoronoiVertex _ -> Nothing +{-# INLINE voronoiVertexPosition #-} + +voronoiVertexOutgoingEdges + :: Triangulation mode vertex directed undirected face + -> VoronoiVertexId + -> Maybe [DirectedVoronoiEdgeId] +voronoiVertexOutgoingEdges triangulation vertex = case vertex of + OuterVoronoiVertex _ -> Nothing + InnerVoronoiVertex face -> + map DirectedVoronoiEdgeId . faceDirectedEdges triangulation <$> nonOuter face + where + nonOuter face + | face == outerFace = Nothing + | otherwise = Just face +{-# INLINE voronoiVertexOutgoingEdges #-} + +voronoiDirectionVector + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> Point +voronoiDirectionVector triangulation (DirectedVoronoiEdgeId edge) = + case vertexPoint triangulation (origin triangulation edge) of + Point ax ay -> case vertexPoint triangulation (destination triangulation edge) of + Point bx by -> Point (ay - by) (bx - ax) + +-- The circumcentre stands on the absolute vertex positions, which is a +-- different value from the query-relative one the Sibson pipeline caches: that +-- one rescales the differences it was handed, so translating the inputs moves +-- the rounding and the two do not differ by the translation. The interpolation +-- workspace's plane therefore cannot serve this function, and the repetition +-- here is across calls rather than within one — a sweep recomputes each face +-- once per incident dual edge, while a single call touches two distinct faces. +-- That threefold repetition is what a dual which is a view rather than a +-- structure costs, and the referent pays it identically, so no cache is owed. +faceCircumcenter + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Maybe (Point) +faceCircumcenter triangulation face + | face == outerFace = Nothing + | otherwise = case adjacentEdge triangulation face of + Nothing -> Nothing + Just e0 -> + let !e1 = next triangulation e0 + !e2 = next triangulation e1 + in if next triangulation e2 /= e0 + then Nothing + else + circumcenter + (vertexPoint triangulation (origin triangulation e0)) + (vertexPoint triangulation (origin triangulation e1)) + (vertexPoint triangulation (origin triangulation e2)) +{-# INLINE faceCircumcenter #-} + +-- The endpoint classification 'voronoiFrom' and 'voronoiTo' publish is two face +-- reads and two comparisons; taken through those observations it is also two +-- sum values built and immediately scrutinized. The geometry reads the faces +-- itself so that the classification stays in registers. +voronoiEdgeGeometry + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> Maybe (VoronoiEdgeGeometry) +voronoiEdgeGeometry triangulation edge@(DirectedVoronoiEdgeId primal) + | innerFrom, innerTo = + VoronoiSegment <$> faceCircumcenter triangulation fromFace <*> faceCircumcenter triangulation toFace + | innerFrom = do + start <- faceCircumcenter triangulation fromFace + pure (VoronoiRay start (normalize (voronoiDirectionVector triangulation edge))) + | innerTo = do + end <- faceCircumcenter triangulation toFace + pure (VoronoiRay end (normalize (negatePoint (voronoiDirectionVector triangulation edge)))) + | otherwise = + let !center = midpoint + (vertexPoint triangulation (origin triangulation primal)) + (vertexPoint triangulation (destination triangulation primal)) + in Just (VoronoiLine center (normalize (voronoiDirectionVector triangulation edge))) + where + !fromFace = incidentFace triangulation primal + !toFace = incidentFace triangulation (reverseEdge primal) + !innerFrom = fromFace /= outerFace + !innerTo = toFace /= outerFace + +normalize :: Point -> Point +normalize (Point x y) + | scale == 0 = Point 0 0 + | otherwise = + let !scaledX = x / scale + !scaledY = y / scale + !length' = sqrt (scaledX * scaledX + scaledY * scaledY) + in Point (scaledX / length') (scaledY / length') + where + !scale = max (abs x) (abs y) + +negatePoint :: Point -> Point +negatePoint (Point x y) = Point (-x) (-y) + +{-# INLINE normalize #-} +{-# INLINE negatePoint #-} diff --git a/src-dual/Moonlight/Triangulation/Voronoi/Handles.hs b/src-dual/Moonlight/Triangulation/Voronoi/Handles.hs new file mode 100644 --- /dev/null +++ b/src-dual/Moonlight/Triangulation/Voronoi/Handles.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +module Moonlight.Triangulation.Voronoi.Handles + ( VoronoiFaceHandle + , DirectedVoronoiEdgeHandle + , UndirectedVoronoiEdgeHandle + , VoronoiVertexHandle + , voronoiFaceHandle + , directedVoronoiEdgeHandle + , undirectedVoronoiEdgeHandle + , vertexAsVoronoiFaceH + , directedEdgeAsVoronoiH + , undirectedEdgeAsVoronoiH + , innerFaceAsVoronoiVertexH + , fixVoronoiFace + , fixDirectedVoronoiEdge + , fixUndirectedVoronoiEdge + , fixVoronoiVertex + , voronoiEdgeReverseH + , voronoiEdgeNextH + , voronoiEdgePreviousH + , voronoiEdgeFromH + , voronoiEdgeToH + , voronoiEdgeFaceH + , voronoiEdgeAsUndirectedH + , voronoiEdgeAsDelaunayH + , voronoiFaceSiteH + , voronoiFaceAdjacentEdgesH + , voronoiVertexPositionH + , voronoiVertexOutEdgesH + , voronoiVertexAsDelaunayFaceH + , voronoiVertexAsOuterEdgeH + , voronoiEdgeDirectionH + , voronoiEdgeGeometryH + ) where + +import Moonlight.Triangulation.Handles.Dynamic +import Moonlight.Triangulation.Math (midpoint) +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Voronoi + +-- | Zero-copy dual handles. Each dual value contains exactly one primal handle, +-- so it cannot accidentally combine an identifier from one triangulation with +-- the storage of another. +newtype VoronoiFaceHandle mode vertex directed undirected face = + VoronoiFaceHandle (VertexHandle mode vertex directed undirected face) + +newtype DirectedVoronoiEdgeHandle mode vertex directed undirected face = + DirectedVoronoiEdgeHandle (DirectedEdgeHandle mode vertex directed undirected face) + +newtype UndirectedVoronoiEdgeHandle mode vertex directed undirected face = + UndirectedVoronoiEdgeHandle (UndirectedEdgeHandle mode vertex directed undirected face) + +data VoronoiVertexHandle mode vertex directed undirected face + = InnerVoronoiVertexHandle + !(FaceHandle InnerTag mode vertex directed undirected face) + | OuterVoronoiVertexHandle + !(DirectedVoronoiEdgeHandle mode vertex directed undirected face) + +instance Show (VoronoiFaceHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixVoronoiFace + +instance Show (DirectedVoronoiEdgeHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixDirectedVoronoiEdge + +instance Show (UndirectedVoronoiEdgeHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixUndirectedVoronoiEdge + +instance Show (VoronoiVertexHandle mode vertex directed undirected face) where + showsPrec precedence = showsPrec precedence . fixVoronoiVertex + +voronoiFaceHandle + :: Triangulation mode vertex directed undirected face + -> VoronoiFaceId + -> Maybe (VoronoiFaceHandle mode vertex directed undirected face) +voronoiFaceHandle triangulation (VoronoiFaceId site) = + VoronoiFaceHandle <$> vertexHandle triangulation site + +vertexAsVoronoiFaceH + :: VertexHandle mode vertex directed undirected face + -> VoronoiFaceHandle mode vertex directed undirected face +vertexAsVoronoiFaceH = VoronoiFaceHandle + +directedVoronoiEdgeHandle + :: Triangulation mode vertex directed undirected face + -> DirectedVoronoiEdgeId + -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face) +directedVoronoiEdgeHandle triangulation (DirectedVoronoiEdgeId edge) = + DirectedVoronoiEdgeHandle <$> directedEdgeHandle triangulation edge + +directedEdgeAsVoronoiH + :: DirectedEdgeHandle mode vertex directed undirected face + -> DirectedVoronoiEdgeHandle mode vertex directed undirected face +directedEdgeAsVoronoiH = DirectedVoronoiEdgeHandle + +undirectedVoronoiEdgeHandle + :: Triangulation mode vertex directed undirected face + -> UndirectedVoronoiEdgeId + -> Maybe (UndirectedVoronoiEdgeHandle mode vertex directed undirected face) +undirectedVoronoiEdgeHandle triangulation (UndirectedVoronoiEdgeId edge) = + UndirectedVoronoiEdgeHandle <$> undirectedEdgeHandle triangulation edge + +undirectedEdgeAsVoronoiH + :: UndirectedEdgeHandle mode vertex directed undirected face + -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face +undirectedEdgeAsVoronoiH = UndirectedVoronoiEdgeHandle + +innerFaceAsVoronoiVertexH + :: FaceHandle InnerTag mode vertex directed undirected face + -> VoronoiVertexHandle mode vertex directed undirected face +innerFaceAsVoronoiVertexH = InnerVoronoiVertexHandle + +fixVoronoiFace :: VoronoiFaceHandle mode vertex directed undirected face -> VoronoiFaceId +fixVoronoiFace (VoronoiFaceHandle site) = VoronoiFaceId (fixVertex site) +{-# INLINE fixVoronoiFace #-} + +fixDirectedVoronoiEdge + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> DirectedVoronoiEdgeId +fixDirectedVoronoiEdge (DirectedVoronoiEdgeHandle edge) = + DirectedVoronoiEdgeId (fixDirectedEdge edge) +{-# INLINE fixDirectedVoronoiEdge #-} + +fixUndirectedVoronoiEdge + :: UndirectedVoronoiEdgeHandle mode vertex directed undirected face + -> UndirectedVoronoiEdgeId +fixUndirectedVoronoiEdge (UndirectedVoronoiEdgeHandle edge) = + UndirectedVoronoiEdgeId (fixUndirectedEdge edge) +{-# INLINE fixUndirectedVoronoiEdge #-} + +fixVoronoiVertex + :: VoronoiVertexHandle mode vertex directed undirected face + -> VoronoiVertexId +fixVoronoiVertex (InnerVoronoiVertexHandle face) = + InnerVoronoiVertex (fixedFaceId (fixFace face)) +fixVoronoiVertex (OuterVoronoiVertexHandle edge) = + OuterVoronoiVertex (fixDirectedVoronoiEdge edge) +{-# INLINE fixVoronoiVertex #-} + +voronoiEdgeReverseH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> DirectedVoronoiEdgeHandle mode vertex directed undirected face +voronoiEdgeReverseH (DirectedVoronoiEdgeHandle edge) = + DirectedVoronoiEdgeHandle (directedEdgeReverse edge) + +voronoiEdgeNextH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> DirectedVoronoiEdgeHandle mode vertex directed undirected face +voronoiEdgeNextH (DirectedVoronoiEdgeHandle edge) = + DirectedVoronoiEdgeHandle (directedEdgeCounterClockwise edge) + +voronoiEdgePreviousH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> DirectedVoronoiEdgeHandle mode vertex directed undirected face +voronoiEdgePreviousH (DirectedVoronoiEdgeHandle edge) = + DirectedVoronoiEdgeHandle (directedEdgeClockwise edge) + +voronoiEdgeFromH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> VoronoiVertexHandle mode vertex directed undirected face +voronoiEdgeFromH edge@(DirectedVoronoiEdgeHandle primal) = + case faceAsInner (directedEdgeFace primal) of + Just inner -> InnerVoronoiVertexHandle inner + Nothing -> OuterVoronoiVertexHandle edge + +voronoiEdgeToH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> VoronoiVertexHandle mode vertex directed undirected face +voronoiEdgeToH = voronoiEdgeFromH . voronoiEdgeReverseH + +voronoiEdgeFaceH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> VoronoiFaceHandle mode vertex directed undirected face +voronoiEdgeFaceH (DirectedVoronoiEdgeHandle edge) = + VoronoiFaceHandle (directedEdgeFrom edge) + +voronoiEdgeAsUndirectedH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face +voronoiEdgeAsUndirectedH (DirectedVoronoiEdgeHandle edge) = + UndirectedVoronoiEdgeHandle (directedEdgeAsUndirected edge) + +voronoiEdgeAsDelaunayH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> DirectedEdgeHandle mode vertex directed undirected face +voronoiEdgeAsDelaunayH (DirectedVoronoiEdgeHandle edge) = edge + +voronoiFaceSiteH + :: VoronoiFaceHandle mode vertex directed undirected face + -> VertexHandle mode vertex directed undirected face +voronoiFaceSiteH (VoronoiFaceHandle site) = site + +voronoiFaceAdjacentEdgesH + :: VoronoiFaceHandle mode vertex directed undirected face + -> [DirectedVoronoiEdgeHandle mode vertex directed undirected face] +voronoiFaceAdjacentEdgesH (VoronoiFaceHandle site) = + map DirectedVoronoiEdgeHandle (vertexHandleOutEdges site) + +voronoiVertexPositionH + :: VoronoiVertexHandle mode vertex directed undirected face + -> Maybe (Point) +voronoiVertexPositionH (InnerVoronoiVertexHandle face) = innerFaceCircumcenter face +voronoiVertexPositionH (OuterVoronoiVertexHandle _) = Nothing + +voronoiVertexOutEdgesH + :: VoronoiVertexHandle mode vertex directed undirected face + -> Maybe [DirectedVoronoiEdgeHandle mode vertex directed undirected face] +voronoiVertexOutEdgesH (InnerVoronoiVertexHandle face) = + Just (map DirectedVoronoiEdgeHandle (faceAdjacentEdges face)) +voronoiVertexOutEdgesH (OuterVoronoiVertexHandle _) = Nothing + +voronoiVertexAsDelaunayFaceH + :: VoronoiVertexHandle mode vertex directed undirected face + -> Maybe (FaceHandle InnerTag mode vertex directed undirected face) +voronoiVertexAsDelaunayFaceH (InnerVoronoiVertexHandle face) = Just face +voronoiVertexAsDelaunayFaceH (OuterVoronoiVertexHandle _) = Nothing + +voronoiVertexAsOuterEdgeH + :: VoronoiVertexHandle mode vertex directed undirected face + -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face) +voronoiVertexAsOuterEdgeH (InnerVoronoiVertexHandle _) = Nothing +voronoiVertexAsOuterEdgeH (OuterVoronoiVertexHandle edge) = Just edge + +voronoiEdgeDirectionH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> Point +voronoiEdgeDirectionH (DirectedVoronoiEdgeHandle primal) = + let (Point ax ay, Point bx by) = directedEdgePositions primal + in Point (ay - by) (bx - ax) + +voronoiEdgeGeometryH + :: DirectedVoronoiEdgeHandle mode vertex directed undirected face + -> Maybe (VoronoiEdgeGeometry) +voronoiEdgeGeometryH edge@(DirectedVoronoiEdgeHandle primal) = + case (voronoiEdgeFromH edge, voronoiEdgeToH edge) of + (InnerVoronoiVertexHandle fromFace, InnerVoronoiVertexHandle toFace) -> + VoronoiSegment <$> innerFaceCircumcenter fromFace <*> innerFaceCircumcenter toFace + (InnerVoronoiVertexHandle fromFace, OuterVoronoiVertexHandle _) -> do + start <- innerFaceCircumcenter fromFace + pure (VoronoiRay start (normalizePoint (voronoiEdgeDirectionH edge))) + (OuterVoronoiVertexHandle _, InnerVoronoiVertexHandle toFace) -> do + end <- innerFaceCircumcenter toFace + pure (VoronoiRay end (normalizePoint (negatePoint (voronoiEdgeDirectionH edge)))) + (OuterVoronoiVertexHandle _, OuterVoronoiVertexHandle _) -> + let (from, to) = directedEdgePositions primal + in Just (VoronoiLine (midpoint from to) (normalizePoint (voronoiEdgeDirectionH edge))) + +normalizePoint :: Point -> Point +normalizePoint (Point x y) + | scale == 0 = Point 0 0 + | otherwise = + let !scaledX = x / scale + !scaledY = y / scale + !length' = sqrt (scaledX * scaledX + scaledY * scaledY) + in Point (scaledX / length') (scaledY / length') + where + !scale = max (abs x) (abs y) + +negatePoint :: Point -> Point +negatePoint (Point x y) = Point (-x) (-y) + +-- The handle verbs cross the same component boundary as the fixed-index ones +-- and carry their unfoldings for the same reason. 'voronoiVertexPositionH' +-- reaches its arithmetic through 'innerFaceCircumcenter', whose own worker +-- publishes no unfolding, so it stops at that call until the dcel layer says +-- otherwise. + diff --git a/src-parallel/Moonlight/Triangulation/Parallel.hs b/src-parallel/Moonlight/Triangulation/Parallel.hs new file mode 100644 --- /dev/null +++ b/src-parallel/Moonlight/Triangulation/Parallel.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +-- | Bounded concurrent interpretation of the canonical join tournament. This +-- layer owns effects only: pairing and pair-schedule semantics remain in the +-- pure build planner. +module Moonlight.Triangulation.Parallel + ( unionsConcurrently + ) where + +import Control.Concurrent.Async (concurrently) +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Data.List.NonEmpty (NonEmpty) +import Moonlight.Triangulation.Internal.Join + ( TournamentPlan (..) + , joinNormalForm + , planTournament + ) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types (BuildError, ConstraintMode (Unconstrained)) +import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice) + +-- | Execute the same deterministic tournament as sequential @unions@, with +-- no more than the requested number of leaf computations live at once. A +-- non-positive request means one worker; requesting more workers than leaves +-- is harmless. Each child is fully evaluated before its parent becomes +-- runnable, so thunks do not smuggle unbounded work across the boundary. +unionsConcurrently + :: (JoinSemilattice annotation, NFData annotation) + => Int + -> NonEmpty (Triangulation 'Unconstrained annotation () () ()) + -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ())) +unionsConcurrently requestedWorkers operands = + executeTournamentConcurrently + (max 1 requestedWorkers) + (planTournament operands) + +executeTournamentConcurrently + :: (JoinSemilattice annotation, NFData annotation) + => Int + -> TournamentPlan (Triangulation 'Unconstrained annotation () () ()) + -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ())) +executeTournamentConcurrently workers tournament = + case tournament of + TournamentLeaf mesh -> Right <$> evaluate (force mesh) + TournamentNode left right + | workers <= 1 -> + publishUnion + =<< ((,) + <$> executeTournamentConcurrently 1 left + <*> executeTournamentConcurrently 1 right + ) + | otherwise -> do + let !leftLeaves = tournamentLeaves left + !rightLeaves = tournamentLeaves right + !available = min workers (leftLeaves + rightLeaves) + !leftWorkers = + max 1 (min leftLeaves (available * leftLeaves `quot` (leftLeaves + rightLeaves))) + !rightWorkers = max 1 (available - leftWorkers) + concurrently + (executeTournamentConcurrently leftWorkers left) + (executeTournamentConcurrently rightWorkers right) + >>= publishUnion + +publishUnion + :: (JoinSemilattice annotation, NFData annotation) + => ( Either BuildError (Triangulation 'Unconstrained annotation () () ()) + , Either BuildError (Triangulation 'Unconstrained annotation () () ()) + ) + -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ())) +publishUnion (Left failure, _) = pure (Left failure) +publishUnion (Right _, Left failure) = pure (Left failure) +publishUnion (Right leftMesh, Right rightMesh) = + evaluate (force (joinNormalForm leftMesh rightMesh)) + +tournamentLeaves :: TournamentPlan mesh -> Int +tournamentLeaves tournament = + case tournament of + TournamentLeaf _ -> 1 + TournamentNode left right -> tournamentLeaves left + tournamentLeaves right +{-# INLINE tournamentLeaves #-} diff --git a/src-public/Moonlight/Triangulation.hs b/src-public/Moonlight/Triangulation.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation.hs @@ -0,0 +1,326 @@ +-- | The equational surface: a triangulation is a value of its site set. +module Moonlight.Triangulation + ( -- * The object — a triangulation is a value of its site set + Triangulation + , DelaunayTriangulation + , ConstrainedDelaunayTriangulation + , ConstraintMode (..) + , Point (..) + , QueryPoint + , queryPointValue + , PointValidationError (..) + , mkQueryPoint + , HasPosition (..) + , ElementDefaults (..) + , unitElementDefaults + , JoinSemilattice (..) + -- | An identifier is admitted by the triangulation that issued it. The + -- observations below index without a second bounds check, so the + -- constructors are withheld here and the projections are not: an + -- identifier can be read, compared and carried, and can only be obtained + -- from a mesh. "Moonlight.Triangulation.Handles.HandleDefs" exports the + -- constructors for a caller who is willing to own that obligation. + , VertexId + , unVertexId + , FaceId + , unFaceId + , DirectedEdgeId + , unDirectedEdgeId + , UndirectedEdgeId + , unUndirectedEdgeId + , reverseEdge + , asUndirected + , normalizedDirected + , reversedDirected + , directedPair + , isNormalized + + -- * Generation — @delaunay@; canonical observation factors through the site set + , delaunay + , BuildResult + , buildTriangulation + , buildInputVertices + , BuildError (..) + , CoordinateError (..) + , NonFiniteValue (..) + + -- * The annotation functor — payloads annotate geometry, never author it; + -- the mesh is the same mesh before and after + , mapVertices + , vertexData + , setVertexData + + -- * Finite-set algebra and its normal form — support order is observable, + -- intersection can combine heterogeneous annotations, and each + -- construction returns its obstruction rather than an instance that lies + , canonicalize + , SiteRelation (..) + , siteRelation + , union + , unions + , intersection + , intersectionWith + , difference + , symmetricDifference + + -- * The constraint layer — 'constrainedDelaunay' is the partial map from + -- (sites, segments), defined exactly on realizable segment sets and + -- naming the corridor that blocked it where it is not + , constrainedDelaunay + , fromDelaunay + , constraintEdges + , isConstraintEdge + , CdtError (..) + , CorridorObstruction (..) + , CanonicalSegment + , segmentStart + , segmentEnd + , ConstraintConflict + , conflictFirstSegment + , conflictSecondSegment + , ConstrainedUnionError (..) + , ConstrainedExtensionResult + , constrainedExtensionTriangulation + , constrainedExtensionConstraintOutcomes + , constrainedExtensionConstraintStats + , constrainedExtensionBuildStats + , ConstrainedSeamSource (..) + , ConstrainedSeamFaceEvidence + , constrainedSeamSourceFace + , constrainedSeamTargetFace + , constrainedSeamFaceFirstPoint + , constrainedSeamFaceSecondPoint + , constrainedSeamFaceThirdPoint + , ConstrainedSeamConstraintEvidence + , constrainedSeamConstraintSegment + , constrainedSeamConstraintRecovery + , ConstrainedSeamResult + , constrainedSeamResultTriangulation + , constrainedSeamLeftFaceEvidence + , constrainedSeamRightFaceEvidence + , constrainedSeamNewFaces + , constrainedSeamLeftConstraintEvidence + , constrainedSeamRightConstraintEvidence + , constrainedSeamConstraintStats + , constrainedSeamBuildStats + , constraintSegments + , unionConstrainedWith + , unionConstrained + , joinSeparatedConstrainedWith + , extendConstrainedWith + + -- * Refinement — budget-bounded, composed after any operation above rather + -- than configured into it; 'refinementComplete' reports sufficiency, not + -- effort + , refine + , refineWithinDomain + , validateRefinementParameters + , RefinementParameters (..) + , defaultRefinementParameters + , RefinementReceipt + , RefinementDomainResult + , RefinementResult + , refinementDomainResult + , refinementDomainReceipt + , refinedTriangulation + , refinementVisitedJoinFaces + , refinementVisitedProtectedFaces + , refinementCreatedFaces + , refinementTouchedEdges + , refinementRemovedEdges + , refinementInterfaceBoundaryReads + , refinementAttemptedBoundaryCrossings + , refinementAddedVertices + , refinementExcludedFaces + , refinementComplete + , withMinimumAngle + , radiusEdgeRatioForAngle + + -- * Observations — pure functions of the value: incidence, location, + -- interpolation and barrier parity, none of which build a second mesh + , numVertices + , vertices + , vertexPoint + , vertexPoints + , numFaces + , innerFaces + , outerFace + , faceDirectedEdges + , faceVertices + , innerFaceVertexTriples + , vertexOutgoingEdges + , numUndirectedEdges + , undirectedEdges + , undirectedEndpoints + , origin + , destination + , incidentFace + , isBoundaryEdge + , nearestNeighbor + , NearestStats (..) + , interpolateNearest + , interpolateBarycentric + , LocationHint (..) + , facesAtEvenBarrierDepth + + -- * Discharge — the invariants the constructors guarantee, checkable on a + -- value built by any route; every violation is a value carrying its witness + , validateTriangulation + , InvariantViolation (..) + ) where + +import Moonlight.Triangulation.BulkLoad (delaunay) +import Moonlight.Triangulation.Dcel + ( destination + , faceDirectedEdges + , faceVertices + , innerFaceVertexTriples + , incidentFace + , isBoundaryEdge + , isConstraintEdge + , numFaces + , numUndirectedEdges + , numVertices + , origin + , outerFace + , setVertexData + , undirectedEndpoints + , vertexData + , vertexOutgoingEdges + , vertexPoint + , vertexPoints + ) +import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth) +import Moonlight.Triangulation.Handles.HandleDefs + ( DirectedEdgeId (..) + , FaceId (..) + , UndirectedEdgeId (..) + , VertexId (..) + , asUndirected + , directedPair + , isNormalized + , normalizedDirected + , reverseEdge + , reversedDirected + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators + ( innerFaces + , undirectedEdges + , vertices + ) +import Moonlight.Triangulation.Internal.Canonical (canonicalize) +import Moonlight.Triangulation.Internal.Cdt.Build + ( constrainedDelaunay + , fromDelaunay + ) +import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) +import Moonlight.Triangulation.Internal.Cdt.Types + ( CanonicalSegment + , CdtError (..) + , ConstrainedUnionError (..) + , ConstrainedExtensionResult + , ConstrainedSeamConstraintEvidence + , ConstrainedSeamFaceEvidence + , ConstrainedSeamResult + , ConstrainedSeamSource (..) + , ConstraintConflict + , CorridorObstruction (..) + , constrainedExtensionBuildStats + , constrainedExtensionConstraintOutcomes + , constrainedExtensionConstraintStats + , constrainedExtensionTriangulation + , constrainedSeamBuildStats + , constrainedSeamConstraintRecovery + , constrainedSeamConstraintSegment + , constrainedSeamConstraintStats + , constrainedSeamFaceFirstPoint + , constrainedSeamFaceSecondPoint + , constrainedSeamFaceThirdPoint + , constrainedSeamLeftConstraintEvidence + , constrainedSeamLeftFaceEvidence + , constrainedSeamNewFaces + , constrainedSeamResultTriangulation + , constrainedSeamRightConstraintEvidence + , constrainedSeamRightFaceEvidence + , constrainedSeamSourceFace + , constrainedSeamTargetFace + , conflictFirstSegment + , conflictSecondSegment + , segmentEnd + , segmentStart + ) +import Moonlight.Triangulation.Internal.Cdt.Union + ( constraintSegments + , extendConstrainedWith + , joinSeparatedConstrainedWith + , unionConstrained + , unionConstrainedWith + ) +import Moonlight.Triangulation.Internal.Representation + ( BuildResult + , ConstrainedDelaunayTriangulation + , DelaunayTriangulation + , RefinementDomainResult + , RefinementReceipt + , RefinementResult + , Triangulation + , buildInputVertices + , buildTriangulation + , refinementDomainReceipt + , refinementDomainResult + , refinedTriangulation + , refinementInterfaceBoundaryReads + , refinementAttemptedBoundaryCrossings + , refinementAddedVertices + , refinementComplete + , refinementCreatedFaces + , refinementExcludedFaces + , refinementRemovedEdges + , refinementTouchedEdges + , refinementVisitedJoinFaces + , refinementVisitedProtectedFaces + ) +import Moonlight.Triangulation.Internal.Types + ( BuildError (..) + , ConstraintMode (..) + , CoordinateError (..) + , ElementDefaults (..) + , HasPosition (..) + , InvariantViolation (..) + , LocationHint (..) + , NearestStats (..) + , NonFiniteValue (..) + , Point (..) + , PointValidationError (..) + , QueryPoint + , RefinementParameters (..) + , SiteRelation (..) + , defaultRefinementParameters + , queryPointValue + , unitElementDefaults + ) +import Moonlight.Triangulation.Interpolation + ( interpolateBarycentric + , interpolateNearest + , nearestNeighbor + ) +import Moonlight.Triangulation.Math (mkQueryPoint) +import Moonlight.Triangulation.Payload (mapVertices) +import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (..)) +import Moonlight.Triangulation.Refinement + ( radiusEdgeRatioForAngle + , refine + , refineWithinDomain + , validateRefinementParameters + , withMinimumAngle + ) +import Moonlight.Triangulation.SetAlgebra + ( difference + , intersection + , intersectionWith + , siteRelation + , symmetricDifference + , union + , unions + ) +import Moonlight.Triangulation.Validation (validateTriangulation) diff --git a/src-serialize/Moonlight/Triangulation/Serialization.hs b/src-serialize/Moonlight/Triangulation/Serialization.hs new file mode 100644 --- /dev/null +++ b/src-serialize/Moonlight/Triangulation/Serialization.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The versioned binary surface: encode a triangulation to bytes and read it +-- back. Decoding refuses a payload whose format version or coordinate encoding this +-- build does not own, rather than reinterpreting it. +module Moonlight.Triangulation.Serialization + ( SerializationError (..) + , serializationVersion + , encodeTriangulation + , decodeTriangulation + ) where + +import Control.Monad (replicateM, unless, when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Data.Binary (Binary (..)) +import Data.Binary.Get + ( Get + , getDoublebe + , getWord16be + , getWord32be + , getWord64be + , getWord8 + , runGetOrFail + ) +import Data.Binary.Put + ( Put + , putDoublebe + , putWord16be + , putWord32be + , putWord64be + , putWord8 + , runPut + ) +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (traverse_) +import qualified Data.IntSet as IntSet +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Word (Word16, Word64, Word8) +import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector, boxedToVector) +import Moonlight.Triangulation.Internal.Paged (fromLocalVector, fromVector, toVector) +import Moonlight.Triangulation.Internal.PointIndex (buildPointIndex) +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Types +import Moonlight.Triangulation.Math (mkQueryPoint) +import Moonlight.Triangulation.Validation (validateTriangulation) + +instance Binary (Point) where + put (Point x y) = putDoublebe x >> putDoublebe y + get = Point <$> getDoublebe <*> getDoublebe + +instance Binary VertexId where + put (VertexId value) = putWord32be value + get = VertexId <$> getWord32be + +instance Binary FaceId where + put (FaceId value) = putWord32be value + get = FaceId <$> getWord32be + +instance Binary DirectedEdgeId where + put (DirectedEdgeId value) = putWord32be value + get = DirectedEdgeId <$> getWord32be + +instance Binary UndirectedEdgeId where + put (UndirectedEdgeId value) = putWord32be value + get = UndirectedEdgeId <$> getWord32be + +-- | Every way serialization refuses, each naming its witness. +data SerializationError + = BinaryDecodeFailure !Int64 !String + | TrailingBytes !Int64 + | InvalidFormatMagic !Word64 + | UnsupportedFormatVersion !Word16 + | ConstraintModeTagMismatch !Word8 !Word8 + | CoordinateEncodingTagMismatch !Word8 !Word8 + | EncodedCountExceedsInt !Word64 + | SerializedCoordinateLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedVertexPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedVertexOutgoingLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedDirectedEdgeCountOdd {-# UNPACK #-} !Int + | SerializedNextLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedPreviousLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedFaceReferenceLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedDirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedUndirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedConstraintLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SerializedMissingOuterFace + | SerializedFacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | InvalidSerializedPoint {-# UNPACK #-} !Int !PointValidationError + | NonCanonicalSerializedConstraintFlag !UndirectedEdgeId !Word8 + | SerializedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | UnconstrainedSerializedConstraints {-# UNPACK #-} !Int + | DuplicateSerializedCoordinates {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | DecodedInvariantViolations !(NonEmpty InvariantViolation) + deriving stock (Eq, Show) + +type Decoder = ExceptT SerializationError Get + +-- | The envelope version this module writes. +serializationVersion :: Word16 +serializationVersion = 4 + +formatMagic :: Word64 +formatMagic = 0x5350414445485307 -- "SPADEHS" + canonical geometry-owned format family + +binary64EncodingTag :: Word8 +binary64EncodingTag = 2 + +-- | Write the versioned binary envelope. +encodeTriangulation + :: forall mode vertex directed undirected face. (KnownConstraintMode mode, Binary vertex, Binary directed, Binary undirected, Binary face) + => Triangulation mode vertex directed undirected face + -> BL.ByteString +encodeTriangulation triangulation = runPut $ do + putWord64be formatMagic + putWord16be serializationVersion + putWord8 (modeTag (constraintModeValue (modeProxy triangulation))) + putWord8 binary64EncodingTag + let ElementDefaults directedDefault undirectedDefault faceDefault = triElementDefaults triangulation + put directedDefault + put undirectedDefault + put faceDefault + -- Geometry and payloads are independent components. Persist the authoritative + -- coordinate pages rather than attempting to recover them from annotations. + putUVector putDoublebe (toVector (triPointX triangulation)) + putUVector putDoublebe (toVector (triPointY triangulation)) + putBoxedVector put (boxedToVector (triVertexData triangulation)) + putUVector putWord32be (toVector (triVertexOut triangulation)) + -- The wire format stores the four topology planes separately; the interleaved + -- arena is a resident layout, not a serialization concern. + let topology = toVector (triHalfTopology triangulation) + plane field = U.generate (U.length topology `quot` 4) (\edge -> topology U.! (4 * edge + field)) + putUVector putWord32be (plane 0) + putUVector putWord32be (plane 1) + putUVector putWord32be (plane 2) + putUVector putWord32be (plane 3) + putBoxedVector put (boxedToVector (triDirectedData triangulation)) + putBoxedVector put (boxedToVector (triUndirectedData triangulation)) + putUVector putWord32be (toVector (triFaceEdge triangulation)) + putBoxedVector put (boxedToVector (triFaceData triangulation)) + putUVector putWord8 (toVector (triConstraint triangulation)) + putCount (fromIntegral (triConstraintCount triangulation)) + +-- | Decode one exact, versioned finite DCEL. Coordinate uniqueness and the +-- complete topology, geometry, and Delaunay/CDT invariants are checked before +-- the opaque value is returned. +decodeTriangulation + :: forall mode vertex directed undirected face. + ( KnownConstraintMode mode + , Binary vertex + , Binary directed + , Binary undirected + , Binary face + ) + => BL.ByteString + -> Either SerializationError (Triangulation mode vertex directed undirected face) +decodeTriangulation bytes = + case runGetOrFail (runExceptT getTriangulation) bytes of + Left (_, offset, message) -> Left (BinaryDecodeFailure offset message) + Right (_, _, Left failure) -> Left failure + Right (remaining, _, Right triangulation) + | not (BL.null remaining) -> Left (TrailingBytes (BL.length remaining)) + | otherwise -> + case validateTriangulation triangulation of + [] -> Right triangulation + firstViolation : remainingViolations -> + Left (DecodedInvariantViolations (firstViolation :| remainingViolations)) + where + getTriangulation :: Decoder (Triangulation mode vertex directed undirected face) + getTriangulation = do + magic <- lift getWord64be + unless (magic == formatMagic) (throwE (InvalidFormatMagic magic)) + version <- lift getWord16be + unless (version == serializationVersion) (throwE (UnsupportedFormatVersion version)) + encodedMode <- lift getWord8 + let expectedMode = modeTag (constraintModeValue (Proxy :: Proxy mode)) + unless (encodedMode == expectedMode) (throwE (ConstraintModeTagMismatch expectedMode encodedMode)) + encodedScalar <- lift getWord8 + let expectedScalar = binary64EncodingTag + unless (encodedScalar == expectedScalar) (throwE (CoordinateEncodingTagMismatch expectedScalar encodedScalar)) + defaults <- ElementDefaults <$> lift get <*> lift get <*> lift get + pointXs <- getUVector (lift getDoublebe) + pointYs <- getUVector (lift getDoublebe) + vertexDataVector <- getBoxedVector (lift get) + vertexOut <- getUVector (lift getWord32be) + halfOrigin <- getUVector (lift getWord32be) + halfNext <- getUVector (lift getWord32be) + halfPrev <- getUVector (lift getWord32be) + halfFace <- getUVector (lift getWord32be) + directedDataVector <- getBoxedVector (lift get) + undirectedDataVector <- getBoxedVector (lift get) + faceEdge <- getUVector (lift getWord32be) + faceDataVector <- getBoxedVector (lift get) + constraints <- getUVector (lift getWord8) + cachedConstraintCount <- getCount + + let vertexCount = U.length pointXs + pointYCount = U.length pointYs + vertexPayloadCount = V.length vertexDataVector + vertexOutgoingCount = U.length vertexOut + halfCount = U.length halfOrigin + nextCount = U.length halfNext + previousCount = U.length halfPrev + faceReferenceCount = U.length halfFace + edgeCount = halfCount `quot` 2 + faceCount = U.length faceEdge + directedPayloadCount = V.length directedDataVector + undirectedPayloadCount = V.length undirectedDataVector + constraintCount = U.length constraints + facePayloadCount = V.length faceDataVector + points = zipWith Point (U.toList pointXs) (U.toList pointYs) + unless (pointYCount == vertexCount) (throwE (SerializedCoordinateLengthMismatch vertexCount pointYCount)) + unless (vertexPayloadCount == vertexCount) (throwE (SerializedVertexPayloadLengthMismatch vertexPayloadCount vertexCount)) + unless (vertexOutgoingCount == vertexCount) (throwE (SerializedVertexOutgoingLengthMismatch vertexOutgoingCount vertexCount)) + unless (even halfCount) (throwE (SerializedDirectedEdgeCountOdd halfCount)) + unless (nextCount == halfCount) (throwE (SerializedNextLengthMismatch nextCount halfCount)) + unless (previousCount == halfCount) (throwE (SerializedPreviousLengthMismatch previousCount halfCount)) + unless (faceReferenceCount == halfCount) (throwE (SerializedFaceReferenceLengthMismatch faceReferenceCount halfCount)) + unless (directedPayloadCount == halfCount) (throwE (SerializedDirectedPayloadLengthMismatch directedPayloadCount halfCount)) + unless (undirectedPayloadCount == edgeCount) (throwE (SerializedUndirectedPayloadLengthMismatch undirectedPayloadCount edgeCount)) + unless (constraintCount == edgeCount) (throwE (SerializedConstraintLengthMismatch constraintCount edgeCount)) + unless (faceCount >= 1) (throwE SerializedMissingOuterFace) + unless (facePayloadCount == faceCount) (throwE (SerializedFacePayloadLengthMismatch facePayloadCount faceCount)) + traverse_ (uncurry validateStoredPoint) (zip [0 ..] points) + + case U.ifoldr (\index flag found -> if flag /= 0 && flag /= 1 then Just (index, flag) else found) Nothing constraints of + Nothing -> pure () + Just (index, flag) -> + throwE + ( NonCanonicalSerializedConstraintFlag + (UndirectedEdgeId (fromIntegral index)) + flag + ) + let actualConstraintCount = U.foldl' (\count flag -> if flag == 1 then count + 1 else count) 0 constraints + unless (cachedConstraintCount == actualConstraintCount) (throwE (SerializedConstraintCountMismatch cachedConstraintCount actualConstraintCount)) + when (expectedMode == 0 && actualConstraintCount /= 0) (throwE (UnconstrainedSerializedConstraints actualConstraintCount)) + + let distinctPoints = Map.fromList (map (\point -> (point, ())) points) + distinctPointCount = Map.size distinctPoints + unless (distinctPointCount == vertexCount) (throwE (DuplicateSerializedCoordinates vertexCount distinctPointCount)) + + let pointXStore = fromLocalVector 0 pointXs + pointYStore = fromLocalVector 0 pointYs + topologyStore = + fromVector maxBound $ + U.generate (4 * halfCount) $ \slot -> + let (edge, field) = slot `quotRem` 4 + in case field of + 0 -> halfOrigin U.! edge + 1 -> halfNext U.! edge + 2 -> halfPrev U.! edge + _ -> halfFace U.! edge + constraintEdgeIndex = + U.ifoldl' + (\edges index flag -> + if flag == 1 then IntSet.insert index edges else edges + ) + IntSet.empty + constraints + pure + Triangulation + { triPointX = pointXStore + , triPointY = pointYStore + , triPointIndex = buildPointIndex pointXStore pointYStore + , triVertexOut = fromLocalVector maxBound vertexOut + , triVertexData = boxedFromVector Nothing vertexDataVector + , triHalfTopology = topologyStore + , triDirectedData = boxedFromVector (Just (defaultDirectedEdgeData defaults)) directedDataVector + , triUndirectedData = boxedFromVector (Just (defaultUndirectedEdgeData defaults)) undirectedDataVector + , triFaceEdge = fromLocalVector maxBound faceEdge + , triFaceData = boxedFromVector (Just (defaultFaceData defaults)) faceDataVector + , triConstraint = fromVector 0 constraints + , triConstraintCount = cachedConstraintCount + , triConstraintEdges = constraintEdgeIndex + , triElementDefaults = defaults + } + +validateStoredPoint :: Int -> Point -> Decoder () +validateStoredPoint index point = + case mkQueryPoint point of + Left failure -> throwE (InvalidSerializedPoint index failure) + Right _ -> pure () + +modeProxy :: Triangulation mode vertex directed undirected face -> Proxy mode +modeProxy _ = Proxy + +modeTag :: ConstraintMode -> Word8 +modeTag Unconstrained = 0 +modeTag Constrained = 1 + +putCount :: Word64 -> Put +putCount = putWord64be + +getCount :: Decoder Int +getCount = do + raw <- lift getWord64be + when (raw > fromIntegral (maxBound :: Int)) (throwE (EncodedCountExceedsInt raw)) + pure (fromIntegral raw) + +putUVector :: U.Unbox a => (a -> Put) -> U.Vector a -> Put +putUVector putElement values = do + putCount (fromIntegral (U.length values)) + U.mapM_ putElement values + +getUVector :: U.Unbox a => Decoder a -> Decoder (U.Vector a) +getUVector getElement = do + count <- getCount + U.fromList <$> replicateM count getElement + +putBoxedVector :: (a -> Put) -> V.Vector a -> Put +putBoxedVector putElement values = do + putCount (fromIntegral (V.length values)) + V.mapM_ putElement values + +getBoxedVector :: Decoder a -> Decoder (V.Vector a) +getBoxedVector getElement = do + count <- getCount + V.fromList <$> replicateM count getElement diff --git a/test/algebra/Main.hs b/test/algebra/Main.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.AlgebraSpec as AlgebraSpec +import qualified Moonlight.Triangulation.ScheduleAgreementSpec as ScheduleAgreementSpec + +main :: IO () +main = do + AlgebraSpec.tests + ScheduleAgreementSpec.tests diff --git a/test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs b/test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs @@ -0,0 +1,268 @@ +-- | The operand meshes and mesh observations both algebra slices are stated +-- over, built against the facade alone. +module Moonlight.Triangulation.AlgebraFixtures + ( Mesh + , PointMesh + , meshOf + , pointMeshOf + , operands + , separatedOperands + , cocircularRing + , collinearSites + , latticeSites + , pointsOf + , dedupeAscending + , siteList + , siteSet + , edgeKeys + , assertMesh + , assertMeshEquivalent + , pairs + , triples + , advance + , scramble + , randomSites + ) where + +import Data.List (sortBy) +import Data.Ord (comparing) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Data.Word (Word64) +import Moonlight.Triangulation + ( DelaunayTriangulation + , Point (Point) + , VertexId + , buildTriangulation + , canonicalize + , delaunay + , mapVertices + , numFaces + , numUndirectedEdges + , numVertices + , undirectedEdges + , undirectedEndpoints + , unitElementDefaults + , vertexPoint + , vertices + ) +import Support (requireRight) + +-- | The carrier. Geometry and nothing else: no vertex payload to need a +-- commutative combining rule, no element payloads to survive a rewrite that +-- destroys the elements they labelled. +type Mesh = DelaunayTriangulation () + +-- | The same carrier with its exact coordinate retained as the vertex +-- annotation. Annotation-preserving set laws use it to construct their +-- expected values without reaching below the public facade. +type PointMesh = DelaunayTriangulation (Point) + +-- ── operands ───────────────────────────────────────────────────────────────── + +-- | The site families the laws are exercised over. +-- +-- Sized so that the cubic sweep in the associativity law stays cheap. Coverage +-- here is by /kind/ of degeneracy, not by count: what breaks a join is a +-- cocircular quad whose tie-break went the other way, or a mesh with no faces +-- at all, and neither of those becomes more likely at ten thousand sites. +families :: [(String, [Point])] +families = + [ ("void", []) + , ("single", [Point 3 (-7)]) + , ("pair", [Point 0 0, Point 4 1]) + , ("collinear", collinearSites) + , ("cocircular", cocircularRing) + , ("lattice", latticeSites) + , ("repeated", concatMap (replicate 3) [Point 0 0, Point 5 0, Point 0 5, Point 5 5, Point 2 3]) + , ("scattered", randomSites 0xC0FFEEBABE 32) + , ("extreme", [Point 1.0e-8 1.0e-8, Point 1.0e8 (-1.0e8), Point (-1.0e8) 1.0e8, Point 0 0, Point 1 1]) + ] + +-- | Exactly cocircular lattice points on @x² + y² = 625@. +-- +-- Trigonometric points would be cocircular only to within rounding, and the +-- rule this is here to exercise — the diagonal tie-break that fires when the +-- lifted quadrilateral is exactly flat — would then never fire at all. +cocircularRing :: [Point] +cocircularRing = + [ Point (fromIntegral (signX * x)) (fromIntegral (signY * y)) + | (x, y) <- [(25, 0), (0, 25), (7, 24), (24, 7), (15, 20), (20, 15)] :: [(Int, Int)] + , signX <- [1, -1] + , signY <- [1, -1] + ] + +collinearSites :: [Point] +collinearSites = [Point (fromIntegral k) (2 * fromIntegral k - 1) | k <- [0 .. 9 :: Int]] + +latticeSites :: [Point] +latticeSites = [Point (fromIntegral i) (fromIntegral j) | i <- [0 .. 4 :: Int], j <- [0 .. 4 :: Int]] + +-- | The meshes every pairwise and triple law runs over. +-- +-- Chosen for overlap structure rather than for size: disjoint operands, nested +-- ones, partially overlapping ones, the empty one, and — the case that matters +-- most — two meshes standing on the /same/ sites built in different orders, so +-- they are geometrically identical and structurally distinct. +operands :: IO [(String, Mesh)] +operands = do + let sites name = maybe [] id (lookup name families) + lattice = sites "lattice" + void' <- meshOf "void" [] + single <- meshOf "single" (sites "single") + collinear <- meshOf "collinear" (sites "collinear") + ring <- meshOf "cocircular" (sites "cocircular") + lower <- meshOf "lattice-lower" (take 15 lattice) + upper <- meshOf "lattice-upper" (drop 10 lattice) + repeated <- meshOf "repeated" (sites "repeated") + scatterA <- meshOf "scattered" (sites "scattered") + scatterB <- meshOf "scattered-scrambled" (scramble 0x5EED (sites "scattered")) + pure + [ ("void", void') + , ("single", single) + , ("collinear", collinear) + , ("cocircular", ring) + , ("lattice-lower", lower) + , ("lattice-upper", upper) + , ("repeated", repeated) + , ("scattered", scatterA) + , ("scattered-scrambled", scatterB) + ] + +-- | Operand pairs whose sites are separated by a vertical line, which is the +-- stratum a seam schedule is defined on and the one the old-edge identity is +-- sharpest over: with no shared site, every edge is unambiguously left, right +-- or cross. +separatedOperands :: IO [((String, Mesh), (String, Mesh))] +separatedOperands = + traverse + ( \(name, seed, count, shift) -> do + let sites = randomSites seed count + left <- meshOf (name <> "-left") sites + right <- meshOf (name <> "-right") [Point (x + shift) y | Point x y <- sites] + pure ((name <> "-left", left), (name <> "-right", right)) + ) + [ ("split-distant", 0x51DE1, 60, 1000) + , ("split-near", 0x51DE2, 60, 3) + , ("split-abutting", 0x51DE3, 60, 2.05) + ] + +-- ── construction ───────────────────────────────────────────────────────────── + +meshOf :: String -> [Point] -> IO Mesh +meshOf label points = mapVertices (const ()) <$> pointMeshOf label points + +pointMeshOf :: String -> [Point] -> IO PointMesh +pointMeshOf label points = + buildTriangulation + <$> requireRight ("build " <> label) (delaunay unitElementDefaults (V.fromList points)) + +pointsOf :: [(Double, Double)] -> [Point] +pointsOf keys = [Point x y | (x, y) <- keys] + +dedupeAscending :: [(Double, Double)] -> [Point] +dedupeAscending sorted = [Point x y | (x, y) <- dropAdjacentDuplicates sorted] + +dropAdjacentDuplicates :: Eq a => [a] -> [a] +dropAdjacentDuplicates (first : second : rest) + | first == second = dropAdjacentDuplicates (second : rest) + | otherwise = first : dropAdjacentDuplicates (second : rest) +dropAdjacentDuplicates rest = rest + +-- ── observation ────────────────────────────────────────────────────────────── + +siteKey :: Mesh -> VertexId -> (Double, Double) +siteKey mesh vertex = let Point x y = vertexPoint mesh vertex in (x, y) + +siteList :: Mesh -> [(Double, Double)] +siteList mesh = [siteKey mesh vertex | vertex <- vertices mesh] + +siteSet :: Mesh -> Set.Set (Double, Double) +siteSet = Set.fromList . siteList + +edgeKeys :: Mesh -> Set.Set ((Double, Double), (Double, Double)) +edgeKeys mesh = + Set.fromList + [ if left <= right then (left, right) else (right, left) + | edge <- undirectedEdges mesh + , let (from, to) = undirectedEndpoints mesh edge + , let left = siteKey mesh from + , let right = siteKey mesh to + ] + +-- | What a mesh looks like when two of them were supposed to be equal. +-- +-- The interesting failure is the one where the coordinate-keyed edge sets +-- agree and the values do not: that is the join having become correct only up +-- to DCEL isomorphism, which is precisely what these laws exist to forbid, and +-- a report that only printed counts would hide it. +assertMesh :: String -> Mesh -> Mesh -> IO () +assertMesh label expected actual + | expected == actual = pure () + | otherwise = fail (label <> ": " <> report) + where + report + | expectedEdges == actualEdges = + "same geometry, different representation — " + <> meshCounts expected + <> " vs " + <> meshCounts actual + | otherwise = + meshCounts expected + <> " vs " + <> meshCounts actual + <> "; edges only in expected: " + <> show (take 4 (Set.toList (Set.difference expectedEdges actualEdges))) + <> "; only in actual: " + <> show (take 4 (Set.toList (Set.difference actualEdges expectedEdges))) + expectedEdges = edgeKeys expected + actualEdges = edgeKeys actual + +assertMeshEquivalent :: String -> Mesh -> Mesh -> IO () +assertMeshEquivalent label expected actual = do + canonicalExpected <- + requireRight (label <> ": canonical expected") (canonicalize expected) + canonicalActual <- + requireRight (label <> ": canonical actual") (canonicalize actual) + assertMesh label canonicalExpected canonicalActual + +meshCounts :: Mesh -> String +meshCounts mesh = + show (numVertices mesh) + <> "v/" + <> show (numUndirectedEdges mesh) + <> "e/" + <> show (numFaces mesh) + <> "f" + +-- ── combinatorics and pseudo-randomness ────────────────────────────────────── + +pairs :: [a] -> [(a, a)] +pairs values = [(left, right) | left <- values, right <- values] + +triples :: [a] -> [(a, a, a)] +triples values = [(a, b, c) | a <- values, b <- values, c <- values] + +advance :: Word64 -> Word64 +advance state = state * 6364136223846793005 + 1442695040888963407 + +randomWords :: Word64 -> Int -> [Word64] +randomWords seed count = take count (drop 1 (iterate advance seed)) + +-- | A deterministic permutation: decorate, sort by the key, discard it. +scramble :: Word64 -> [a] -> [a] +scramble seed values = + map snd (sortBy (comparing fst) (zip (randomWords seed (length values)) values)) + +randomSites :: Word64 -> Int -> [Point] +randomSites seed count = + [ Point (unitCoordinate first) (unitCoordinate second) + | (first, second) <- take count (chunkPairs (randomWords seed (2 * count))) + ] + +chunkPairs :: [a] -> [(a, a)] +chunkPairs (first : second : rest) = (first, second) : chunkPairs rest +chunkPairs _ = [] + +unitCoordinate :: Word64 -> Double +unitCoordinate value = 2 * fromIntegral (value `div` 2048) / 9007199254740992 - 1 diff --git a/test/algebra/Moonlight/Triangulation/AlgebraSpec.hs b/test/algebra/Moonlight/Triangulation/AlgebraSpec.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/AlgebraSpec.hs @@ -0,0 +1,880 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The laws of finite union, stated against the typed facade a caller has. +-- +-- Algebraic laws are observed through 'canonicalize'. Structural 'Eq' remains +-- the exact physical-representation observation used by round trips and caches. +module Moonlight.Triangulation.AlgebraSpec (tests) where + +import Control.Monad (forM_, unless, when) +import Data.Foldable (traverse_) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.List (sort) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import qualified Data.Vector as V +import Moonlight.Triangulation + ( BuildError + , ConstraintMode (..) + , DelaunayTriangulation + , HasPosition (..) + , JoinSemilattice (..) + , Point (Point) + , Triangulation + , buildTriangulation + , delaunay + , unitElementDefaults + , vertexData + , vertexPoint + , vertices + , SiteRelation (..) + , canonicalize + , difference + , intersection + , intersectionWith + , mapVertices + , numVertices + , siteRelation + , symmetricDifference + , union + , unions + , validateTriangulation + ) +import Moonlight.Triangulation.AlgebraFixtures + ( Mesh + , advance + , assertMesh + , assertMeshEquivalent + , cocircularRing + , collinearSites + , dedupeAscending + , edgeKeys + , latticeSites + , meshOf + , operands + , pairs + , pointMeshOf + , pointsOf + , randomSites + , scramble + , separatedOperands + , siteList + , siteSet + , triples + ) +import Support (requireRight) + +tests :: IO () +tests = do + testJoinIdentity + testJoinCommutative + testJoinAssociative + testJoinIdempotent + testJoinGeneralPathIdempotent + testJoinSiteUnion + testJoinGluesAnnotations + testJoinIsUnionRebuild + testJoinResultValid + testSkewedJoinPreservesBaseHandles + testJoinBalancedFold + testJoinPartitionTrees + testConstructionOrderIndependent + testCanonicalPublication + testSiteRelationCoherence + testMeetLaws + testEmptySetIdentitiesPreserveVerbatim + testSkewedSetOperationsRemainValid + testDifferenceLaws + testSymmetricDifferenceLaws + testLatticeLaws + testSetOperationsPublishCanonical + testAnnotationPreservation + testOldEdgeAccounting + putStrLn "algebra: ok" + +-- ── laws ───────────────────────────────────────────────────────────────────── + +testJoinIdentity :: IO () +testJoinIdentity = do + values <- operands + identity <- requireRight "union identity" (unions []) + forM_ values $ \(name, mesh) -> do + left <- requireRight ("left identity at " <> name) (union identity mesh) + right <- requireRight ("right identity at " <> name) (union mesh identity) + assertMesh ("left identity at " <> name) mesh left + assertMesh ("right identity at " <> name) mesh right + idempotent <- requireRight "identity is idempotent" (union identity identity) + assertMesh "identity is idempotent" identity idempotent + +testJoinCommutative :: IO () +testJoinCommutative = do + values <- operands + forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do + leftRight <- requireRight "commutative union left/right" (union left right) + rightLeft <- requireRight "commutative union right/left" (union right left) + assertMeshEquivalent + ("commutativity at " <> leftName <> " ⋄ " <> rightName) + leftRight + rightLeft + +testJoinAssociative :: IO () +testJoinAssociative = do + values <- operands + forM_ (triples values) $ \((aName, a), (bName, b), (cName, c)) -> do + leftAssociated <- requireRight "left-associated union" (union a b >>= (`union` c)) + rightAssociated <- requireRight "right-associated union" (union b c >>= union a) + assertMeshEquivalent + ("associativity at " <> aName <> " ⋄ " <> bName <> " ⋄ " <> cName) + leftAssociated + rightAssociated + +testJoinIdempotent :: IO () +testJoinIdempotent = do + values <- operands + forM_ values $ \(name, mesh) -> do + result <- requireRight ("idempotence at " <> name) (union mesh mesh) + assertMesh ("idempotence at " <> name) mesh result + +-- | Idempotence with the structural-equality shortcut deliberately disarmed. +-- +-- @a \<\> a@ is answered by a shortcut that compares the operands and returns +-- one verbatim, so on its own it says nothing about the operator underneath. +-- Three meshes standing on the same sites, built in three different orders, are +-- pairwise distinct as values — the test asserts that before relying on it — +-- so every join below takes the general path, and joining a fourth +-- representation of the same site set onto the result must still change +-- nothing. +testJoinGeneralPathIdempotent :: IO () +testJoinGeneralPathIdempotent = do + let base = randomSites 0xA11CE 40 + first <- meshOf "order-1" base + second <- meshOf "order-2" (scramble 0x1111 base) + third <- meshOf "order-3" (scramble 0x2222 base) + fourth <- meshOf "order-4" (reverse base) + unless (first /= second && second /= third && third /= fourth) $ + fail "general-path idempotence: the four builds are not distinct values, so the shortcut is not disarmed" + joined <- requireRight "general-path union" (union first second) + thirdResult <- requireRight "absorbing a third representation" (union joined third) + fourthResult <- requireRight "absorbing a fourth representation" (union joined fourth) + symmetric <- requireRight "the union of two representations is symmetric" (union second first) + assertMeshEquivalent "absorbing a third representation" joined thirdResult + assertMeshEquivalent "absorbing a fourth representation" joined fourthResult + assertMeshEquivalent "the union of two representations is symmetric" joined symmetric + +-- | The sites of a join are exactly the union of the operands' sites: none +-- dropped, none invented, each stored once. +testJoinSiteUnion :: IO () +testJoinSiteUnion = do + values <- operands + forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do + let label = leftName <> " ⋄ " <> rightName + expected = Set.union (siteSet left) (siteSet right) + joined <- requireRight ("site union at " <> label) (union left right) + let actual = siteSet joined + unless (expected == actual) $ + fail + ( "site union at " + <> label + <> ": dropped " + <> show (Set.toList (Set.difference expected actual)) + <> ", invented " + <> show (Set.toList (Set.difference actual expected)) + ) + unless (Set.size actual == numVertices joined) $ + fail ("site union at " <> label <> ": a site is stored more than once") + +-- | The reference semantics: a join /is/ a rebuild of the union when both are +-- observed canonically. +-- +-- The union is rebuilt three times, in three unrelated orders, and all three +-- must canonicalize to the canonical observation of the join. Comparing +-- against a single rebuild would only say the two agree; comparing against +-- three says that what they agree on is a function of the site set and not of +-- any build schedule, which is the actual claim. +-- +-- Both shortcut cases are excluded, because a shortcut returns an operand +-- verbatim and an operand need not be canonically published. The count of +-- pairs that actually reached the general path is asserted, so this cannot +-- quietly become a test of nothing. +testJoinIsUnionRebuild :: IO () +testJoinIsUnionRebuild = do + values <- operands + exercised <- newIORef (0 :: Int) + forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> + when (numVertices left > 0 && numVertices right > 0 && left /= right) $ do + let label = leftName <> " ⋄ " <> rightName + unionSites = siteList left <> siteList right + joined <- requireRight ("union of " <> label) (union left right) + canonicalJoined <- requireRight ("canonical union of " <> label) (canonicalize joined) + forM_ [("ranked", dedupeAscending (sort unionSites)), ("reversed", pointsOf (reverse unionSites)), ("scrambled", pointsOf (scramble 0x7A57E unionSites))] $ + \(order, sites) -> do + rebuilt <- meshOf ("rebuild of " <> label <> " in " <> order <> " order") sites + canonical <- requireRight ("canonical rebuild of " <> label <> " in " <> order <> " order") (canonicalize rebuilt) + assertMesh + ("join equals canonical rebuild at " <> label <> " (" <> order <> ")") + canonical + canonicalJoined + modifyIORef' exercised (+ 1) + count <- readIORef exercised + unless (count >= 40) $ + fail ("join-equals-rebuild exercised only " <> show count <> " general-path pairs") + +-- | Canonical publication in its own right, since the union laws lean on it. +-- +-- Renumbering must not move geometry, must be a fixed point, must leave a +-- valid triangulation, and — the load-bearing one — must send every build +-- order of a site set to the same value. The distinctness of the inputs is +-- asserted first, so a canonicalization that did nothing at all would fail +-- here rather than pass everything. +testCanonicalPublication :: IO () +testCanonicalPublication = do + values <- operands + forM_ values $ \(name, mesh) -> do + canonical <- requireRight ("canonicalization at " <> name) (canonicalize mesh) + unless (siteSet canonical == siteSet mesh) $ + fail ("canonicalization at " <> name <> " moved the site set") + unless (edgeKeys canonical == edgeKeys mesh) $ + fail ("canonicalization at " <> name <> " changed the triangulation") + case validateTriangulation canonical of + [] -> pure () + violations -> fail ("canonicalization at " <> name <> " is invalid: " <> show violations) + fixedPoint <- requireRight ("canonicalization fixed point at " <> name) (canonicalize canonical) + assertMesh ("canonicalization at " <> name <> " is a fixed point") canonical fixedPoint + forM_ [("scattered", randomSites 0xB0A710 48), ("cocircular", cocircularRing), ("lattice", latticeSites), ("collinear", collinearSites)] $ + \(name, base) -> do + built <- + traverse + (\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites) + [ ("input", base) + , ("ranked", dedupeAscending (sort [(x, y) | Point x y <- base])) + , ("reversed", reverse base) + , ("scrambled", scramble 0x6666 base) + ] + case built of + [] -> fail "canonical publication: nothing built" + (_, reference) : rest -> do + unless (any (\(_, mesh) -> mesh /= reference) rest) $ + fail ("canonical publication at " <> name <> ": every order already agreed, so this asserts nothing") + canonicalReference <- requireRight ("canonical reference at " <> name) (canonicalize reference) + forM_ rest $ \(order, mesh) -> do + canonicalMesh <- requireRight ("canonical publication at " <> name <> " from " <> order <> " order") (canonicalize mesh) + assertMesh + ("canonical publication at " <> name <> " from " <> order <> " order") + canonicalReference + canonicalMesh + +testJoinResultValid :: IO () +testJoinResultValid = do + values <- operands + forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do + joined <- requireRight ("valid union at " <> leftName <> " ⋄ " <> rightName) (union left right) + case validateTriangulation joined of + [] -> pure () + violations -> + fail ("join at " <> leftName <> " ⋄ " <> rightName <> " is invalid: " <> show violations) + +testSkewedJoinPreservesBaseHandles :: IO () +testSkewedJoinPreservesBaseHandles = do + let baseSites = randomSites 0x5A71E 256 + extensionSites = + fmap + (\(Point x y) -> Point (x + 4) y) + (randomSites 0xE71E 16) + base <- meshOf "persistent base" baseSites + extension <- meshOf "persistent extension" extensionSites + joined <- requireRight "persistent skewed union" (union base extension) + let baseObservations = fmap (\vertex -> (vertex, vertexPoint base vertex)) (vertices base) + forM_ baseObservations $ \(vertex, expectedPoint) -> + unless (vertexPoint joined vertex == expectedPoint) $ + fail + ( "persistent skewed union moved base handle " + <> show vertex + <> " from " + <> show expectedPoint + <> " to " + <> show (vertexPoint joined vertex) + ) + canonicalJoined <- requireRight "canonical persistent skewed union" (canonicalize joined) + reference <- meshOf "persistent union reference" (baseSites <> extensionSites) + canonicalReference <- requireRight "canonical persistent union reference" (canonicalize reference) + assertMesh "persistent skewed union agrees with canonical reference" canonicalReference canonicalJoined + +-- | The balanced tournament agrees with every typed fold, in both directions. +testJoinBalancedFold :: IO () +testJoinBalancedFold = do + shards <- shardMeshes 6 (randomSites 0xBA5EBA11 48) + identity <- requireRight "empty union" (unions []) + case shards of + [] -> fail "balanced fold: no shards were built" + firstShard : _ -> do + expected <- requireRight "balanced unions" (unions shards) + foldRight <- requireRight "right-folded unions" (foldr (\shard result -> result >>= union shard) (Right identity) shards) + foldLeft <- requireRight "left-folded unions" (foldl (\result shard -> result >>= (`union` shard)) (Right identity) shards) + singleton <- requireRight "singleton unions" (unions [firstShard]) + repeated <- requireRight "repeated unions" (unions [firstShard, firstShard]) + assertMeshEquivalent "balanced unions agree with foldr" expected foldRight + assertMeshEquivalent "balanced unions agree with foldl" expected foldLeft + assertMesh "unions of one shard is that shard" firstShard singleton + assertMesh "unions respects the idempotence shortcut" firstShard repeated + +-- | The document's partition test: one site set, many shardings, many +-- bracketings, one canonical observation. +testJoinPartitionTrees :: IO () +testJoinPartitionTrees = do + let base = randomSites 0xD15EA5E 54 + whole <- meshOf "whole" base + reference <- requireRight "canonical whole partition reference" (canonicalize whole) + forM_ ([2, 3, 5, 7] :: [Int]) $ \shardCount -> do + shards <- shardMeshes shardCount base + forM_ ([0 .. 7] :: [Int]) $ \shape -> do + let scrambled = scramble (fromIntegral shape * 7919 + 13) shards + result <- + requireRight + ("partition tree " <> show shardCount <> "/" <> show shape) + (bracketRandomly (fromIntegral shape * 104729 + 7) scrambled) + assertMeshEquivalent + ("partition tree " <> show shardCount <> "/" <> show shape) + reference + result + +-- | Delaunay uniqueness, stated as a law about this construction: the same +-- sites in any order give the same triangulation, and differ only in how it is +-- numbered. +-- +-- Both halves are asserted, and the second is the one that carries weight. If +-- the numbering did /not/ differ, canonical publication would be a no-op and +-- the quotient this test names would be trivial. Because it does differ, this +-- law licenses construction in whichever order is cheapest and an explicit +-- canonical observation only where physical agreement is required. +-- +-- The cocircular ring and the lattice are here because they are where it could +-- fail: an exactly flat lifted quadrilateral has two legal diagonals, and the +-- rule that picks between them is keyed on coordinates rather than on vertex +-- identifiers precisely so that this law holds. +testConstructionOrderIndependent :: IO () +testConstructionOrderIndependent = do + forM_ [("scattered", randomSites 0x0DDBA11 60), ("cocircular", cocircularRing), ("lattice", latticeSites)] $ + \(name, base) -> do + let ranked = dedupeAscending (sort [(x, y) | Point x y <- base]) + meshes <- + traverse + (\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites) + [ ("input", base) + , ("ranked", ranked) + , ("reversed", reverse base) + , ("scrambled-a", scramble 0x3333 base) + , ("scrambled-b", scramble 0x4444 base) + ] + case meshes of + [] -> fail "order independence: nothing built" + (referenceOrder, reference) : rest -> do + forM_ rest $ \(order, mesh) -> + unless (edgeKeys reference == edgeKeys mesh) $ + fail + ( "order independence at " + <> name + <> ": " + <> referenceOrder + <> " and " + <> order + <> " reached different triangulations" + ) + unless (any (\(_, mesh) -> mesh /= reference) rest) $ + fail + ( "order independence at " + <> name + <> ": every build order produced the identical value, so the" + <> " numbering quotient is trivial and this law asserts nothing" + ) + +-- | The Guibas–Stolfi old-edge theorem, asserted as a law of the operator. +-- +-- Adding sites to a Delaunay triangulation cannot create an edge between two +-- sites that were already there. So every edge of a join whose endpoints both +-- stood in one operand must already have been an edge of that operand, and any +-- other edge is bichromatic — it joins a site exclusive to the left to a site +-- exclusive to the right. +-- +-- This is strictly stronger than checking that the result is a valid Delaunay +-- triangulation, and it is stronger in exactly the direction a merge schedule +-- fails in. A seam that stitches the wrong pair of hull vertices, or that +-- retracts one edge too far before it stops deleting, produces a mesh that is +-- still Delaunay for /some/ site set and still passes validation; what it does +-- not do is leave the two interiors alone. The identity names that. +-- +-- It holds for every schedule, including the rebuild the operator uses today, +-- because it is a property of the Delaunay triangulation of the union and not +-- of the route taken to it. That is why it can be asserted before a second +-- schedule exists: it is the gate one would have to pass, green on the path +-- that is already trusted. +-- +-- Degeneracy does not weaken it. The tie-break on an exactly cocircular +-- quadrilateral is keyed on the four coordinates alone, so the same quad +-- resolves the same way whatever else stands nearby; a cocircular diagonal can +-- therefore be lost when a site lands inside its circle, which the theorem +-- permits, but cannot be exchanged for the other diagonal, which it forbids. +testOldEdgeAccounting :: IO () +testOldEdgeAccounting = do + overlapping <- operands + separated <- separatedOperands + census <- newIORef (0 :: Int, 0 :: Int) + forM_ ([(l, r) | l <- overlapping, r <- overlapping] <> separated) $ \((leftName, left), (rightName, right)) -> do + let label = "old-edge " <> leftName <> " / " <> rightName + joined <- requireRight label (union left right) + let leftSites = siteSet left + rightSites = siteSet right + leftEdges = edgeKeys left + rightEdges = edgeKeys right + forM_ (Set.toList (edgeKeys joined)) $ \edge -> do + let (from, to) = edge + spans sites = Set.member from sites && Set.member to sites + monochromeLeft = spans leftSites + monochromeRight = spans rightSites + when (monochromeLeft && not (Set.member edge leftEdges)) $ + fail (label <> ": join created " <> show edge <> ", an edge between two sites of the left operand") + when (monochromeRight && not (Set.member edge rightEdges)) $ + fail (label <> ": join created " <> show edge <> ", an edge between two sites of the right operand") + modifyIORef' census $ \(retained, cross) -> + if monochromeLeft || monochromeRight + then (retained + 1, cross) + else (retained, cross + 1) + (retained, cross) <- readIORef census + when (retained < 1000 || cross < 100) $ + fail + ( "old-edge accounting: the census is too thin to have asserted anything — " + <> show retained + <> " retained and " + <> show cross + <> " cross edges" + ) + +-- ── finite-set descent laws ───────────────────────────────────────────────── + +-- | The public support relation is the exact order observation of the same +-- site sets consumed by union, meet and relative complement. Its overlap +-- witness must therefore agree with every operation's cardinality rather than +-- merely with another classification routine. +testSiteRelationCoherence :: IO () +testSiteRelationCoherence = do + values <- operands + traverse_ (uncurry checkRelation) (pairs values) + where + checkRelation (leftName, left) (rightName, right) = do + let label = "site relation at " <> leftName <> " / " <> rightName + leftSites = siteSet left + rightSites = siteSet right + overlap = Set.size (Set.intersection leftSites rightSites) + expected = referenceSiteRelation leftSites rightSites + coldActual = siteRelation left right + unless (coldActual == expected) $ + fail (label <> ": expected " <> show expected <> ", got " <> show coldActual) + let repeatedActual = siteRelation left right + unless (repeatedActual == coldActual) $ + fail (label <> ": repeated observation changed the relation") + met <- requireRight (label <> " intersection") (intersection left right) + removed <- requireRight (label <> " difference") (difference left right) + joined <- requireRight (label <> " union") (union left right) + unless (numVertices met == overlap) $ + fail (label <> ": intersection cardinality disagrees with overlap") + unless (numVertices removed == Set.size leftSites - overlap) $ + fail (label <> ": difference cardinality disagrees with overlap") + unless (numVertices joined == Set.size leftSites + Set.size rightSites - overlap) $ + fail (label <> ": union cardinality disagrees with overlap") + +referenceSiteRelation + :: Set.Set (Double, Double) + -> Set.Set (Double, Double) + -> SiteRelation +referenceSiteRelation left right + | left == right = EqualSites + | left `Set.isProperSubsetOf` right = LeftProperSubset + | right `Set.isProperSubsetOf` left = RightProperSubset + | Set.null overlap = DisjointSites + | otherwise = PartialOverlap (Set.size overlap) + where + overlap = Set.intersection left right + +testMeetLaws :: IO () +testMeetLaws = do + values <- setLawOperands + traverse_ + ( \(name, mesh) -> + assertSetEquation + ("meet idempotence at " <> name) + (intersection mesh mesh) + (canonicalize mesh) + ) + values + traverse_ + ( \((leftName, left), (rightName, right)) -> + assertSetEquation + ("meet commutativity at " <> leftName <> " / " <> rightName) + (intersection left right) + (intersection right left) + ) + (pairs values) + traverse_ + ( \((aName, a), (bName, b), (cName, c)) -> + assertSetEquation + ("meet associativity at " <> aName <> " / " <> bName <> " / " <> cName) + (intersection a b >>= (`intersection` c)) + (intersection b c >>= intersection a) + ) + (triples values) + +testEmptySetIdentitiesPreserveVerbatim :: IO () +testEmptySetIdentitiesPreserveVerbatim = do + let sites = scramble 0xE771D3 (randomSites 0xE771D4 48) + mesh <- meshOf "verbatim empty identity source" sites + canonical <- requireRight "canonical verbatim empty identity source" (canonicalize mesh) + unless (mesh /= canonical) $ + fail "verbatim empty identities: the source was already canonical, so this asserts nothing" + empty <- requireRight "verbatim empty identity" (unions []) + differenceRightIdentity <- requireRight "verbatim difference right identity" (difference mesh empty) + differenceLeftZero <- requireRight "verbatim difference left zero" (difference empty mesh) + symmetricRightIdentity <- requireRight "verbatim symmetric difference right identity" (symmetricDifference mesh empty) + symmetricLeftIdentity <- requireRight "verbatim symmetric difference left identity" (symmetricDifference empty mesh) + assertMesh "difference by empty preserves the left representative verbatim" mesh differenceRightIdentity + assertMesh "empty difference remains the empty representative" empty differenceLeftZero + assertMesh "symmetric difference by empty preserves the left representative verbatim" mesh symmetricRightIdentity + assertMesh "empty symmetric difference preserves the right representative verbatim" mesh symmetricLeftIdentity + +testSkewedSetOperationsRemainValid :: IO () +testSkewedSetOperationsRemainValid = do + let baseSites = randomSites 0xD1FFE7 1024 + removedSites = take 4 (scramble 0xD1FFE8 baseSites) + retainedSites = filter (`notElem` removedSites) baseSites + disjointIncomingSites = fmap (\(Point x y) -> Point (x + 4) y) (randomSites 0xD1FFE9 4) + nearFullIntersectionSites = retainedSites <> disjointIncomingSites + overlappingRemovedSites = take 2 removedSites + overlappingIncomingSites = overlappingRemovedSites <> take 2 disjointIncomingSites + xorDisjointSites = baseSites <> disjointIncomingSites + xorOverlappingSites = filter (`notElem` overlappingRemovedSites) baseSites <> take 2 disjointIncomingSites + base <- meshOf "skewed set-operation base" baseSites + removed <- meshOf "skewed difference subset" removedSites + disjointIncoming <- meshOf "skewed difference disjoint" disjointIncomingSites + nearFullIntersection <- meshOf "skewed geometry-only intersection" nearFullIntersectionSites + overlappingIncoming <- meshOf "skewed xor overlapping" overlappingIncomingSites + differenceSubset <- requireRight "skewed difference subset" (difference base removed) + differenceDisjoint <- requireRight "skewed difference disjoint" (difference base disjointIncoming) + intersectionNearFull <- requireRight "skewed geometry-only intersection" (intersection base nearFullIntersection) + xorDisjoint <- requireRight "skewed xor disjoint" (symmetricDifference base disjointIncoming) + xorOverlapping <- requireRight "skewed xor overlapping" (symmetricDifference base overlappingIncoming) + assertRawSetResult "skewed difference subset" retainedSites differenceSubset + assertRawSetResult "skewed difference disjoint" baseSites differenceDisjoint + assertMesh "skewed difference disjoint preserves the base verbatim" base differenceDisjoint + assertRawSetResult "skewed geometry-only intersection" retainedSites intersectionNearFull + assertRawSetResult "skewed xor disjoint" xorDisjointSites xorDisjoint + assertRawSetResult "skewed xor overlapping" xorOverlappingSites xorOverlapping + +assertRawSetResult :: String -> [Point] -> Mesh -> IO () +assertRawSetResult label expectedSites result = do + case validateTriangulation result of + [] -> pure () + violations -> fail (label <> " raw result is invalid: " <> show violations) + reference <- meshOf (label <> " fresh rebuild") (scramble 0xD1FFEA expectedSites) + assertMeshEquivalent (label <> " agrees canonically with a fresh rebuild") reference result + +testDifferenceLaws :: IO () +testDifferenceLaws = do + values <- setLawOperands + identity <- requireRight "difference identity" (unions []) + traverse_ + ( \(name, mesh) -> do + assertSetEquation + ("difference cancellation at " <> name) + (difference mesh mesh) + (Right identity) + assertSetEquation + ("difference right identity at " <> name) + (difference mesh identity) + (canonicalize mesh) + ) + values + traverse_ + ( \((leftName, left), (rightName, right)) -> do + let label = "difference partition at " <> leftName <> " / " <> rightName + commonAndRemainder = do + common <- intersection left right + remainder <- difference left right + union common remainder + remainderMeetRight = difference left right >>= (`intersection` right) + assertSetEquation label commonAndRemainder (canonicalize left) + assertSetEquation (label <> " disjointness") remainderMeetRight (Right identity) + ) + (pairs values) + +testSymmetricDifferenceLaws :: IO () +testSymmetricDifferenceLaws = do + values <- setLawOperands + identity <- requireRight "symmetric-difference identity" (unions []) + traverse_ + ( \(name, mesh) -> do + assertSetEquation + ("symmetric-difference cancellation at " <> name) + (symmetricDifference mesh mesh) + (Right identity) + assertSetEquation + ("symmetric-difference identity at " <> name) + (symmetricDifference mesh identity) + (canonicalize mesh) + ) + values + traverse_ + ( \((leftName, left), (rightName, right)) -> do + let label = "symmetric difference at " <> leftName <> " / " <> rightName + decomposed = do + leftOnly <- difference left right + rightOnly <- difference right left + union leftOnly rightOnly + assertSetEquation + (label <> " commutativity") + (symmetricDifference left right) + (symmetricDifference right left) + assertSetEquation + (label <> " decomposition") + (symmetricDifference left right) + decomposed + ) + (pairs values) + traverse_ + ( \((aName, a), (bName, b), (cName, c)) -> + assertSetEquation + ("symmetric-difference associativity at " <> aName <> " / " <> bName <> " / " <> cName) + (symmetricDifference a b >>= (`symmetricDifference` c)) + (symmetricDifference b c >>= symmetricDifference a) + ) + (triples values) + +testLatticeLaws :: IO () +testLatticeLaws = do + values <- setLawOperands + traverse_ + ( \((leftName, left), (rightName, right)) -> do + let label = "absorption at " <> leftName <> " / " <> rightName + assertSetEquation + (label <> " meet-over-join") + (union left right >>= intersection left) + (canonicalize left) + assertSetEquation + (label <> " join-over-meet") + (intersection left right >>= union left) + (canonicalize left) + ) + (pairs values) + traverse_ + ( \((aName, a), (bName, b), (cName, c)) -> do + let label = "distributivity at " <> aName <> " / " <> bName <> " / " <> cName + meetOverJoin = union b c >>= intersection a + joinedMeets = do + left <- intersection a b + right <- intersection a c + union left right + joinOverMeet = intersection b c >>= union a + metJoins = do + left <- union a b + right <- union a c + intersection left right + assertSetEquation (label <> " meet-over-join") meetOverJoin joinedMeets + assertSetEquation (label <> " join-over-meet") joinOverMeet metJoins + ) + (triples values) + +testSetOperationsPublishCanonical :: IO () +testSetOperationsPublishCanonical = do + values <- setLawOperands + traverse_ + ( \((leftName, left), (rightName, right)) -> do + let label = "canonical set publication at " <> leftName <> " / " <> rightName + case siteRelation left right of + DisjointSites -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right) + PartialOverlap _ -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right) + EqualSites -> pure () + LeftProperSubset -> pure () + RightProperSubset -> pure () + when (numVertices left > 0 && numVertices right > 0) $ do + assertCanonicalFixedPoint (label <> " difference") (difference left right) + assertCanonicalFixedPoint (label <> " symmetric difference") (symmetricDifference left right) + ) + (pairs values) + +-- | Payloads descend with their coordinates. Intersection combines only the +-- common sections, difference preserves the left section, and symmetric +-- difference preserves whichever unique section survives. The independently +-- built expected meshes ensure this is not a restatement of the implementation. +testAnnotationPreservation :: IO () +testAnnotationPreservation = do + let shared = randomSites 0xA6607A7E 12 + leftOnly = randomSites 0x1EF7 8 + rightOnly = randomSites 0xA1167 10 + leftPoints = leftOnly <> shared + rightPoints = shared <> rightOnly + left <- pointMeshOf "annotation-left" leftPoints + rightPointsMesh <- pointMeshOf "annotation-right" rightPoints + sharedReference <- canonicalPointMesh "annotation-shared" shared + leftOnlyReference <- canonicalPointMesh "annotation-left-only" leftOnly + exclusiveReference <- canonicalPointMesh "annotation-exclusive" (leftOnly <> rightOnly) + let right = mapVertices rightAnnotation rightPointsMesh + expectedCombined = mapVertices (\point -> (point, rightAnnotation point)) sharedReference + taggedLeft = mapVertices (\point -> ExclusiveAnnotation point LeftOperand) left + taggedRight = mapVertices (\point -> ExclusiveAnnotation point RightOperand) rightPointsMesh + taggedExclusive = + mapVertices + (\point -> ExclusiveAnnotation point (if point `elem` leftOnly then LeftOperand else RightOperand)) + exclusiveReference + unless (siteRelation left right == PartialOverlap (length shared)) $ + fail "siteRelation changed when the vertex annotation type changed" + combined <- requireRight "annotation intersectionWith" (intersectionWith (,) left right) + restricted <- requireRight "annotation restriction" (intersectionWith const left right) + removed <- requireRight "annotation difference" (difference left right) + exclusive <- requireRight "annotation symmetric difference" (symmetricDifference taggedLeft taggedRight) + assertAnnotatedMesh "intersectionWith combines left then right" expectedCombined combined + assertAnnotatedMesh "intersectionWith const restricts the left section" sharedReference restricted + assertAnnotatedMesh "difference preserves left annotations" leftOnlyReference removed + assertAnnotatedMesh "symmetric difference preserves the annotation of each exclusive owner" taggedExclusive exclusive + +data ExclusiveOperand + = LeftOperand + | RightOperand + deriving stock (Eq) + +data ExclusiveAnnotation = ExclusiveAnnotation !(Point) !ExclusiveOperand + deriving stock (Eq) + +rightAnnotation :: Point -> (Double, Double) +rightAnnotation (Point x y) = (x + y, x - y) + +canonicalPointMesh :: String -> [Point] -> IO (DelaunayTriangulation (Point)) +canonicalPointMesh label points = + pointMeshOf label points + >>= requireRight ("canonicalize " <> label) . canonicalize + +assertAnnotatedMesh :: Eq mesh => String -> mesh -> mesh -> IO () +assertAnnotatedMesh label expected actual = + unless (expected == actual) (fail (label <> ": structural values differ")) + +assertSetEquation + :: String + -> Either BuildError Mesh + -> Either BuildError Mesh + -> IO () +assertSetEquation label leftExpression rightExpression = do + left <- requireRight (label <> " left") leftExpression + right <- requireRight (label <> " right") rightExpression + leftCanonical <- requireRight (label <> " canonical left") (canonicalize left) + rightCanonical <- requireRight (label <> " canonical right") (canonicalize right) + assertMesh label leftCanonical rightCanonical + +assertCanonicalFixedPoint :: String -> Either BuildError Mesh -> IO () +assertCanonicalFixedPoint label expression = do + result <- requireRight label expression + fixedPoint <- requireRight (label <> " fixed point") (canonicalize result) + assertMesh label result fixedPoint + +-- | Six representatives retain empty, degenerate, nested, partially +-- overlapping and equal-support/different-publication cases without turning +-- every ternary law into the full nine-cubed join corpus already exercised +-- above. +setLawOperands :: IO [(String, Mesh)] +setLawOperands = + filter + (\(name, _) -> name `elem` ["void", "single", "lattice-lower", "lattice-upper", "scattered", "scattered-scrambled"]) + <$> operands + +-- ── construction ───────────────────────────────────────────────────────────── + +-- | Deal the sites round-robin into @count@ shards, so every shard spans the +-- whole extent and the joins are genuinely overlapping rather than separable. +shardMeshes :: Int -> [Point] -> IO [Mesh] +shardMeshes count sites = + traverse + (\shard -> meshOf ("shard " <> show shard) [site | (index, site) <- indexed, index `mod` count == shard]) + [0 .. count - 1] + where + indexed = zip [0 :: Int ..] sites + +-- | Combine by repeatedly joining a pseudo-randomly chosen adjacent pair, so +-- that successive seeds give genuinely different bracketings. +bracketRandomly :: Word64 -> [Mesh] -> Either BuildError Mesh +bracketRandomly _ [] = unions [] +bracketRandomly _ [single] = Right single +bracketRandomly seed values = + let !stepped = advance seed + !cut = fromIntegral (stepped `mod` fromIntegral (length values - 1)) + in joinAdjacent cut values >>= bracketRandomly stepped + +-- | Replace the pair at @index@ with its join, leaving everything else alone. +joinAdjacent :: Int -> [Mesh] -> Either BuildError [Mesh] +joinAdjacent index (left : right : rest) + | index <= 0 = (: rest) <$> union left right + | otherwise = (left :) <$> joinAdjacent (index - 1) (right : rest) +joinAdjacent _ rest = Right rest + +-- | A site is a coordinate carrying a tag. The join acts on tags alone: two +-- annotations only ever meet at a shared coordinate, where the positions +-- already agree, so geometry is never authored by the payload. +data Site = Site !(Point) !Int + deriving stock (Eq, Show) + +instance HasPosition Site where + position (Site point _) = point + +instance JoinSemilattice Site where + joinAnnotations (Site point left) (Site _ right) = Site point (max left right) + +type AnnotatedMesh = Triangulation 'Unconstrained Site () () () + +annotatedMesh :: String -> [Site] -> IO AnnotatedMesh +annotatedMesh label sites = + buildTriangulation <$> requireRight label (delaunay unitElementDefaults (V.fromList sites)) + +-- Keyed on the coordinate plane rather than on the payload's own point, +-- because geometry is authoritative and a payload that disagreed with it must +-- not be able to hide behind itself. +tagsOf :: AnnotatedMesh -> Map.Map (Double, Double) Int +tagsOf mesh = + Map.fromList + [ ((x, y), tag) + | vertex <- vertices mesh + , let Point x y = vertexPoint mesh vertex + , let Site _ tag = vertexData mesh vertex + ] + +-- The whole law in one equation: the union's annotation at every site is the +-- join of whatever the operands carried there. +assertGluing :: String -> [Site] -> [Site] -> IO () +assertGluing label leftSites rightSites = do + left <- annotatedMesh (label <> " left") leftSites + right <- annotatedMesh (label <> " right") rightSites + glued <- requireRight (label <> " union") (union left right) + assertEqualTags + (label <> ": union glues shared annotations by join") + (Map.unionWith max (tagsOf left) (tagsOf right)) + (tagsOf glued) + +assertEqualTags :: String -> Map.Map (Double, Double) Int -> Map.Map (Double, Double) Int -> IO () +assertEqualTags label expected actual = + unless (expected == actual) $ + fail (label <> ": expected " <> show (Map.toList expected) <> ", got " <> show (Map.toList actual)) + +-- The plan is chosen by size: a small addition is inserted into the larger +-- operand, and only comparably sized operands are rebuilt canonically. Both +-- paths glue, and only running both shows it. +testJoinGluesAnnotations :: IO () +testJoinGluesAnnotations = do + assertGluing + "insertion plan" + [Site (Point 0 0) 1, Site (Point 6 0) 1, Site (Point 0 6) 1, Site (Point 2 1) 7] + [Site (Point 0 0) 5, Site (Point 6 0) 2, Site (Point 0 6) 3, Site (Point 4 3) 9] + assertGluing "rebuild plan" (grid 0 1) (grid 6 2) + where + -- Two hundred-odd sites overlapping in half, so neither operand is small + -- enough to be inserted into the other and the canonical rebuild is taken. + grid offset tag = + [ Site (Point (fromIntegral column) (fromIntegral row)) (tag * (column + row)) + | column <- [offset .. offset + 11 :: Int] + , row <- [0 .. 9 :: Int] + ] diff --git a/test/algebra/Moonlight/Triangulation/ScheduleAgreementSpec.hs b/test/algebra/Moonlight/Triangulation/ScheduleAgreementSpec.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/ScheduleAgreementSpec.hs @@ -0,0 +1,72 @@ +-- | The schedule-agreement slice: the seam merge publishes what the reference +-- rebuild publishes. It travels and dies with the schedule it names. +module Moonlight.Triangulation.ScheduleAgreementSpec (tests) where + +import Control.Monad (forM_, when) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Moonlight.Triangulation (Point (Point), canonicalize, union) +import Moonlight.Triangulation.AlgebraFixtures + ( assertMesh + , meshOf + , operands + , separatedOperands + , siteList + ) +import Moonlight.Triangulation.Internal.Join.Seam (executeSeam, planSeam) +import Support (requireRight) + +tests :: IO () +tests = do + testSeamAgreesWithReference + putStrLn "schedule agreement: ok" + +-- | The seam schedule and the reference schedule are the same function. +-- +-- A join has one meaning and several internal schedules, so this is the law +-- that lets a second one exist at all: for every input where the seam applies, +-- it must publish the value the rebuild publishes — not an isomorphic mesh, the +-- same value, once both are canonically numbered. +-- +-- The guard matters more than the equality. 'executeSeam' can only be reached +-- with the opaque proof returned by 'planSeam'; the run fails if too few cases +-- obtain that proof, so the reference cannot quietly be compared with itself. +testSeamAgreesWithReference :: IO () +testSeamAgreesWithReference = do + separable <- separatedOperands + overlapping <- operands + taken <- newIORef (0 :: Int) + forM_ separable $ \((leftName, left), (rightName, right)) -> do + let label = "seam " <> leftName <> " / " <> rightName + seamPlan <- case planSeam left right of + Nothing -> + fail (label <> ": the operands are separated but planSeam refused them") + Just admitted -> do + modifyIORef' taken (+ 1) + pure admitted + rawRebuild <- meshOf label [Point x y | (x, y) <- siteList left <> siteList right] + rebuilt <- requireRight (label <> ", canonical rebuild") (canonicalize rawRebuild) + seamed <- requireRight (label <> ", direct seam") (executeSeam seamPlan left right) + canonicalSeam <- requireRight (label <> ", canonical seam") (canonicalize seamed) + assertMesh (label <> ", against a rebuild") rebuilt canonicalSeam + joined <- requireRight (label <> ", through union") (union left right) + canonicalJoined <- requireRight (label <> ", canonical union") (canonicalize joined) + assertMesh (label <> ", through the operator") rebuilt canonicalJoined + forM_ [(l, r) | l <- overlapping, r <- overlapping] $ \((leftName, left), (rightName, right)) -> + case planSeam left right of + Nothing -> pure () + Just seamPlan -> do + rawRebuild <- + meshOf + ("seam admission " <> leftName <> " / " <> rightName) + [Point x y | (x, y) <- siteList left <> siteList right] + rebuilt <- requireRight "seam admission canonical rebuild" (canonicalize rawRebuild) + seamed <- requireRight "seam admission" (executeSeam seamPlan left right) + canonicalSeam <- requireRight "seam admission canonical seam" (canonicalize seamed) + assertMesh + ("seam admission " <> leftName <> " / " <> rightName) + rebuilt + canonicalSeam + modifyIORef' taken (+ 1) + count <- readIORef taken + when (count < 3) $ + fail ("seam agreement: only " <> show count <> " cases entered the seam, so the law asserted nothing") diff --git a/test/coherence/Main.hs b/test/coherence/Main.hs new file mode 100644 --- /dev/null +++ b/test/coherence/Main.hs @@ -0,0 +1,13 @@ +-- | Compile every test slice against the union of their dependencies. Empty +-- imports make module and instance collisions observable without executing the +-- four focused behavioral suites twice. +module Main (main) where + +import Moonlight.Triangulation.AlgebraSpec () +import Moonlight.Triangulation.NativeSpec () +import Moonlight.Triangulation.ParallelSpec () +import Moonlight.Triangulation.ScheduleAgreementSpec () +import Moonlight.Triangulation.SerializationSpec () + +main :: IO () +main = pure () diff --git a/test/native/Main.hs b/test/native/Main.hs new file mode 100644 --- /dev/null +++ b/test/native/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.NativeSpec as NativeSpec + +main :: IO () +main = NativeSpec.tests diff --git a/test/native/Moonlight/Triangulation/FilteredPredicateOptimizationSpec.hs b/test/native/Moonlight/Triangulation/FilteredPredicateOptimizationSpec.hs new file mode 100644 --- /dev/null +++ b/test/native/Moonlight/Triangulation/FilteredPredicateOptimizationSpec.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -O1 #-} + +-- | The allocation law for the optimized filtered-predicate artifact. This +-- module remains at O1 when the surrounding behavioral body is compiled at O0; +-- without the simplifier, the loop does not unbox and the witness is vacuous. +module Moonlight.Triangulation.FilteredPredicateOptimizationSpec + ( assertFilteredPredicatesSkipExactOracle + ) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad (unless) +import GHC.Stats (allocated_bytes, getRTSStats, getRTSStatsEnabled) +import Moonlight.Triangulation.Math + ( inCircle + , inCircleDetApprox + , orient2d + , orientDetApprox + ) +import Moonlight.Triangulation.Types (Point (..)) +import System.Mem (performGC) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Data.Word (Word64) + +-- | A filtered predicate must not evaluate its exact oracle when the floating +-- approximation already certifies the sign. The exact path allocates +-- 'Integer's, so equal-shaped certified and degenerate folds expose whether +-- that fallback remains genuinely conditional. +assertFilteredPredicatesSkipExactOracle :: IO () +assertFilteredPredicatesSkipExactOracle = do + enabled <- getRTSStatsEnabled + unless enabled $ fail "allocation counters unavailable: the suite must run with -T" + let count = 20_000 + bigScale = 2 ^^ (200 :: Int) :: Double + smallScale = 2 ^^ (-200 :: Int) :: Double + orientCertified = + V.generate + count + (\index -> Point (fromIntegral index * bigScale) (if even index then 0 else smallScale)) + orientDegenerate = + V.generate + count + (\index -> Point (fromIntegral index * bigScale) (fromIntegral index * smallScale)) + zigzag = V.generate count (\index -> Point (fromIntegral index) (if even index then 0 else 1)) + collinear = V.generate count (\index -> Point (fromIntegral index) (fromIntegral index)) + orientationIndices = U.enumFromN 0 (max 0 (count - 2)) + circleIndices = U.enumFromN 0 (max 0 (count - 3)) + _ <- evaluate (force orientCertified) + _ <- evaluate (force orientDegenerate) + _ <- evaluate (force zigzag) + _ <- evaluate (force collinear) + _ <- evaluate (force orientationIndices) + _ <- evaluate (force circleIndices) + certifiedSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientCertified) + fallbackSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientDegenerate) + certified <- allocationOf (sumTripleRelations orient2d orientationIndices orientCertified) + fallback <- allocationOf (sumTripleRelations orient2d orientationIndices orientDegenerate) + let certifiedOracle = allocationBeyondApproximation certified certifiedSupport + fallbackOracle = allocationBeyondApproximation fallback fallbackSupport + unless (fallbackOracle > 0) $ + fail "degenerate orientations allocated nothing: the measurement is not observing the oracle" + unless (certifiedOracle * 8 < fallbackOracle) $ + fail + ( "orient2d evaluates its exact oracle on certified input: " + <> show certifiedOracle + <> " excess bytes certified versus " + <> show fallbackOracle + <> " excess bytes degenerate (raw " + <> show certified + <> " versus " + <> show fallback + <> ")" + ) + certifiedCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices zigzag) + fallbackCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices collinear) + certifiedCircle <- allocationOf (sumQuadRelations inCircle circleIndices zigzag) + fallbackCircle <- allocationOf (sumQuadRelations inCircle circleIndices collinear) + let certifiedCircleOracle = allocationBeyondApproximation certifiedCircle certifiedCircleSupport + fallbackCircleOracle = allocationBeyondApproximation fallbackCircle fallbackCircleSupport + unless (fallbackCircleOracle > 0) $ + fail "degenerate incircles allocated nothing: the measurement is not observing the oracle" + unless (certifiedCircleOracle * 8 < fallbackCircleOracle) $ + fail + ( "inCircle evaluates its exact oracle on certified input: " + <> show certifiedCircleOracle + <> " excess bytes certified versus " + <> show fallbackCircleOracle + <> " excess bytes degenerate (raw " + <> show certifiedCircle + <> " versus " + <> show fallbackCircle + <> ")" + ) + +allocationOf :: Int -> IO Word64 +allocationOf work = do + performGC + before <- allocated_bytes <$> getRTSStats + _ <- evaluate work + performGC + after <- allocated_bytes <$> getRTSStats + pure (after - before) + +allocationBeyondApproximation :: Word64 -> Word64 -> Word64 +allocationBeyondApproximation measured support = measured - min measured support + +sumTripleRelations + :: (Point -> Point -> Point -> Ordering) + -> U.Vector Int + -> V.Vector (Point) + -> Int +sumTripleRelations relation indices points = + U.foldl' + (\accumulated index -> + accumulated + + fromEnum + ( relation + (V.unsafeIndex points index) + (V.unsafeIndex points (index + 1)) + (V.unsafeIndex points (index + 2)) + ) + ) + 0 + indices +{-# INLINE sumTripleRelations #-} + +sumQuadRelations + :: (Point -> Point -> Point -> Point -> Ordering) + -> U.Vector Int + -> V.Vector (Point) + -> Int +sumQuadRelations relation indices points = + U.foldl' + (\accumulated index -> + accumulated + + fromEnum + ( relation + (V.unsafeIndex points index) + (V.unsafeIndex points (index + 1)) + (V.unsafeIndex points (index + 2)) + (V.unsafeIndex points (index + 3)) + ) + ) + 0 + indices +{-# INLINE sumQuadRelations #-} + +approximateOrientation :: Point -> Point -> Point -> Ordering +approximateOrientation a b c = compare (orientDetApprox a b c) 0 +{-# INLINE approximateOrientation #-} + +approximateInCircle :: Point -> Point -> Point -> Point -> Ordering +approximateInCircle a b c d = compare (inCircleDetApprox a b c d) 0 +{-# INLINE approximateInCircle #-} diff --git a/test/native/Moonlight/Triangulation/NativeSpec.hs b/test/native/Moonlight/Triangulation/NativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/native/Moonlight/Triangulation/NativeSpec.hs @@ -0,0 +1,2956 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | The native core slice: everything that needs no serialization surface. +module Moonlight.Triangulation.NativeSpec (tests) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Control.Monad (forM_, unless, void, when) +import Control.Monad.ST (runST, stToIO) +import GHC.Float (castDoubleToWord64) +import Data.Maybe (isJust) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.List (sort) +import qualified Data.Vector as V +import Data.Primitive.PrimArray (indexPrimArray, primArrayFromList, sizeofPrimArray) +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MUV +import Data.Word (Word32, Word64) +import Moonlight.Triangulation.BulkLoad +import Moonlight.Triangulation.Cdt +import Moonlight.Triangulation.Dcel +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.FloodFillIterator +import Moonlight.Triangulation.Handles +import Moonlight.Triangulation.HintGenerator +import Moonlight.Triangulation.Interpolation +import Moonlight.Triangulation.IntersectionIterator +import Moonlight.Triangulation.Math +import Moonlight.Triangulation.Payload +import Moonlight.Triangulation.FilteredPredicateOptimizationSpec + ( assertFilteredPredicatesSkipExactOracle + ) +import Moonlight.Triangulation.PointLocation +import Moonlight.Triangulation.Refinement +import Moonlight.Triangulation.Removal +import Moonlight.Triangulation.Scalar +import Moonlight.Triangulation.Session +import Moonlight.Triangulation.Types +import Moonlight.Triangulation.Validation +import Moonlight.Triangulation.Voronoi +import Moonlight.Triangulation.Handles.Dynamic qualified as Dynamic +import Moonlight.Triangulation.Handles.Iterators.DynamicIterators qualified as DynamicIterators +import Moonlight.Triangulation.Internal.Canonical (canonicalize) +import Moonlight.Triangulation.Internal.Paged (Paged, fromVector, toVector) +import Moonlight.Triangulation.Internal.PointIndex + ( MutablePointIndexUpdate (..) + , lookupMutablePoint + , newMutablePointIndex + , relocateMutablePoint + , removeMutablePoint + , seedMutablePointIndex + ) +import Moonlight.Triangulation.Internal.Representation qualified as Internal +import Moonlight.Triangulation.Voronoi.Handles qualified as VoronoiDynamic +import GHC.Generics (Generic) +import Support (assertEqual, assertValid, requireQueryPoint, requireRight) + +tests :: IO () +tests = do + testConstructors + testPredicates + testParaboloidLift + assertFilteredPredicatesSkipExactOracle + testValidationRejectsCorruptedMeshes + testRefinementCompletionIsAFixpoint + testScalarFormat + testWideDistanceNearestNeighbor + testIncrementalLocationDescent + testPersistentInsertionReusesFrozenLocation + testCircleSweepBulkLoad + testMixedEditSession + testBulkRemovalAgreement + testMutablePointIndexWraparoundBackshift + testBatchIdentityIndexBatchToEmpty + testBatchIdentityIndexToSingletonActive + testBulkIdentityIndexDoesNotEscapeRemovalBatch + testHierarchyRemovalAgreement + testHandlesAndFiniteDcel + testDegenerateConstruction + testPersistentLocalUpdates + testGenericPayloads + testPayloadMaps + testPayloadTraversals + testRewritePayloadIdentity + testPointLocationAndHints + testHierarchyNestingLaw + testSibsonInterpolation + testVoronoiDual + testRemoval + testConstrainedDelaunay + testAnnotatedConstrainedUnion + testAsymmetricConstrainedExtension + testLargeAsymmetricConstrainedExtension + testSeparatedConstrainedSeam + testConstrainedRefinement + testCheckedLocalRefinement + testRepeatedBoundaryAdjacentRefinement + testTraversal + testRandomizedConstruction + testErrors + putStrLn "all native core tests passed" + +data SampleVertex = SampleVertex + { samplePosition :: !(Point) + , sampleLabel :: !Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance HasPosition SampleVertex where + position = samplePosition + + +testConstructors :: IO () +testConstructors = do + let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point) + originQuery <- requireQueryPoint "empty location query" (Point 0 0) + assertValid "empty" vacant + assertEqual "empty vertex count" 0 (numVertices vacant) + assertEqual "empty directed edge count" 0 (numDirectedEdges vacant) + assertEqual "empty face count" 1 (numFaces vacant) + assertEqual "empty locates nowhere" EmptyTriangulation (locatePoint vacant originQuery) + built <- requirePointBuild "clear source" [Point 0 0, Point 1 0, Point 0 1] + assertEqual "clear returns the origin" vacant (clear (buildTriangulation built)) + +type NativeMesh = Triangulation 'Unconstrained (Point) () () () + +-- | A named corruption of a mesh that was valid one line earlier, paired with +-- the violation it must provoke. Validation that has never been made to fail is +-- evidence only that it ran. +data Corruption = Corruption + { corruptionName :: String + , corruptMesh :: NativeMesh -> NativeMesh + , provokes :: InvariantViolation -> Bool + } + +-- Sheared so that no four sites are cocircular: on a square grid the diagonal +-- of every cell is a free choice, and a fixture that admits two answers cannot +-- witness a wrong one. +corruptionFixture :: [Point] +corruptionFixture = + [ Point (fromIntegral column + 0.25 * fromIntegral row) (1.3 * fromIntegral row) + | column <- [0 .. 3 :: Int] + , row <- [0 .. 3 :: Int] + ] + +rewritePlane :: (U.Unbox a, Num a) => (U.Vector a -> U.Vector a) -> Paged a -> Paged a +rewritePlane edit = fromVector 0 . edit . toVector + +slot :: U.Unbox a => Int -> a -> U.Vector a -> U.Vector a +slot at value = (U.// [(at, value)]) + +-- Past the end of every plane in the fixture, and far from the sentinels the +-- packed representation reserves for absence. +beyond :: NativeMesh -> Word32 +beyond mesh = fromIntegral (numDirectedEdges mesh + numVertices mesh + 64) + +onTopology :: (NativeMesh -> U.Vector Word32 -> U.Vector Word32) -> NativeMesh -> NativeMesh +onTopology edit mesh = + mesh {Internal.triHalfTopology = rewritePlane (edit mesh) (Internal.triHalfTopology mesh)} + +-- The half-edge plane has stride four — origin, next, previous, face — so the +-- first four entries below are one surgery distinguished only by which field +-- the out-of-range index lands on. +structuralCorruptions :: [Corruption] +structuralCorruptions = + [ Corruption + "edge origin names an absent vertex" + (onTopology (slot 0 . beyond)) + (\case EdgeOriginOutOfRange {} -> True; _ -> False) + , Corruption + "edge next names an absent edge" + (onTopology (slot 1 . beyond)) + (\case EdgeNextOutOfRange {} -> True; _ -> False) + , Corruption + "edge previous names an absent edge" + (onTopology (slot 2 . beyond)) + (\case EdgePreviousOutOfRange {} -> True; _ -> False) + , Corruption + "edge face names an absent face" + (onTopology (slot 3 . beyond)) + (\case EdgeFaceOutOfRange {} -> True; _ -> False) + , Corruption + "vertex outgoing names an absent edge" + ( \mesh -> + mesh + { Internal.triVertexOut = + rewritePlane (slot 0 (beyond mesh)) (Internal.triVertexOut mesh) + } + ) + (\case VertexOutgoingOutOfRange {} -> True; _ -> False) + , Corruption + "a coordinate plane is one short" + (\mesh -> mesh {Internal.triPointX = rewritePlane U.init (Internal.triPointX mesh)}) + (\case CoordinatePlaneLengthMismatch {} -> True; _ -> False) + , Corruption + "every inner face wound clockwise" + (\mesh -> mesh {Internal.triPointY = rewritePlane (U.map negate) (Internal.triPointY mesh)}) + (\case InnerFaceNotCounterClockwise {} -> True; _ -> False) + ] + +-- Structural corruption is caught before geometry is read, so the empty-circle +-- law needs a mesh that stays well formed and merely stops being Delaunay. +delaunayCorruptions :: [Corruption] +delaunayCorruptions = + [ Corruption + "one site dragged through its neighbours' circumcircles" + (\mesh -> mesh {Internal.triPointX = rewritePlane (slot 5 40) (Internal.triPointX mesh)}) + (\case LocallyIllegalDelaunayEdge {} -> True; _ -> False) + ] + +-- A surgery that changed nothing would report the oracle as unarmed when in +-- truth it was never asked anything, so the mutant must differ before its +-- rejection means a thing. +assertRejects + :: String -> (NativeMesh -> [InvariantViolation]) -> NativeMesh -> Corruption -> IO () +assertRejects oracle check pristine corruption = do + let mutant = corruptMesh corruption pristine + label = oracle <> " / " <> corruptionName corruption + reported = check mutant + when (mutant == pristine) $ fail (label <> ": the surgery changed nothing") + unless (any (provokes corruption) reported) $ + fail (label <> ": admitted, reporting " <> show reported) + +testValidationRejectsCorruptedMeshes :: IO () +testValidationRejectsCorruptedMeshes = do + built <- requirePointBuild "corruption fixture" corruptionFixture + let pristine = buildTriangulation built + assertValid "corruption fixture" pristine + mapM_ (assertRejects "topology" validateTopology pristine) structuralCorruptions + mapM_ (assertRejects "delaunay" validateDelaunay pristine) delaunayCorruptions + +-- Twin half-edges are arithmetic complements, so a crossing's undirected +-- identity is its handle halved. Comparing cardinality alone would admit a +-- traversal that returned the right number of the wrong crossings. +crossingIdentity :: Intersection -> Either Int Int +crossingIdentity = \case + EdgeIntersection edge -> Right (fromIntegral (unDirectedEdgeId edge) `quot` 2) + EdgeOverlap edge -> Right (fromIntegral (unDirectedEdgeId edge) `quot` 2) + VertexIntersection vertex -> Left (fromIntegral (unVertexId vertex)) + +-- | What @refinementComplete@ claims is that the quality worklist drained. The +-- assertable content of that claim is a fixpoint: a second pass under the same +-- parameters can admit nothing. The complementary run is budget-starved, where +-- the run must stop short and spend exactly what it was given. +testRefinementCompletionIsAFixpoint :: IO () +testRefinementCompletionIsAFixpoint = do + -- Barrier parity needs constraints to bound a domain: on an unconstrained + -- mesh every face sits at depth zero, so excluding outer faces excludes all + -- of them and the worklist drains having refined nothing. + bounded <- + requireRight "refinement fixpoint domain" $ + constrainedDelaunay + unitElementDefaults + (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8]) + (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]) + let source = buildTriangulation bounded + parameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just 500 + , refineMaxArea = Just 3 + , refineExcludeOuterFaces = True + } + drained <- requireRight "drained refinement" (refine id parameters source) + unless (refinementComplete drained) $ + fail "the refinement budget was too small to drain the worklist" + -- Without this the fixpoint below is vacuous: a run that refined nothing + -- trivially admits nothing on a second pass. + unless (refinementAddedVertices drained > 0) $ + fail "the drained run inserted no Steiner points, so the fixpoint proves nothing" + assertValid "drained refinement" (refinedTriangulation drained) + again <- requireRight "second refinement pass" (refine id parameters (refinedTriangulation drained)) + assertEqual + "a drained worklist admits nothing on a second pass" + 0 + (refinementAddedVertices again) + starved <- + requireRight + "starved refinement" + (refine id parameters {refineMaxAdditionalVertices = Just 3} source) + when (refinementComplete starved) $ + fail "a three-vertex budget reported a drained worklist" + assertEqual "a starved run spends exactly its budget" 3 (refinementAddedVertices starved) + +testScalarFormat :: IO () +testScalarFormat = do + let binary64 = scalarBinaryFormat + assertEqual "binary64 radix" 2 (formatRadix binary64) + assertEqual "binary64 mantissa" 53 (formatMantissaDigits binary64) + assertEqual "binary64 unit roundoff" (encodeFloat 1 (-53)) (scalarUnitRoundoff :: Double) + +testWideDistanceNearestNeighbor :: IO () +testWideDistanceNearestNeighbor = do + let largePoints = V.fromList + [ Point 0 0 + , Point 1.0e20 0 + , Point 2.0e20 0 + , Point 1.0e20 1.0e19 + ] :: V.Vector (Point) + largeBuild <- requireRight "wide-distance build" (delaunay unitElementDefaults largePoints) + let largeTriangulation = buildTriangulation largeBuild + assertValid "wide-distance triangulation" largeTriangulation + query <- requireQueryPoint "wide-distance query" (Point 1.05e20 0) + case nearestNeighbor largeTriangulation Nothing query of + Nothing -> fail "wide-distance nearest-neighbor returned Nothing" + Just (nearest, _) -> assertEqual "wide-distance nearest-neighbor" (VertexId 1) nearest + +data IncrementalLocationEvidence = IncrementalLocationEvidence + { incrementalTriangulation :: !(DelaunayTriangulation (Point)) + , incrementalWalkSteps :: {-# UNPACK #-} !Int + , incrementalFallbacks :: {-# UNPACK #-} !Int + } + +testIncrementalLocationDescent :: IO () +testIncrementalLocationDescent = do + small <- collectIncrementalLocationEvidence 500 + large <- collectIncrementalLocationEvidence 1000 + assertEqual "incremental location fallbacks/500" 0 (incrementalFallbacks small) + assertEqual "incremental location fallbacks/1000" 0 (incrementalFallbacks large) + unless (2 * incrementalWalkSteps large < 7 * incrementalWalkSteps small) $ + fail + ( "incremental location approached quadratic growth: " + <> show (incrementalWalkSteps small, incrementalWalkSteps large) + ) + assertValid "incremental location descent/1000" (incrementalTriangulation large) + +collectIncrementalLocationEvidence :: Int -> IO IncrementalLocationEvidence +collectIncrementalLocationEvidence count = + V.foldM' insertAndAccumulate initialEvidence (V.fromList (randomPoints 0xc1ac_10ca count)) + where + initialEvidence = + IncrementalLocationEvidence + { incrementalTriangulation = empty unitElementDefaults + , incrementalWalkSteps = 0 + , incrementalFallbacks = 0 + } + + insertAndAccumulate evidence point = do + result <- requireRight "incremental location descent" (insert (incrementalTriangulation evidence) point) + let stats = insertionStats result + pure + IncrementalLocationEvidence + { incrementalTriangulation = insertionTriangulation result + , incrementalWalkSteps = incrementalWalkSteps evidence + statLocationWalkSteps stats + , incrementalFallbacks = incrementalFallbacks evidence + statLocationFallbacks stats + } + +-- A persistent insertion locates on the frozen mesh before opening its dense +-- transaction. The thaw preserves every extant handle, so a lawful frozen +-- location can be interpreted directly without a second mutable walk. A +-- degenerate-line outside witness lacks the terminal-edge evidence its mutable +-- interpreter requires, so that one stratum deliberately retains the mutable +-- fallback. Exercise every frozen stratum, including the singleton's edge-less +-- outside witness, rather than testing only the ordinary face case. +testPersistentInsertionReusesFrozenLocation :: IO () +testPersistentInsertionReusesFrozenLocation = do + let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point) + emptyLocation <- assertPersistentInsertionFromFrozenLocation "empty" Inserted vacant (Point 0 0) + assertEqual "empty insertion frozen location" EmptyTriangulation emptyLocation + + singletonBuild <- requirePointBuild "singleton frozen location" [Point 0 0] + singletonLocation <- + assertPersistentInsertionFromFrozenLocation + "singleton outside insertion" + Inserted + (buildTriangulation singletonBuild) + (Point 2 0) + assertEqual "singleton insertion frozen location" (OutsideConvexHull Nothing) singletonLocation + + lineBuild <- requirePointBuild "line frozen locations" [Point 0 0, Point 2 0, Point 4 0] + let line = buildTriangulation lineBuild + lineEdgeLocation <- assertPersistentInsertionFromFrozenLocation "line edge insertion" Inserted line (Point 1 0) + case lineEdgeLocation of + OnEdge _ -> pure () + other -> fail ("line edge insertion located " <> show other) + lineOutsideLocation <- assertPersistentInsertionFromFrozenLocation "line extension" Inserted line (Point 6 0) + case lineOutsideLocation of + OutsideConvexHull (Just _) -> pure () + other -> fail ("line extension located " <> show other) + + triangleBuild <- requirePointBuild "area frozen locations" [Point 0 0, Point 4 0, Point 0 4] + let triangle = buildTriangulation triangleBuild + faceLocation <- assertPersistentInsertionFromFrozenLocation "face insertion" Inserted triangle (Point 1 1) + case faceLocation of + InFace _ -> pure () + other -> fail ("face insertion located " <> show other) + edgeLocation <- assertPersistentInsertionFromFrozenLocation "area edge insertion" Inserted triangle (Point 2 0) + case edgeLocation of + OnEdge _ -> pure () + other -> fail ("area edge insertion located " <> show other) + hullLocation <- assertPersistentInsertionFromFrozenLocation "hull insertion" Inserted triangle (Point 5 1) + case hullLocation of + OutsideConvexHull (Just _) -> pure () + other -> fail ("hull insertion located " <> show other) + duplicateLocation <- assertPersistentInsertionFromFrozenLocation "duplicate insertion" AlreadyPresent triangle (Point 0 0) + assertEqual "duplicate insertion frozen location" (OnVertex (VertexId 0)) duplicateLocation + +assertPersistentInsertionFromFrozenLocation + :: String + -> InsertionDisposition + -> DelaunayTriangulation (Point) + -> Point + -> IO Location +assertPersistentInsertionFromFrozenLocation label expectedDisposition source point = do + query <- requireQueryPoint (label <> " frozen query") point + let (located, walked) = locatePointWithHint source Nothing query + sourceVertices = numVertices source + usesMutableFallback = + case located of + OutsideConvexHull (Just _) -> numInnerFaces source == 0 + _ -> False + result <- requireRight (label <> " insert") (insert source point) + ((referenceVertex, referenceDisposition), reference, _) <- + requireRight (label <> " session reference") $ + withSession source 1 (insertVertexAt point point) + let stats = insertionStats result + expectedVertices = + case expectedDisposition of + Inserted -> sourceVertices + 1 + AlreadyPresent -> sourceVertices + expectedUnique = + case expectedDisposition of + Inserted -> 1 + AlreadyPresent -> 0 + expectedExisting = + case expectedDisposition of + Inserted -> 0 + AlreadyPresent -> 1 + assertEqual (label <> " disposition") expectedDisposition (insertionDisposition result) + assertEqual (label <> " session disposition") referenceDisposition (insertionDisposition result) + assertEqual (label <> " session vertex") referenceVertex (insertionVertex result) + assertEqual + (label <> " exact-location topology matches session") + (canonicalEdges reference) + (canonicalEdges (insertionTriangulation result)) + assertEqual (label <> " source remains unchanged") sourceVertices (numVertices source) + assertEqual (label <> " result vertex count") expectedVertices (numVertices (insertionTriangulation result)) + assertEqual (label <> " input count") 1 (statInputPoints stats) + assertEqual (label <> " unique count") expectedUnique (statUniquePoints stats) + assertEqual (label <> " existing count") expectedExisting (statExistingPoints stats) + assertEqual (label <> " duplicate count") expectedExisting (statDuplicatePoints stats) + if usesMutableFallback + then do + let assertAtLeast counter expected actual = + unless + (actual >= expected) + ( fail + ( label + <> " " + <> counter + <> " includes frozen evidence: expected at least " + <> show expected + <> ", got " + <> show actual + ) + ) + assertAtLeast "walk steps" (locationWalkSteps walked) (statLocationWalkSteps stats) + assertAtLeast "walk maximum" (locationWalkSteps walked) (statLocationMaxWalk stats) + assertAtLeast + "fallback count" + (if locationUsedFallback walked then 1 else 0) + (statLocationFallbacks stats) + else do + assertEqual (label <> " frozen walk steps") (locationWalkSteps walked) (statLocationWalkSteps stats) + assertEqual (label <> " frozen walk maximum") (locationWalkSteps walked) (statLocationMaxWalk stats) + assertEqual + (label <> " frozen fallback count") + (if locationUsedFallback walked then 1 else 0) + (statLocationFallbacks stats) + assertValid (label <> " result") (insertionTriangulation result) + pure located + +-- Circle sweep must be a construction schedule, not a second topology. It is +-- compared against the arrival-order session kernel on the same exact inputs. +-- | One session, both verbs. The reason the two published sessions became one: +-- a caller who removes and inserts had to thaw twice and pay the O(n) +-- publication a session exists to delete. +-- +-- Graded against the oracle that needs no second implementation — the Delaunay +-- triangulation of a point set in general position is unique, so a mixed edit +-- must land exactly where a fresh bulk load of the surviving set lands. +testMixedEditSession :: IO () +testMixedEditSession = do + let original = V.fromList (randomPoints 0x5eed1e 400) + doomed = V.take 120 original + survivors = V.drop 120 original + arrivals = V.fromList (randomPoints 0xa7717a1 90) + (_, edited, stats) <- + requireRight "mixed session" $ + withSession + (buildTriangulation (either (error . show) id (delaunay unitElementDefaults original))) + (V.length arrivals) + ( do + V.mapM_ (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))) doomed + V.mapM_ insertVertex arrivals + ) + fresh <- requireRight "fresh rebuild" (delaunay unitElementDefaults (survivors <> arrivals)) + assertEqual + "mixed edit equals a fresh build of the surviving set" + (canonicalEdges (buildTriangulation fresh)) + (canonicalEdges edited) + assertValid "mixed edit session" edited + assertEqual + "the whole transaction charged one counter set" + (V.length arrivals) + (statInputPoints stats) + +-- The bulk removal verb must land exactly where the singleton fold lands, on +-- both sides of its locate-strategy crossover: a small batch keeps the +-- per-question walk, a large one buys the identity index once. Same removals, +-- same order, same survivor either way. +testBulkRemovalAgreement :: IO () +testBulkRemovalAgreement = do + let original = V.fromList (randomPoints 0xb01dca7 400) + base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original)) + run label doomed = do + (outcomes, survived, _) <- + requireRight (label <> " bulk removal") (withSession base 0 (removeManyAt doomed)) + V.imapM_ + ( \index outcome -> + maybe (fail (label <> " bulk removal missed index " <> show index)) (const (pure ())) outcome + ) + outcomes + (_, folded, _) <- + requireRight (label <> " singleton removal fold") $ + withSession + base + 0 + ( V.mapM_ + (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))) + doomed + ) + assertEqual + (label <> " bulk removal equals singleton descent") + (canonicalEdges folded) + (canonicalEdges survived) + assertValid (label <> " bulk removal") survived + run "walking" (V.take 40 original) + run "indexed" (V.take 120 original) + +-- The three fixture positions hash to home slot 15 in the 16-slot table made +-- for three keys. They therefore occupy 15, 0, and 1 in insertion order. The +-- middle deletion exercises both wraparound and backward shift, while the +-- coordinate overwrite models the tail move performed before the table handle +-- is renamed by 'swapRemoveVertex'. +testMutablePointIndexWraparoundBackshift :: IO () +testMutablePointIndexWraparoundBackshift = do + (removed, first, movedBeforeRelocation, relocated, movedAfterRelocation) <- + requireRight "mutable point-index wraparound/backshift law" wraparoundLaw + case removed of + MutablePointIndexUpdated -> pure () + MutablePointIndexInvalidated -> fail "mutable point-index middle delete invalidated a valid table" + assertEqual "mutable point-index first wraparound occupant" (Just 0) first + assertEqual "mutable point-index shifted tail before relocation" (Just 2) movedBeforeRelocation + case relocated of + MutablePointIndexUpdated -> pure () + MutablePointIndexInvalidated -> fail "mutable point-index tail relocation invalidated a valid table" + assertEqual "mutable point-index relocated tail" (Just 1) movedAfterRelocation + where + wraparoundLaw = runST $ do + pointXs <- MUV.replicate 3 (0 :: Double) + pointYs <- MUV.replicate 3 (0 :: Double) + MUV.unsafeWrite pointXs 0 (-20) + MUV.unsafeWrite pointYs 0 (-15) + MUV.unsafeWrite pointXs 1 (-20) + MUV.unsafeWrite pointYs 1 0 + MUV.unsafeWrite pointXs 2 (-20) + MUV.unsafeWrite pointYs 2 7 + table <- newMutablePointIndex 3 + seeded <- seedMutablePointIndex table 3 (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) + case seeded of + Left failure -> pure (Left failure) + Right () -> do + -- The tail has moved into slot one before identity transport begins. + MUV.unsafeWrite pointXs 1 (-20) + MUV.unsafeWrite pointYs 1 7 + removed <- + removeMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 0 1 + first <- + lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) (-15) + movedBeforeRelocation <- + lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7 + relocated <- relocateMutablePoint table (-20) 7 2 1 + movedAfterRelocation <- + lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7 + pure + ( Right + ( removed + , first + , movedBeforeRelocation + , relocated + , movedAfterRelocation + ) + ) + +-- A dense table must also close lawfully when it removes every vertex. The +-- point-keyed query after freeze forces the empty published derivation rather +-- than retaining an impossible ST table. +testBatchIdentityIndexBatchToEmpty :: IO () +testBatchIdentityIndexBatchToEmpty = do + let points = V.fromList (randomPoints 0x7a110bad 32) + built <- requireRight "batch identity empty base" (delaunay unitElementDefaults points) + (outcomes, emptied, _) <- + requireRight "batch identity removes every point" $ + withSession (buildTriangulation built) 0 (removeManyAt points) + unless (V.all isJust outcomes) $ + fail "batch identity table missed a point while removing to empty" + assertEqual "batch identity empty vertex count" 0 (numVertices emptied) + assertValid "batch identity empty result" emptied + absent <- requireRight "empty published identity lookup" (locateAndRemove emptied (Point 0 0)) + case absent of + Nothing -> pure () + Just _ -> fail "empty published identity lookup manufactured a removal" + +-- A dense batch discards its ST table before the next singleton handle rewrite. +-- 'excise' must therefore activate and transport the ordinary persistent index +-- without consulting the expired batch representation. +testBatchIdentityIndexToSingletonActive :: IO () +testBatchIdentityIndexToSingletonActive = do + let original = V.fromList (randomPoints 0x51a91e 64) + doomed = V.take 32 original + survivors = V.drop 32 original + built <- requireRight "batch-to-singleton identity base" (delaunay unitElementDefaults original) + (singletonOutcome, transitioned, _) <- + requireRight "batch-to-singleton identity session" $ + withSession (buildTriangulation built) 0 $ do + _ <- removeManyAt doomed + excise (VertexId 0) + let singletonPoint = removalOutcomePoint singletonOutcome + expected = V.filter (/= singletonPoint) survivors + fresh <- requireRight "batch-to-singleton fresh rebuild" (delaunay unitElementDefaults expected) + assertEqual + "batch-to-singleton identity topology" + (canonicalEdges (buildTriangulation fresh)) + (canonicalEdges transitioned) + assertValid "batch-to-singleton identity result" transitioned + case V.find (/= singletonPoint) survivors of + Nothing -> fail "batch-to-singleton fixture exhausted every survivor" + Just remaining -> do + located <- requireRight "batch-to-singleton published lookup" (locateAndRemove transitioned remaining) + case located of + Nothing -> fail "batch-to-singleton published lookup missed a survivor" + Just removal -> assertValid "batch-to-singleton published removal" (removalTriangulation removal) + +-- The mutable identity table is an internal section of @removeManyAt@, never a +-- session-wide owner. An insertion after the dense batch invalidates it, the +-- subsequent removal walks correctly, and the frozen mesh must rederive the +-- published identity cache from its final coordinate authority. +testBulkIdentityIndexDoesNotEscapeRemovalBatch :: IO () +testBulkIdentityIndexDoesNotEscapeRemovalBatch = do + let original = V.fromList (randomPoints 0x5a11ce 400) + doomed = V.take 120 original + survivors = V.drop 120 original + arrival = Point (-0.25) 0.75 + baseBuild <- requireRight "bulk identity section base" (delaunay unitElementDefaults original) + (_, edited, _) <- + requireRight "bulk identity section mixed session" $ + withSession (buildTriangulation baseBuild) 1 $ do + _ <- removeManyAt doomed + _ <- insertVertexAt arrival arrival + removeAt arrival >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ())) + fresh <- requireRight "bulk identity section fresh survivor rebuild" (delaunay unitElementDefaults survivors) + assertEqual + "bulk identity section mixed program equals fresh survivors" + (canonicalEdges (buildTriangulation fresh)) + (canonicalEdges edited) + assertValid "bulk identity section mixed session" edited + case V.uncons survivors of + Nothing -> fail "bulk identity section test has no survivor" + Just (survivor, _) -> do + located <- requireRight "published lazy identity lookup" (locateAndRemove edited survivor) + case located of + Nothing -> fail "published lazy identity lookup missed survivor" + Just removal -> assertValid "published lazy identity removal" (removalTriangulation removal) + +-- The hierarchy-hinted removal program must land exactly where the unhinted +-- session lands. The guesses are all computed against the original base, so +-- later removals in the batch answer for guesses whose slots swap-compaction +-- has renamed — the walk must correct every one of them. The repaired +-- hierarchy must equal the reference rebuild over the same survivor. +testHierarchyRemovalAgreement :: IO () +testHierarchyRemovalAgreement = do + let original = V.fromList (randomPoints 0x5eed1e55 400) + base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original)) + hierarchy <- requireRight "hierarchy build" (buildHierarchyHint defaultHierarchyBranchFactor base) + let run label doomed = do + (outcomes, survived, repaired) <- + requireRight (label <> " hinted removal") (removeManyWithHierarchy hierarchy base doomed) + V.imapM_ + ( \index outcome -> + maybe (fail (label <> " hinted removal missed index " <> show index)) (const (pure ())) outcome + ) + outcomes + (_, folded, _) <- + requireRight (label <> " unhinted session") (withSession base 0 (removeManyAt doomed)) + reference <- requireRight (label <> " reference rebuild") (rebuildHierarchyHint hierarchy folded) + assertEqual + (label <> " hinted removal equals unhinted session") + (canonicalEdges folded) + (canonicalEdges survived) + assertEqual (label <> " repaired hierarchy equals reference rebuild") reference repaired + assertValid (label <> " hinted removal") survived + run "sparse" (V.take 40 original) + run "dense" (V.take 120 original) + +testCircleSweepBulkLoad :: IO () +testCircleSweepBulkLoad = do + let points = V.fromList (randomPoints 0xc1ac1e 1500) + swept <- requireRight "circle-sweep build" (delaunay unitElementDefaults points) + (_, sessioned, _) <- + requireRight "session build" $ + withSession (empty unitElementDefaults) (V.length points) $ + V.mapM_ insertVertex points + assertEqual + "circle-sweep/session topology" + (canonicalEdges sessioned) + (canonicalEdges (buildTriangulation swept)) + assertValid "circle-sweep build" (buildTriangulation swept) + assertValid "session build" sessioned + +testPredicates :: IO () +testPredicates = do + let a, b, c :: Point + a = Point 0 0 + b = Point 1 0 + c = Point 0 1 + assertEqual "orientation left" GT (orient2d a b c) + assertEqual "orientation right" LT (orient2d b a c) + assertEqual "orientation collinear" EQ (orient2d a b (Point 0.5 0)) + assertEqual "incircle inside" GT (inCircle a b c (Point 0.25 0.25)) + assertEqual "incircle boundary" EQ (inCircle a b c (Point 1 1)) + assertEqual "incircle outside" LT (inCircle a b c (Point 2 2)) + assertEqual "underflow mitigation" (Point 0 1) (mitigateUnderflow (Point 1.0e-44 1 :: Point)) + _ <- requireRight "point validation" (validatePoint Nothing (Point 0 1 :: Point)) + let large = encodeFloat 1 180 :: Double + ulp = encodeFloat 1 128 :: Double + assertEqual + "large exact orientation" + GT + (orient2d (Point large large) (Point (large + ulp) large) (Point large (large + ulp))) + assertEqual + "large exact cocircularity" + EQ + (inCircle + (Point large large) + (Point (large + ulp) large) + (Point large (large + ulp)) + (Point (large + ulp) (large + ulp))) + +testHandlesAndFiniteDcel :: IO () +testHandlesAndFiniteDcel = do + built <- requirePointBuild "handle algebra" [Point 0 0, Point 3 0, Point 0 2, Point 0.4 0.7] + let triangulation = buildTriangulation built + assertValid "handle algebra" triangulation + assertEqual "one outer face" (numInnerFaces triangulation + 1) (numFaces triangulation) + forM_ (directedEdges triangulation) $ \edge -> do + assertEqual "double reversal" edge (reverseEdge (reverseEdge edge)) + assertEqual "next/previous" edge (previous triangulation (next triangulation edge)) + assertEqual "previous/next" edge (next triangulation (previous triangulation edge)) + forM_ (undirectedEdges triangulation) $ \edge -> do + let (forward, backward) = directedPair edge + assertEqual "pair reversal" backward (reverseEdge forward) + assertEqual "undirected projection" edge (asUndirected forward) + assertEqual "vertex iterator" (numVertices triangulation) (length (vertices triangulation)) + assertEqual + "dense vertex projection" + (V.fromList (fmap (vertexPoint triangulation) (vertices triangulation))) + (vertexPoints triangulation) + assertEqual "edge iterator" (numUndirectedEdges triangulation) (length (undirectedEdges triangulation)) + assertEqual "face iterator" (numInnerFaces triangulation) (length (innerFaces triangulation)) + assertEqual + "dense inner-face projection" + (Just (V.toList (innerFaceVertexTriples triangulation))) + (traverse (Dcel.innerFaceVertices triangulation) (innerFaces triangulation)) + assertEqual "dynamic vertex iterator" (numVertices triangulation) (length (DynamicIterators.vertexHandles triangulation)) + assertEqual "dynamic edge iterator" (numDirectedEdges triangulation) (length (DynamicIterators.directedEdgeHandles triangulation)) + assertEqual "dynamic face iterator" (numInnerFaces triangulation) (length (DynamicIterators.innerFaceHandles triangulation)) + unless (geometryTopologyBytes triangulation > topologyIndexBytes triangulation) $ + fail "geometry byte accounting omitted coordinates" + vertex0 <- requireJust "dynamic vertex handle" (Dynamic.vertexHandle triangulation (VertexId 0)) + assertEqual "dynamic vertex fix" (VertexId 0) (Dynamic.fixVertex vertex0) + assertEqual "dynamic vertex position" (vertexPoint triangulation (VertexId 0)) (Dynamic.vertexHandlePosition vertex0) + case Dynamic.vertexHandleOutEdge vertex0 of + Nothing -> fail "connected dynamic vertex has no outgoing edge" + Just edge -> do + assertEqual "dynamic edge reversal" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgeReverse (Dynamic.directedEdgeReverse edge))) + assertEqual "dynamic edge next/previous" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgePrevious (Dynamic.directedEdgeNext edge))) + let face = Dynamic.directedEdgeFace edge + if Dynamic.faceIsOuter face + then pure () + else case Dynamic.faceAsInner face of + Nothing -> fail "non-outer dynamic face did not refine to InnerTag" + Just inner -> do + _ <- requireJust "inner dynamic face vertices" (Dynamic.innerFaceVertices inner) + case Dynamic.innerFaceCircumcenter inner of + Nothing -> fail "inner dynamic face has no circumcenter" + Just _ -> pure () + +testDegenerateConstruction :: IO () +testDegenerateConstruction = do + emptyBuild <- requirePointBuild "empty" [] + emptyQuery <- requireQueryPoint "empty location" (Point 0 0) + assertEqual "empty vertices" 0 (numVertices (buildTriangulation emptyBuild)) + assertEqual "empty location" EmptyTriangulation (locatePoint (buildTriangulation emptyBuild) emptyQuery) + assertValid "empty" (buildTriangulation emptyBuild) + + singleton <- requirePointBuild "singleton" [Point 2 3] + singletonQuery <- requireQueryPoint "singleton lookup" (Point 2 3) + assertEqual "singleton lookup" (OnVertex (VertexId 0)) (locatePoint (buildTriangulation singleton) singletonQuery) + assertValid "singleton" (buildTriangulation singleton) + + duplicates <- requirePointBuild "duplicates" [Point 0 0, Point 1 0, Point (-0.0) 0, Point 1 0, Point 2 0] + assertEqual "deduplicated count" 3 (numVertices (buildTriangulation duplicates)) + assertEqual + "stable duplicate mapping" + (primArrayFromList [0, 1, 0, 1, 2]) + (buildInputVertices duplicates) + assertValid "duplicates" (buildTriangulation duplicates) + + -- Deduplicating a signed zero is not the same claim as storing it canonically: + -- the first only needs '==', which already identifies the two, while anything + -- reading the bit pattern — a radix ordering, a byte-for-byte cross-check — + -- reads the sign bit and gets a coordinate below every other. Both ingest + -- paths canonicalize, and both are held to it here rather than to the weaker + -- statement that comparison happens to survive. + let bits point = (castDoubleToWord64 (pointX point), castDoubleToWord64 (pointY point)) + signedZero <- requirePointBuild "signed zero" [Point (-0.0) (-0.0), Point 1 0, Point 0 1] + assertEqual "bulk load stores a canonical zero" + (0, 0) (bits (vertexPoint (buildTriangulation signedZero) (VertexId 0))) + incremental <- + requireRight "signed zero insert" + (insert (empty unitElementDefaults :: DelaunayTriangulation (Point)) (Point (-0.0) (-0.0))) + assertEqual "insertion stores a canonical zero" + (0, 0) (bits (vertexPoint (insertionTriangulation incremental) (VertexId 0))) + + collinear <- requirePointBuild "collinear" [Point 0 4, Point 0 0, Point 0 3, Point 0 2, Point 0 1] + let line = buildTriangulation collinear + assertEqual "line edge count" 4 (numUndirectedEdges line) + assertEqual "line face count" 0 (numInnerFaces line) + assertValid "collinear terminal splits" line + +testPersistentLocalUpdates :: IO () +testPersistentLocalUpdates = do + base <- requirePointBuild "persistent base" (randomPoints 0x5eed 4095) + let triangulation = buildTriangulation base + query = Point 0.000_123 (-0.000_271) + inserted <- requireRight "persistent insert" (insert triangulation query) + assertEqual "persistent source remains unchanged" 4095 (numVertices triangulation) + assertEqual "persistent result appends one vertex" 4096 (numVertices (insertionTriangulation inserted)) + assertValid "persistent insertion result" (insertionTriangulation inserted) + + let payloads = V.fromList + [ SampleVertex (Point 0 0) 10 + , SampleVertex (Point 1 0) 20 + , SampleVertex (Point 0 1) 30 + ] + defaults = ElementDefaults (0 :: Int) False ("face" :: String) + payloadBuild <- requireRight "payload base" (delaunay defaults payloads) + duplicate <- requireRight "payload-only replacement" (insert (buildTriangulation payloadBuild) (SampleVertex (Point 1 0) 99)) + assertEqual "payload update disposition" AlreadyPresent (insertionDisposition duplicate) + assertEqual "payload replacement" 99 (sampleLabel (vertexData (insertionTriangulation duplicate) (VertexId 1))) + +testGenericPayloads :: IO () +testGenericPayloads = do + let defaults = ElementDefaults (7 :: Int) False ("new-face" :: String) + payloads = V.fromList + [ SampleVertex (Point 0 0) 1 + , SampleVertex (Point 2 0) 2 + , SampleVertex (Point 0 2) 3 + , SampleVertex (Point 0.5 0.5) 4 + ] + built <- requireRight "generic payload build" (delaunay defaults payloads) + let triangulation = buildTriangulation built + assertValid "generic payload build" triangulation + assertEqual "vertex payload" 4 (sampleLabel (vertexData triangulation (VertexId 3))) + forM_ (directedEdges triangulation) $ \edge -> assertEqual "directed default" 7 (directedEdgeData triangulation edge) + forM_ (undirectedEdges triangulation) $ \edge -> assertEqual "undirected default" False (undirectedEdgeData triangulation edge) + forM_ (allFaces triangulation) $ \face -> assertEqual "face default" "new-face" (faceData triangulation face) + (firstEdge, firstFace) <- case (directedEdges triangulation, innerFaces triangulation) of + (edge : _, face : _) -> pure (edge, face) + _ -> fail "generic payload build produced no inner topology" + let firstUndirected = asUndirected firstEdge + changed = setFaceData (setUndirectedEdgeData (setDirectedEdgeData triangulation firstEdge 42) firstUndirected True) firstFace "changed" + assertEqual "directed payload update" 42 (directedEdgeData changed firstEdge) + assertEqual "undirected payload update" True (undirectedEdgeData changed firstUndirected) + assertEqual "face payload update" "changed" (faceData changed firstFace) + -- Geometry owns the points, so a payload carrying a different position is not + -- a contradiction to be refused — it is a payload whose position nobody reads. + let moved = setVertexData triangulation (VertexId 0) (SampleVertex (Point 9 9) 0) + assertEqual "a payload position does not site a vertex" + (vertexPoint triangulation (VertexId 0)) (vertexPoint moved (VertexId 0)) + assertEqual "the payload is stored as given" + (Point 9 9) (samplePosition (vertexData moved (VertexId 0))) + +-- The payload layer over a fixed geometry is a product of four free components. +-- Each is a functor and each is checked as such; nothing in the product can +-- disturb the geometry underneath it. +testPayloadMaps :: IO () +testPayloadMaps = do + let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String) + payloads = V.fromList + [ SampleVertex (Point 0 0) 1 + , SampleVertex (Point 4 0) 2 + , SampleVertex (Point 4 4) 3 + , SampleVertex (Point 0 4) 4 + , SampleVertex (Point 1 2) 5 + ] + built <- requireRight "payload map build" (delaunay defaults payloads) + let plain = buildTriangulation built + -- Distinct payloads everywhere: a map that permuted its component would + -- be invisible against uniform defaults. + withDirected = foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain)) + withUndirected = foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected)) + sample = foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected)) + endpoints :: + Triangulation mode vertex directed undirected face -> + [(VertexId, VertexId)] + endpoints t = [(origin t edge, destination t edge) | edge <- directedEdges t] + + -- Identity. Equality on a triangulation compares geometry, topology, + -- constraint flags and element defaults as well as payloads, so this single + -- equation states that each map disturbs nothing but the component it names. + assertEqual "mapDirectedEdges identity" sample (mapDirectedEdges id sample) + assertEqual "mapUndirectedEdges identity" sample (mapUndirectedEdges id sample) + assertEqual "mapFaces identity" sample (mapFaces id sample) + assertEqual "mapVertices identity" sample (mapVertices id sample) + + assertEqual "mapDirectedEdges composition" + (mapDirectedEdges ((* 2) . (+ 1)) sample) + (mapDirectedEdges (* 2) (mapDirectedEdges (+ 1) sample)) + assertEqual "mapFaces composition" + (mapFaces (("<" <>) . (<> ">")) sample) + (mapFaces ("<" <>) (mapFaces (<> ">") sample)) + + -- Commutation with the accessors. Identity and composition are blind to the + -- indexing; this is the law that pins each payload to its own handle. + let directedMapped = mapDirectedEdges (+ 1) sample + undirectedMapped = mapUndirectedEdges ("<" <>) sample + facesMapped = mapFaces ("<" <>) sample + forM_ (directedEdges sample) $ \edge -> + assertEqual "mapDirectedEdges commutes with directedEdgeData" + (directedEdgeData sample edge + 1) (directedEdgeData directedMapped edge) + forM_ (undirectedEdges sample) $ \edge -> + assertEqual "mapUndirectedEdges commutes with undirectedEdgeData" + ("<" <> undirectedEdgeData sample edge) (undirectedEdgeData undirectedMapped edge) + forM_ (allFaces sample) $ \face -> + assertEqual "mapFaces commutes with faceData" + ("<" <> faceData sample face) (faceData facesMapped face) + + -- The components are independent, and none of them is geometry. + assertEqual "face and directed maps commute" + (mapFaces ("<" <>) (mapDirectedEdges (+ 1) sample)) + (mapDirectedEdges (+ 1) (mapFaces ("<" <>) sample)) + assertEqual "mapFaces preserves topology" (endpoints sample) (endpoints facesMapped) + assertEqual "mapFaces preserves the face count" (numFaces sample) (numFaces facesMapped) + forM_ (vertices sample) $ \vertex -> + assertEqual "mapFaces preserves geometry" (vertexPoint sample vertex) (vertexPoint facesMapped vertex) + + -- The element default is a payload and must travel with them: every element a + -- later insertion creates is handed the default, so a map that reindexed the + -- stored payloads and left the default behind would produce a triangulation + -- whose future elements disagree with its present ones. Every stored payload + -- here differs from the default, so carrying the wrong one is visible. + grownFaces <- insertionTriangulation <$> requireRight "insertion into mapped faces" (insert facesMapped (SampleVertex (Point 2 1) 6)) + grownUndirected <- insertionTriangulation <$> requireRight "insertion into mapped undirected edges" (insert undirectedMapped (SampleVertex (Point 2 1) 6)) + grownDirected <- insertionTriangulation <$> requireRight "insertion into mapped directed edges" (insert directedMapped (SampleVertex (Point 2 1) 6)) + unless (numFaces grownFaces > numFaces facesMapped) $ fail "the insertion created no face" + unless (" show (map (faceData grownFaces) (allFaces grownFaces))) + unless (" v{sampleLabel = sampleLabel v * 10}) sample + collapsed = mapVertices (\v -> v{samplePosition = Point 9 9}) sample + forM_ (vertices sample) $ \vertex -> do + assertEqual "mapVertices commutes with vertexData" + (sampleLabel (vertexData sample vertex) * 10) (sampleLabel (vertexData relabelled vertex)) + assertEqual "mapVertices preserves geometry" (vertexPoint sample vertex) (vertexPoint relabelled vertex) + assertEqual "a payload map cannot move a vertex" + (vertexPoint sample vertex) (vertexPoint collapsed vertex) + assertEqual "mapVertices composes" + (mapVertices (\v -> v{sampleLabel = sampleLabel v + 1}) relabelled) + (mapVertices (\v -> v{sampleLabel = sampleLabel v * 10 + 1}) sample) + + -- The sharpest statement of freedom available: the image type has no + -- 'HasPosition' instance at all. This does not typecheck under a vertex + -- component that geometry reads through. + let projected = mapVertices sampleLabel sample + forM_ (vertices sample) $ \vertex -> do + assertEqual "a vertex payload need not have a position" + (sampleLabel (vertexData sample vertex)) (vertexData projected vertex) + assertEqual "projecting payloads away preserves geometry" + (vertexPoint sample vertex) (vertexPoint projected vertex) + +testPayloadTraversals :: IO () +testPayloadTraversals = do + let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String) + payloads = V.fromList + [ SampleVertex (Point 0 0) 1 + , SampleVertex (Point 4 0) 2 + , SampleVertex (Point 4 4) 3 + , SampleVertex (Point 0 4) 4 + , SampleVertex (Point 1 2) 5 + ] + built <- requireRight "payload traversal build" (delaunay defaults payloads) + let plain = buildTriangulation built + withDirected = foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain)) + withUndirected = foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected)) + sample = foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected)) + + -- 'overPayloads' is the traversal under 'Identity', so this is the traversal + -- identity law. It also says that rebuilding a payload store from its own + -- contents is not observable, which is the part a paged store could get + -- wrong: the traversal materializes pages the map would have left absent. + assertEqual "vertexPayloads identity" sample (overPayloads vertexPayloads id sample) + assertEqual "directedPayloads identity" sample (overPayloads directedPayloads id sample) + assertEqual "undirectedPayloads identity" sample (overPayloads undirectedPayloads id sample) + assertEqual "facePayloads identity" sample (overPayloads facePayloads id sample) + + -- Each traversal and its named map are one function. The effectful + -- generalization is not allowed a second opinion about what relabeling means. + assertEqual "vertexPayloads agrees with mapVertices" + (mapVertices sampleLabel sample) (overPayloads vertexPayloads sampleLabel sample) + assertEqual "directedPayloads agrees with mapDirectedEdges" + (mapDirectedEdges (* 2) sample) (overPayloads directedPayloads (* 2) sample) + assertEqual "undirectedPayloads agrees with mapUndirectedEdges" + (mapUndirectedEdges ("<" <>) sample) (overPayloads undirectedPayloads ("<" <>) sample) + assertEqual "facePayloads agrees with mapFaces" + (mapFaces ("<" <>) sample) (overPayloads facePayloads ("<" <>) sample) + + assertEqual "facePayloads composes" + (overPayloads facePayloads (("<" <>) . (<> ">")) sample) + (overPayloads facePayloads ("<" <>) (overPayloads facePayloads (<> ">") sample)) + + -- The class instances range over the face payload, being the last parameter. + assertEqual "fmap is the face payload map" (mapFaces ("<" <>) sample) (fmap ("<" <>) sample) + assertEqual "traverse is facePayloads" + (Just (overPayloads facePayloads ("<" <>) sample)) + (traverse (Just . ("<" <>)) sample) + assertEqual "the Foldable instance is the face traversal" + (payloadList facePayloads sample) (foldr (:) [] sample) + + -- Visit order, and the element default's place in it. A fold that skipped + -- the default would report the triangulation as holding one fewer face + -- payload than it holds. + assertEqual "vertexPayloads visits the vertices in order" + (map (vertexData sample) (vertices sample)) + (payloadList vertexPayloads sample) + assertEqual "facePayloads visits the faces and then the default" + (map (faceData sample) (allFaces sample) <> [defaultFaceData (Internal.triElementDefaults sample)]) + (payloadList facePayloads sample) + + -- The point of the exercise: relabeling under an effect, with a refusal + -- reaching the caller instead of a half-relabelled triangulation. + let refuseAtThree :: SampleVertex -> Either String Int + refuseAtThree v = if sampleLabel v == 3 then Left "vertex three refuses" else Right (sampleLabel v * 10) + keepLabel :: SampleVertex -> Either String Int + keepLabel = Right . sampleLabel + decorate :: String -> Either String String + decorate = Right . ("<" <>) + assertEqual "an effectful relabel short-circuits" + (Left "vertex three refuses") (vertexPayloads refuseAtThree sample) + relabelled <- requireRight "effectful relabel" (vertexPayloads keepLabel sample) + assertEqual "a successful effectful relabel is the pure one" + (mapVertices sampleLabel sample) relabelled + + -- The default travels through the traversal, and travels exactly once: the + -- store's fill and the element defaults are written from a single visit, so + -- an element created afterwards inherits precisely what the traversal made. + traversedFaces <- requireRight "effectful face relabel" (facePayloads decorate sample) + grown <- insertionTriangulation <$> requireRight "insertion after traversal" (insert traversedFaces (SampleVertex (Point 2 1) 6)) + unless (numFaces grown > numFaces traversedFaces) $ fail "the insertion created no face" + unless (" show (map (faceData grown) (allFaces grown))) + +-- | The in-circle predicate is the orientation of the four points lifted to +-- the paraboloid @z = x² + y²@. The referent is that 4×4 determinant evaluated +-- exactly over 'Rational' — deliberately not the translated 3×3 the instances +-- expand, which would only be the implementation checking its own algebra. +testParaboloidLift :: IO () +testParaboloidLift = do + let lifted :: Point -> (Rational, Rational, Rational) + lifted (Point x y) = + let (rx, ry) = (toRational x, toRational y) in (rx, ry, rx * rx + ry * ry) + minor3 + :: (Rational, Rational, Rational) + -> (Rational, Rational, Rational) + -> (Rational, Rational, Rational) + -> Rational + minor3 (a1, a2, a3) (b1, b2, b3) (c1, c2, c3) = + a1 * (b2 * c3 - b3 * c2) - a2 * (b1 * c3 - b3 * c1) + a3 * (b1 * c2 - b2 * c1) + -- Laplace expansion of the lifted determinant along its column of ones. + liftedOrientation + :: (Rational, Rational, Rational) + -> (Rational, Rational, Rational) + -> (Rational, Rational, Rational) + -> (Rational, Rational, Rational) + -> Rational + liftedOrientation a b c d = + negate (minor3 b c d) + minor3 a c d - minor3 a b d + minor3 a b c + predicted :: Point -> Point -> Point -> Point -> Ordering + predicted a b c d = compare (liftedOrientation (lifted a) (lifted b) (lifted c) (lifted d)) 0 + measured :: Point -> Point -> Point -> Point -> Ordering + measured (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) = + inCircleCoordinates ax ay bx by cx cy dx dy + quadruples :: [Point] -> [(Point, Point, Point, Point)] + quadruples (a : b : c : d : rest) = (a, b, c, d) : quadruples rest + quadruples _ = [] + + forM_ (quadruples (randomPoints 0x51ca_0b17 1600)) $ \(a, b, c, d) -> + assertEqual ("in-circle is the lifted orientation at " <> show (a, b, c, d)) + (predicted a b c d) (measured a b c d) + + -- Exactly cocircular quadruples, which are exactly the ones the floating + -- filter must decline to answer. Every Pythagorean point of the radius-5 + -- circle is representable without rounding, so 'EQ' here is a fact about the + -- geometry rather than about the arithmetic. + let ring = + [ Point x y + | (x, y) <- + [ (5, 0), (0, 5), (-5, 0), (0, -5) + , (3, 4), (4, 3), (-3, 4), (-4, 3) + , (3, -4), (4, -3), (-3, -4), (-4, -3) + ] + ] :: [Point] + indexed = zip [(0 :: Int) ..] ring + cocircular = + [ (a, b, c, d) + | (i, a) <- indexed, (j, b) <- indexed, j > i + , (k, c) <- indexed, k > j, (l, d) <- indexed, l > k + ] + unless (length cocircular == 495) $ fail ("expected 495 cocircular quadruples, got " <> show (length cocircular)) + forM_ cocircular $ \(a, b, c, d) -> do + assertEqual ("cocircular points are cocircular at " <> show (a, b, c, d)) EQ (measured a b c d) + assertEqual ("the lift agrees on cocircularity at " <> show (a, b, c, d)) EQ (predicted a b c d) + + -- The geometry the sign means, stated once against a circle anyone can read. + let (a, b, c) = (Point 1 0, Point 0 1, Point (-1) 0) :: (Point, Point, Point) + assertEqual "the centre is inside the circle" GT (measured a b c (Point 0 0)) + assertEqual "the antipode is on the circle" EQ (measured a b c (Point 0 (-1))) + assertEqual "a distant point is outside" LT (measured a b c (Point 2 2)) + +-- | A payload labels an element, and an element is its geometry. Every rewrite +-- an insertion performs — an edge split, a face split, a Lawson flip — hands +-- some slot a different element to hold, and the label the displaced one +-- carried does not describe what took its place. +-- +-- So: label every element of a triangulation by its own key, insert a point, +-- and demand that an element whose key survives still carries exactly the label +-- it was given while every element whose key is new carries the default and +-- nothing else. Both directions are checked; either alone is satisfiable by a +-- store that throws everything away. +-- +-- The flip is the load-bearing case. Legalization is confluent, so which flips +-- fire and in what order is not observable in the topology that comes out. A +-- payload that rode through a flip would make it observable in the payload +-- plane, and a triangulation that is a normal form in one component and a +-- history in another is not a normal form. +testRewritePayloadIdentity :: IO () +testRewritePayloadIdentity = do + let defaults = ElementDefaults (0 :: Int) (0 :: Int) (0 :: Int) + target = Point 0.001_37 (-0.002_11) + corpus = randomPoints 0x1a2b3c4d 512 + built <- requireRight "rewrite identity base" (delaunay defaults (V.fromList corpus)) + let base = buildTriangulation built + directedTable = labelTable (map (directedKeyOf base) (directedEdges base)) + undirectedTable = labelTable (map (undirectedKeyOf base) (undirectedEdges base)) + faceTable = labelTable (map (faceKeyOf base) (innerFaces base)) + + -- Keys identify elements only if they are unique, so the premise is checked + -- rather than assumed: a collapsed table would silently weaken everything + -- below it into a test of nothing. + assertEqual "directed keys are unique" (length (directedEdges base)) (Map.size directedTable) + assertEqual "undirected keys are unique" (length (undirectedEdges base)) (Map.size undirectedTable) + assertEqual "face keys are unique" (length (innerFaces base)) (Map.size faceTable) + + let withDirected = + foldl' (\t e -> setDirectedEdgeData t e (directedTable Map.! directedKeyOf base e)) base (directedEdges base) + withUndirected = + foldl' (\t e -> setUndirectedEdgeData t e (undirectedTable Map.! undirectedKeyOf base e)) withDirected (undirectedEdges base) + labelled = + foldl' (\t f -> setFaceData t f (faceTable Map.! faceKeyOf base f)) withUndirected (innerFaces base) + inserted <- requireRight "rewrite identity insert" (insert labelled target) + let result = insertionTriangulation inserted + assertValid "rewrite identity result" result + assertEqual "the point was genuinely inserted" Inserted (insertionDisposition inserted) + + -- Both directions, on every plane. A surviving element keeps exactly its + -- label; everything else holds the default and nothing else. + assertPayloadSurvival "directed" directedTable + [(directedKeyOf result e, directedEdgeData result e) | e <- directedEdges result] + assertPayloadSurvival "undirected" undirectedTable + [(undirectedKeyOf result e, undirectedEdgeData result e) | e <- undirectedEdges result] + assertPayloadSurvival "face" faceTable + [(faceKeyOf result f, faceData result f) | f <- innerFaces result] + + -- The flip signature. Every flip after an insertion joins the new vertex to + -- the far corner of a cavity quad, so a new edge is not evidence of one — a + -- split produces those too. A DESTROYED edge is: splitting a face destroys + -- nothing and adds exactly three edges and two faces, which is asserted here + -- so that the arithmetic holds, and under it every base key that is gone from + -- the result was flipped away. Without this the paragraphs above are a claim + -- about splits alone. + assertEqual "the point landed strictly inside a face" + (numUndirectedEdges base + 3, numFaces base + 2) + (numUndirectedEdges result, numFaces result) + let surviving = Set.fromList (map (undirectedKeyOf result) (undirectedEdges result)) + flippedAway = filter (`Set.notMember` surviving) (Map.keys undirectedTable) + when (null flippedAway) (fail "the insertion caused no flip, so the flip case went unchecked") + + -- The same claim across one transaction that both retires and creates. + -- Removal swap-compacts, which leaves a retired element's payload sitting in + -- the slot it vacated; the inserts that follow are handed those slots back. + -- Nothing else in the suite makes an allocation reissue a used slot. + let doomed = take 60 corpus + arrivals = randomPoints 0x5f3a19c2 60 + (_, edited, _) <- + requireRight "rewrite identity session" $ + withSession labelled (length arrivals) $ do + mapM_ + (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))) + doomed + mapM_ insertVertex arrivals + assertValid "rewrite identity session" edited + assertPayloadSurvival "session directed" directedTable + [(directedKeyOf edited e, directedEdgeData edited e) | e <- directedEdges edited] + assertPayloadSurvival "session undirected" undirectedTable + [(undirectedKeyOf edited e, undirectedEdgeData edited e) | e <- undirectedEdges edited] + assertPayloadSurvival "session face" faceTable + [(faceKeyOf edited f, faceData edited f) | f <- innerFaces edited] + +directedKeyOf + :: Triangulation mode vertex directed undirected face + -> DirectedEdgeId + -> (Point, Point) +directedKeyOf triangulation edge = + ( vertexPoint triangulation (origin triangulation edge) + , vertexPoint triangulation (destination triangulation edge) + ) + +undirectedKeyOf + :: Triangulation mode vertex directed undirected face + -> UndirectedEdgeId + -> (Point, Point) +undirectedKeyOf triangulation edge = + case undirectedEndpoints triangulation edge of + (from, to) -> + let (left, right) = (vertexPoint triangulation from, vertexPoint triangulation to) + in if left <= right then (left, right) else (right, left) + +faceKeyOf + :: Triangulation mode vertex directed undirected face + -> FaceId + -> [Point] +faceKeyOf triangulation face = sort (map (vertexPoint triangulation) (faceVertices triangulation face)) + +labelTable :: Ord key => [key] -> Map.Map key Int +labelTable keys = Map.fromList (zip keys [1 ..]) + +-- | Every element carries the label its key was given, or the default if its +-- key is new. Both counts are asserted too: a store that kept everything and a +-- store that kept nothing each satisfy one half of this on its own. +assertPayloadSurvival :: (Ord key, Show key) => String -> Map.Map key Int -> [(key, Int)] -> IO () +assertPayloadSurvival plane labels elements = do + let kept = length (filter ((`Map.member` labels) . fst) elements) + when (kept == 0) (fail (plane <> ": the insertion perturbed every element")) + when (kept == length elements) (fail (plane <> ": the insertion perturbed no element")) + forM_ elements $ \(key, payload) -> + assertEqual (plane <> " label at " <> show key) (Map.findWithDefault 0 key labels) payload + +testPointLocationAndHints :: IO () +testPointLocationAndHints = do + built <- requirePointBuild "location" (randomPoints 0x1234_5678 1200) + let triangulation = buildTriangulation built + queries <- traverse (requireQueryPoint "location query") (take 250 (randomPoints 0xdead_beef 250)) + let + baseline = sum [locationWalkSteps stats | query <- queries, let (_, stats) = locatePointWithHint triangulation Nothing query] + hierarchy <- requireRight "hierarchy build" (buildHierarchyHint 16 triangulation) + let hinted = sum + [ locationWalkSteps stats + | query <- queries + , let hint = hierarchyHint hierarchy query + (_, stats) = locatePointWithHint triangulation hint query + ] + unless (hinted <= baseline) $ + fail ("hierarchy hint increased aggregate walking: " <> show (baseline, hinted)) + staleHintQuery <- requireQueryPoint "stale hint query" (Point 0.125 (-0.375)) + let staleVertexHint = VertexHint (VertexId (fromIntegral (numVertices triangulation))) + assertEqual + "stale vertex hint falls back to the canonical start face" + (locatePointWithHint triangulation Nothing staleHintQuery) + (locatePointWithHint triangulation (Just staleVertexHint) staleHintQuery) + forM_ (vertices triangulation) $ \vertex -> do + vertexQuery <- requireQueryPoint "vertex lookup" (vertexPoint triangulation vertex) + assertEqual "vertex lookup" (OnVertex vertex) (locatePoint triangulation vertexQuery) + let insertedPoint = Point 0.1234567 (-0.2345678) + inserted <- requireRight "hierarchy incremental source" (insert triangulation insertedPoint) + let updatedTriangulation = insertionTriangulation inserted + updatedHierarchy <- + requireRight + "hierarchy incremental update" + ( updateHierarchyAfterInsertion + hierarchy + insertedPoint + (insertionVertex inserted) + (insertionDisposition inserted) + ) + rebuiltHierarchy <- requireRight "hierarchy reference rebuild" (buildHierarchyHint 16 updatedTriangulation) + assertEqual "incremental hierarchy equals canonical rebuild" rebuiltHierarchy updatedHierarchy + +-- The hierarchy replaces its level-to-base correspondence with the arithmetic +-- claim that level-local handle @j@ names base vertex @j * branch@. Query each +-- sampled vertex with its own position: the descent must return that very +-- vertex, at every branch factor and along the whole of level 0. A stride the +-- construction does not actually obey shows up here as a named mismatch. +testHierarchyNestingLaw :: IO () +testHierarchyNestingLaw = do + built <- requirePointBuild "hierarchy nesting" (randomPoints 0x0f1e_2d3c 900) + let triangulation = buildTriangulation built + forM_ [2, 3, 16] $ \branch -> do + hierarchy <- requireRight ("hierarchy build at branch " <> show branch) (buildHierarchyHint branch triangulation) + let sampled = [0, branch .. numVertices triangulation - 1] + forM_ sampled $ \index -> do + let vertex = VertexId (fromIntegral index) + vertexQuery <- requireQueryPoint "sampled hierarchy vertex" (vertexPoint triangulation vertex) + assertEqual + ("branch " <> show branch <> " descent onto sampled vertex " <> show index) + (Just (VertexHint vertex)) + (hierarchyHint hierarchy vertexQuery) + +testSibsonInterpolation :: IO () +testSibsonInterpolation = do + built <- requirePointBuild "sibson" (gridPoints 9 9) + let triangulation = buildTriangulation built + queryPoint = Point 3.25 4.4 + linear vertex = let Point x y = vertexPoint triangulation vertex in 2 * x - 3 * y + 5 + expected = let Point x y = queryPoint in 2 * x - 3 * y + 5 + query <- requireQueryPoint "Sibson query" queryPoint + workspace <- stToIO (newNaturalNeighborWorkspace triangulation) + result <- stToIO (naturalNeighborWeights workspace Nothing query) + let weights = naturalNeighborValues result + unless (V.length weights >= 3) $ fail "Sibson query did not discover a natural-neighbor cavity" + assertNear "Sibson partition" 1.0e-11 1 (V.sum (V.map snd weights)) + unless (V.all ((>= (-1.0e-12)) . snd) weights) $ fail "Sibson produced a negative weight" + (folded, _, foldedStats) <- stToIO (foldNaturalNeighborWeights + (\total vertex weight -> total + weight * linear vertex) + 0 + workspace + Nothing + query) + assertNear "allocation-free Sibson fold" 2.0e-9 expected folded + assertEqual "Sibson fold neighbor count" (V.length weights) (interpolationNaturalNeighbors foldedStats) + (interpolated, _) <- stToIO (interpolateNaturalNeighbor linear workspace Nothing query) + case interpolated of + Nothing -> fail "Sibson interpolation rejected an interior query" + Just value -> assertNear "Sibson affine precision" 2.0e-9 expected value + let gradients = estimateGradients linear triangulation + V.forM_ gradients $ \(gx, gy) -> do + assertNear "planar gradient x" 1.0e-9 2 gx + assertNear "planar gradient y" 1.0e-9 (-3) gy + let gradient (VertexId raw) = gradients V.! fromIntegral raw + (gradientValue, _) <- stToIO (interpolateNaturalNeighborGradient linear gradient 0.5 workspace Nothing query) + case gradientValue of + Nothing -> fail "gradient natural-neighbor interpolation rejected an interior query" + Just value -> assertNear "gradient affine precision" 2.0e-9 expected value + unless (workspaceBytes workspace > 0) $ fail "Sibson workspace byte accounting is empty" + +testVoronoiDual :: IO () +testVoronoiDual = do + built <- requirePointBuild "voronoi" [Point 0 0, Point 2 0, Point 0 2, Point 2 2, Point 1 1] + let triangulation = buildTriangulation built + assertEqual "Voronoi face count" (numVertices triangulation) (length (voronoiFaces triangulation)) + assertEqual "directed dual edge count" (numDirectedEdges triangulation) (length (directedVoronoiEdges triangulation)) + assertEqual "undirected dual edge count" (numUndirectedEdges triangulation) (length (undirectedVoronoiEdges triangulation)) + forM_ (directedVoronoiEdges triangulation) $ \edge -> do + assertEqual "dual double reversal" edge (reverseVoronoiEdge (reverseVoronoiEdge edge)) + assertEqual "dual next/previous" edge (voronoiPrevious triangulation (voronoiNext triangulation edge)) + assertEqual + "dual face/site" + (origin triangulation (asDelaunayDirectedEdge edge)) + (voronoiFaceSite (voronoiIncidentFace triangulation edge)) + case voronoiEdgeGeometry triangulation edge of + Nothing -> fail "valid dual edge has no geometry" + Just _ -> pure () + case directedVoronoiEdges triangulation of + [] -> fail "Voronoi test produced no directed dual edge" + first : _ -> do + handle <- requireJust "dynamic Voronoi edge" (VoronoiDynamic.directedVoronoiEdgeHandle triangulation first) + assertEqual "dynamic dual fix" first (VoronoiDynamic.fixDirectedVoronoiEdge handle) + assertEqual "dynamic dual reversal" first (VoronoiDynamic.fixDirectedVoronoiEdge (VoronoiDynamic.voronoiEdgeReverseH (VoronoiDynamic.voronoiEdgeReverseH handle))) + assertEqual "dynamic dual/primal conversion" (asDelaunayDirectedEdge first) (Dynamic.fixDirectedEdge (VoronoiDynamic.voronoiEdgeAsDelaunayH handle)) + let dualFace = VoronoiDynamic.voronoiEdgeFaceH handle + assertEqual "dynamic dual face site" (origin triangulation (asDelaunayDirectedEdge first)) (Dynamic.fixVertex (VoronoiDynamic.voronoiFaceSiteH dualFace)) + let source = VoronoiDynamic.voronoiEdgeFromH handle + case VoronoiDynamic.voronoiVertexAsDelaunayFaceH source of + Just inner -> case VoronoiDynamic.voronoiVertexPositionH source of + Nothing -> fail "inner dynamic Voronoi vertex has no position" + Just voronoiPosition -> assertEqual "inner dynamic Voronoi position" (Dynamic.innerFaceCircumcenter inner) (Just voronoiPosition) + Nothing -> unless (isJust (VoronoiDynamic.voronoiVertexAsOuterEdgeH source)) $ + fail "outer dynamic Voronoi vertex has no defining edge" + +testRemoval :: IO () +testRemoval = do + built <- requirePointBuild "removal" [Point 0 0, Point 3 0, Point 3 3, Point 0 3, Point 1.5 1.5] + let triangulation = buildTriangulation built + assertEqual + "out-of-range removal obstruction" + (Left (RemovalVertexOutOfRange (VertexId 5) 5)) + (void (removeVertex triangulation (VertexId 5))) + removedInterior <- requireRight "interior removal" (removeVertex triangulation (VertexId 4)) + assertEqual "interior removed point" (Point 1.5 1.5) (removalOutcomePoint (removalOutcome removedInterior)) + assertEqual "interior removal count" 4 (numVertices (removalTriangulation removedInterior)) + assertValid "interior removal" (removalTriangulation removedInterior) + let beforeHullRemoval = removalTriangulation removedInterior + previousLastVertex = VertexId (fromIntegral (numVertices beforeHullRemoval - 1)) + swappedPoint = vertexPoint beforeHullRemoval previousLastVertex + swappedData = vertexData beforeHullRemoval previousLastVertex + removedHull <- requireRight "hull removal" (removeVertex beforeHullRemoval (VertexId 0)) + assertEqual "hull removal count" 3 (numVertices (removalTriangulation removedHull)) + case removalOutcomeSwap (removalOutcome removedHull) of + Nothing -> fail "hull removal omitted the swap-compacted vertex handle" + Just (swappedIn, swappedInPoint) -> do + assertEqual "hull swapped-in handle" (VertexId 0) swappedIn + assertEqual "hull swapped-in point" swappedPoint (vertexPoint (removalTriangulation removedHull) swappedIn) + assertEqual "hull swapped-in payload" swappedData (vertexData (removalTriangulation removedHull) swappedIn) + -- The reported position must be the one the arena now holds, bit for + -- bit: a caller seeding a search from it is seeding from the mesh. + assertEqual "hull swapped-in reported position" swappedPoint swappedInPoint + assertValid "hull removal" (removalTriangulation removedHull) + + let afterHullRemoval = removalTriangulation removedHull + lastVertex = VertexId (fromIntegral (numVertices afterHullRemoval - 1)) + removedLast <- requireRight "last-vertex removal" (removeVertex afterHullRemoval lastVertex) + assertEqual + "removing the last vertex relocates nothing" + Nothing + (removalOutcomeSwap (removalOutcome removedLast)) + assertEqual "last-vertex removal count" 2 (numVertices (removalTriangulation removedLast)) + assertValid "last-vertex removal" (removalTriangulation removedLast) + + lineBuild <- requirePointBuild "line removal" [Point 0 0, Point 1 0, Point 2 0, Point 3 0] + lineMiddle <- requireRight "line middle removal" (removeVertex (buildTriangulation lineBuild) (VertexId 1)) + assertEqual "line middle count" 3 (numVertices (removalTriangulation lineMiddle)) + assertValid "line middle removal" (removalTriangulation lineMiddle) + + degreeThreeBuild <- + requirePointBuild + "degree-three removal" + [Point 0 0, Point 4 0, Point 0 4, Point 1 1] + let degreeThreeMapping = buildInputVertices degreeThreeBuild + case if 3 < sizeofPrimArray degreeThreeMapping + then Just (VertexId (indexPrimArray degreeThreeMapping 3)) + else Nothing of + Nothing -> fail "degree-three removal input mapping omitted the interior vertex" + Just centerVertex -> do + degreeThree <- + requireRight + "degree-three interior removal" + (removeVertex (buildTriangulation degreeThreeBuild) centerVertex) + assertEqual "degree-three removal count" 3 (numVertices (removalTriangulation degreeThree)) + assertValid "degree-three interior removal" (removalTriangulation degreeThree) + + -- A removal hands its vertex's whole ring to edge/face cleanup, so a + -- high-degree star is the only shape that exercises the ordered-set path + -- there; an ordinary mesh keeps degrees near six and never leaves the + -- insertion sort. Radii are jittered so no four rim points are cocircular. + let rimCount = 48 + rimPoint index = + let angle = 2 * pi * fromIntegral index / fromIntegral rimCount + radius = 1 + 0.001 * fromIntegral (index `mod` 7) + in Point (radius * cos angle) (radius * sin angle) + starBuild <- + requirePointBuild + "high-degree removal" + (Point 0 0 : map rimPoint [0 .. rimCount - 1]) + let starTriangulation = buildTriangulation starBuild + starCentre = VertexId (indexPrimArray (buildInputVertices starBuild) 0) + centreDegree = + length + [ () + | edge <- undirectedEdges starTriangulation + , let (from, to) = undirectedEndpoints starTriangulation edge + , from == starCentre || to == starCentre + ] + assertEqual "high-degree centre ring" rimCount centreDegree + starRemoved <- + requireRight "high-degree interior removal" (removeVertex starTriangulation starCentre) + assertEqual "high-degree removal count" rimCount (numVertices (removalTriangulation starRemoved)) + assertEqual + "high-degree removed point" + (Point 0 0) + (removalOutcomePoint (removalOutcome starRemoved)) + assertValid "high-degree interior removal" (removalTriangulation starRemoved) + + -- A transaction that refuses publishes nothing: the refusal is the whole + -- answer, so no half-remeshed arena can reach a caller as a triangulation. + let sessionRefusal = RemovalVertexOutOfRange (VertexId 99) 5 + assertEqual + "a refused session publishes nothing" + (Left sessionRefusal) + (void (withSession triangulation 1 (refuse sessionRefusal :: Session s (Point) () () () ()))) + + -- Refusal short-circuits: an edit after it never runs, so the mesh the + -- transaction abandoned is the mesh it was handed. + assertEqual + "a refusal abandons the edits behind it" + (Left sessionRefusal) + ( void + ( withSession + triangulation + 1 + ( ( do + _ <- removeAt (Point 0 0) + _ <- refuse sessionRefusal + removeAt (Point 1 1) + ) :: + Session s (Point) () () () (Maybe (RemovalOutcome (Point))) + ) + ) + ) + + -- The two point-keyed entries must publish one story. A handle-keyed removal + -- locates nothing, while the coordinate-keyed route resolves the same site + -- through the exact derived identity section rather than a topological walk. + -- Both therefore charge no location steps and retire the same vertex. + handleRemoval <- requireRight "handle removal stats" (removeVertex triangulation (VertexId 4)) + assertEqual + "a handle-keyed removal locates nothing" + 0 + (statLocationWalkSteps (removalStats handleRemoval)) + locatedRemoval <- + requireRight "point removal stats" (locateAndRemove triangulation (Point 1.5 1.5)) + pointRemoval <- requireJust "point removal located a vertex" locatedRemoval + assertEqual + "a point-keyed removal performs no topological location walk" + 0 + (statLocationWalkSteps (removalStats pointRemoval)) + assertEqual + "point-keyed and handle-keyed removal publish the same mesh" + (canonicalEdges (removalTriangulation handleRemoval)) + (canonicalEdges (removalTriangulation pointRemoval)) + +testConstrainedDelaunay :: IO () +testConstrainedDelaunay = do + base <- requirePointBuild "CDT base" [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 1 1, Point 3 3, Point 1 3, Point 3 1] + let cdt0 = fromDelaunay (buildTriangulation base) + diagonalBatch <- + requireRight + "constraint recovery" + (recoverConstraints cdt0 (V.singleton (VertexId 0, VertexId 2))) + (diagonalPath, diagonalAdded) <- + requireAcceptedConstraint "constraint recovery" diagonalBatch + let cdt1 = constraintBatchTriangulation diagonalBatch + when (V.null diagonalPath) $ fail "constraint recovery returned an empty path" + assertEqual "constraint count" diagonalAdded (numConstraints cdt1) + assertCdtValid "constraint recovery" cdt1 + conflictBatch <- + requireRight + "atomic conflict" + (recoverConstraints cdt1 (V.singleton (VertexId 1, VertexId 3))) + case V.toList (constraintBatchOutcomes conflictBatch) of + [ConstraintRejected _] -> pure () + outcomes -> + fail + ( "crossing constraint was not rejected atomically: " + <> show outcomes + ) + assertEqual + "crossing rejection preserves topology" + cdt1 + (constraintBatchTriangulation conflictBatch) + let constraintProgram = + V.fromList + [ (VertexId 0, VertexId 2) + , (VertexId 1, VertexId 3) + , (VertexId 4, VertexId 6) + ] + wholeProgram <- + requireRight + "whole constraint program" + (recoverConstraints cdt0 constraintProgram) + (singletonTriangulation, singletonOutcomes) <- + requireRight + "singleton constraint program" + (V.foldM' replayConstraintRequest (cdt0, []) constraintProgram) + assertEqual + "batch outcomes equal singleton descent" + (V.toList (constraintBatchOutcomes wholeProgram)) + (reverse singletonOutcomes) + assertEqual + "batch topology equals singleton descent" + singletonTriangulation + (constraintBatchTriangulation wholeProgram) + assertBatchStats "whole constraint program" wholeProgram + forM_ [0 .. 7 :: Int] $ \batchIndex -> do + randomizedBuild <- + requirePointBuild + ("random constraint batch " <> show batchIndex) + (randomPoints (0x6a09_e667_f3bc_c909 + fromIntegral batchIndex) 40) + let randomizedBase = fromDelaunay (buildTriangulation randomizedBuild) + mapping = buildInputVertices randomizedBuild + handles = V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping) + requests = V.take 18 (V.zip handles (V.reverse handles)) + randomizedBatch <- + requireRight + ("random whole constraint batch " <> show batchIndex) + (recoverConstraints randomizedBase requests) + (randomizedSingleton, randomizedOutcomes) <- + requireRight + ("random singleton constraint batch " <> show batchIndex) + (V.foldM' replayConstraintRequest (randomizedBase, []) requests) + assertEqual + ("random batch outcomes equal singleton descent " <> show batchIndex) + (V.toList (constraintBatchOutcomes randomizedBatch)) + (reverse randomizedOutcomes) + assertEqual + ("random batch topology equals singleton descent " <> show batchIndex) + randomizedSingleton + (constraintBatchTriangulation randomizedBatch) + assertBatchStats + ("random constraint batch " <> show batchIndex) + randomizedBatch + assertCdtValid + ("random constraint batch " <> show batchIndex) + (constraintBatchTriangulation randomizedBatch) + -- Batch admission returns the first typed obstruction. Callers that need a + -- complete diagnosis ask the explicit corridor query and alone pay for it. + diagnosisBatch <- + requireRight + "conflict diagnosis" + (recoverConstraints cdt1 (V.singleton (VertexId 6, VertexId 7))) + case V.toList (constraintBatchOutcomes diagnosisBatch) of + [ConstraintRejected blocking] -> do + let diagnosed = + fmap + asUndirected + (getConflictingEdgesBetweenVertices cdt1 (VertexId 6) (VertexId 7)) + case diagnosed of + [] -> fail "explicit conflict diagnosis named no edge" + firstBlocking : _ -> + assertEqual "batch rejection is the first corridor obstruction" firstBlocking blocking + assertEqual + "explicit conflict diagnosis is deduplicated" + (length diagnosed) + (length (Set.fromList diagnosed)) + forM_ diagnosed $ \edge -> + unless (isConstraintEdge cdt1 edge) $ + fail ("explicit conflict diagnosis named a non-constraint edge: " <> show edge) + outcomes -> + fail + ( "a constraint crossing the diagonal was not rejected: " + <> show outcomes + ) + + split <- requireRight "constraint split" (addConstraintAndSplit id cdt1 (VertexId 1) (VertexId 3)) + let splitCdt = constraintTriangulation split + unless (numVertices splitCdt > numVertices cdt1) $ fail "constraint split did not insert an intersection vertex" + assertCdtValid "constraint split" splitCdt + + -- The batch splitter must agree with singleton descent, including across a + -- suspension: every vertical below is constrained only inside the batch + -- itself, so no census against the base can reserve for its crossings and + -- the chunk's vertex reservation exhausts mid-batch. The driver publishes, + -- re-reserves against the published mesh, and resumes; the final mesh must + -- not know any of that happened. + let bandColumns = [0 .. 7 :: Int] + bandVertices = + V.fromList + ( Point 0 5 + : Point 90 5 + : concat + [ [Point x 10, Point x 0] + | column <- bandColumns + , let x = 10 * fromIntegral column + 5 + ] + ) + bandBuild <- + requireRight + "split band base" + (constrainedDelaunayMaximal unitElementDefaults bandVertices V.empty) + let bandMapping = cdtBuildInputVertices bandBuild + bandHandle input = VertexId (indexPrimArray bandMapping input) + bandBase = cdtBuildTriangulation bandBuild + bandRequests = + V.fromList + ( (bandHandle 0, bandHandle 1) + : [ (bandHandle (2 * column + 2), bandHandle (2 * column + 3)) + | column <- bandColumns + ] + ) + replaySplit + :: ConstrainedDelaunayTriangulation (Point) + -> (VertexId, VertexId) + -> Either (CdtError) (ConstrainedDelaunayTriangulation (Point)) + replaySplit triangulation request = + constraintTriangulation + <$> uncurry (addConstraintAndSplit id triangulation) request + bandBatch <- + requireRight + "split batch" + (addConstraintsAndSplit id bandBase bandRequests) + bandDescent <- + requireRight + "split singleton descent" + (V.foldM' replaySplit bandBase bandRequests) + assertEqual + "split batch topology equals singleton descent" + bandDescent + (splitBatchTriangulation bandBatch) + assertEqual + "split batch added one vertex per crossing" + (numVertices bandBase + length bandColumns) + (numVertices (splitBatchTriangulation bandBatch)) + assertCdtValid "split batch" (splitBatchTriangulation bandBatch) + + -- The same law with the reservation exhausting inside one corridor rather + -- than between corridors: the closing horizontal crosses two constraints + -- the census can see and fifteen it cannot, so the corridor suspends with + -- its cursor mid-walk and the resumed transaction continues from the last + -- split vertex, not from the corridor's start. + let laceColumns = [0 .. 16 :: Int] + laceVertices = + V.fromList + ( Point 0 5 + : Point 90 5 + : concat + [ [Point x 10, Point x 0] + | column <- laceColumns + , let x = 5 * fromIntegral column + 5 + ] + ) + laceBuiltIn = V.fromList [(2, 3), (34, 35)] + laceBuild <- + requireRight + "split lace base" + (constrainedDelaunayMaximal unitElementDefaults laceVertices laceBuiltIn) + let laceMapping = cdtBuildInputVertices laceBuild + laceHandle input = VertexId (indexPrimArray laceMapping input) + laceBase = cdtBuildTriangulation laceBuild + laceRequests = + V.fromList + ( [ (laceHandle (2 * column + 2), laceHandle (2 * column + 3)) + | column <- [1 .. 15] + ] + <> [(laceHandle 0, laceHandle 1)] + ) + laceBatch <- + requireRight + "split lace batch" + (addConstraintsAndSplit id laceBase laceRequests) + laceDescent <- + requireRight + "split lace singleton descent" + (V.foldM' replaySplit laceBase laceRequests) + assertEqual + "split lace batch topology equals singleton descent" + laceDescent + (splitBatchTriangulation laceBatch) + assertEqual + "split lace batch added one vertex per crossing" + (numVertices laceBase + length laceColumns) + (numVertices (splitBatchTriangulation laceBatch)) + assertCdtValid "split lace batch" (splitBatchTriangulation laceBatch) + + let verticesInput :: V.Vector (Point) + verticesInput = V.fromList [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 0 0] + constraintsInput = V.fromList [(0, 2), (1, 3), (4, 1)] + bulk <- requireRight "stable CDT bulk load" (constrainedDelaunayMaximal unitElementDefaults verticesInput constraintsInput) + let bulkMapping = cdtBuildInputVertices bulk + unless (sizeofPrimArray bulkMapping > 4) $ fail "cdtBuildInputVertices out of bounds" + assertEqual "stable duplicate reroute" (VertexId (indexPrimArray bulkMapping 0)) (VertexId (indexPrimArray bulkMapping 4)) + assertEqual "conflict reporting" 1 (V.length (cdtRejectedConstraints bulk)) + assertCdtValid "stable CDT bulk load" (cdtBuildTriangulation bulk) + +testAnnotatedConstrainedUnion :: IO () +testAnnotatedConstrainedUnion = do + let leftPoints :: V.Vector (Point) + leftPoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2] + rightPoints :: V.Vector (Point) + rightPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2] + thirdPoints :: V.Vector (Point) + thirdPoints = V.fromList [Point 4 0, Point 6 0, Point 6 2, Point 4 2] + leftBuild <- + requireRight "annotated constrained union left" $ + constrainedDelaunay + unitElementDefaults + leftPoints + (V.singleton (0, 2)) + rightBuild <- + requireRight "annotated constrained union right" $ + constrainedDelaunay + unitElementDefaults + rightPoints + (V.singleton (0, 2)) + thirdBuild <- + requireRight "annotated constrained union third" $ + constrainedDelaunay + unitElementDefaults + thirdPoints + (V.singleton (0, 2)) + let left = + mapVertices + (const (Set.singleton "left")) + (buildTriangulation leftBuild) + right = + mapVertices + (const (Set.singleton "right")) + (buildTriangulation rightBuild) + third = + mapVertices + (const (Set.singleton "third")) + (buildTriangulation thirdBuild) + joined <- + requireRight + "annotated constrained union" + (unionConstrainedWith Set.union left right) + let expectedAnnotations = + Map.fromList + [ (Point 0 0, Set.singleton "left") + , (Point 0 2, Set.singleton "left") + , (Point 2 0, Set.fromList ["left", "right"]) + , (Point 2 2, Set.fromList ["left", "right"]) + , (Point 4 0, Set.singleton "right") + , (Point 4 2, Set.singleton "right") + ] + actualAnnotations = + Map.fromList + [ (vertexPoint joined vertex, vertexData joined vertex) + | vertex <- vertices joined + ] + expectedConstraints = + Set.union + (Set.fromList (V.toList (constraintSegments left))) + (Set.fromList (V.toList (constraintSegments right))) + assertEqual + "annotated constrained union preserves and combines site payloads" + expectedAnnotations + actualAnnotations + assertEqual + "annotated constrained union preserves both constraint sections" + expectedConstraints + (Set.fromList (V.toList (constraintSegments joined))) + assertCdtValid "annotated constrained union" joined + commuted <- + requireRight + "annotated constrained union commuted" + (unionConstrainedWith Set.union right left) + assertEqual + "annotated constrained union is commutative under a commutative payload combiner" + joined + commuted + leftAssociated <- + requireRight + "annotated constrained union left-associated" + (unionConstrainedWith Set.union joined third) + rightPair <- + requireRight + "annotated constrained union right pair" + (unionConstrainedWith Set.union right third) + rightAssociated <- + requireRight + "annotated constrained union right-associated" + (unionConstrainedWith Set.union left rightPair) + assertEqual + "annotated constrained union is associative wherever both descents are admitted" + leftAssociated + rightAssociated + unitJoined <- + requireRight + "unit constrained union specialization" + ( unionConstrained + (mapVertices (const ()) left) + (mapVertices (const ()) right) + ) + assertEqual + "unit constrained union specializes annotated constrained union" + unitJoined + (mapVertices (const ()) joined) + +-- | Sequential extension retains the base authority as the transaction root. +-- The semantic result agrees with canonical union on sites and constraint +-- sections, but its receipt proves that only the incoming constraint section +-- was interpreted. +testAsymmetricConstrainedExtension :: IO () +testAsymmetricConstrainedExtension = do + let basePoints :: V.Vector (Point) + basePoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2] + extensionPoints :: V.Vector (Point) + extensionPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2] + baseBuild <- + requireRight + "asymmetric extension base" + (constrainedDelaunay unitElementDefaults basePoints (V.singleton (0, 2))) + extensionBuild <- + requireRight + "asymmetric extension incoming" + (constrainedDelaunay unitElementDefaults extensionPoints (V.singleton (0, 2))) + let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild) + extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild) + expectedAnnotations = + Map.fromList + [ (Point 0 0, Set.singleton "base") + , (Point 0 2, Set.singleton "base") + , (Point 2 0, Set.fromList ["base", "extension"]) + , (Point 2 2, Set.fromList ["base", "extension"]) + , (Point 4 0, Set.singleton "extension") + , (Point 4 2, Set.singleton "extension") + ] + expectedConstraints = + Set.union + (Set.fromList (V.toList (constraintSegments base))) + (Set.fromList (V.toList (constraintSegments extension))) + baseAnnotations = + Map.fromList + [ (vertexPoint base vertex, vertexData base vertex) + | vertex <- vertices base + ] + extensionAnnotations = + Map.fromList + [ (vertexPoint extension vertex, vertexData extension vertex) + | vertex <- vertices extension + ] + baseAnnotationsBefore <- evaluate (force baseAnnotations) + baseConstraintsBefore <- evaluate (force (constraintSegments base)) + extensionAnnotationsBefore <- evaluate (force extensionAnnotations) + extensionConstraintsBefore <- evaluate (force (constraintSegments extension)) + extendedResult <- + requireRight + "asymmetric constrained extension" + (extendConstrainedWith Set.union base extension) + let extended = constrainedExtensionTriangulation extendedResult + receipt = constrainedExtensionConstraintStats extendedResult + buildReceipt = constrainedExtensionBuildStats extendedResult + actualAnnotations = + Map.fromList + [ (vertexPoint extended vertex, vertexData extended vertex) + | vertex <- vertices extended + ] + assertEqual + "asymmetric extension preserves base and combines coincident site payloads" + expectedAnnotations + actualAnnotations + assertEqual + "asymmetric extension preserves resident and incoming constraint sections" + expectedConstraints + (Set.fromList (V.toList (constraintSegments extended))) + assertEqual + "asymmetric extension does not mutate the frozen base predecessor sites" + baseAnnotationsBefore + ( Map.fromList + [ (vertexPoint base vertex, vertexData base vertex) + | vertex <- vertices base + ] + ) + assertEqual + "asymmetric extension does not mutate the frozen base predecessor constraints" + baseConstraintsBefore + (constraintSegments base) + assertEqual + "asymmetric extension does not mutate the frozen incoming predecessor sites" + extensionAnnotationsBefore + ( Map.fromList + [ (vertexPoint extension vertex, vertexData extension vertex) + | vertex <- vertices extension + ] + ) + assertEqual + "asymmetric extension does not mutate the frozen incoming predecessor constraints" + extensionConstraintsBefore + (constraintSegments extension) + assertEqual + "asymmetric extension recovers only incoming constraints" + (V.length (constraintSegments extension)) + (constraintBatchRequests receipt) + assertEqual + "asymmetric extension returns one outcome for each incoming constraint" + (V.length (constraintSegments extension)) + (V.length (constrainedExtensionConstraintOutcomes extendedResult)) + assertEqual + "asymmetric extension admits every incoming constraint" + (V.length (constraintSegments extension)) + (constraintBatchAccepted receipt) + assertEqual + "asymmetric extension reports no incoming constraint rejection" + 0 + (constraintBatchRejected receipt) + assertEqual + "asymmetric extension charges every incoming site once" + (V.length extensionPoints) + (statInputPoints buildReceipt) + assertEqual + "asymmetric extension distinguishes occupied incoming sites" + 2 + (statExistingPoints buildReceipt) + assertEqual + "asymmetric extension distinguishes newly materialized incoming sites" + 2 + (statUniquePoints buildReceipt) + assertCdtValid "asymmetric constrained extension" extended + + crossingBuild <- + requireRight + "asymmetric extension crossing incoming section" + (constrainedDelaunay unitElementDefaults basePoints (V.singleton (1, 3))) + case + extendConstrainedWith + Set.union + base + (mapVertices (const (Set.singleton "crossing")) (buildTriangulation crossingBuild)) of + Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure () + other -> fail ("asymmetric extension did not return the corridor intersection witness: " <> show other) + +testLargeAsymmetricConstrainedExtension :: IO () +testLargeAsymmetricConstrainedExtension = do + let width = 40 :: Int + height = 28 :: Int + basePoints :: V.Vector (Point) + basePoints = + V.fromList + ( [ Point 0 0 + , Point (fromIntegral (width + 1)) 0 + , Point (fromIntegral (width + 1)) (fromIntegral (height + 1)) + , Point 0 (fromIntegral (height + 1)) + ] + <> [ Point + (fromIntegral (column + 1) + fromIntegral ((column * 17 + row * 31) `mod` 13) * 1.0e-3) + (fromIntegral (row + 1) + fromIntegral ((column * 23 + row * 19) `mod` 17) * 1.0e-3) + | row <- [0 .. height - 1] + , column <- [0 .. width - 1] + ] + ) + baseConstraints = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (0, 2)] + extensionPoints :: V.Vector (Point) + extensionPoints = V.fromList [Point 48 8, Point 53.2 8.4, Point 50.4 15.8] + extensionConstraints = V.fromList [(0, 1), (1, 2), (2, 0)] + conflictPoints :: V.Vector (Point) + conflictPoints = V.fromList [Point 8 22, Point 30 5, Point 26 7] + baseBuild <- + requireRight + "large asymmetric extension base" + (constrainedDelaunay unitElementDefaults basePoints baseConstraints) + extensionBuild <- + requireRight + "large asymmetric extension incoming" + (constrainedDelaunay unitElementDefaults extensionPoints extensionConstraints) + conflictBuild <- + requireRight + "large asymmetric extension conflicting incoming" + (constrainedDelaunay unitElementDefaults conflictPoints (V.singleton (0, 1))) + let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild) + extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild) + conflicting = mapVertices (const (Set.singleton "conflict")) (buildTriangulation conflictBuild) + predecessor + :: Triangulation 'Constrained (Set.Set String) () () () + -> ( Triangulation 'Constrained (Set.Set String) () () () + , Map.Map VertexId (Point, Set.Set String) + , Set.Set (CanonicalSegment) + ) + predecessor triangulation = + ( triangulation + , Map.fromList + [ (vertex, (vertexPoint triangulation vertex, vertexData triangulation vertex)) + | vertex <- vertices triangulation + ] + , Set.fromList (V.toList (constraintSegments triangulation)) + ) + assertPredecessor + :: String + -> ( Triangulation 'Constrained (Set.Set String) () () () + , Map.Map VertexId (Point, Set.Set String) + , Set.Set (CanonicalSegment) + ) + -> Triangulation 'Constrained (Set.Set String) () () () + -> IO () + assertPredecessor label snapshot triangulation = + assertEqual label snapshot (predecessor triangulation) + baseBefore <- evaluate (force (predecessor base)) + extensionBefore <- evaluate (force (predecessor extension)) + conflictingBefore <- evaluate (force (predecessor conflicting)) + let (_, baseVertexSnapshotBefore, baseConstraintSnapshotBefore) = baseBefore + (_, _, extensionConstraintSnapshotBefore) = extensionBefore + extensionResult <- + requireRight + "large asymmetric constrained extension" + (extendConstrainedWith Set.union base extension) + let extended = constrainedExtensionTriangulation extensionResult + extendedConstraints = Set.fromList (V.toList (constraintSegments extended)) + extendedVertexSnapshot = + Map.fromList + [ (vertex, (vertexPoint extended vertex, vertexData extended vertex)) + | vertex <- vertices extended + ] + assertEqual + "large asymmetric extension retains every base vertex handle, coordinate, and payload" + baseVertexSnapshotBefore + (Map.restrictKeys extendedVertexSnapshot (Map.keysSet baseVertexSnapshotBefore)) + assertEqual + "large asymmetric extension retains its complete base constraint source section" + baseConstraintSnapshotBefore + (Set.intersection baseConstraintSnapshotBefore extendedConstraints) + assertEqual + "large asymmetric extension retains its complete incoming constraint source section" + extensionConstraintSnapshotBefore + (Set.intersection extensionConstraintSnapshotBefore extendedConstraints) + assertEqual + "large asymmetric extension preserves exactly both source constraint sections" + (Set.union baseConstraintSnapshotBefore extensionConstraintSnapshotBefore) + extendedConstraints + assertEqual + "large asymmetric extension leaves the frozen base predecessor physically unchanged" + baseBefore + (predecessor base) + assertPredecessor + "large asymmetric extension leaves the frozen incoming predecessor physically unchanged" + extensionBefore + extension + assertEqual + "large asymmetric extension charges only the incoming sites" + (V.length extensionPoints) + (statInputPoints (constrainedExtensionBuildStats extensionResult)) + assertEqual + "large asymmetric extension replays only the incoming constraints" + (V.length extensionConstraints) + (constraintBatchRequests (constrainedExtensionConstraintStats extensionResult)) + assertCdtValid "large asymmetric constrained extension" extended + case extendConstrainedWith Set.union base conflicting of + Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure () + outcome -> + fail + ( "large asymmetric extension did not refuse the crossing incoming corridor: " + <> show outcome + ) + assertEqual + "large asymmetric extension refusal leaves the frozen base predecessor physically unchanged" + baseBefore + (predecessor base) + assertPredecessor + "large asymmetric extension refusal leaves the conflicting predecessor physically unchanged" + conflictingBefore + conflicting + +-- | A separated constrained seam is a restriction-preserving operation, not +-- the canonical site-set union wearing a cheaper costume. Both closed source +-- sections survive face-for-face; only the corridor contributes new faces. +testSeparatedConstrainedSeam :: IO () +testSeparatedConstrainedSeam = do + let leftPoints :: V.Vector (Point) + leftPoints = + V.fromList + [ Point (-4) (-1) + , Point (-2) (-1) + , Point (-2) 1 + , Point (-4) 1 + ] + rightPoints :: V.Vector (Point) + rightPoints = + V.fromList + [ Point 2 (-1) + , Point 4 (-1) + , Point 4 1 + , Point 2 1 + ] + closedContour = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)] + leftBuild <- + requireRight + "separated constrained seam left" + (constrainedDelaunay unitElementDefaults leftPoints closedContour) + rightBuild <- + requireRight + "separated constrained seam right" + (constrainedDelaunay unitElementDefaults rightPoints closedContour) + let left = + mapVertices + (const (Set.singleton "left")) + (buildTriangulation leftBuild) + right = + mapVertices + (const (Set.singleton "right")) + (buildTriangulation rightBuild) + leftFaceKeys = Set.fromList (fmap (faceKeyOf left) (innerFaces left)) + rightFaceKeys = Set.fromList (fmap (faceKeyOf right) (innerFaces right)) + expectedConstraints = + Set.union + (Set.fromList (V.toList (constraintSegments left))) + (Set.fromList (V.toList (constraintSegments right))) + seam <- + requireRight + "source-preserving separated constrained seam" + (joinSeparatedConstrainedWith Set.union left right) + let joined = constrainedSeamResultTriangulation seam + joinedFaceKeys = Set.fromList (fmap (faceKeyOf joined) (innerFaces joined)) + actualAnnotations = + Map.fromList + [ (vertexPoint joined vertex, vertexData joined vertex) + | vertex <- vertices joined + ] + expectedAnnotations = + Map.union + ( Map.fromList + [ (vertexPoint left vertex, vertexData left vertex) + | vertex <- vertices left + ] + ) + ( Map.fromList + [ (vertexPoint right vertex, vertexData right vertex) + | vertex <- vertices right + ] + ) + assertCdtValid "source-preserving separated constrained seam" joined + assertEqual + "separated seam preserves all source annotations" + expectedAnnotations + actualAnnotations + assertEqual + "separated seam preserves the exact constraint section" + expectedConstraints + (Set.fromList (V.toList (constraintSegments joined))) + unless (leftFaceKeys `Set.isSubsetOf` joinedFaceKeys) $ + fail "separated seam removed or retriangulated a left source face" + unless (rightFaceKeys `Set.isSubsetOf` joinedFaceKeys) $ + fail "separated seam removed or retriangulated a right source face" + assertEqual + "separated seam has one left face witness per source face" + (numInnerFaces left) + (V.length (constrainedSeamLeftFaceEvidence seam)) + assertEqual + "separated seam has one right face witness per source face" + (numInnerFaces right) + (V.length (constrainedSeamRightFaceEvidence seam)) + forM_ (V.toList (constrainedSeamLeftFaceEvidence seam)) $ \evidence -> + assertEqual + "left face witness names the exact target triangle" + (faceKeyOf left (constrainedSeamSourceFace evidence)) + (faceKeyOf joined (constrainedSeamTargetFace evidence)) + forM_ (V.toList (constrainedSeamRightFaceEvidence seam)) $ \evidence -> + assertEqual + "right face witness names the exact target triangle" + (faceKeyOf right (constrainedSeamSourceFace evidence)) + (faceKeyOf joined (constrainedSeamTargetFace evidence)) + when (V.null (constrainedSeamNewFaces 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 (constrainedSeamLeftConstraintEvidence seam) + <> V.toList (constrainedSeamRightConstraintEvidence seam) + ) + ) $ + fail "separated seam recovered a constraint already represented by its copied source" + + reversed <- + requireRight + "source-preserving reversed separated constrained seam" + (joinSeparatedConstrainedWith Set.union right left) + assertEqual + "reversing separated seam operands preserves the published constrained value" + joined + (constrainedSeamResultTriangulation reversed) + + case joinSeparatedConstrainedWith Set.union left left of + Left ConstraintUnionNotSeparated -> pure () + other -> fail ("non-separated constrained seam was not refused: " <> show other) + +testConstrainedRefinement :: IO () +testConstrainedRefinement = do + cdtBuild <- requireRight "bounded domain" $ constrainedDelaunay + unitElementDefaults + (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 4 2, Point 4 6]) + (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]) + let cdt = buildTriangulation cdtBuild + parameters = defaultRefinementParameters + { refineMaxAdditionalVertices = Just 80 + , refineMaxArea = Just 3 + , refineMaxRadiusEdgeRatio = Just 1.4 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + refined <- requireRight "constrained refinement" (refine id parameters cdt) + let result = refinedTriangulation refined + canonicalResult <- requireRight "canonical constrained refinement" (canonicalize result) + unless (refinementAddedVertices refined > 0) $ fail "constrained refinement inserted no Steiner points" + assertCdtValid "constrained refinement" result + unless (numConstraints result >= numConstraints cdt) $ + fail "constraint splitting lost the constrained boundary" + assertEqual + "canonical publication preserves constraint segments" + (constraintSegments result) + (constraintSegments canonicalResult) + + -- Refinement maintains the outer-region classification incrementally, from + -- the touched patch alone. That is a claim about what an insertion cannot + -- reach, so it is gated against an independent flood over the finished mesh + -- rather than trusted. The domain here is deliberately narrower than its + -- convex hull, so the excluded set is non-empty and the two can disagree. + notchBuild <- requireRight "notched domain" $ constrainedDelaunay + unitElementDefaults + (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 13 4, Point 4 4]) + (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]) + let notch = buildTriangulation notchBuild + notchParameters = defaultRefinementParameters + { refineMaxAdditionalVertices = Just 120 + , refineMaxArea = Just 1.5 + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + notchRefined <- requireRight "notched refinement" (refine id notchParameters notch) + let notchResult = refinedTriangulation notchRefined + maintained = sort (V.toList (refinementExcludedFaces notchRefined)) + independent = sort (outerRegionFaces notchResult) + unless (refinementAddedVertices notchRefined > 0) $ fail "notched refinement inserted no Steiner points" + when (null independent) $ fail "notched domain produced no outer region: the gate is vacuous" + assertEqual "incremental exclusion agrees with an independent flood" independent maintained + assertCdtValid "notched refinement" notchResult + + annulusBuild <- requireRight "annular domain" $ constrainedDelaunay + unitElementDefaults + ( V.fromList + [ Point 0 0 + , Point 12 0 + , Point 12 12 + , Point 0 12 + , Point 4 4 + , Point 8 4 + , Point 8 8 + , Point 4 8 + ] + ) + ( V.fromList + [ (0, 1) + , (1, 2) + , (2, 3) + , (3, 0) + , (4, 5) + , (5, 6) + , (6, 7) + , (7, 4) + ] + ) + let annulus = buildTriangulation annulusBuild + annulusParameters :: Int -> Maybe Double -> RefinementParameters + annulusParameters budget maximumArea = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just budget + , refineMaxArea = maximumArea + , refineExcludeOuterFaces = True + , refineKeepConstraintEdges = False + } + annulusUnchanged <- + requireRight + "budget-zero annular refinement" + (refine id (annulusParameters 0 Nothing) annulus) + let initialAnnulusOutside = sort (outerRegionFaces annulus) + budgetZeroOutside = + sort (V.toList (refinementExcludedFaces annulusUnchanged)) + assertEqual "annulus has one two-crossing hole" 2 (length initialAnnulusOutside) + assertEqual + "budget-zero refinement uses the authoritative annulus classification" + initialAnnulusOutside + budgetZeroOutside + + annulusRefined <- + requireRight + "positive-budget annular refinement" + (refine id (annulusParameters 40 (Just 4)) annulus) + let refinedAnnulus = refinedTriangulation annulusRefined + maintainedAnnulus = + sort (V.toList (refinementExcludedFaces annulusRefined)) + independentAnnulus = sort (outerRegionFaces refinedAnnulus) + unless (refinementAddedVertices annulusRefined > 0) $ + fail "annular refinement inserted no Steiner points" + assertEqual + "incremental annulus exclusion agrees with authoritative barrier depth" + independentAnnulus + maintainedAnnulus + assertCdtValid "annular constrained refinement" refinedAnnulus + + -- A tiny constraint can share a mesh with coordinates of vastly different + -- magnitude. Encroachment is discovered by a local cavity walk, so there is + -- no broad phase for the range to overflow; the pin is that the scaled + -- circumcenter and diametral predicates still produce exactly one vertex. + wideGridBuild <- requireRight "wide-grid constrained domain" $ constrainedDelaunay + unitElementDefaults + ( V.fromList + [ Point 0 0 + , Point 2.0e-43 0 + , Point 1.0e60 0 + , Point 0 1.0e60 + ] :: V.Vector (Point) + ) + (V.singleton (0, 1)) + wideGridRefined <- + requireRight + "wide-grid constrained refinement" + ( refine + id + defaultRefinementParameters + { refineMaxAdditionalVertices = Just 1 + , refineMaxArea = Just 1.0e119 + , refineKeepConstraintEdges = False + } + (buildTriangulation wideGridBuild) + ) + assertEqual "wide-grid refinement count" 1 (refinementAddedVertices wideGridRefined) + assertCdtValid "wide-grid constrained refinement" (refinedTriangulation wideGridRefined) + +-- | A local domain is a closed section, not a hopeful initial queue. Its +-- interface is exact, its protected faces survive point-for-point, and the +-- receipt contains no visit to the protected side. +testCheckedLocalRefinement :: IO () +testCheckedLocalRefinement = do + built <- + requireRight + "checked local refinement source" + ( constrainedDelaunay + unitElementDefaults + ( V.fromList + [ Point 0 0 + , Point 4.1 0 + , Point 8 0.2 + , Point 0.1 4 + , Point 4 4.2 + , Point 8.1 4 + ] + ) + (V.singleton (2, 5)) + ) + let source = buildTriangulation built + permitted = + Set.fromList + [ face + | face <- innerFaces source + , faceCentroidX source face < 4.05 + ] + interface = + Set.fromList + [ edge + | edge <- undirectedEdges source + , let (forward, backward) = directedPair edge + forwardFace = incidentFace source forward + backwardFace = incidentFace source backward + , forwardFace /= outerFace + , backwardFace /= outerFace + , Set.member forwardFace permitted /= Set.member backwardFace permitted + ] + protected = filter (`Set.notMember` permitted) (innerFaces source) + protectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint source) (faceVertices source face)))) protected + calmParameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just 3 + , refineMaxRadiusEdgeRatio = Nothing + , refineKeepConstraintEdges = True + } + crossingParameters = calmParameters{refineMaxArea = Just 1} + unless (not (Set.null permitted) && not (null protected) && not (Set.null interface)) $ + fail "checked local refinement fixture did not form a nontrivial cover" + case 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) + let localResult = refinementDomainResult refined + target = refinedTriangulation localResult + targetProtectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint target) (faceVertices target face)))) protected + receipt = refinementDomainReceipt refined + assertEqual "checked local protected face restriction" protectedSignatures targetProtectedSignatures + assertEqual "checked local protected visit receipt" V.empty (refinementVisitedProtectedFaces receipt) + assertEqual "checked local boundary crossing receipt" 0 (refinementAttemptedBoundaryCrossings receipt) + assertEqual + "checked local protected constraint restriction" + (constraintSegments source) + (constraintSegments target) + assertValid "checked local refinement" target + case refineWithinDomain id crossingParameters permitted interface 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 + 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 + 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 + Left RefinementDomainForbidsOuterFaceExclusion -> pure () + outcome -> fail ("checked local refinement accepted outer-face exclusion: " <> either show (const "success") outcome) + wholeRefined <- + requireRight + "checked whole-section refinement" + ( refineWithinDomain + id + crossingParameters + (Set.fromList (innerFaces source)) + Set.empty + source + ) + let wholeResult = refinementDomainResult wholeRefined + wholeReceipt = refinementDomainReceipt wholeRefined + unless (refinementAddedVertices wholeResult > 0) $ + fail "checked whole-section refinement did not improve its admitted section" + unless (not (V.null (refinementCreatedFaces wholeReceipt))) $ + fail "checked whole-section refinement omitted semantically rewritten face slots" + unless + ( V.any + (\(FaceId raw) -> toInteger raw < toInteger (numFaces source)) + (refinementCreatedFaces wholeReceipt) + ) $ + fail "checked whole-section refinement omitted recycled face slots" + assertValid "checked whole-section refinement" (refinedTriangulation wholeResult) + where + faceCentroidX + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Double + faceCentroidX triangulation face = + case fmap (vertexPoint triangulation) (faceVertices triangulation face) of + [] -> 0 + points -> + sum [x | Point x _ <- points] / fromIntegral (length points) + +testRepeatedBoundaryAdjacentRefinement :: IO () +testRepeatedBoundaryAdjacentRefinement = (do + built <- + requireRight + "repeated boundary-adjacent constrained source" + ( constrainedDelaunay + unitElementDefaults + ( V.fromList + [ Point 0 0 + , Point 4 0 + , Point 8 0 + , Point 12 0 + , Point 0 4 + , Point 4 4 + , Point 8 4 + , Point 12 4 + ] + ) + (V.singleton (2, 6)) + ) + let source = buildTriangulation built + (sourcePermitted, sourceInterface) = leftSection source + firstParameters = + defaultRefinementParameters + { refineMaxAdditionalVertices = Just 20 + , refineMaxArea = Just 1 + , refineMaxRadiusEdgeRatio = Nothing + , refineKeepConstraintEdges = True + } + firstRefinement <- + requireRight + "first boundary-adjacent refinement" + ( refineWithinDomain + id + firstParameters + sourcePermitted + sourceInterface + source + ) + let firstResult = refinementDomainResult firstRefinement + firstTarget = refinedTriangulation firstResult + firstReceipt = refinementDomainReceipt firstRefinement + (secondPermitted, secondInterface) = leftSection firstTarget + secondParameters = firstParameters{refineMaxAdditionalVertices = Just 1} + unless (refinementAddedVertices firstResult > 0) $ + fail "first boundary-adjacent refinement did not refine its admitted section" + unless (refinementInterfaceBoundaryReads firstReceipt > 0) $ + fail "boundary-adjacent refinement did not report its immutable interface read" + assertEqual + "boundary-adjacent crossing attempts" + 0 + (refinementAttemptedBoundaryCrossings firstReceipt) + assertEqual + "first boundary-adjacent constraint restriction" + (constraintSegments source) + (constraintSegments firstTarget) + secondRefinement <- + requireRight + "repeated boundary-adjacent refinement" + ( refineWithinDomain + id + secondParameters + secondPermitted + secondInterface + firstTarget + ) + let secondResult = refinementDomainResult secondRefinement + secondTarget = refinedTriangulation secondResult + secondReceipt = refinementDomainReceipt secondRefinement + unless (refinementAddedVertices secondResult > 0) $ + fail "repeated boundary-adjacent refinement did not retain its dynamic join-face support" + assertEqual + "repeated boundary-adjacent protected visits" + V.empty + (refinementVisitedProtectedFaces secondReceipt) + assertEqual + "repeated boundary-adjacent constraint restriction" + (constraintSegments firstTarget) + (constraintSegments secondTarget) + assertValid "repeated boundary-adjacent refinement" secondTarget) + where + leftSection + :: Triangulation mode vertex directed undirected face + -> (Set.Set FaceId, Set.Set UndirectedEdgeId) + 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) + faceCentroidX + :: Triangulation mode vertex directed undirected face + -> FaceId + -> Double + faceCentroidX triangulation face = + case fmap (vertexPoint triangulation) (faceVertices triangulation face) of + [] -> 0 + points -> + sum [x | Point x _ <- points] / fromIntegral (length points) + +testTraversal :: IO () +testTraversal = do + built <- requirePointBuild "traversal" [Point (-3) 0, Point (-1) (-2), Point (-1) 2, Point 1 (-2), Point 1 2, Point 3 0] + forwardStart <- requireQueryPoint "forward traversal start" (Point (-4) 0) + forwardEnd <- requireQueryPoint "forward traversal end" (Point 4 0) + let triangulation = buildTriangulation built + forward = lineIntersections triangulation forwardStart forwardEnd + backward = lineIntersections triangulation forwardEnd forwardStart + when (null forward) $ fail "ordered line traversal crossed nothing" + assertEqual + "reversing the segment reverses the crossings" + (map crossingIdentity forward) + (reverse (map crossingIdentity backward)) + circleEdges <- Set.fromList <$> requireRight "circle edge query" (edgesInCircle triangulation (Point 0 0) 4) + let bruteCircle = Set.fromList + [ edge + | edge <- undirectedEdges triangulation + , let (a, b) = undirectedEndpoints triangulation edge + , segmentDistanceSquared (vertexPoint triangulation a) (vertexPoint triangulation b) (Point 0 0) <= 4 + ] + assertEqual "circle edge flood" bruteCircle circleEdges + assertEqual + "negative circle metric refusal" + (Left (NegativeRadiusSquared (-1))) + (circleMetric (Point 0 0 :: Point) (-1)) + assertEqual + "negative circle edge-query refusal" + (Left (NegativeRadiusSquared (-1))) + (edgesInCircle triangulation (Point 0 0) (-1)) + assertEqual + "negative circle vertex-query refusal" + (Left (NegativeRadiusSquared (-1))) + (verticesInCircle triangulation (Point 0 0) (-1)) + assertEqual + "NaN circle metric refusal" + (Left (NonFiniteRadiusSquared ValueNaN)) + (circleMetric (Point 0 0 :: Point) (0 / 0)) + assertEqual + "NaN circle center-x refusal" + (Left (InvalidCircleCenter (InvalidPointX CoordinateNaN))) + (circleMetric (Point (0 / 0) 0 :: Point) 1) + assertEqual + "positive-infinite circle center-y refusal" + (Left (InvalidCircleCenter (InvalidPointY CoordinateInfinite))) + (edgesInCircle triangulation (Point 0 (1 / 0)) 1) + assertEqual + "negative-infinite circle center-x refusal" + (Left (InvalidCircleCenter (InvalidPointX CoordinateInfinite))) + (verticesInCircle triangulation (Point ((-1) / 0) 0) 1) + assertEqual + "infinite circle edge-query refusal" + (Left (NonFiniteRadiusSquared ValuePositiveInfinity)) + (edgesInCircle triangulation (Point 0 0) (1 / 0)) + assertEqual + "negative-infinite circle vertex-query refusal" + (Left (NonFiniteRadiusSquared ValueNegativeInfinity)) + (verticesInCircle triangulation (Point 0 0) ((-1) / 0)) + rectangleVertices <- + Set.fromList + <$> requireRight + "rectangle query" + (verticesInRectangle triangulation (Point (-1.1) (-2.1)) (Point 1.1 2.1)) + let bruteVertices = Set.fromList + [ vertex + | vertex <- vertices triangulation + , let Point x y = vertexPoint triangulation vertex + , x >= (-1.1), x <= 1.1, y >= (-2.1), y <= 2.1 + ] + assertEqual "rectangle vertex flood" bruteVertices rectangleVertices + +testRandomizedConstruction :: IO () +testRandomizedConstruction = do + forM_ [0 .. 31] $ \index -> do + let points = randomPoints (0x9e37_79b9 + fromIntegral index) (40 + index * 7) + built <- requirePointBuild ("random build " <> show index) points + let triangulation = buildTriangulation built + assertValid ("random build " <> show index) triangulation + assertEqual "random input mapping" (length points) (sizeofPrimArray (buildInputVertices built)) + +testErrors :: IO () +testErrors = do + assertEqual + "NaN query x refusal" + (Left (InvalidPointX CoordinateNaN)) + (mkQueryPoint (Point (0 / 0) 0)) + assertEqual + "infinite query y refusal" + (Left (InvalidPointY CoordinateInfinite)) + (mkQueryPoint (Point 0 (1 / 0))) + assertEqual + "negative-infinite query x refusal" + (Left (InvalidPointX CoordinateInfinite)) + (mkQueryPoint (Point ((-1) / 0) 0)) + case delaunay unitElementDefaults (V.singleton (Point (0 / 0) 0 :: Point)) of + Left (InvalidCoordinate (Just 0) _ CoordinateNaN) -> pure () + Left other -> fail ("NaN insertion result: " <> show other) + Right built -> + fail + ( "NaN insertion result: built a triangulation of " + <> show (numVertices (buildTriangulation built)) + <> " vertices" + ) + expectBuildFailure + "NaN minimum angle" + (RefinementMinimumAngleNotFinite ValueNaN) + (withMinimumAngle (0 / 0 :: Double) defaultRefinementParameters) + expectBuildFailure + "infinite minimum angle" + (RefinementMinimumAngleNotFinite ValuePositiveInfinity) + (withMinimumAngle (1 / 0 :: Double) defaultRefinementParameters) + expectBuildFailure + "out-of-range minimum angle" + (RefinementMinimumAngleOutOfRange 61) + (withMinimumAngle (61 :: Double) defaultRefinementParameters) + expectBuildFailure + "minimum angle whose derived ratio overflows" + (RefinementMinimumAngleDerivedRatioNotFinite ValuePositiveInfinity) + (withMinimumAngle (encodeFloat 1 (-1074) :: Double) defaultRefinementParameters) + square <- requirePointBuild "area validation square" [Point 0 0, Point 1 0, Point 1 1, Point 0 1] + let refineWith parameters = + refine id parameters (buildTriangulation square) + refineWithArea area = + refineWith defaultRefinementParameters{refineMaxArea = Just area} + expectBuildFailure + "negative refinement vertex budget" + (RefinementMaximumAdditionalVerticesNegative (-1)) + (refineWith defaultRefinementParameters{refineMaxAdditionalVertices = Just (-1)}) + expectBuildFailure + "infinite minimum area" + (RefinementMinimumAreaNotFinite ValuePositiveInfinity) + (refineWith defaultRefinementParameters{refineMinArea = Just (1 / 0)}) + expectBuildFailure + "negative minimum area" + (RefinementMinimumAreaNegative (-1)) + (refineWith defaultRefinementParameters{refineMinArea = Just (-1)}) + expectBuildFailure + "NaN maximum area" + (RefinementMaximumAreaNotFinite ValueNaN) + (refineWithArea (0 / 0)) + expectBuildFailure + "infinite maximum area" + (RefinementMaximumAreaNotFinite ValuePositiveInfinity) + (refineWithArea (1 / 0)) + expectBuildFailure + "zero maximum area" + (RefinementMaximumAreaNotPositive 0) + (refineWithArea 0) + expectBuildFailure + "negative maximum area" + (RefinementMaximumAreaNotPositive (-1)) + (refineWithArea (-1)) + expectBuildFailure + "infinite maximum radius/edge ratio" + (RefinementMaximumRadiusEdgeRatioNotFinite ValuePositiveInfinity) + (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just (1 / 0)}) + expectBuildFailure + "non-positive maximum radius/edge ratio" + (RefinementMaximumRadiusEdgeRatioNotPositive 0) + (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just 0}) + expectBuildFailure + "minimum area above maximum area" + (RefinementMinimumAreaExceedsMaximum 2 1) + ( refineWith + defaultRefinementParameters + { refineMinArea = Just 2 + , refineMaxArea = Just 1 + } + ) + case refineWithArea 0.25 of + Right _ -> pure () + Left failure -> fail ("positive maximum area rejected: " <> show failure) + +expectBuildFailure :: String -> BuildError -> Either BuildError value -> IO () +expectBuildFailure label expected outcome = + case outcome of + Left actual -> assertEqual label expected actual + Right _ -> fail (label <> ": expected " <> show expected <> ", got success") + + +canonicalEdges + :: Triangulation mode vertex directed undirected face + -> Set.Set (Point, Point) +canonicalEdges triangulation = + Set.fromList + [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge)) + | undirected <- undirectedEdges triangulation + , let edge = normalizedDirected undirected + ] + where + ordered :: Ord value => value -> value -> (value, value) + ordered left right = if left <= right then (left, right) else (right, left) + +requireJust :: String -> Maybe value -> IO value +requireJust _ (Just value) = pure value +requireJust label Nothing = fail (label <> ": expected Just") + +requireAcceptedConstraint + :: String + -> ConstraintBatchResult vertex directed undirected face + -> IO (V.Vector DirectedEdgeId, Int) +requireAcceptedConstraint label batch = + case V.toList (constraintBatchOutcomes batch) of + [ConstraintAccepted path added] -> pure (path, added) + outcomes -> + fail + ( label + <> ": expected one accepted constraint, got " + <> show outcomes + ) + +assertBatchStats + :: String + -> ConstraintBatchResult vertex directed undirected face + -> IO () +assertBatchStats label batch = do + let stats = constraintBatchStats batch + (accepted, rejected) = + V.foldl' + (\(!acceptedCount, !rejectedCount) outcome -> + case outcome of + ConstraintAccepted _ _ -> (acceptedCount + 1, rejectedCount) + ConstraintRejected _ -> (acceptedCount, rejectedCount + 1) + ) + (0, 0) + (constraintBatchOutcomes batch) + assertEqual + (label <> " request count") + (V.length (constraintBatchOutcomes batch)) + (constraintBatchRequests stats) + assertEqual + (label <> " accepted count") + accepted + (constraintBatchAccepted stats) + assertEqual + (label <> " rejected count") + rejected + (constraintBatchRejected stats) + +replayConstraintRequest + :: (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome]) + -> (VertexId, VertexId) + -> Either + (CdtError) + (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome]) +replayConstraintRequest (current, outcomes) request = do + singleton <- recoverConstraints current (V.singleton request) + case V.toList (constraintBatchOutcomes singleton) of + [outcome] -> + Right + ( constraintBatchTriangulation singleton + , outcome : outcomes + ) + cardinality -> + Left + ( ConstraintBatchCardinalityMismatch + 1 + (length cardinality) + ) + +requirePointBuild :: String -> [Point] -> IO (BuildResult 'Unconstrained (Point) () () ()) +requirePointBuild label points = requireRight label (delaunay unitElementDefaults (V.fromList points)) + +assertCdtValid :: String -> Triangulation 'Constrained vertex () () () -> IO () +assertCdtValid label triangulation = + case validateTriangulation triangulation of + [] -> pure () + violations -> fail (label <> " CDT violations: " <> show violations) + +assertNear :: String -> Double -> Double -> Double -> IO () +assertNear label tolerance expected actual = + unless (abs (expected - actual) <= tolerance * max 1 (max (abs expected) (abs actual))) $ + fail (label <> ": expected " <> show expected <> ", got " <> show actual) + +gridPoints :: Int -> Int -> [Point] +gridPoints width height = + [ Point (fromIntegral x + jitter x y) (fromIntegral y + jitter y x) + | y <- [0 .. height - 1] + , x <- [0 .. width - 1] + ] + where + jitter :: Int -> Int -> Double + jitter a b = fromIntegral ((a * 17 + b * 31) `mod` 11) * 1.0e-5 + +randomPoints :: Word64 -> Int -> [Point] +randomPoints seed count = take count (go seed Set.empty) + where + go :: Word64 -> Set.Set (Point) -> [Point] + go state seen = + let state1 = lcg state + state2 = lcg state1 + x = unit state1 * 2 - 1 + y = unit state2 * 2 - 1 + point = Point x y + in if Set.member point seen + then go state2 seen + else point : go state2 (Set.insert point seen) + + unit :: Word64 -> Double + unit value = fromIntegral (value `mod` 9_007_199_254_740_881) / 9_007_199_254_740_881 + + lcg :: Word64 -> Word64 + lcg value = value * 6_364_136_223_846_793_005 + 1_442_695_040_888_963_407 diff --git a/test/parallel/Main.hs b/test/parallel/Main.hs new file mode 100644 --- /dev/null +++ b/test/parallel/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.ParallelSpec as ParallelSpec + +main :: IO () +main = ParallelSpec.tests diff --git a/test/parallel/Moonlight/Triangulation/ParallelSpec.hs b/test/parallel/Moonlight/Triangulation/ParallelSpec.hs new file mode 100644 --- /dev/null +++ b/test/parallel/Moonlight/Triangulation/ParallelSpec.hs @@ -0,0 +1,72 @@ +-- | The one module in the package that spawns threads. Its whole contract is +-- that scheduling is invisible: the same tournament, the same value, at every +-- worker count. That is what is asserted here, because a concurrent join whose +-- result depended on the worker count would be wrong in a way no amount of +-- validity checking on a single run could see. +module Moonlight.Triangulation.ParallelSpec + ( tests + ) where + +import qualified Data.List.NonEmpty as NE +import Moonlight.Triangulation (unions) +import Moonlight.Triangulation.AlgebraFixtures (Mesh, assertMesh, operands) +import Moonlight.Triangulation.Parallel (unionsConcurrently) +import Support (requireRight) + +tests :: IO () +tests = do + testConcurrentJoinAgreesWithSequential + testConcurrentJoinIsWorkerCountInvariant + putStrLn "parallel: ok" + +-- Counts on both sides of the operand count, so the tournament is starved at +-- one end and saturated at the other, and 1 exercises the sequential-collapse +-- branch that a purely concurrent test would never reach. +workerCounts :: [Int] +workerCounts = [1, 2, 3, 5, 16] + +concurrentJoin :: Int -> NE.NonEmpty Mesh -> IO Mesh +concurrentJoin workers shards = do + outcome <- unionsConcurrently workers shards + requireRight ("concurrent unions at " <> show workers <> " workers") outcome + +-- The sequential tournament is the oracle. It is a different interpreter over +-- the same plan, not a second copy of this one, so agreement is evidence. +testConcurrentJoinAgreesWithSequential :: IO () +testConcurrentJoinAgreesWithSequential = do + shards <- fmap (map snd) operands + nonEmptyShards <- case NE.nonEmpty shards of + Nothing -> fail "concurrent join agreement: no operands" + Just present -> pure present + sequential <- requireRight "sequential unions" (unions shards) + mapM_ + ( \workers -> do + concurrent <- concurrentJoin workers nonEmptyShards + assertMesh + ("concurrent tournament at " <> show workers <> " workers") + sequential + concurrent + ) + workerCounts + +-- Stated separately from agreement: even if both interpreters were wrong in +-- the same way, a result that moved with the worker count would still be a +-- defect, and this is the assertion that would catch it. +testConcurrentJoinIsWorkerCountInvariant :: IO () +testConcurrentJoinIsWorkerCountInvariant = do + shards <- fmap (map snd) operands + nonEmptyShards <- case NE.nonEmpty shards of + Nothing -> fail "worker-count invariance: no operands" + Just present -> pure present + results <- traverse (`concurrentJoin` nonEmptyShards) workerCounts + case results of + [] -> fail "worker-count invariance: no worker counts" + (reference : rest) -> + mapM_ + ( \(workers, result) -> + assertMesh + ("worker count " <> show workers <> " agrees with the first") + reference + result + ) + (zip (drop 1 workerCounts) rest) diff --git a/test/serialization/Main.hs b/test/serialization/Main.hs new file mode 100644 --- /dev/null +++ b/test/serialization/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.SerializationSpec as SerializationSpec + +main :: IO () +main = SerializationSpec.tests diff --git a/test/serialization/Moonlight/Triangulation/SerializationSpec.hs b/test/serialization/Moonlight/Triangulation/SerializationSpec.hs new file mode 100644 --- /dev/null +++ b/test/serialization/Moonlight/Triangulation/SerializationSpec.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | The serialization slice: the versioned binary envelope and its refusals. +module Moonlight.Triangulation.SerializationSpec (tests) where + +import Control.DeepSeq (NFData) +import Control.Monad (forM_, unless) +import Data.Binary (Binary) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Moonlight.Triangulation +import Moonlight.Triangulation.Serialization +import Support (assertEqual, assertValid, requireRight) + +tests :: IO () +tests = do + testRoundTrip + testIndependentPayloadGeometryRoundTrip + testPointPayloadRoundTrip + testRejectsCorruption + putStrLn "all serialization tests passed" + +data SerialVertex = SerialVertex + { serialPosition :: !(Point) + , serialLabel :: !Int + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, Binary) + +instance HasPosition SerialVertex where + position = serialPosition + +type SerialTriangulation = Triangulation 'Unconstrained SerialVertex Int Bool String + +source :: IO SerialTriangulation +source = do + let defaults = ElementDefaults (3 :: Int) True ("face" :: String) + payloads = + V.fromList + [ SerialVertex (Point 0 0) 10 + , SerialVertex (Point 2 0) 20 + , SerialVertex (Point 0 2) 30 + , SerialVertex (Point 0.5 0.5) 40 + ] + buildTriangulation <$> requireRight "serialization source" (delaunay defaults payloads) + +testRoundTrip :: IO () +testRoundTrip = do + original <- source + let bytes = encodeTriangulation original + unless (BL.length bytes > 0) $ fail "serialization produced an empty payload" + roundTrip <- requireRight "serialization round trip" (decodeTriangulation bytes :: Either SerializationError SerialTriangulation) + assertEqual "serialization equality" original roundTrip + assertValid "serialization round trip" roundTrip + +-- Vertex payload positions are annotations after ingestion. Serialization must +-- therefore preserve the fixed geometry and the independently edited payload, +-- rather than letting the latter reauthor the former on decode. +testIndependentPayloadGeometryRoundTrip :: IO () +testIndependentPayloadGeometryRoundTrip = do + geometry <- source + vertex <- case vertices geometry of + (first : _) -> pure first + [] -> fail "independent payload fixture has no vertices" + let independentPayload = SerialVertex (Point 91 73) 1010 + original = setVertexData geometry vertex independentPayload + positionless = mapVertices serialLabel original + assertEqual "independent payload leaves geometry fixed" + (vertexPoint geometry vertex) (vertexPoint original vertex) + assertEqual "independent payload position is stored" + (Point 91 73) (serialPosition (vertexData original vertex)) + roundTrip <- + requireRight + "independent payload serialization" + (decodeTriangulation (encodeTriangulation original) :: Either SerializationError SerialTriangulation) + assertEqual "independent geometry, payload, and topology round trip" original roundTrip + assertValid "independent payload serialization" roundTrip + positionlessRoundTrip <- + requireRight + "positionless payload serialization" + (decodeTriangulation (encodeTriangulation positionless) :: Either SerializationError (Triangulation 'Unconstrained Int Int Bool String)) + assertEqual "positionless payload round trip" positionless positionlessRoundTrip + assertValid "positionless payload serialization" positionlessRoundTrip + +testPointPayloadRoundTrip :: IO () +testPointPayloadRoundTrip = do + let points = V.fromList [Point 0 0, Point 2 0, Point 0 2, Point 0.5 0.5] :: V.Vector (Point) + built <- requireRight "point payload source" (delaunay unitElementDefaults points) + let geometry = buildTriangulation built + vertex <- case vertices geometry of + (first : _) -> pure first + [] -> fail "point payload fixture has no vertices" + let original = setVertexData geometry vertex (Point 13 17) + assertEqual "point payload leaves geometry fixed" + (vertexPoint geometry vertex) (vertexPoint original vertex) + assertEqual "point payload is stored" + (Point 13 17) (vertexData original vertex) + roundTrip <- + requireRight + "point payload serialization" + (decodeTriangulation (encodeTriangulation original) :: Either SerializationError (Triangulation 'Unconstrained (Point) () () ())) + assertEqual "point payload serialization equality" original roundTrip + assertValid "point payload serialization round trip" roundTrip + +-- The header is the part of the stream that is structurally constrained: magic, +-- version, constraint mode and coordinate encoding each have exactly one admissible +-- byte pattern, so every mutation of them must be refused. Beyond the header +-- the stream carries payload values, and a byte flipped inside an element +-- payload names a different but entirely legal value — the guarantee there is +-- not refusal but soundness: a decoder that rebuilds its indexes rather than +-- trusting them may never surface a triangulation that violates its invariants, +-- whatever it is fed. +testRejectsCorruption :: IO () +testRejectsCorruption = do + original <- source + let bytes = encodeTriangulation original + size = BL.length bytes + headerSize = 8 + 2 + 1 + 1 + decode candidate = decodeTriangulation candidate :: Either SerializationError SerialTriangulation + flipAt offset = + BL.concat [BL.take offset bytes, BL.singleton (BL.index bytes offset + 1), BL.drop (offset + 1) bytes] + rejects :: String -> BL.ByteString -> IO () + rejects label candidate = + case decode candidate of + Left _ -> pure () + Right _ -> fail ("decoder accepted " <> label) + assertEqual + "typed trailing-byte refusal" + (Left (TrailingBytes 1)) + (decode (bytes <> BL.singleton 0)) + case decode (BL.cons 0 (BL.drop 1 bytes)) of + Left (InvalidFormatMagic _) -> pure () + other -> fail ("magic corruption produced " <> show other) + rejects "an empty payload" BL.empty + forM_ [1 .. size] $ \dropped -> + rejects ("a payload truncated by " <> show dropped) (BL.take (size - dropped) bytes) + forM_ [0 .. headerSize - 1] $ \offset -> + rejects ("a header byte flipped at offset " <> show offset) (flipAt offset) + forM_ [headerSize .. size - 1] $ \offset -> + case decode (flipAt offset) of + Left _ -> pure () + Right decoded -> + assertValid ("a byte flipped at offset " <> show offset <> " decoded to") decoded diff --git a/test/support/Support.hs b/test/support/Support.hs new file mode 100644 --- /dev/null +++ b/test/support/Support.hs @@ -0,0 +1,37 @@ +-- | Assertions shared by every test slice. Nothing here may depend on an +-- optional package flag, so that the minimal core configuration compiles the +-- same helpers the full configuration does. +module Support + ( requireRight + , requireQueryPoint + , assertEqual + , assertValid + ) where + +import Control.Monad (unless) +import Moonlight.Triangulation + ( Point + , QueryPoint + , Triangulation + , mkQueryPoint + , validateTriangulation + ) + +requireRight :: Show error => String -> Either error value -> IO value +requireRight label value = case value of + Left failure -> fail (label <> ": " <> show failure) + Right result -> pure result + +requireQueryPoint :: String -> Point -> IO (QueryPoint) +requireQueryPoint label = requireRight label . mkQueryPoint + +assertEqual :: (Eq value, Show value) => String -> value -> value -> IO () +assertEqual label expected actual = + unless (expected == actual) $ + fail (label <> ": expected " <> show expected <> ", got " <> show actual) + +assertValid :: String -> Triangulation mode vertex directed undirected face -> IO () +assertValid label triangulation = + case validateTriangulation triangulation of + [] -> pure () + violations -> fail (label <> " invariant violations: " <> show violations) diff --git a/weeder.toml b/weeder.toml new file mode 100644 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,47 @@ +roots = [ + '^Main\.main$', + '^Paths_.*' +] + +# Every exposed non-Internal module is public API and therefore a root. The +# exposed Internal modules exist only to connect the package's sublibrary tower; +# their unreachable declarations remain subject to the gate. +root-modules = [ + '^Moonlight\.Triangulation\.Scalar$', + '^Moonlight\.Triangulation\.LineSideInfo$', + '^Moonlight\.Triangulation\.Types$', + '^Moonlight\.Triangulation\.Math$', + '^Moonlight\.Triangulation\.Interop$', + '^Moonlight\.Triangulation\.Dcel$', + '^Moonlight\.Triangulation\.Payload$', + '^Moonlight\.Triangulation\.JoinSemilattice$', + '^Moonlight\.Triangulation\.Handles$', + '^Moonlight\.Triangulation\.Handles\.HandleDefs$', + '^Moonlight\.Triangulation\.Handles\.Dynamic$', + '^Moonlight\.Triangulation\.Handles\.Iterators$', + '^Moonlight\.Triangulation\.Handles\.Iterators\.CircularIterator$', + '^Moonlight\.Triangulation\.Handles\.Iterators\.DynamicIterators$', + '^Moonlight\.Triangulation\.Handles\.Iterators\.FixedIterators$', + '^Moonlight\.Triangulation\.Handles\.Iterators\.HullIterator$', + '^Moonlight\.Triangulation\.PointLocation$', + '^Moonlight\.Triangulation\.Validation$', + '^Moonlight\.Triangulation\.FloodFillIterator$', + '^Moonlight\.Triangulation\.IntersectionIterator$', + '^Moonlight\.Triangulation\.BulkLoad$', + '^Moonlight\.Triangulation\.Removal$', + '^Moonlight\.Triangulation\.Session$', + '^Moonlight\.Triangulation\.Cdt$', + '^Moonlight\.Triangulation\.Refinement$', + '^Moonlight\.Triangulation\.SetAlgebra$', + '^Moonlight\.Triangulation\.Parallel$', + '^Moonlight\.Triangulation\.Serialization$', + '^Moonlight\.Triangulation\.Voronoi$', + '^Moonlight\.Triangulation\.Voronoi\.Handles$', + '^Moonlight\.Triangulation\.Interpolation$', + '^Moonlight\.Triangulation\.HintGenerator$', + '^Moonlight\.Triangulation$' +] + +root-instances = [] +type-class-roots = true +unused-types = true