packages feed

moonlight-homology (empty) → 0.1.0.0

raw patch · 114 files changed

+21374/−0 lines, 114 filesdep +algebraic-graphsdep +basedep +bytestring

Dependencies added: algebraic-graphs, base, bytestring, containers, filepath, moonlight-algebra, moonlight-category, moonlight-core, moonlight-homology, moonlight-linalg, moonlight-pale, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, text, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,61 @@+# Changelog++All notable changes to `moonlight-homology` are documented here.++## 0.1.0.0 - 2026-08-21++- Initial public release.+- Finite chain complexes with validated boundary-incidence matrices.+- Phase-gated Betti and spectral-sequence capabilities.+- Field-rank, GF2-rank, and Smith-normal-form homology backends.+- Effective-homology reductions with sampled law witnesses.+- Exact and spectral sequence scaffolding, bidegrees, formal maps, pages, and+  rational spectral-family construction.+- Topological carriers: 2D cell complexes, graph skeletons, macro-scaffolds,+  persistence helpers, harmonic summaries, and graph spectral helpers.+- Discrete Morse and Block-Schur reductions.+- Public `moonlight-homology-laws` sublibrary for boundary, reduction, normalization,+  and determinism harnesses.+- Split into private implementation sublibraries (`moonlight-homology-chain`,+  `moonlight-homology-matrix`, `moonlight-homology-topology`,+  `moonlight-homology-sequence`), a curated public facade, and the public laws+  sublibrary; external proof-assistant certification was removed from the package.+- Consolidated the old Criterion benchmark entrypoints into a single+  `moonlight-homology-bench` `tasty-bench` target matching `moonlight-category`.+- Added Apple M4 Pro benchmark documentation at `docs/BENCHMARKS-m4-pro.md`, with+  large sparse spectral cases gated behind explicit environment variables.+- Pre-Hackage hardening pass (failure-mode audit):+  - Field-rank backends treat degrees above `maxHomologicalDegree` as zero by+    convention instead of consulting the raw incidence function at `max + 1`,+    which silently corrupted the top homology group for malformed inputs.+  - `validatedColumnAt` returns legal columns of zero-row matrices (the+    transpose-based path lost them).+  - Non-nilpotent boundaries surface as `ChainComplexNilpotenceViolation d` on+    every detection path (checked construction, field-rank gate, Morse gate);+    previously the same failure appeared as three different constructors.+  - `restrictComplex` materializes each retained degree exactly once and+    propagates materialization failures instead of collapsing them into+    silently empty boundaries.+  - Sparse echelon rows are compacted at the reduction boundary, eliminating+    phantom zero pivots from uncompacted input; redundant double reversal+    removed from RREF canonicalization.+  - Morse: DAG machinery extracted to+    `Moonlight.Homology.Pure.Topology.Morse.Digraph`; the refined descent+    gates its first stage and trusts theorem-guaranteed later stages instead+    of re-validating per stage; the gradient path-weight oracle is shared per+    upper cell; nilpotence violations are no longer misreported as+    `ReductionInclusionChainMapLaw`.+  - Performance: persistence boundary columns and BlockSchur law sweeps index+    entries by source; filtration-ordered spectral reduction uses vectors+    instead of per-lookup list walks; `nub` quadratics removed from Reeb arc+    seeds, spectral support levels, and torsion-order normalization; strict+    accumulators for persistence state, duplicate-cell detection, and ordered+    entry canonicalization; `materializeBoundary` evaluates the user boundary+    function once per basis element.+  - Documentation: realization budget floor semantics, spectral input+    scrubbing contract, `subtractFromDiagonal` orientation, and the+    forward-looking bi-parameter persistence vocabulary are stated explicitly;+    duplicate export block removed from the `Chain` facade.+  - Packaging: compile-fixture files ship in the sdist via+    `extra-source-files`; upper bounds pinned for test and benchmark+    dependencies.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Blue Rose++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+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.
+ README.md view
@@ -0,0 +1,225 @@+# moonlight-homology++> Part of **Moonlight**, the sheaf-theoretic computation layer beneath+> [Melusine](https://bluerose.blue) and Pale Meridian.++The homology foundation for Pale Meridian. Finite chain complexes, validated+boundary-incidence matrices, phase-gated rank/homology backends, exact and spectral+sequences, discrete Morse reductions, persistence, and finite topological carriers:+the homological invariants the sheaf, derived, e-graph, geometry, and analysis layers+build on.++Built on [`moonlight-core`](../moonlight-core),+[`moonlight-algebra`](../moonlight-algebra), and+[`moonlight-linalg`](../moonlight-linalg).++## What it provides++- **Finite chain complexes.** `FiniteChainComplex` over any coefficient ring: a top+  homological degree plus a validated boundary-incidence matrix at each degree.+  Construction is total and explicit-error: malformed shapes are rejected as typed+  failures.+- **Phase-gated homology.** Every Betti/homology computation is unlocked by a+  capability value that first verifies boundary nilpotence (`∂ ∘ ∂ = 0`). A complex+  that fails the law returns a law violation before backend dispatch.+- **Coefficient backends.** One `runHomologyBackend` dispatcher over three regimes:+  Smith-normal-form integral homology (with torsion), rational field ranks, and GF(2)+  field ranks. A GADT ties each backend to its coefficient type, so a mismatched+  backend is a compile error.+- **Exact and spectral sequences.** Filtered spectral families with page-by-page+  reduction and convergence tracking; exact-sequence helpers; Block–Schur reductions.+- **Persistence.** One- and two-parameter filtered complexes and mod-2 persistence+  pairs.+- **Discrete Morse theory.** Acyclic matchings that reduce a complex to its critical+  cells while preserving homology.+- **Topological carriers.** Cell complexes, graph 1-skeletons, Reeb/macro-scaffold+  structures, graph-Laplacian spectral modes, an observation EDSL over topology+  witnesses, and declarative topological constraints.+- **Cell-complex categories.** `CellComplex2D` is available as a narrow public+  component, and `ComplexCat` derives its finite incidence category without+  importing the matrix or spectral topology closure.++## Key operations++### Build a finite chain complex++The foundational object is the finite chain complex: a top degree together with a+validated boundary-incidence matrix at each degree. Present a circle as a triangle:+three vertices, three oriented edges glued head to tail. The degree-1 boundary sends+each oriented edge to `head − tail`; every degree above 1 is empty.++```haskell+{-# LANGUAGE DataKinds #-}++import Moonlight.Homology++circle :: Either BoundaryIncidenceShapeError (FiniteChainComplex Rational)+circle = do+  d1 <-+    mkBoundaryIncidence 3 3+      [ mkBoundaryEntry 0 0 (-1), mkBoundaryEntry 0 1 1,+        mkBoundaryEntry 1 1 (-1), mkBoundaryEntry 1 2 1,+        mkBoundaryEntry 2 2 (-1), mkBoundaryEntry 2 0 1+      ]+  pure $+    mkFiniteChainComplex (HomologicalDegree 1) $ \degree ->+      case degree of+        HomologicalDegree 1 -> d1+        HomologicalDegree 0 -> emptyBoundaryIncidenceOf 3 0+        _                   -> emptyBoundaryIncidence+```++`mkBoundaryIncidence sourceDim targetDim entries` builds the validated matrix of ∂ₙ,+the boundary map from the `sourceDim` cells of degree *n* to the `targetDim` cells of+degree *n − 1*. Each `mkBoundaryEntry source target coefficient` is one nonzero+incidence: the degree-*n* cell `source` contains the degree-*(n − 1)* cell `target` in+its boundary with that `coefficient`. Edge 0, entries `(0, 0, -1)` and+`(0, 1, 1)`, encodes ∂(edge₀) = vertex₁ − vertex₀, running from vertex 0 (tail, `-1`)+to vertex 1 (head, `+1`); edges 1 and 2 close the loop v₀ → v₁ → v₂ → v₀. Construction+is total: mismatched shapes are rejected as `BoundaryIncidenceShapeError`. `emptyBoundaryIncidenceOf sourceDim targetDim` is the zero map of that shape+(here ∂₀, three vertices to nothing), and `emptyBoundaryIncidence` the empty map used+above the top degree. `mkFiniteChainComplex topDegree atDegree` then assembles the+complex from its boundary at each degree: a top degree and one `∂` per degree.++### Betti numbers over a field++`computeBettiNumbers` is phase-gated: it verifies boundary nilpotence before any rank+backend runs, so a `BettiCapability` is the only key that unlocks the count. For the+circle, `fmap freeRank` on the result is `[1, 1]`: b₀ = 1 (one component), b₁ = 1+(one loop).++```haskell+betti :: FiniteChainComplex Rational -> Either HomologyFailure [HomologyGroup Rational]+betti =+  computeBettiNumbers+    (fieldBettiCapability RationalFieldRankBackend :: BettiCapability 'Phase2 Rational)+```++The gate is total: a malformed complex yields `Left (InvalidTopologyInput …)`, and a+non-nilpotent boundary yields `Left (ChainComplexNilpotenceViolation d)`, naming+the lower degree of the offending composite — the same constructor the checked+constructor path reports. A+`BettiCapability` is required for the count.++### Integral homology and torsion++Field ranks see only free rank; torsion is invisible to them. To recover the full+finitely-generated decomposition, run the Smith-normal-form backend. The real+projective plane RP² is the canonical witness: one cell in each degree 0, 1, and 2,+with the 2-cell attached by a degree-2 map, giving H₁(RP²) = ℤ/2.++```haskell+{-# LANGUAGE DataKinds #-}++import Moonlight.Homology++realProjectivePlane :: Either BoundaryIncidenceShapeError (FiniteChainComplex Integer)+realProjectivePlane = do+  d2 <- mkBoundaryIncidence 1 1 [mkBoundaryEntry 0 0 2]+  pure $+    mkFiniteChainComplex (HomologicalDegree 2) $ \degree ->+      case degree of+        HomologicalDegree 2 -> d2+        HomologicalDegree 1 -> emptyBoundaryIncidenceOf 1 1+        HomologicalDegree 0 -> emptyBoundaryIncidenceOf 1 0+        _                   -> emptyBoundaryIncidence++integralHomology ::+  FiniteChainComplex Integer -> Either HomologyFailure [HomologyGroup Integer]+integralHomology =+  runHomologyBackend (IntegralSmithBackend :: HomologyBackend Integer Integer)+```++On the result, `fmap freeRank` is `[1, 0, 0]` and `fmap torsionInvariants` is+`[[], [2], []]`: the ℤ/2 in degree 1 missed by rational and mod-2 Betti counts.++### Choosing a rank backend++`runHomologyBackend` unifies all three coefficient regimes behind one call. The+`HomologyBackend` GADT ties each backend to the coefficient type it accepts, so the+compiler rejects a backend applied to the wrong complex.++| Backend | Complex | Result |+| --- | --- | --- |+| `IntegralSmithBackend` | `FiniteChainComplex` over any `Integral` | full groups with `torsionInvariants` |+| `RationalRankBackend` | `FiniteChainComplex Rational` | rational Betti (`freeRank`) |+| `GF2RankBackend` | `FiniteChainComplex GF2` | mod-2 Betti (`freeRank`) |++`homologyBackendTag` recovers the `HomologyBackendTag` for logging or downstream+dispatch.++### Beyond Betti++The same finite chain complex feeds the higher invariants. Each is reachable from the+`Moonlight.Homology` umbrella, or from the narrower module noted below.++- **Persistence.** `mkFilteredFiniteChainComplex` builds a filtered complex;+  `mod2PersistentPairs` reads its birth/death pairs, and `BiPersistencePair` carries+  the two-parameter case. In `Moonlight.Homology.Persistence`.+- **Spectral sequences.** `mkSpectralSource` and `spectralFamilyPages` produce the+  page-by-page family; `spectralFamilyLimitPage`, `spectralFamilyStableFrom`, and+  `convergenceDepth` track convergence. In `Moonlight.Homology.Sequence`.+- **Discrete Morse.** `morseComplex` (and `morseComplexWith` /+  `refinedMorseComplex`) reduce a complex to its critical cells while preserving+  homology; `refinedMatchingCriticalCells` and `finalRefinedCriticalCellCount` read+  the reduction.+- **Topological carriers & constraints.** `mkCellCarrier` and graph skeletons build+  topology witnesses; macro-scaffold observers (`observeBettiVector`,+  `observeIntegralHomology`, `observeHarmonicCount`) interrogate them; and+  `evaluateTopologicalConstraint` checks a declarative `TopologicalConstraint`.++## Components++The pure core is carved into four private domain sublibraries along an acyclic+dependency DAG (`chain ← matrix ← topology ← sequence`), two narrow public+topology components, a public entry point, and a public law harness:++- **`moonlight-homology-chain`**: base vocabulary and chain algebra: degrees, groups,+  phases, failures, cell carriers, filtration values, the `Chain` algebra, reductions,+  graded torsion, and finite abelian groups.+- **`moonlight-homology-matrix`**: boundary matrices and rank: boundary incidence,+  Smith normal form, sparse and validated matrices, field and GF(2) rank backends, the+  phase-gated Betti reducer, and effective homology.+- **`moonlight-homology-topology`**: the topology subsystem: cell complexes, graph+  skeletons, Reeb/macro-scaffold structures, discrete Morse, persistence,+  graph-Laplacian spectral modes, observers, and the integral-homology backend+  dispatcher.+- **`moonlight-homology-sequence`**: exact sequences and filtered spectral sequences.+- **`cell-complex`**: the generic `CellComplex2D` incidence interface.+- **`cell-category`**: the finite, path-sensitive incidence category derived from+  any `CellComplex2D`.+- **`moonlight-homology`**: the public entry point below.+- **`moonlight-homology-laws`**: public law harness: boundary nilpotence, reduction,+  normalization, determinism.++Downstream packages import the public modules below.++## Public modules++| Module | Surface |+| --- | --- |+| `Moonlight.Homology` | Broad convenience surface over every module below. |+| `Moonlight.Homology.Boundary` | Boundary incidence, finite chain complexes, linear-algebra and Smith-normal-form helpers. |+| `Moonlight.Homology.Boundary.GraphGF2` | GF(2) boundary construction from graph data. |+| `Moonlight.Homology.Chain` | Degrees, groups, reductions, effective homology, graded torsion, phase-gated witnesses. |+| `Moonlight.Homology.Matrix` | Validated matrix construction and projections. |+| `Moonlight.Homology.Rank` | Field and GF(2) rank backends; Betti-capability construction. |+| `Moonlight.Homology.Rank.Field` | Rational/field rank-backend surface. |+| `Moonlight.Homology.Rank.GF2` | GF(2) rank-backend surface. |+| `Moonlight.Homology.Backend` | The `HomologyBackend` dispatcher: Smith / rational / GF(2). |+| `Moonlight.Homology.Sequence` | Exact and spectral sequences, Block–Schur reductions, graph spectral helpers. |+| `Moonlight.Homology.Topology` | Cell complexes, graph skeletons, macro-scaffolds, discrete Morse, persistence values, observers, and constraints. |+| `Moonlight.Homology.Persistence` | Filtered complexes and mod-2 persistence pairs. |+| `Moonlight.Homology.Pure.Topology.CellComplex` | Generic two-dimensional cell incidence; requires `moonlight-homology:cell-complex`. |+| `Moonlight.Homology.Pure.Topology.CellCategory` | Finite incidence category for a `CellComplex2D`; requires `moonlight-homology:cell-category`. |+| `Moonlight.Homology.Effect.Laws` | Boundary-nilpotence and reduction law harnesses. |+| `Moonlight.Homology.Effect.Determinism` | Deterministic fingerprints for bases, incidences, and complexes. |++## Benchmarks++`tasty-bench` covers boundary construction, rank backends, reductions, and persistence helpers.++## License++MIT; see [`LICENSE`](./LICENSE). Third-party notes in+[`THIRD_PARTY_NOTICES.md`](./THIRD_PARTY_NOTICES.md).
+ THIRD_PARTY_NOTICES.md view
@@ -0,0 +1,15 @@+# Third-party notices++`moonlight-homology` does not vendor or adapt third-party source code.++The package depends on other Haskell packages through Cabal, including+`algebraic-graphs`, `containers`, and the local Moonlight foundation packages. Those+dependencies remain under their own licenses as resolved by the build plan; no source+from them is copied into this package.++## Acknowledgements (inspiration, no derived code)++The package's finite chain-complex and topological-carrier surfaces are shaped by the+standard algebraic topology literature and by the practical need to make homological+invariants executable inside Pale Meridian. The implementation is local to this+repository.
+ bench/Main.hs view
@@ -0,0 +1,27 @@+module Main+  ( main,+  )+where++import MorseSpectral+  ( morseSpectralBenchmarks,+  )+import SparseSpectral+  ( benchmarkNotice,+    shouldIncludeLarge,+    shouldInclude100k,+    sparseSpectralBenchmarks,+  )+import Test.Tasty.Bench+  ( defaultMain,+  )++main :: IO ()+main = do+  includeLarge <- shouldIncludeLarge+  include100k <- shouldInclude100k+  putStrLn (benchmarkNotice includeLarge include100k)+  defaultMain+    [ morseSpectralBenchmarks includeLarge,+      sparseSpectralBenchmarks includeLarge include100k+    ]
+ bench/sequence/SparseSpectral.hs view
@@ -0,0 +1,140 @@+module SparseSpectral+  ( benchmarkNotice,+    shouldIncludeLarge,+    shouldInclude100k,+    sparseSpectralBenchmarks,+  )+where++import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf)+import Data.Function ((&))+import Moonlight.Homology+  ( GraphSpectralMode (..),+    HomologyFailure,+  )+import Moonlight.Homology.Sequence+  ( defaultSparseSpectralConfig,+    weightedGraphSparseSpectralModes,+  )+import System.Environment (lookupEnv)++data SparseSpectralBenchmarkCase = SparseSpectralBenchmarkCase+  { ssbcLabel :: !String,+    ssbcVertexCount :: !Int,+    ssbcRequestedModeCount :: !Int+  }++data MeasuredSpectralWeight+  = MeasuredSpectralWeight !Double+  | SpectralMeasurementFailure !String+  deriving stock (Show)++sparseSpectralBenchmarks :: Bool -> Bool -> Benchmark+sparseSpectralBenchmarks includeLarge include100k =+  bgroup+    "successor-like-sparse-spectral"+    (fmap benchmarkSparseSpectralCase (sparseSpectralBenchmarkCases includeLarge include100k))++sparseSpectralBenchmarkCases :: Bool -> Bool -> [SparseSpectralBenchmarkCase]+sparseSpectralBenchmarkCases includeLarge include100k =+  [SparseSpectralBenchmarkCase "successor-carrier-1k" 1024 3]+    <> ( if includeLarge+           then+             [ SparseSpectralBenchmarkCase "successor-carrier-10k" 10000 3,+               SparseSpectralBenchmarkCase "successor-carrier-50k" 50000 3+             ]+           else []+       )+    <> [SparseSpectralBenchmarkCase "successor-carrier-100k" 100000 3 | include100k]++benchmarkNotice :: Bool -> Bool -> String+benchmarkNotice includeLarge include100k =+  "large sparse spectral benchmarks "+    <> gateNotice "MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_LARGE" includeLarge+    <> "; 100k sparse spectral benchmark "+    <> gateNotice "MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_100K" include100k+    <> "."++gateNotice :: String -> Bool -> String+gateNotice variableName enabled =+  if enabled+    then "enabled via " <> variableName+    else "skipped by default; set " <> variableName <> "=1 to opt in"++shouldIncludeLarge :: IO Bool+shouldIncludeLarge =+  fmap parseTruthy (lookupEnv "MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_LARGE")++shouldInclude100k :: IO Bool+shouldInclude100k =+  fmap parseTruthy (lookupEnv "MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_100K")++parseTruthy :: Maybe String -> Bool+parseTruthy maybeValue =+  case maybeValue of+    Just "1" -> True+    Just "true" -> True+    Just "TRUE" -> True+    Just "yes" -> True+    Just "YES" -> True+    _ -> False++benchmarkSparseSpectralCase :: SparseSpectralBenchmarkCase -> Benchmark+benchmarkSparseSpectralCase benchmarkCase =+  bench (ssbcLabel benchmarkCase) (whnf sparseSpectralWeight benchmarkCase)++sparseSpectralWeight :: SparseSpectralBenchmarkCase -> MeasuredSpectralWeight+sparseSpectralWeight =+  either+    (SpectralMeasurementFailure . show)+    MeasuredSpectralWeight+    . sparseSpectralWeightResult++sparseSpectralWeightResult :: SparseSpectralBenchmarkCase -> Either HomologyFailure Double+sparseSpectralWeightResult benchmarkCase =+  weightedGraphSparseSpectralModes+    defaultSparseSpectralConfig+    (ssbcRequestedModeCount benchmarkCase)+    (ssbcVertexCount benchmarkCase)+    (successorLikeSparseSupports (ssbcVertexCount benchmarkCase))+    & fmap spectralModeChecksum++successorLikeSparseSupports :: Int -> [(Int, Int, Double)]+successorLikeSparseSupports vertexCount =+  localSuccessorSupports vertexCount+    <> strideSuccessorSupports vertexCount 8 0.25+    <> strideSuccessorSupports vertexCount 31 0.125++localSuccessorSupports :: Int -> [(Int, Int, Double)]+localSuccessorSupports vertexCount+  | vertexCount <= 1 = []+  | otherwise =+      [0 .. max 0 (vertexCount - 2)]+        & fmap (\sourceVertex -> (sourceVertex, sourceVertex + 1, 1.0))++strideSuccessorSupports :: Int -> Int -> Double -> [(Int, Int, Double)]+strideSuccessorSupports vertexCount strideValue edgeWeight+  | vertexCount <= strideValue = []+  | otherwise =+      [0, strideValue .. max 0 (vertexCount - strideValue - 1)]+        & fmap (\sourceVertex -> (sourceVertex, sourceVertex + strideValue, edgeWeight))++spectralModeChecksum :: [GraphSpectralMode] -> Double+spectralModeChecksum =+  foldl' (\checksumValue modeValue -> checksumValue + spectralModeWeight modeValue) 0.0++spectralModeWeight :: GraphSpectralMode -> Double+spectralModeWeight modeValue =+  spectralEigenvalue modeValue+    + spectralSupportCriticality modeValue+    + coefficientChecksum (spectralCoefficients modeValue)+    + fromIntegral (length (spectralPositiveSupport modeValue))+    - fromIntegral (length (spectralNegativeSupport modeValue))++coefficientChecksum :: [(Int, Double)] -> Double+coefficientChecksum =+  foldl'+    ( \checksumValue (cellIndex, coefficientValue) ->+        checksumValue + coefficientValue * fromIntegral (cellIndex + 1)+    )+    0.0
+ bench/topology/MorseSpectral.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module MorseSpectral+  ( morseSpectralBenchmarks,+  )+where++import Test.Tasty.Bench (Benchmark, bench, bgroup, whnf)+import Data.Kind (Type)+import Data.Map.Strict qualified as Map+import Moonlight.Homology+  ( BasisCellRef (..),+    BoundaryEntry,+    BoundaryIncidence,+    FiltrationFunction,+    FiniteChainComplex,+    FormalMap (..),+    HomologicalDegree (..),+    HomologyFailure,+    RationalSpectralPage,+    SpectralEntry (..),+    computeRationalSpectralPages,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    entryGroupValue,+    filteredRefinedMorseComplex,+    filteredReducedFiltration,+    frmcRefinedMorseComplex,+    formalCodomainBasis,+    formalDomainBasis,+    formalMatrix,+    freeRank,+    mkBoundaryEntry,+    mkBoundaryIncidence,+    pageDifferentialMap,+    pageEntryMap,+    pageIndex,+    rationalizeFiniteChainComplex,+    rmcReducedComplex,+    torsionInvariants,+  )+import Moonlight.Homology.Boundary.Finite (mkFiniteChainComplex)++type BenchComplex :: Type+data BenchComplex = BenchComplex+  { bcPathComplex :: PathBenchComplex,+    bcReducedRational :: FiniteChainComplex Rational+  }++type PathBenchComplex :: Type+data PathBenchComplex = PathBenchComplex+  { pbcRawIntegral :: FiniteChainComplex Integer,+    pbcRawRational :: FiniteChainComplex Rational+  }++type MeasuredWeight :: Type+data MeasuredWeight+  = MeasuredWeight !Int+  | MeasurementObstruction !String+  deriving stock (Show)++morseSpectralBenchmarks :: Bool -> Benchmark+morseSpectralBenchmarks includeLarge =+  case morseSpectralBenchmarkSuites includeLarge of+    Left failureMessage -> bench "invalid-morse-spectral-fixture" (whnf id failureMessage)+    Right benchmarks -> bgroup "morse-spectral" benchmarks++morseSpectralBenchmarkSuites :: Bool -> Either String [Benchmark]+morseSpectralBenchmarkSuites includeLarge =+  (<>)+    <$> traverse (uncurry unfilteredBenchSuite) (unfilteredPathBenchmarkCases includeLarge)+    <*> traverse (uncurry filteredBenchSuite) (filteredPathBenchmarkCases includeLarge)++unfilteredPathBenchmarkCases :: Bool -> [(String, Int)]+unfilteredPathBenchmarkCases includeLarge =+  [ ("path-16", 16),+    ("path-32", 32),+    ("path-64", 64),+    ("path-256", 256),+    ("path-512", 512)+  ]+    <> [("path-1024", 1024) | includeLarge]++filteredPathBenchmarkCases :: Bool -> [(String, Int)]+filteredPathBenchmarkCases includeLarge =+  [ ("filtered-path-16", 16),+    ("filtered-path-32", 32),+    ("filtered-path-64", 64)+  ]+    <> [("filtered-path-128", 128) | includeLarge]++unfilteredBenchSuite :: String -> Int -> Either String Benchmark+unfilteredBenchSuite label edgeCount =+  fmap+    ( \complexValue ->+        bgroup+          label+          [ bench "raw-unreduced-rational-spectral" (whnf (rawSpectralWeight trivialFiltration) (pbcRawRational (bcPathComplex complexValue))),+            bench "refined-morse-plus-spectral" (whnf (refinedMorseSpectralWeight trivialFiltration) (pbcRawIntegral (bcPathComplex complexValue))),+            bench "reduced-rational-spectral-only" (whnf (rationalSpectralWeight trivialFiltration) (bcReducedRational complexValue))+          ]+    )+    (unfilteredBenchComplex edgeCount)++filteredBenchSuite :: String -> Int -> Either String Benchmark+filteredBenchSuite label edgeCount =+  fmap+    ( \complexValue ->+        bgroup+          label+          [ bench "raw-unreduced-rational-spectral" (whnf (rawSpectralWeight pathFiltration) (pbcRawRational complexValue)),+            bench "refined-morse-plus-spectral" (whnf (refinedMorseSpectralWeight pathFiltration) (pbcRawIntegral complexValue))+          ]+    )+    (filteredBenchComplex edgeCount)++unfilteredBenchComplex :: Int -> Either String BenchComplex+unfilteredBenchComplex edgeCount = do+  pathComplexValue <- pathBenchComplex edgeCount+  reducedComplexValue <- reducedComplex (pbcRawIntegral pathComplexValue)+  _ <- rawSpectralWeightResult trivialFiltration (pbcRawRational pathComplexValue)+  _ <- refinedMorseSpectralWeightResult trivialFiltration (pbcRawIntegral pathComplexValue)+  _ <- rationalSpectralWeightResult trivialFiltration reducedComplexValue+  pure+    BenchComplex+      { bcPathComplex = pathComplexValue,+        bcReducedRational = reducedComplexValue+      }++filteredBenchComplex :: Int -> Either String PathBenchComplex+filteredBenchComplex edgeCount = do+  pathComplexValue <- pathBenchComplex edgeCount+  _ <- rawSpectralWeightResult pathFiltration (pbcRawRational pathComplexValue)+  _ <- refinedMorseSpectralWeightResult pathFiltration (pbcRawIntegral pathComplexValue)+  pure pathComplexValue++pathBenchComplex :: Int -> Either String PathBenchComplex+pathBenchComplex edgeCount = do+  rawComplex <- pathComplex edgeCount+  pure+    PathBenchComplex+      { pbcRawIntegral = rawComplex,+        pbcRawRational = rationalizeFiniteChainComplex rawComplex+      }++pathComplex :: Int -> Either String (FiniteChainComplex Integer)+pathComplex edgeCount+  | edgeCount <= 0 = Left ("edge count must be positive: " <> show edgeCount)+  | otherwise = do+      edgeBoundary <- pathBoundary edgeCount+      pure+        ( mkFiniteChainComplex (HomologicalDegree 1) $ \degreeValue ->+            case degreeValue of+              HomologicalDegree 1 -> edgeBoundary+              HomologicalDegree 0 -> emptyBoundaryIncidenceOf (fromIntegral (edgeCount + 1)) 0+              _ -> emptyBoundaryIncidence+        )++pathBoundary :: Int -> Either String (BoundaryIncidence Integer)+pathBoundary edgeCount =+  case mkBoundaryIncidence (fromIntegral edgeCount) (fromIntegral (edgeCount + 1)) (pathBoundaryEntries edgeCount) of+    Left shapeError -> Left ("invalid path boundary: " <> show shapeError)+    Right incidenceValue -> Right incidenceValue++pathBoundaryEntries :: Int -> [BoundaryEntry Integer]+pathBoundaryEntries edgeCount =+  foldMap edgeBoundaryEntries [0 .. edgeCount - 1]++edgeBoundaryEntries :: Int -> [BoundaryEntry Integer]+edgeBoundaryEntries edgeIndexValue =+  [ boundaryEntry edgeIndexValue edgeIndexValue (-1),+    boundaryEntry edgeIndexValue (edgeIndexValue + 1) 1+  ]++boundaryEntry :: Int -> Int -> coefficient -> BoundaryEntry coefficient+boundaryEntry sourceIndexValue targetIndexValue =+  mkBoundaryEntry (fromIntegral sourceIndexValue) (fromIntegral targetIndexValue)++reducedComplex :: FiniteChainComplex Integer -> Either String (FiniteChainComplex Rational)+reducedComplex rawComplex =+  case filteredRefinedMorseComplex rawComplex trivialFiltration (const 0) of+    Left failureValue -> Left ("filtered refined Morse reduction failed: " <> show failureValue)+    Right filteredValue -> Right (rmcReducedComplex (frmcRefinedMorseComplex filteredValue))++rawSpectralWeight :: FiltrationFunction -> FiniteChainComplex Rational -> MeasuredWeight+rawSpectralWeight filtration finiteComplex =+  measuredWeight (rawSpectralWeightResult filtration finiteComplex)++refinedMorseSpectralWeight :: FiltrationFunction -> FiniteChainComplex Integer -> MeasuredWeight+refinedMorseSpectralWeight filtration finiteComplex =+  measuredWeight (refinedMorseSpectralWeightResult filtration finiteComplex)++rationalSpectralWeight :: FiltrationFunction -> FiniteChainComplex Rational -> MeasuredWeight+rationalSpectralWeight filtration finiteComplex =+  measuredWeight (rationalSpectralWeightResult filtration finiteComplex)++rawSpectralWeightResult :: FiltrationFunction -> FiniteChainComplex Rational -> Either String Int+rawSpectralWeightResult filtration finiteComplex =+  firstHomologyFailure "raw unreduced rational spectral computation failed" $+    fmap spectralPagesWeight (computeRationalSpectralPages finiteComplex filtration)++refinedMorseSpectralWeightResult :: FiltrationFunction -> FiniteChainComplex Integer -> Either String Int+refinedMorseSpectralWeightResult filtration finiteComplex =+  case filteredRefinedMorseComplex finiteComplex filtration (const 0) of+    Left failureValue -> Left ("filtered refined Morse reduction failed: " <> show failureValue)+    Right filteredValue ->+      rationalSpectralWeightResult+        (filteredReducedFiltration filteredValue)+        (rmcReducedComplex (frmcRefinedMorseComplex filteredValue))++rationalSpectralWeightResult :: FiltrationFunction -> FiniteChainComplex Rational -> Either String Int+rationalSpectralWeightResult filtration finiteComplex =+  firstHomologyFailure "rational spectral computation failed" $+    fmap spectralPagesWeight (computeRationalSpectralPages finiteComplex filtration)++firstHomologyFailure :: String -> Either HomologyFailure value -> Either String value+firstHomologyFailure contextMessage =+  either (\failureValue -> Left (contextMessage <> ": " <> show failureValue)) Right++measuredWeight :: Either String Int -> MeasuredWeight+measuredWeight =+  either MeasurementObstruction MeasuredWeight++trivialFiltration :: BasisCellRef -> Int+trivialFiltration = const 0++pathFiltration :: BasisCellRef -> Int+pathFiltration basisCellRef =+  case cellDegree basisCellRef of+    HomologicalDegree 0 -> cellIndex basisCellRef+    HomologicalDegree 1 -> cellIndex basisCellRef + 1+    _ -> 0++spectralPagesWeight :: [RationalSpectralPage] -> Int+spectralPagesWeight =+  foldl' (\weightValue pageValue -> weightValue + spectralPageWeight pageValue) 0++spectralPageWeight :: RationalSpectralPage -> Int+spectralPageWeight pageValue =+  pageIndex pageValue+    + foldl' (\weightValue entryValue -> weightValue + spectralEntryWeight entryValue) 0 (Map.elems (pageEntryMap pageValue))+    + foldl' (\weightValue formalMapValue -> weightValue + formalMapWeight formalMapValue) 0 (Map.elems (pageDifferentialMap pageValue))++spectralEntryWeight :: SpectralEntry Rational -> Int+spectralEntryWeight entryValue =+  let groupValue = entryGroupValue entryValue+   in freeRank groupValue + length (torsionInvariants groupValue)++formalMapWeight :: FormalMap Rational -> Int+formalMapWeight formalMapValue =+  sumMatrixWeight (formalMatrix formalMapValue)+    + length (formalDomainBasis formalMapValue)+    + length (formalCodomainBasis formalMapValue)++sumMatrixWeight :: [[Rational]] -> Int+sumMatrixWeight =+  foldl' (\weightValue rowValue -> weightValue + rowWeight rowValue) 0++rowWeight :: [Rational] -> Int+rowWeight =+  foldl' (\weightValue coefficientValue -> weightValue + coefficientWeight coefficientValue) 0++coefficientWeight :: Rational -> Int+coefficientWeight coefficientValue =+  if coefficientValue == 0+    then 0+    else 1
+ docs/BENCHMARKS-m4-pro.md view
@@ -0,0 +1,97 @@+# moonlight-homology Benchmarks — Apple M4 Pro++Measured on Apple M4 Pro via `tasty-bench` on macOS.++## Environment++| Field | Value |+|---|---|+| Machine | MacBook Pro |+| Model identifier | Mac16,7 |+| Chip | Apple M4 Pro |+| CPU cores | 14 total: 10 performance, 4 efficiency |+| Memory | 48 GB unified memory |+| Architecture | aarch64 / arm64 macOS |+| macOS | 26.5.1 (25F80) |+| GHC | 9.14.1 |+| Cabal | 3.16.1.0 |+| Benchmark runner | `tasty-bench` |+| Cabal target | `moonlight-homology:moonlight-homology-bench` |+| Cabal parallelism | `-j1` |+| Benchmark timeout | `--timeout=1s` |+| CSV source | `/tmp/moonlight-homology-bench-m4-pro-all.csv` |++Notes:++- The default sweep intentionally uses a short `--timeout=1s` runner so it stays fast.+- `successor-carrier-10k` and `successor-carrier-50k` are opt-in via `MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_LARGE=1`.+- `successor-carrier-100k` is opt-in via `MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_100K=1`.+- Morse/spectral rows report whole-operation time for the named prepared path complex.++## Focused linalg P2 graph-spectral evidence (2026-07-21)++The 10,000-vertex successor carrier no longer collapses into repeated restarted+Lanczos windows. Homology now constructs its sparse spectral operator through+linalg's checked graph-Laplacian owner, preserving enough provenance for the+large smallest-mode request to use heavy-edge cascadic descent. Returned modes+still come from the existing `Eigenpairs` owner with residuals recomputed on the+fine matrix; no homology-specific solver or parallel public API was added.++| Benchmark | P1 | P2 | P2 allocation | P2 peak |+|---|---:|---:|---:|---:|+| successor-carrier-1k | 134.9 ms ± 28.7 ms | 161 ms ± 32 ms | 332 MB | 14 MB |+| successor-carrier-10k | >30 s timeout | 48.0 ms ± 14 ms | 127 MB | 19 MB |+| successor-carrier-50k | not retained | 265 ms ± 46 ms | 619 MB | 51 MB |+| successor-carrier-100k | not retained | 496 ms ± 60 ms | 1.2 GB | 81 MB |++Against P1's bounded 10k observation, P2 is more than 625x faster and reduces+allocation from 72,968,137,200 bytes by about 575x. The 50k and 100k observations+then scale approximately with carrier size instead of resurrecting the old+convergence cliff. The 1k request remains on P1's route; its timing intervals+overlap while allocation is modestly lower.++```sh+MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_LARGE=1 cabal run \+  moonlight-homology:bench:moonlight-homology-bench -j1 -- \+  --hide-progress --stdev 20 --timeout=30s \+  --pattern 'successor-carrier-10k' +RTS -T -s++MOONLIGHT_HOMOLOGY_SPARSE_SPECTRAL_BENCH_ENABLE_100K=1 cabal run \+  moonlight-homology:bench:moonlight-homology-bench -j1 -- \+  --hide-progress --stdev 20 --timeout=30s \+  --pattern 'successor-carrier-100k' +RTS -T -s+```++## Focused linalg P1 downstream evidence (2026-07-21)++The successor carrier is the real generic sparse consumer used to validate the+Moonlight linalg restart repair. With identical benchmark input, the 1,024-row+carrier moved from 298.1 ms ± 39.4 ms and about 1.2 GB allocated per evaluation+to 134.9 ms ± 28.7 ms and 354,183,382 bytes allocated. The result is 2.2x faster+with 70.5% less allocation.++```sh+cabal run moonlight-homology:bench:moonlight-homology-bench -j1 -- \+  --hide-progress --stdev 100 --timeout=10s \+  --pattern 'successor-carrier-1k' +RTS -T -s+```++The gated 10,000-row carrier still exceeds 30 seconds. Its bounded run allocated+72,968,137,200 bytes after the repair versus 147,409,380,400 bytes before it,+but did not converge within the gate. That is explicit evidence that allocation+was repaired while smallest-mode convergence on the tightly clustered graph+Laplacian remains the large-scale obstruction; this document does not pretend a+timeout is a successful 10k solve.++| Group | Benchmark | Mean | 2*Stdev |+|---|---:|---:|---:|+| morse-spectral / path-16 | raw-unreduced-rational-spectral | 147 us | 28.4 us |+| morse-spectral / path-16 | refined-morse-plus-spectral | 624 us | 149 us |+| morse-spectral / path-16 | reduced-rational-spectral-only | 397 ns | 56.2 ns |+| morse-spectral / path-32 | raw-unreduced-rational-spectral | 804 us | 130 us |+| morse-spectral / path-32 | refined-morse-plus-spectral | 2.65 ms | 463 us |+| morse-spectral / path-32 | reduced-rational-spectral-only | 403 ns | 127 ns |+| morse-spectral / path-64 | raw-unreduced-rational-spectral | 8.06 ms | 2.04 ms |+| morse-spectral / path-64 | refined-morse-plus-spectral | 12.7 ms | 2.18 ms |+| morse-spectral / path-64 | reduced-rational-spectral-only | 409 ns | 128 ns |+| successor-like-sparse-spectral | successor-carrier-1k | 134.9 ms | 28.7 ms |
+ moonlight-homology.cabal view
@@ -0,0 +1,313 @@+cabal-version:       3.0+name:                moonlight-homology+version:             0.1.0.0+homepage:            https://github.com/PaleRoses/moonlight+bug-reports:         https://github.com/PaleRoses/moonlight/issues+synopsis:            Chain complexes, phase-gated homology interfaces, and spectral scaffolding.+description:         Finite chain complexes, validated boundary matrices, field and Smith-normal-form rank backends, phase-gated Betti numbers and spectral sequences, discrete Morse reductions, and persistence helpers.+license:             MIT+license-file:        LICENSE+copyright:           (c) 2026 Blue Rose+author:              Blue Rose+maintainer:          rosaliafialkova@gmail.com+category:            Math+build-type:          Simple+tested-with:         GHC == 9.14.1+extra-doc-files:+  README.md+  CHANGELOG.md+  THIRD_PARTY_NOTICES.md+  docs/BENCHMARKS-m4-pro.md++-- The compile-fixture test suite reads these at test time; without them the+-- sdist tarball ships a test suite that cannot run.+extra-source-files:+  test/fixtures/CompileFail/*.hs+  test/fixtures/CompilePass/*.hs+  test/fixtures/Snapshots/*.json++common shared-properties+  default-language: GHC2024+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -Wno-missing-import-lists+    -Wmissing-deriving-strategies+    -Wmissing-local-signatures+  default-extensions:+    FunctionalDependencies+    TypeFamilies++library moonlight-homology-chain+  import: shared-properties+  visibility: private+  hs-source-dirs: src-chain+  exposed-modules:+    Moonlight.Homology.Pure.Carrier+    Moonlight.Homology.Pure.Chain+    Moonlight.Homology.Pure.Constraint.Core+    Moonlight.Homology.Pure.Degree+    Moonlight.Homology.Pure.Failure+    Moonlight.Homology.Pure.Filtration+    Moonlight.Homology.Pure.FiniteAbelian+    Moonlight.Homology.Pure.Graded.Query+    Moonlight.Homology.Pure.GradedTorsion+    Moonlight.Homology.Pure.Group+    Moonlight.Homology.Pure.LinearCombination+    Moonlight.Homology.Pure.Phase+    Moonlight.Homology.Pure.Reductions+    Moonlight.Homology.Pure.Reductions.Core+    Moonlight.Homology.Pure.Skeleton+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:abstract >= 0.1 && < 0.2+    , moonlight-core >= 0.1 && < 0.2++library moonlight-homology-matrix+  import: shared-properties+  visibility: private+  hs-source-dirs: src-matrix+  exposed-modules:+    Moonlight.Homology.Boundary.Finite+    Moonlight.Homology.Boundary.LinAlg+    Moonlight.Homology.Boundary.SNF+    Moonlight.Homology.Pure.Effective+    Moonlight.Homology.Pure.Matrix.Reducer+    Moonlight.Homology.Pure.Matrix.Shape+    Moonlight.Homology.Pure.Matrix.SparseLinAlg+    Moonlight.Homology.Pure.Matrix.Validated+    Moonlight.Homology.Pure.Rank.Field+    Moonlight.Homology.Pure.Rank.GF2+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-dense >= 0.1 && < 0.2+    , moonlight-pale:diagnostic >= 0.1 && < 0.2+    , moonlight-homology:moonlight-homology-chain++-- The incidence interface is independently useful to mesh and visualization+-- consumers. Keep it outside the matrix/diagnostic topology closure.+library cell-complex+  import: shared-properties+  visibility: public+  hs-source-dirs: src-cell-complex+  exposed-modules:+    Moonlight.Homology.Pure.Topology.CellComplex+  build-depends:+    base >= 4.22 && < 5+    , moonlight-algebra:abstract >= 0.1 && < 0.2++-- The finite incidence category is a generic derived view of CellComplex2D.+-- Keeping it beside the cell-complex owner prevents an engine package from+-- becoming the authority for foundation mathematics.+library cell-category+  import: shared-properties+  visibility: public+  hs-source-dirs: src-cell-category+  default-extensions:+    UndecidableInstances+  exposed-modules:+    Moonlight.Homology.Pure.Topology.CellCategory+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:abstract >= 0.1 && < 0.2+    , moonlight-category:abstract >= 1.1.0.0 && < 1.2+    , moonlight-homology:cell-complex++library moonlight-homology-topology+  import: shared-properties+  visibility: private+  hs-source-dirs: src-topology+  exposed-modules:+    Moonlight.Homology.Pure.Backend+    Moonlight.Homology.Pure.Constraint+    Moonlight.Homology.Pure.Constraint.Algebra+    Moonlight.Homology.Pure.Topology+    Moonlight.Homology.Pure.Topology.Algebra+    Moonlight.Homology.Pure.Topology.BlockSchur+    Moonlight.Homology.Pure.Topology.Core+    Moonlight.Homology.Pure.Topology.Graph+    Moonlight.Homology.Pure.Topology.Graph.Algebra+    Moonlight.Homology.Pure.Topology.Graph.Critical+    Moonlight.Homology.Pure.Topology.Graph.Reeb+    Moonlight.Homology.Pure.Topology.Graph.Skeleton+    Moonlight.Homology.Pure.Topology.Graph.Witness+    Moonlight.Homology.Pure.Topology.Harmonic+    Moonlight.Homology.Pure.Topology.Integral+    Moonlight.Homology.Pure.Topology.MacroScaffold+    Moonlight.Homology.Pure.Topology.MacroScaffold.Compose+    Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Core+    Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Merge+    Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Reindex+    Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Stitch+    Moonlight.Homology.Pure.Topology.MacroScaffold.Direction+    Moonlight.Homology.Pure.Topology.MacroScaffold.HarmonicLoop+    Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+    Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb+    Moonlight.Homology.Pure.Topology.MacroScaffold.Singularity+    Moonlight.Homology.Pure.Topology.Morse+    Moonlight.Homology.Pure.Topology.Morse.Digraph+    Moonlight.Homology.Pure.Topology.Observation+    Moonlight.Homology.Pure.Topology.Persistence+    Moonlight.Homology.Pure.Topology.Realize+    Moonlight.Homology.Pure.Topology.ScaffoldSummary+    Moonlight.Homology.Pure.Topology.SparseAlgebra+    Moonlight.Homology.Pure.Topology.Spectral+    Moonlight.Homology.Pure.Topology.Target+    Moonlight.Homology.Pure.TopologyObserver+    Moonlight.Homology.Pure.TopologyView+  build-depends:+    algebraic-graphs >= 0.8 && < 0.9+    , base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:abstract >= 0.1 && < 0.2+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-carrier >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-dense >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-domain >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-sparse >= 0.1 && < 0.2+    , moonlight-linalg:moonlight-linalg-spectral >= 0.1 && < 0.2+    , vector >= 0.13 && < 0.14+    , moonlight-homology:cell-complex+    , moonlight-homology:moonlight-homology-chain+    , moonlight-homology:moonlight-homology-matrix++library moonlight-homology-sequence+  import: shared-properties+  visibility: private+  hs-source-dirs: src-sequence+  exposed-modules:+    Moonlight.Homology.Pure.Sequence.Exact+    Moonlight.Homology.Pure.Sequence.Spectral+    Moonlight.Homology.Pure.Sequence.Spectral.Bidegree+    Moonlight.Homology.Pure.Sequence.Spectral.Build+    Moonlight.Homology.Pure.Sequence.Spectral.Linear+    Moonlight.Homology.Pure.Sequence.Spectral.Support+    Moonlight.Homology.Pure.Sequence.Spectral.Types+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-core >= 0.1 && < 0.2+    , vector >= 0.13 && < 0.14+    , moonlight-homology:moonlight-homology-chain+    , moonlight-homology:moonlight-homology-matrix+    , moonlight-homology:moonlight-homology-topology++library+  import: shared-properties+  hs-source-dirs: src-public+  exposed-modules:+    Moonlight.Homology.Backend+    Moonlight.Homology.Boundary.GraphGF2+    Moonlight.Homology.Boundary+    Moonlight.Homology.Chain+    Moonlight.Homology.Matrix+    Moonlight.Homology.Persistence+    Moonlight.Homology.Presentation+    Moonlight.Homology.Rank.Field+    Moonlight.Homology.Rank.GF2+    Moonlight.Homology.Rank+    Moonlight.Homology.Sequence+    Moonlight.Homology.Topology+    Moonlight.Homology+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-homology:moonlight-homology-chain+    , moonlight-homology:moonlight-homology-matrix+    , moonlight-homology:moonlight-homology-topology+    , moonlight-homology:moonlight-homology-sequence+    , moonlight-linalg:moonlight-linalg-dense >= 0.1 && < 0.2++library moonlight-homology-laws+  import: shared-properties+  visibility: public+  hs-source-dirs: src-laws+  exposed-modules:+    Moonlight.Homology.Effect.Determinism+    Moonlight.Homology.Effect.Laws+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.11 && < 0.13+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-homology:moonlight-homology-chain+    , moonlight-homology:moonlight-homology-matrix+    , moonlight-homology:moonlight-homology-topology++test-suite moonlight-homology-cell-category-test+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test-cell-category+  main-is: Main.hs+  build-depends:+    base >= 4.22 && < 5+    , moonlight-algebra:abstract >= 0.1 && < 0.2+    , moonlight-category:abstract >= 1.1.0.0 && < 1.2+    , moonlight-category:simplicial >= 1.1.0.0 && < 1.2+    , moonlight-homology:cell-category+    , moonlight-homology:cell-complex+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11++test-suite moonlight-homology-test+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test test/matrix test/topology test/sequence test/facade test/support+  main-is: Main.hs+  other-modules:+    BlockSchurSpec+    CompileFailSpec+    FieldBettiSpec+    GF2GraphSpec+    MorseSpec+    PresentationSpec+    SpectralSpec+    TestFixtures+    TopologySpec+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , filepath >= 1.4 && < 1.6+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:diagnostic-ghc >= 0.1 && < 0.2+    , moonlight-homology+    , moonlight-homology:moonlight-homology-matrix+    , moonlight-homology:moonlight-homology-topology+    , moonlight-homology:moonlight-homology-sequence+    , moonlight-homology:moonlight-homology-laws+    , moonlight-linalg:moonlight-linalg-dense >= 0.1 && < 0.2+    , moonlight-pale:test >= 0.1 && < 0.2+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , tasty-quickcheck >= 0.10 && < 0.12+    , text >= 2.0 && < 2.2++benchmark moonlight-homology-bench+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: bench bench/topology bench/sequence+  main-is: Main.hs+  other-modules:+    MorseSpectral+    SparseSpectral+  ghc-options: -O2 -rtsopts+  ghc-prof-options: -fprof-auto-top+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-homology+    , moonlight-homology:moonlight-homology-matrix+    , tasty-bench >= 0.3 && < 0.6++source-repository head+  type:     git+  location: https://github.com/PaleRoses/moonlight.git+  subdir:   moonlight-homology
+ src-cell-category/Moonlight/Homology/Pure/Topology/CellCategory.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE StandaloneDeriving #-}++-- | The finite, path-sensitive incidence category generated by a+-- 'CellComplex2D'. Objects are cells. Generating arrows descend from faces to+-- boundary edges and from edges to endpoint vertices; a face-to-vertex+-- composite retains the intermediate edge, so distinct incidence flags remain+-- distinct morphisms.+module Moonlight.Homology.Pure.Topology.CellCategory+  ( ComplexCat (..),+    ComplexOb (..),+    ComplexMor (..),+    complexCategory,+  )+where++import Data.Containers.ListUtils (nubOrd)+import Moonlight.Algebra.Pure.Orientation (Orientation)+import Moonlight.Category.Pure.Category (Category (..))+import Moonlight.Category.Pure.FiniteComposable (FiniteComposableCategory (..))+import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..), CellTypes (..), OrientedEdge (..))++-- | A cell complex regarded as its finite incidence category.+data ComplexCat c = ComplexCat c++data ComplexTwoMor c = ComplexTwoMor+  deriving stock (Eq, Ord, Show)++data ComplexCompositor c = ComplexCompositor+  deriving stock (Eq, Ord, Show)++-- | An object of the incidence category, indexed by cell dimension.+data ComplexOb c+  = VertexOb (Vertex c)+  | EdgeOb (Edge c)+  | FaceOb (Face c)++deriving stock instance+  (Eq (Vertex c), Eq (Edge c), Eq (Face c)) =>+  Eq (ComplexOb c)++deriving stock instance+  (CellTypes c, Ord (Vertex c), Ord (Edge c), Ord (Face c)) =>+  Ord (ComplexOb c)++deriving stock instance+  (Show (Vertex c), Show (Edge c), Show (Face c)) =>+  Show (ComplexOb c)++-- | A path-sensitive incidence morphism.+data ComplexMor c+  = -- | Identity on one cell object.+    IdentityMor (ComplexOb c)+  | -- | Oriented boundary incidence from a face to one edge.+    FaceToEdge (Face c) (Edge c) Orientation+  | -- | Endpoint incidence from an edge to one vertex.+    EdgeToVertex (Edge c) (Vertex c)+  | -- | The composite through the retained intermediate edge.+    FaceToVertex (Face c) (Edge c) (Vertex c)++deriving stock instance+  (Eq (Vertex c), Eq (Edge c), Eq (Face c)) =>+  Eq (ComplexMor c)++deriving stock instance+  (CellTypes c, Ord (Vertex c), Ord (Edge c), Ord (Face c)) =>+  Ord (ComplexMor c)++deriving stock instance+  (Show (Vertex c), Show (Edge c), Show (Face c)) =>+  Show (ComplexMor c)++-- | Regard a cell complex as its incidence category without copying it.+complexCategory :: c -> ComplexCat c+complexCategory = ComplexCat++instance CellComplex2D c => Category (ComplexCat c) where+  type Ob (ComplexCat c) = ComplexOb c+  type Mor (ComplexCat c) = ComplexMor c+  type TwoMor (ComplexCat c) = ComplexTwoMor c+  type Compositor (ComplexCat c) = ComplexCompositor c++  identity _ =+    Right . IdentityMor++  compose _ left right+    | complexTarget right /= complexSource left = Left ()+    | isIdentity left = Right (right, ComplexCompositor)+    | isIdentity right = Right (left, ComplexCompositor)+    | otherwise =+        case (left, right) of+          (EdgeToVertex edgeValue vertexValue, FaceToEdge faceValue edgeValue' _)+            | edgeValue == edgeValue' ->+                Right (FaceToVertex faceValue edgeValue vertexValue, ComplexCompositor)+          _ -> Left ()++  source _ =+    Right . complexSource++  target _ =+    Right . complexTarget++instance CellComplex2D c => FiniteComposableCategory (ComplexCat c) where+  enumerateObjects (ComplexCat complexValue) =+    complexObjects complexValue++  enumerateMorphisms categoryValue@(ComplexCat complexValue) =+    nubOrd+      ( fmap IdentityMor (enumerateObjects categoryValue)+          <> foldMap (faceIncidenceMorphisms complexValue) (faces complexValue)+          <> foldMap (edgeIncidenceMorphisms complexValue) (edges complexValue)+          <> foldMap (faceVertexMorphisms complexValue) (faces complexValue)+      )++complexObjects :: CellComplex2D c => c -> [ComplexOb c]+complexObjects complexValue =+  fmap VertexOb (vertices complexValue)+    <> fmap EdgeOb (edges complexValue)+    <> fmap FaceOb (faces complexValue)++faceIncidenceMorphisms :: CellComplex2D c => c -> Face c -> [ComplexMor c]+faceIncidenceMorphisms complexValue faceValue =+  fmap+    (\orientedBoundary -> FaceToEdge faceValue (orientedEdge orientedBoundary) (edgeOrientation orientedBoundary))+    (faceBoundary complexValue faceValue)++edgeIncidenceMorphisms :: CellComplex2D c => c -> Edge c -> [ComplexMor c]+edgeIncidenceMorphisms complexValue edgeValue =+  let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue+   in fmap (EdgeToVertex edgeValue) (nubOrd [sourceVertex, targetVertex])++faceVertexMorphisms :: CellComplex2D c => c -> Face c -> [ComplexMor c]+faceVertexMorphisms complexValue faceValue =+  faceBoundary complexValue faceValue+    >>= ( \orientedBoundary ->+            let edgeValue = orientedEdge orientedBoundary+                (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue+             in fmap+                  (FaceToVertex faceValue edgeValue)+                  (nubOrd [sourceVertex, targetVertex])+        )++complexSource :: ComplexMor c -> ComplexOb c+complexSource morphism =+  case morphism of+    IdentityMor objectValue -> objectValue+    FaceToEdge faceValue _ _ -> FaceOb faceValue+    EdgeToVertex edgeValue _ -> EdgeOb edgeValue+    FaceToVertex faceValue _ _ -> FaceOb faceValue++complexTarget :: ComplexMor c -> ComplexOb c+complexTarget morphism =+  case morphism of+    IdentityMor objectValue -> objectValue+    FaceToEdge _ edgeValue _ -> EdgeOb edgeValue+    EdgeToVertex _ vertexValue -> VertexOb vertexValue+    FaceToVertex _ _ vertexValue -> VertexOb vertexValue++isIdentity :: ComplexMor c -> Bool+isIdentity morphism =+  case morphism of+    IdentityMor _ -> True+    _ -> False
+ src-cell-complex/Moonlight/Homology/Pure/Topology/CellComplex.hs view
@@ -0,0 +1,98 @@+module Moonlight.Homology.Pure.Topology.CellComplex+  ( CellTypes (..),+    Dimension (..),+    CellRef (..),+    cellDimension,+    OrientedEdge (..),+    CellComplex2D (..),+    ValidateComplex2D (..),+    isBoundaryEdge,+    isInteriorEdge,+    eulerCharacteristic,+  )+where++import Data.Kind (Constraint, Type)+import Moonlight.Algebra.Pure.Orientation (Orientation)++type CellTypes :: Type -> Constraint+class+  ( Eq (Vertex c),+    Ord (Vertex c),+    Show (Vertex c),+    Eq (Edge c),+    Ord (Edge c),+    Show (Edge c),+    Eq (Face c),+    Ord (Face c),+    Show (Face c)+  ) =>+  CellTypes c+  where+  type Vertex c+  type Edge c+  type Face c++type Dimension :: Type+data Dimension+  = Dim0+  | Dim1+  | Dim2+  deriving stock (Eq, Ord, Show, Read, Enum, Bounded)++type CellRef :: Type -> Type -> Type -> Type+data CellRef vertex edge face+  = CellVertexRef vertex+  | CellEdgeRef edge+  | CellFaceRef face+  deriving stock (Eq, Ord, Show, Read)++cellDimension :: CellRef vertex edge face -> Dimension+cellDimension cellReference =+  case cellReference of+    CellVertexRef _ -> Dim0+    CellEdgeRef _ -> Dim1+    CellFaceRef _ -> Dim2++type OrientedEdge :: Type -> Type+data OrientedEdge edge = OrientedEdge+  { orientedEdge :: edge,+    edgeOrientation :: Orientation+  }+  deriving stock (Eq, Ord, Show, Read)++type CellComplex2D :: Type -> Constraint+class CellTypes c => CellComplex2D c where+  vertices :: c -> [Vertex c]+  edges :: c -> [Edge c]+  faces :: c -> [Face c]++  edgeBoundary :: c -> Edge c -> (Vertex c, Vertex c)+  faceBoundary :: c -> Face c -> [OrientedEdge (Edge c)]++  edgesAtVertex :: c -> Vertex c -> [Edge c]+  facesAtEdge :: c -> Edge c -> (Maybe (Face c), Maybe (Face c))++type ValidateComplex2D :: Type -> Constraint+class CellComplex2D c => ValidateComplex2D c where+  type ValidationIssue c+  validateComplex :: c -> [ValidationIssue c]++isBoundaryEdge :: CellComplex2D c => c -> Edge c -> Bool+isBoundaryEdge complex edge =+  case facesAtEdge complex edge of+    (Nothing, _) -> True+    (_, Nothing) -> True+    (Just _, Just _) -> False++isInteriorEdge :: CellComplex2D c => c -> Edge c -> Bool+isInteriorEdge complex edge =+  case facesAtEdge complex edge of+    (Just _, Just _) -> True+    _ -> False++eulerCharacteristic :: CellComplex2D c => c -> Int+eulerCharacteristic complex =+  length (vertices complex)+    - length (edges complex)+    + length (faces complex)
+ src-chain/Moonlight/Homology/Pure/Carrier.hs view
@@ -0,0 +1,83 @@+module Moonlight.Homology.Pure.Carrier+  ( BasisCellRef (..),+    CellCarrier,+    CellCarrierError (..),+    carrierDegree,+    carrierCells,+    mkCellCarrier,+  )+where++import Data.Kind (Type)+import Data.Function ((&))+import Data.List qualified as List+import Data.Set qualified as Set+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))++type BasisCellRef :: Type+data BasisCellRef = BasisCellRef+  { cellDegree :: HomologicalDegree,+    cellIndex :: Int+  }+  deriving stock (Eq, Ord, Show)++type CellCarrier :: Type+data CellCarrier = CellCarrier+  { carrierDegree :: HomologicalDegree,+    carrierCells :: [BasisCellRef]+  }+  deriving stock (Eq, Show)++type CellCarrierError :: Type+data CellCarrierError+  = CellCarrierDegreeMismatch HomologicalDegree BasisCellRef+  | CellCarrierCellsNotDistinct [BasisCellRef]+  deriving stock (Eq, Show)++type DuplicateCellsAccumulator :: Type+data DuplicateCellsAccumulator = DuplicateCellsAccumulator+  { seenCellRefs :: !(Set.Set BasisCellRef),+    duplicateCellRefs :: !(Set.Set BasisCellRef)+  }++mkCellCarrier :: HomologicalDegree -> [BasisCellRef] -> Either CellCarrierError CellCarrier+mkCellCarrier degreeValue cells =+  case List.find ((/= degreeValue) . cellDegree) cells of+    Just invalidCell ->+      Left (CellCarrierDegreeMismatch degreeValue invalidCell)+    Nothing ->+      case duplicateCells cells of+        [] ->+          Right+            CellCarrier+              { carrierDegree = degreeValue,+                carrierCells = cells+              }+        duplicateCellValues ->+          Left (CellCarrierCellsNotDistinct duplicateCellValues)++duplicateCells :: [BasisCellRef] -> [BasisCellRef]+duplicateCells cells =+  cells+    & List.foldl' accumulateDuplicateCell emptyDuplicateCellsAccumulator+    & duplicateCellRefs+    & Set.toAscList++emptyDuplicateCellsAccumulator :: DuplicateCellsAccumulator+emptyDuplicateCellsAccumulator =+  DuplicateCellsAccumulator+    { seenCellRefs = Set.empty,+      duplicateCellRefs = Set.empty+    }++accumulateDuplicateCell :: DuplicateCellsAccumulator -> BasisCellRef -> DuplicateCellsAccumulator+accumulateDuplicateCell accumulator cellRefValue =+  if Set.member cellRefValue (seenCellRefs accumulator)+    then+      accumulator+        { duplicateCellRefs = Set.insert cellRefValue (duplicateCellRefs accumulator)+        }+    else+      accumulator+        { seenCellRefs = Set.insert cellRefValue (seenCellRefs accumulator)+        }
+ src-chain/Moonlight/Homology/Pure/Chain.hs view
@@ -0,0 +1,196 @@+module Moonlight.Homology.Pure.Chain+  ( HomologicalDegree (..),+    incrementDegree,+    decrementDegree,+    EulerCharacteristic (..),+    PersistencePair (..),+    RepresentativeChain (..),+    RepresentativeCycle,+    RepresentativeCocycle,+    HarmonicBasisElement (..),+    ExactRepresentativeClass (..),+    TopologyWitness (..),+    emptyTopologyWitness,+    mergeTopologyWitness,+    mergeTopologyWitnessChecked,+    topologyRepresentativeCycles,+    topologyRepresentativeCocycles,+    topologyWitnessFromBetti,+  )+where++import Control.Applicative ((<|>))+import Data.Kind (Type)+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..), decrementDegree, incrementDegree)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Group (HomologyGroup (..))++type EulerCharacteristic :: Type+newtype EulerCharacteristic = EulerCharacteristic+  { unEulerCharacteristic :: Int+  }+  deriving stock (Eq, Ord, Show, Read)++type PersistencePair :: Type -> Type+data PersistencePair scalar = PersistencePair+  { persistenceDegree :: HomologicalDegree,+    persistenceBirth :: scalar,+    persistenceDeath :: Maybe scalar+  }+  deriving stock (Eq, Show)++type RepresentativeChain :: Type -> Type -> Type+data RepresentativeChain coefficient basis = RepresentativeChain+  { representativeDegree :: HomologicalDegree,+    representativeTerms :: [(coefficient, basis)]+  }+  deriving stock (Eq, Show)++type RepresentativeCycle :: Type -> Type -> Type+type RepresentativeCycle coefficient basis = RepresentativeChain coefficient basis++type RepresentativeCocycle :: Type -> Type -> Type+type RepresentativeCocycle coefficient basis = RepresentativeChain coefficient basis++type HarmonicBasisElement :: Type -> Type -> Type+data HarmonicBasisElement coefficient basis = HarmonicBasisElement+  { harmonicDegree :: HomologicalDegree,+    harmonicRepresentative :: RepresentativeCocycle coefficient basis+  }+  deriving stock (Eq, Show)++type ExactRepresentativeClass :: Type -> Type+data ExactRepresentativeClass basis = ExactRepresentativeClass+  { exactClassDegree :: HomologicalDegree,+    exactClassOrder :: Maybe Integer,+    exactClassRepresentative :: RepresentativeCycle Integer basis+  }+  deriving stock (Eq, Show)++type TopologyWitness :: Type -> Type -> Type -> Type -> Type -> Type+data TopologyWitness scaffold spectral persistence coefficient basis = TopologyWitness+  { topologyEulerCharacteristic :: Maybe EulerCharacteristic,+    topologyBettiVector :: [Int],+    topologyIntegralHomologyGroups :: [HomologyGroup Integer],+    topologyExactRepresentativeClasses :: [ExactRepresentativeClass basis],+    topologyPersistencePairs :: [PersistencePair persistence],+    topologyCoefficientRepresentativeCycles :: [RepresentativeCycle coefficient basis],+    topologyCoefficientRepresentativeCocycles :: [RepresentativeCocycle coefficient basis],+    topologyHarmonicBasis :: [HarmonicBasisElement coefficient basis],+    topologyMacroScaffold :: Maybe scaffold,+    topologyLowSpectralModes :: [spectral]+  }+  deriving stock (Eq, Show)++emptyTopologyWitness :: TopologyWitness scaffold spectral persistence coefficient basis+emptyTopologyWitness =+  TopologyWitness+    { topologyEulerCharacteristic = Nothing,+      topologyBettiVector = [],+      topologyIntegralHomologyGroups = [],+      topologyExactRepresentativeClasses = [],+      topologyPersistencePairs = [],+      topologyCoefficientRepresentativeCycles = [],+      topologyCoefficientRepresentativeCocycles = [],+      topologyHarmonicBasis = [],+      topologyMacroScaffold = Nothing,+      topologyLowSpectralModes = []+    }++mergeTopologyWitness ::+  TopologyWitness scaffold spectral persistence coefficient basis ->+  TopologyWitness scaffold spectral persistence coefficient basis ->+  TopologyWitness scaffold spectral persistence coefficient basis+mergeTopologyWitness left right =+  TopologyWitness+    { topologyEulerCharacteristic =+        topologyEulerCharacteristic left <|> topologyEulerCharacteristic right,+      topologyBettiVector =+        preferNonEmpty (topologyBettiVector left) (topologyBettiVector right),+      topologyIntegralHomologyGroups =+        preferNonEmpty (topologyIntegralHomologyGroups left) (topologyIntegralHomologyGroups right),+      topologyExactRepresentativeClasses =+        preferNonEmpty (topologyExactRepresentativeClasses left) (topologyExactRepresentativeClasses right),+      topologyPersistencePairs =+        topologyPersistencePairs left <> topologyPersistencePairs right,+      topologyCoefficientRepresentativeCycles =+        topologyCoefficientRepresentativeCycles left <> topologyCoefficientRepresentativeCycles right,+      topologyCoefficientRepresentativeCocycles =+        topologyCoefficientRepresentativeCocycles left <> topologyCoefficientRepresentativeCocycles right,+      topologyHarmonicBasis =+        topologyHarmonicBasis left <> topologyHarmonicBasis right,+      topologyMacroScaffold =+        topologyMacroScaffold left <|> topologyMacroScaffold right,+      topologyLowSpectralModes =+        topologyLowSpectralModes left <> topologyLowSpectralModes right+    }+  where+    preferNonEmpty :: [a] -> [a] -> [a]+    preferNonEmpty preferred fallback =+      case preferred of+        [] -> fallback+        _ -> preferred++mergeTopologyWitnessChecked ::+  (Eq scaffold, Eq basis) =>+  TopologyWitness scaffold spectral persistence coefficient basis ->+  TopologyWitness scaffold spectral persistence coefficient basis ->+  Either HomologyFailure (TopologyWitness scaffold spectral persistence coefficient basis)+mergeTopologyWitnessChecked left right = do+  mergedEuler <- mergeOptional "Euler characteristic" (topologyEulerCharacteristic left) (topologyEulerCharacteristic right)+  mergedBetti <- mergePreferNonEmpty "Betti vector" (topologyBettiVector left) (topologyBettiVector right)+  mergedGroups <- mergePreferNonEmpty "integral homology groups" (topologyIntegralHomologyGroups left) (topologyIntegralHomologyGroups right)+  mergedExact <- mergePreferNonEmpty "exact representative classes" (topologyExactRepresentativeClasses left) (topologyExactRepresentativeClasses right)+  mergedScaffold <- mergeOptional "macro scaffold" (topologyMacroScaffold left) (topologyMacroScaffold right)+  pure+    TopologyWitness+      { topologyEulerCharacteristic = mergedEuler,+        topologyBettiVector = mergedBetti,+        topologyIntegralHomologyGroups = mergedGroups,+        topologyExactRepresentativeClasses = mergedExact,+        topologyPersistencePairs = topologyPersistencePairs left <> topologyPersistencePairs right,+        topologyCoefficientRepresentativeCycles = topologyCoefficientRepresentativeCycles left <> topologyCoefficientRepresentativeCycles right,+        topologyCoefficientRepresentativeCocycles = topologyCoefficientRepresentativeCocycles left <> topologyCoefficientRepresentativeCocycles right,+        topologyHarmonicBasis = topologyHarmonicBasis left <> topologyHarmonicBasis right,+        topologyMacroScaffold = mergedScaffold,+        topologyLowSpectralModes = topologyLowSpectralModes left <> topologyLowSpectralModes right+      }++mergeOptional :: Eq a => String -> Maybe a -> Maybe a -> Either HomologyFailure (Maybe a)+mergeOptional fieldName leftValue rightValue =+  case (leftValue, rightValue) of+    (Nothing, _) -> Right rightValue+    (_, Nothing) -> Right leftValue+    (Just leftInner, Just rightInner)+      | leftInner == rightInner -> Right leftValue+      | otherwise -> Left (InvalidTopologyInput ("conflicting topology witness data for " <> fieldName))++mergePreferNonEmpty :: Eq a => String -> [a] -> [a] -> Either HomologyFailure [a]+mergePreferNonEmpty fieldName leftValue rightValue =+  case (leftValue, rightValue) of+    ([], _) -> Right rightValue+    (_, []) -> Right leftValue+    _+      | leftValue == rightValue -> Right leftValue+      | otherwise -> Left (InvalidTopologyInput ("conflicting topology witness data for " <> fieldName))++topologyWitnessFromBetti ::+  [HomologyGroup r] ->+  TopologyWitness scaffold spectral persistence coefficient basis+topologyWitnessFromBetti groups =+  emptyTopologyWitness+    { topologyBettiVector = fmap freeRank groups+    }++topologyRepresentativeCycles ::+  TopologyWitness scaffold spectral persistence coefficient basis ->+  [RepresentativeCycle coefficient basis]+topologyRepresentativeCycles =+  topologyCoefficientRepresentativeCycles++topologyRepresentativeCocycles ::+  TopologyWitness scaffold spectral persistence coefficient basis ->+  [RepresentativeCocycle coefficient basis]+topologyRepresentativeCocycles =+  topologyCoefficientRepresentativeCocycles+
+ src-chain/Moonlight/Homology/Pure/Constraint/Core.hs view
@@ -0,0 +1,218 @@+module Moonlight.Homology.Pure.Constraint.Core+  ( Bound (..),+    TargetBetti (..),+    PersistenceBudget (..),+    EulerBound (..),+    LoopSemanticRole (..),+    LoopRole (..),+    RequireTorsionInvariant (..),+    RequireElementOrder (..),+    RequireOrderSupport (..),+    PrimaryOrderSupportBudget (..),+    RequirePrimaryOrderSupport (..),+    TorsionBudgetMeasure (..),+    TorsionBudget (..),+    RequireCyclicOrder (..),+    SingularityBudget (..),+    HarmonicLoopBudget (..),+    SkeletonAdherence (..),+    TopologicalConstraint (..),+    TopologicalViolation (..),+    boundSatisfied,+    checkBound,+  )+where++import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import Moonlight.Homology.Pure.Chain+  ( EulerCharacteristic (..),+    HomologicalDegree (..),+  )+import Moonlight.Homology.Pure.Filtration+  ( CriticalKind (..),+    FiltrationValue (..),+  )+import Moonlight.Homology.Pure.Skeleton (SkeletonSignature (..))++type Bound :: Type -> Type+data Bound a+  = Exactly a+  | AtLeast a+  | AtMost a+  | Between a a+  deriving stock (Eq, Ord, Show, Read)++type TargetBetti :: Type+newtype TargetBetti = TargetBetti+  { targetBettiVector :: [Int]+  }+  deriving stock (Eq, Show, Read)++type PersistenceBudget :: Type+data PersistenceBudget = PersistenceBudget+  { persistenceBudgetDegree :: Maybe HomologicalDegree,+    persistenceBudgetMinimumLifetime :: FiltrationValue,+    persistenceBudgetCountBound :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type EulerBound :: Type+newtype EulerBound = EulerBound+  { requiredEulerBound :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type LoopSemanticRole :: Type+data LoopSemanticRole+  = CirculationLoop+  | StructuralLoop+  | OrnamentLoop+  | AccessLoop+  deriving stock (Eq, Ord, Show, Read, Enum, Bounded)++type LoopRole :: Type+data LoopRole = LoopRole+  { loopSemanticRole :: LoopSemanticRole,+    loopTargetDegree :: HomologicalDegree,+    loopCountBound :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type RequireTorsionInvariant :: Type+data RequireTorsionInvariant = RequireTorsionInvariant+  { requiredTorsionDegree :: HomologicalDegree,+    requiredTorsionInvariant :: Integer,+    requiredTorsionMultiplicity :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type RequireElementOrder :: Type+data RequireElementOrder = RequireElementOrder+  { requiredElementDegree :: HomologicalDegree,+    requiredElementOrder :: Integer,+    requiredElementMultiplicity :: Bound Integer+  }+  deriving stock (Eq, Show, Read)++type RequireOrderSupport :: Type+data RequireOrderSupport = RequireOrderSupport+  { requiredOrderSupportDegree :: Maybe HomologicalDegree,+    requiredSupportedOrders :: [Integer],+    requiredForbiddenOrders :: [Integer]+  }+  deriving stock (Eq, Show, Read)++type PrimaryOrderSupportBudget :: Type+data PrimaryOrderSupportBudget = PrimaryOrderSupportBudget+  { primarySupportBudgetDegree :: Maybe HomologicalDegree,+    primarySupportBudgetPrime :: Integer,+    primarySupportBudgetBound :: Bound Integer+  }+  deriving stock (Eq, Show, Read)++type RequirePrimaryOrderSupport :: Type+data RequirePrimaryOrderSupport = RequirePrimaryOrderSupport+  { requiredPrimarySupportDegree :: Maybe HomologicalDegree,+    requiredPrimarySupportPrime :: Integer,+    requiredPrimarySupportedOrders :: [Integer],+    requiredPrimaryForbiddenOrders :: [Integer]+  }+  deriving stock (Eq, Show, Read)++type TorsionBudget :: Type+data TorsionBudget = TorsionBudget+  { torsionBudgetDegree :: Maybe HomologicalDegree,+    torsionBudgetOrder :: Maybe Integer,+    torsionBudgetMeasure :: TorsionBudgetMeasure,+    torsionBudgetBound :: Bound Integer+  }+  deriving stock (Eq, Show, Read)++type TorsionBudgetMeasure :: Type+data TorsionBudgetMeasure+  = TorsionSummandCount+  | TorsionTotalCardinality+  | TorsionElementOrderCount+  | TorsionOrderSupportCount+  deriving stock (Eq, Show, Read)++type RequireCyclicOrder :: Type+data RequireCyclicOrder = RequireCyclicOrder+  { requiredCyclicDegree :: HomologicalDegree,+    requiredCyclicOrder :: Integer,+    requiredCyclicMultiplicity :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type SingularityBudget :: Type+newtype SingularityBudget = SingularityBudget+  { singularityBounds :: Map.Map CriticalKind (Bound Int)+  }+  deriving stock (Eq, Show, Read)++type HarmonicLoopBudget :: Type+data HarmonicLoopBudget = HarmonicLoopBudget+  { harmonicLoopDegree :: HomologicalDegree,+    harmonicLoopCountBound :: Bound Int+  }+  deriving stock (Eq, Show, Read)++type SkeletonAdherence :: Type+data SkeletonAdherence = SkeletonAdherence+  { skeletonTargetSignature :: SkeletonSignature,+    skeletonTolerance :: Int+  }+  deriving stock (Eq, Show, Read)++type TopologicalConstraint :: Type+data TopologicalConstraint+  = TargetBettiConstraint TargetBetti+  | PersistenceBudgetConstraint PersistenceBudget+  | EulerBoundConstraint EulerBound+  | LoopRoleConstraint LoopRole+  | RequireTorsionInvariantConstraint RequireTorsionInvariant+  | RequireElementOrderConstraint RequireElementOrder+  | RequireOrderSupportConstraint RequireOrderSupport+  | PrimaryOrderSupportBudgetConstraint PrimaryOrderSupportBudget+  | RequirePrimaryOrderSupportConstraint RequirePrimaryOrderSupport+  | TorsionBudgetConstraint TorsionBudget+  | RequireCyclicOrderConstraint RequireCyclicOrder+  | SingularityBudgetConstraint SingularityBudget+  | HarmonicLoopBudgetConstraint HarmonicLoopBudget+  | SkeletonAdherenceConstraint SkeletonAdherence+  deriving stock (Eq, Show, Read)++type TopologicalViolation :: Type+data TopologicalViolation+  = BettiViolation TargetBetti [Int]+  | EulerWitnessMissing EulerBound+  | EulerBoundViolation EulerBound EulerCharacteristic+  | PersistenceBudgetViolation PersistenceBudget Int+  | LoopRoleViolation LoopRole Int+  | IntegralHomologyWitnessMissing TopologicalConstraint+  | RequireTorsionInvariantViolation RequireTorsionInvariant Int+  | RequireElementOrderViolation RequireElementOrder Integer+  | RequireOrderSupportViolation RequireOrderSupport [Integer] [Integer]+  | PrimaryOrderSupportBudgetViolation PrimaryOrderSupportBudget Integer+  | RequirePrimaryOrderSupportViolation RequirePrimaryOrderSupport [Integer] [Integer]+  | InvalidPrimaryPrime TopologicalConstraint Integer+  | TorsionBudgetViolation TorsionBudget Integer+  | RequireCyclicOrderViolation RequireCyclicOrder Int+  | MacroScaffoldMissing TopologicalConstraint+  | SingularityBudgetViolation CriticalKind (Bound Int) Int+  | HarmonicLoopBudgetViolation HarmonicLoopBudget Int+  | SkeletonAdherenceViolation SkeletonAdherence SkeletonSignature+  deriving stock (Eq, Show, Read)++boundSatisfied :: Ord a => Bound a -> a -> Bool+boundSatisfied boundValue observedValue =+  case boundValue of+    Exactly targetValue -> observedValue == targetValue+    AtLeast minimumValue -> observedValue >= minimumValue+    AtMost maximumValue -> observedValue <= maximumValue+    Between minimumValue maximumValue -> observedValue >= minimumValue && observedValue <= maximumValue++checkBound :: Ord a => Bound a -> a -> violation -> [violation]+checkBound bound observed violation =+  if boundSatisfied bound observed then [] else [violation]
+ src-chain/Moonlight/Homology/Pure/Degree.hs view
@@ -0,0 +1,22 @@+module Moonlight.Homology.Pure.Degree+  ( HomologicalDegree (..),+    incrementDegree,+    decrementDegree,+  )+where++import Data.Kind (Type)++type HomologicalDegree :: Type+newtype HomologicalDegree = HomologicalDegree+  { unHomologicalDegree :: Int+  }+  deriving stock (Eq, Ord, Show, Read)++incrementDegree :: HomologicalDegree -> HomologicalDegree+incrementDegree (HomologicalDegree degreeValue) =+  HomologicalDegree (degreeValue + 1)++decrementDegree :: HomologicalDegree -> HomologicalDegree+decrementDegree (HomologicalDegree degreeValue) =+  HomologicalDegree (degreeValue - 1)
+ src-chain/Moonlight/Homology/Pure/Failure.hs view
@@ -0,0 +1,61 @@+module Moonlight.Homology.Pure.Failure+  ( HomologyLaw (..),+    NonEffectiveCause (..),+    TopologyInputObstruction (..),+    HomologyFailure (..),+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Carrier (BasisCellRef)++type HomologyLaw :: Type+data HomologyLaw+  = ChainNilpotenceLaw+  | ReductionLeftInverseLaw+  | ReductionHomotopyLaw+  | ReductionProjectionChainMapLaw+  | ReductionInclusionChainMapLaw+  | IncidenceScopeLaw+  | DeterminismLaw+  deriving stock (Eq, Show)++type NonEffectiveCause :: Type+data NonEffectiveCause+  = MissingFiniteReduction+  | UnsupportedInfiniteCarrier+  | MissingConvergenceWitness+  deriving stock (Eq, Show)++type TopologyInputObstruction :: Type+data TopologyInputObstruction+  = TopologyObjectAbsent+  | TopologyStrongComponentAbsent !Int+  | TopologyUpperSetAbsent !Int+  | TopologyRankAbsent !Int+  | TopologyGeneratedDegreeAbsent !Int+  | TopologyGeneratedFaceAbsent !Int ![Int]+  | TopologyGeneratedChainIndexCollision !Int+  | TopologyGeneratedEmptyChain !Int+  | TopologyDuplicateCells !Int !Int+  | TopologyBasisCardinalityMismatch !Int !Int+  deriving stock (Eq, Show)++type HomologyFailure :: Type+data HomologyFailure+  = NonConvergent Int+  | BudgetExceeded Int Int+  | NonEffective NonEffectiveCause+  | LawViolation HomologyLaw+  | InvalidBoundaryIncidence String+  | InvalidMatrixShape String+  | InvalidTopologyInput String+  | TopologyInputRejected TopologyInputObstruction+  | ChainComplexShapeMismatch Int Int Int+  | ChainComplexNilpotenceViolation Int+  | MissingCriticalBasisProvenance BasisCellRef+  | FiltrationIncompatibleMorsePair BasisCellRef BasisCellRef Int Int+  | FiltrationNotPreserved BasisCellRef BasisCellRef Int Int+  | SpectralQuotientDenominatorNotSubspace (Int, Int) Int [Rational]+  | BackendFailure String+  deriving stock (Eq, Show)
+ src-chain/Moonlight/Homology/Pure/Filtration.hs view
@@ -0,0 +1,30 @@+module Moonlight.Homology.Pure.Filtration+  ( FiltrationValue (..),+    CriticalKind (..),+    enumerateFromZero,+  )+where++import Data.Kind (Type)++type FiltrationValue :: Type+newtype FiltrationValue = FiltrationValue+  { unFiltrationValue :: Double+  }+  deriving stock (Eq, Ord, Show, Read)++type CriticalKind :: Type+data CriticalKind+  = Basin+  | Peak+  | Merge+  | Split+  | Pass+  | Isolated+  deriving stock (Eq, Ord, Show, Read, Enum, Bounded)++enumerateFromZero :: Int -> [Int]+enumerateFromZero upperExclusive =+  if upperExclusive <= 0+    then []+    else [0 .. upperExclusive - 1]
+ src-chain/Moonlight/Homology/Pure/FiniteAbelian.hs view
@@ -0,0 +1,122 @@+module Moonlight.Homology.Pure.FiniteAbelian+  ( FiniteAbelianTorsion,+    mkFiniteAbelianTorsion,+    torsionFromHomologyGroup,+    finiteAbelianInvariants,+    normalizeTorsionOrders,+    finiteAbelianSummandCount,+    finiteAbelianCyclicSummandMultiplicity,+    finiteAbelianFilteredCardinality,+    finiteAbelianCardinality,+    finiteAbelianExponent,+    finiteAbelianOrderSupport,+    finiteAbelianPrimaryOrderSupport,+    finiteAbelianExactOrderElementCount,+    isPrime,+    matchesOptional,+  )+where++import Data.Kind (Type)+import Data.Function ((&))+import qualified Data.List as List+import Moonlight.Algebra.Pure.NumberTheory+  ( countExactOrderElements,+    divisorsOf,+    isPrime,+    primePowerPart,+  )+import Moonlight.Homology.Pure.Group (HomologyGroup (..))++type FiniteAbelianTorsion :: Type+newtype FiniteAbelianTorsion = FiniteAbelianTorsion+  { finiteAbelianInvariants :: [Integer]+  }+  deriving stock (Eq, Show)++mkFiniteAbelianTorsion :: [Integer] -> FiniteAbelianTorsion+mkFiniteAbelianTorsion =+  FiniteAbelianTorsion . normalizeInvariantFactors++torsionFromHomologyGroup :: HomologyGroup Integer -> FiniteAbelianTorsion+torsionFromHomologyGroup =+  mkFiniteAbelianTorsion . torsionInvariants++finiteAbelianSummandCount :: Maybe Integer -> FiniteAbelianTorsion -> Integer+finiteAbelianSummandCount orderConstraint =+  toInteger . length . finiteAbelianMatchingInvariants orderConstraint++finiteAbelianCyclicSummandMultiplicity :: Integer -> FiniteAbelianTorsion -> Int+finiteAbelianCyclicSummandMultiplicity orderValue =+  length . finiteAbelianMatchingInvariants (Just orderValue)++finiteAbelianFilteredCardinality :: Maybe Integer -> FiniteAbelianTorsion -> Integer+finiteAbelianFilteredCardinality orderConstraint =+  product . finiteAbelianMatchingInvariants orderConstraint++finiteAbelianCardinality :: FiniteAbelianTorsion -> Integer+finiteAbelianCardinality =+  finiteAbelianFilteredCardinality Nothing++finiteAbelianExponent :: FiniteAbelianTorsion -> Integer+finiteAbelianExponent =+  foldr lcm 1 . finiteAbelianInvariants++finiteAbelianOrderSupport :: FiniteAbelianTorsion -> [Integer]+finiteAbelianOrderSupport torsionValue =+  finiteAbelianExponent torsionValue+    & divisorsOf+    & filter (> 1)+    & normalizeTorsionOrders++finiteAbelianPrimaryOrderSupport :: Integer -> FiniteAbelianTorsion -> Maybe [Integer]+finiteAbelianPrimaryOrderSupport primeValue torsionValue =+  if not (isPrime primeValue)+    then Nothing+    else+      let primaryExponent =+            finiteAbelianInvariants torsionValue+              & fmap (primePowerPart primeValue)+              & foldr lcm 1+       in Just (primePowerOrdersUpToExponent primeValue primaryExponent)++finiteAbelianExactOrderElementCount :: Integer -> FiniteAbelianTorsion -> Integer+finiteAbelianExactOrderElementCount orderValue =+  countExactOrderElements orderValue . finiteAbelianInvariants++finiteAbelianMatchingInvariants :: Maybe Integer -> FiniteAbelianTorsion -> [Integer]+finiteAbelianMatchingInvariants orderConstraint torsionValue =+  finiteAbelianInvariants torsionValue+    & filter (matchesOptional (fmap abs orderConstraint) . abs)++matchesOptional :: Eq a => Maybe a -> a -> Bool+matchesOptional = maybe (const True) (==)++normalizeInvariantFactors :: [Integer] -> [Integer]+normalizeInvariantFactors =+  List.sort . filter (> 1) . fmap abs++normalizeTorsionOrders :: [Integer] -> [Integer]+normalizeTorsionOrders =+  deduplicateAdjacentValues . List.sort . filter (> 1) . fmap abs++deduplicateAdjacentValues :: Eq value => [value] -> [value]+deduplicateAdjacentValues =+  foldr+    ( \value deduplicatedValues ->+        case deduplicatedValues of+          nextValue : _+            | value == nextValue -> deduplicatedValues+          _ -> value : deduplicatedValues+    )+    []++primePowerOrdersUpToExponent :: Integer -> Integer -> [Integer]+primePowerOrdersUpToExponent primeValue exponentValue =+  let normalizedPrime = abs primeValue+      normalizedExponent = abs exponentValue+   in if not (isPrime normalizedPrime) || normalizedExponent <= 1+        then []+        else+          iterate (* normalizedPrime) normalizedPrime+            & takeWhile (<= normalizedExponent)
+ src-chain/Moonlight/Homology/Pure/Graded/Query.hs view
@@ -0,0 +1,90 @@+module Moonlight.Homology.Pure.Graded.Query+  ( DegreeSelection (..),+    GradedAggregation (..),+    GradedQuery (..),+    selectAllDegrees,+    selectDegree,+    degreeSelectionFromMaybe,+    combineSelectedQuery,+    preserveDegreewiseQuery,+    matchesDegreeSelection,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    selectDegreeIndexed,+    selectGradedMembers,+    countGradedMembers,+  )+where++import Data.Kind (Type)+import qualified Data.List as List+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..))++type DegreeSelection :: Type+data DegreeSelection+  = SelectAllDegrees+  | SelectDegree HomologicalDegree+  deriving stock (Eq, Ord, Show, Read)++type GradedAggregation :: Type+data GradedAggregation+  = CombineSelected+  | PreserveDegreewise+  deriving stock (Eq, Ord, Show, Read)++type GradedQuery :: Type+data GradedQuery = GradedQuery+  { gradedQuerySelection :: DegreeSelection,+    gradedQueryAggregation :: GradedAggregation+  }+  deriving stock (Eq, Ord, Show, Read)++selectAllDegrees :: DegreeSelection+selectAllDegrees = SelectAllDegrees++selectDegree :: HomologicalDegree -> DegreeSelection+selectDegree = SelectDegree++degreeSelectionFromMaybe :: Maybe HomologicalDegree -> DegreeSelection+degreeSelectionFromMaybe =+  maybe selectAllDegrees selectDegree++combineSelectedQuery :: DegreeSelection -> GradedQuery+combineSelectedQuery selectionValue =+  GradedQuery+    { gradedQuerySelection = selectionValue,+      gradedQueryAggregation = CombineSelected+    }++preserveDegreewiseQuery :: DegreeSelection -> GradedQuery+preserveDegreewiseQuery selectionValue =+  GradedQuery+    { gradedQuerySelection = selectionValue,+      gradedQueryAggregation = PreserveDegreewise+    }++matchesDegreeSelection :: DegreeSelection -> HomologicalDegree -> Bool+matchesDegreeSelection selectionValue degreeValue =+  case selectionValue of+    SelectAllDegrees -> True+    SelectDegree requiredDegree -> degreeValue == requiredDegree++enumerateDegreeIndexed :: [a] -> [(HomologicalDegree, a)]+enumerateDegreeIndexed =+  zipWith (\indexValue memberValue -> (HomologicalDegree indexValue, memberValue)) [0 :: Int ..]++lookupDegreeIndexed :: HomologicalDegree -> [(HomologicalDegree, a)] -> Maybe a+lookupDegreeIndexed degreeValue =+  fmap snd . List.find ((== degreeValue) . fst)++selectDegreeIndexed :: DegreeSelection -> [(HomologicalDegree, a)] -> [a]+selectDegreeIndexed selectionValue =+  fmap snd . filter (matchesDegreeSelection selectionValue . fst)++selectGradedMembers :: (a -> HomologicalDegree) -> DegreeSelection -> [a] -> [a]+selectGradedMembers degreeOf selectionValue =+  filter (matchesDegreeSelection selectionValue . degreeOf)++countGradedMembers :: (a -> HomologicalDegree) -> DegreeSelection -> [a] -> Int+countGradedMembers degreeOf selectionValue =+  length . selectGradedMembers degreeOf selectionValue
+ src-chain/Moonlight/Homology/Pure/GradedTorsion.hs view
@@ -0,0 +1,134 @@+module Moonlight.Homology.Pure.GradedTorsion+  ( DegreeSelection (..),+    GradedAggregation (..),+    GradedQuery (..),+    selectAllDegrees,+    selectDegree,+    degreeSelectionFromMaybe,+    combineSelectedQuery,+    preserveDegreewiseQuery,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    selectDegreeIndexed,+    selectGradedMembers,+    countGradedMembers,+    directProductQuery,+    degreewiseUnionQuery,+    GradedTorsionFamily,+    mkGradedTorsionFamily,+    gradedTorsionPresent,+    gradedTorsionAtDegree,+    gradedTorsionCombined,+    gradedTorsionOrderSupport,+    gradedTorsionPrimaryOrderSupport,+  )+where++import Data.Kind (Type)+import Data.Function ((&))+import Moonlight.Homology.Pure.FiniteAbelian+  ( FiniteAbelianTorsion,+    finiteAbelianInvariants,+    finiteAbelianOrderSupport,+    finiteAbelianPrimaryOrderSupport,+    mkFiniteAbelianTorsion,+    normalizeTorsionOrders,+    torsionFromHomologyGroup,+  )+import Moonlight.Homology.Pure.Group (HomologyGroup (..))+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..))+import Moonlight.Homology.Pure.Graded.Query+  ( DegreeSelection (..),+    GradedAggregation (..),+    GradedQuery (..),+    combineSelectedQuery,+    countGradedMembers,+    degreeSelectionFromMaybe,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    preserveDegreewiseQuery,+    selectAllDegrees,+    selectDegree,+    selectDegreeIndexed,+    selectGradedMembers,+  )++-- | Alias of 'combineSelectedQuery' under its mathematical name; the two+-- exported names denote one function.+directProductQuery :: DegreeSelection -> GradedQuery+directProductQuery = combineSelectedQuery++-- | Alias of 'preserveDegreewiseQuery' under its mathematical name; the two+-- exported names denote one function.+degreewiseUnionQuery :: DegreeSelection -> GradedQuery+degreewiseUnionQuery = preserveDegreewiseQuery++type GradedTorsionFamily :: Type+newtype GradedTorsionFamily = GradedTorsionFamily+  { gradedTorsionEntries :: [(HomologicalDegree, FiniteAbelianTorsion)]+  }+  deriving stock (Eq, Show)++mkGradedTorsionFamily :: [HomologyGroup Integer] -> GradedTorsionFamily+mkGradedTorsionFamily homologyGroups =+  homologyGroups+    & enumerateDegreeIndexed+    & fmap (\(degreeValue, homologyGroupValue) -> (degreeValue, torsionFromHomologyGroup homologyGroupValue))+    & GradedTorsionFamily++gradedTorsionPresent :: GradedTorsionFamily -> Bool+gradedTorsionPresent =+  not . null . gradedTorsionEntries++gradedTorsionAtDegree ::+  HomologicalDegree ->+  GradedTorsionFamily ->+  Maybe FiniteAbelianTorsion+gradedTorsionAtDegree degreeValue family =+  gradedTorsionEntries family+    & lookupDegreeIndexed degreeValue++gradedTorsionCombined ::+  DegreeSelection ->+  GradedTorsionFamily ->+  FiniteAbelianTorsion+gradedTorsionCombined selectionValue =+  mkFiniteAbelianTorsion . foldMap finiteAbelianInvariants . selectTorsion selectionValue++gradedTorsionOrderSupport ::+  GradedQuery ->+  GradedTorsionFamily ->+  [Integer]+gradedTorsionOrderSupport queryValue family =+  case gradedQueryAggregation queryValue of+    CombineSelected ->+      finiteAbelianOrderSupport (gradedTorsionCombined (gradedQuerySelection queryValue) family)+    PreserveDegreewise ->+      selectTorsion (gradedQuerySelection queryValue) family+        & fmap finiteAbelianOrderSupport+        & concat+        & normalizeTorsionOrders++gradedTorsionPrimaryOrderSupport ::+  Integer ->+  GradedQuery ->+  GradedTorsionFamily ->+  Maybe [Integer]+gradedTorsionPrimaryOrderSupport primeValue queryValue family =+  case gradedQueryAggregation queryValue of+    CombineSelected ->+      finiteAbelianPrimaryOrderSupport+        primeValue+        (gradedTorsionCombined (gradedQuerySelection queryValue) family)+    PreserveDegreewise ->+      selectTorsion (gradedQuerySelection queryValue) family+        & traverse (finiteAbelianPrimaryOrderSupport primeValue)+        & fmap (normalizeTorsionOrders . concat)++selectTorsion ::+  DegreeSelection ->+  GradedTorsionFamily ->+  [FiniteAbelianTorsion]+selectTorsion selectionValue family =+  gradedTorsionEntries family+    & selectDegreeIndexed selectionValue
+ src-chain/Moonlight/Homology/Pure/Group.hs view
@@ -0,0 +1,13 @@+module Moonlight.Homology.Pure.Group+  ( HomologyGroup (..),+  )+where++import Data.Kind (Type)++type HomologyGroup :: Type -> Type+data HomologyGroup r = HomologyGroup+  { freeRank :: Int,+    torsionInvariants :: [r]+  }+  deriving stock (Eq, Show)
+ src-chain/Moonlight/Homology/Pure/LinearCombination.hs view
@@ -0,0 +1,132 @@+module Moonlight.Homology.Pure.LinearCombination+  ( LinearCombination,+    LinearCombinationArithmetic (..),+    numArithmetic,+    ringArithmetic,+    normalizeWith,+    composeWith,+    addWith,+    subtractWith,+    identityWith,+    checkLawWith,+  )+where++import Data.Kind (Type)+import Data.Map.Strict qualified as Map+import Moonlight.Core (AdditiveGroup (..), AdditiveMonoid (..), MultiplicativeMonoid (..), Ring)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw)++type LinearCombination :: Type -> Type -> Type+type LinearCombination coefficient basis = [(coefficient, basis)]++type LinearCombinationArithmetic :: Type -> Type+data LinearCombinationArithmetic coefficient = LinearCombinationArithmetic+  { lcaZero :: !coefficient,+    lcaOne :: !coefficient,+    lcaAdd :: !(coefficient -> coefficient -> coefficient),+    lcaNegate :: !(coefficient -> coefficient),+    lcaMultiply :: !(coefficient -> coefficient -> coefficient)+  }++numArithmetic :: Num coefficient => LinearCombinationArithmetic coefficient+numArithmetic =+  LinearCombinationArithmetic+    { lcaZero = 0,+      lcaOne = 1,+      lcaAdd = (+),+      lcaNegate = negate,+      lcaMultiply = (*)+    }++ringArithmetic :: Ring coefficient => LinearCombinationArithmetic coefficient+ringArithmetic =+  LinearCombinationArithmetic+    { lcaZero = zero,+      lcaOne = one,+      lcaAdd = add,+      lcaNegate = neg,+      lcaMultiply = mul+    }++normalizeWith ::+  (Eq coefficient, Ord basis) =>+  LinearCombinationArithmetic coefficient ->+  LinearCombination coefficient basis ->+  LinearCombination coefficient basis+normalizeWith arithmetic =+  fmap (\(basisValue, coefficientValue) -> (coefficientValue, basisValue))+    . Map.toAscList+    . Map.filter (/= lcaZero arithmetic)+    . Map.fromListWith (lcaAdd arithmetic)+    . fmap (\(coefficientValue, basisValue) -> (basisValue, coefficientValue))++composeWith ::+  (Eq coefficient, Ord targetBasis) =>+  LinearCombinationArithmetic coefficient ->+  (sourceBasis -> LinearCombination coefficient targetBasis) ->+  LinearCombination coefficient sourceBasis ->+  LinearCombination coefficient targetBasis+composeWith arithmetic mapping combination =+  normalizeWith arithmetic+    [ (lcaMultiply arithmetic sourceCoefficient targetCoefficient, targetBasis)+    | (sourceCoefficient, sourceBasis) <- combination,+      (targetCoefficient, targetBasis) <- mapping sourceBasis+    ]++addWith ::+  (Eq coefficient, Ord basis) =>+  LinearCombinationArithmetic coefficient ->+  LinearCombination coefficient basis ->+  LinearCombination coefficient basis ->+  LinearCombination coefficient basis+addWith arithmetic leftCombination rightCombination =+  normalizeWith arithmetic (leftCombination <> rightCombination)++subtractWith ::+  (Eq coefficient, Ord basis) =>+  LinearCombinationArithmetic coefficient ->+  LinearCombination coefficient basis ->+  LinearCombination coefficient basis ->+  LinearCombination coefficient basis+subtractWith arithmetic leftCombination rightCombination =+  normalizeWith arithmetic+    (leftCombination <> fmap (negateTermWith arithmetic) rightCombination)++identityWith ::+  LinearCombinationArithmetic coefficient ->+  basis ->+  LinearCombination coefficient basis+identityWith arithmetic basisValue =+  [(lcaOne arithmetic, basisValue)]++checkLawWith ::+  (Eq coefficient, Ord targetBasis) =>+  LinearCombinationArithmetic coefficient ->+  HomologyLaw ->+  [sourceBasis] ->+  (sourceBasis -> LinearCombination coefficient targetBasis) ->+  (sourceBasis -> LinearCombination coefficient targetBasis) ->+  Either HomologyFailure ()+checkLawWith arithmetic law basisElements leftSide rightSide =+  if all (lawHoldsWith arithmetic leftSide rightSide) basisElements+    then Right ()+    else Left (LawViolation law)++lawHoldsWith ::+  (Eq coefficient, Ord targetBasis) =>+  LinearCombinationArithmetic coefficient ->+  (sourceBasis -> LinearCombination coefficient targetBasis) ->+  (sourceBasis -> LinearCombination coefficient targetBasis) ->+  sourceBasis ->+  Bool+lawHoldsWith arithmetic leftSide rightSide basisValue =+  normalizeWith arithmetic (leftSide basisValue)+    == normalizeWith arithmetic (rightSide basisValue)++negateTermWith ::+  LinearCombinationArithmetic coefficient ->+  (coefficient, basis) ->+  (coefficient, basis)+negateTermWith arithmetic (coefficientValue, basisValue) =+  (lcaNegate arithmetic coefficientValue, basisValue)
+ src-chain/Moonlight/Homology/Pure/Phase.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}++module Moonlight.Homology.Pure.Phase+  ( HomologyPhase (..),+    RequirePhase2,+    RequirePhase4,+    requirePhase2Witness,+    requirePhase4Witness,+  )+where++import Data.Kind (Constraint, Type)+import GHC.TypeLits (ErrorMessage (..), TypeError)++type HomologyPhase :: Type+data HomologyPhase+  = Phase1+  | Phase2+  | Phase4++type RequirePhase2 :: HomologyPhase -> Constraint+class RequirePhase2 (phase :: HomologyPhase) where+  requirePhase2Witness :: ()++instance RequirePhase2 'Phase2 where+  requirePhase2Witness = ()++instance RequirePhase2 'Phase4 where+  requirePhase2Witness = ()++instance+  TypeError+    ( 'Text "Moonlight.Homology phase gate violation."+        ':$$: 'Text "Phase 1 can expose interfaces and boundary materialization only."+        ':$$: 'Text "Betti reduction and Smith Normal Form require Phase 2 or later."+    ) =>+  RequirePhase2 'Phase1+  where+  requirePhase2Witness = ()++type RequirePhase4 :: HomologyPhase -> Constraint+class RequirePhase4 (phase :: HomologyPhase) where+  requirePhase4Witness :: ()++instance RequirePhase4 'Phase4 where+  requirePhase4Witness = ()++instance+  TypeError+    ( 'Text "Moonlight.Homology phase gate violation."+        ':$$: 'Text "Spectral sequence page advancement is Phase 4 infrastructure."+        ':$$: 'Text "Requested phase: Phase1"+    ) =>+  RequirePhase4 'Phase1+  where+  requirePhase4Witness = ()++instance+  TypeError+    ( 'Text "Moonlight.Homology phase gate violation."+        ':$$: 'Text "Spectral sequence page advancement is Phase 4 infrastructure."+        ':$$: 'Text "Requested phase: Phase2"+    ) =>+  RequirePhase4 'Phase2+  where+  requirePhase4Witness = ()
+ src-chain/Moonlight/Homology/Pure/Reductions.hs view
@@ -0,0 +1,17 @@+module Moonlight.Homology.Pure.Reductions+  ( ChainMap (..),+    ChainHomotopy (..),+    Reduction (..),+    ReductionWitness,+    checkedReduction,+    ReductionLawContext (..),+    ReductionViolation (..),+    Validation (..),+    ReductionValidation,+    ReductionChecks (..),+    mkReductionWitness,+  )+where++import Moonlight.Core (Validation (..))+import Moonlight.Homology.Pure.Reductions.Core as X
+ src-chain/Moonlight/Homology/Pure/Reductions/Core.hs view
@@ -0,0 +1,97 @@+module Moonlight.Homology.Pure.Reductions.Core+  ( ChainMap (..),+    ChainHomotopy (..),+    Reduction (..),+    ReductionWitness (..),+    ReductionViolation (..),+    ReductionLawContext (..),+    ReductionValidation,+    ReductionChecks (..),+    mkReductionWitness,+  )+where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Moonlight.Core (Validation (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure)++type ChainMap :: Type -> Type -> Type -> Type+newtype ChainMap source target r = ChainMap+  { runChainMap :: source -> [(r, target)]+  }++type ChainHomotopy :: Type -> Type -> Type+newtype ChainHomotopy basis r = ChainHomotopy+  { runChainHomotopy :: basis -> [(r, basis)]+  }++type Reduction :: Type -> Type -> Type -> Type -> Type -> Type+data Reduction large small r largeBasis smallBasis = Reduction+  { projection :: ChainMap largeBasis smallBasis r,+    inclusion :: ChainMap smallBasis largeBasis r,+    homotopy :: ChainHomotopy largeBasis r+  }++type ReductionViolation :: Type+data ReductionViolation+  = ProjectionInclusionIdentityViolation HomologyFailure+  | InclusionProjectionHomotopyViolation HomologyFailure+  | ProjectionChainMapViolation HomologyFailure+  | InclusionChainMapViolation HomologyFailure+  deriving stock (Eq, Show)++type ReductionLawContext :: Type -> Type -> Type -> Type+data ReductionLawContext largeBasis smallBasis r = ReductionLawContext+  { sampledLargeBasis :: [largeBasis],+    sampledSmallBasis :: [smallBasis],+    largeBoundary :: largeBasis -> [(r, largeBasis)],+    smallBoundary :: smallBasis -> [(r, smallBasis)]+  }++type ReductionValidation :: Type -> Type+type ReductionValidation a = Validation (NonEmpty ReductionViolation) a++type ReductionChecks :: Type -> Type -> Type -> Type+data ReductionChecks largeBasis smallBasis r = ReductionChecks+  { checkProjectionInclusionIdentity ::+      ChainMap largeBasis smallBasis r ->+      ChainMap smallBasis largeBasis r ->+      Either ReductionViolation (),+    checkInclusionProjectionHomotopy ::+      ChainMap largeBasis smallBasis r ->+      ChainMap smallBasis largeBasis r ->+      ChainHomotopy largeBasis r ->+      Either ReductionViolation (),+    checkProjectionChainMap ::+      ChainMap largeBasis smallBasis r ->+      Either ReductionViolation (),+    checkInclusionChainMap ::+      ChainMap smallBasis largeBasis r ->+      Either ReductionViolation ()+  }++type ReductionWitness :: Type -> Type -> Type -> Type -> Type -> Type+newtype ReductionWitness large small r largeBasis smallBasis = ReductionWitness+  { checkedReduction :: Reduction large small r largeBasis smallBasis+  }++mkReductionWitness ::+  Reduction large small r largeBasis smallBasis ->+  ReductionChecks largeBasis smallBasis r ->+  ReductionValidation (ReductionWitness large small r largeBasis smallBasis)+mkReductionWitness reduction checks =+  (\_ _ _ _ -> ReductionWitness reduction)+    <$> validate (checkProjectionInclusionIdentity checks projectionMap inclusionMap)+    <*> validate (checkInclusionProjectionHomotopy checks projectionMap inclusionMap homotopyMap)+    <*> validate (checkProjectionChainMap checks projectionMap)+    <*> validate (checkInclusionChainMap checks inclusionMap)+  where+    projectionMap = projection reduction+    inclusionMap = inclusion reduction+    homotopyMap = homotopy reduction+    validate :: Either ReductionViolation () -> ReductionValidation ()+    validate checkResult =+      case checkResult of+        Left violation -> Invalid (violation :| [])+        Right () -> Valid ()
+ src-chain/Moonlight/Homology/Pure/Skeleton.hs view
@@ -0,0 +1,31 @@+module Moonlight.Homology.Pure.Skeleton+  ( SkeletonSignature (..),+    skeletonSignatureWithinTolerance,+  )+where++import Data.Function ((&))+import Data.Kind (Type)+import Data.Map.Strict qualified as Map+import Moonlight.Homology.Pure.Filtration (CriticalKind)++type SkeletonSignature :: Type+data SkeletonSignature = SkeletonSignature+  { signatureCriticalCounts :: Map.Map CriticalKind Int,+    signatureArcCount :: Int+  }+  deriving stock (Eq, Show, Read)++skeletonSignatureWithinTolerance :: Int -> SkeletonSignature -> SkeletonSignature -> Bool+skeletonSignatureWithinTolerance toleranceValue targetSignature observedSignature =+  let criticalKinds = [minBound .. maxBound] :: [CriticalKind]+      criticalMatches =+        criticalKinds+          & all+            ( \criticalKindValue ->+                let observedCount = Map.findWithDefault 0 criticalKindValue (signatureCriticalCounts observedSignature)+                    targetCount = Map.findWithDefault 0 criticalKindValue (signatureCriticalCounts targetSignature)+                 in abs (observedCount - targetCount) <= toleranceValue+            )+      arcMatch = abs (signatureArcCount observedSignature - signatureArcCount targetSignature) <= toleranceValue+   in criticalMatches && arcMatch
+ src-laws/Moonlight/Homology/Effect/Determinism.hs view
@@ -0,0 +1,85 @@+module Moonlight.Homology.Effect.Determinism+  ( DeterminismFingerprint (..),+    fingerprintBasis,+    fingerprintBoundaryIncidence,+    fingerprintReductionImage,+    fingerprintFiniteChainComplex,+    verifyDeterministicFingerprints,+  )+where++import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.Function ((&))+import Data.Kind (Type)+import Data.List (sort, sortOn)+import Moonlight.Core (StableHashDigest, stableHashByteStrings)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+    maxHomologicalDegree,+  )+import Moonlight.Homology.Boundary.LinAlg (BoundaryEntry, boundaryCoefficient, sourceIndex, targetIndex, BoundaryIncidence, boundaryEntries, sourceCardinality, targetCardinality)+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw (..))++type DeterminismFingerprint :: Type+newtype DeterminismFingerprint = DeterminismFingerprint+  { unFingerprint :: StableHashDigest+  }+  deriving stock (Eq, Show)++fingerprintTokens :: [String] -> DeterminismFingerprint+fingerprintTokens =+  DeterminismFingerprint . stableHashByteStrings . fmap ByteString.Char8.pack++fingerprintBasis :: Show basis => [basis] -> DeterminismFingerprint+fingerprintBasis values =+  values+    & fmap show+    & sort+    & fingerprintTokens++canonicalEntryToken :: Show r => BoundaryEntry r -> String+canonicalEntryToken entry =+  show (sourceIndex entry, targetIndex entry, boundaryCoefficient entry)++fingerprintBoundaryIncidence :: Show r => BoundaryIncidence r -> DeterminismFingerprint+fingerprintBoundaryIncidence incidence =+  let headerToken = show (sourceCardinality incidence, targetCardinality incidence)+      entryTokens =+        boundaryEntries incidence+          & sortOn (\entry -> (sourceIndex entry, targetIndex entry, show (boundaryCoefficient entry)))+          & fmap canonicalEntryToken+   in fingerprintTokens (headerToken : entryTokens)++fingerprintReductionImage :: (Show r, Show basis) => [(r, basis)] -> DeterminismFingerprint+fingerprintReductionImage terms =+  terms+    & fmap (\(coefficientValue, basisValue) -> (show basisValue, show coefficientValue))+    & sortOn id+    & fmap (\(basisToken, coefficientToken) -> basisToken <> ":" <> coefficientToken)+    & fingerprintTokens++fingerprintFiniteChainComplex :: Show r => FiniteChainComplex r -> DeterminismFingerprint+fingerprintFiniteChainComplex chainComplex =+  let HomologicalDegree maxDegree = maxHomologicalDegree chainComplex+      dimensionTokens =+        [0 .. maxDegree]+          & fmap+            ( \dimensionValue ->+                let boundaryFingerprint =+                      incidenceMatrixAt chainComplex (HomologicalDegree dimensionValue)+                        & fingerprintBoundaryIncidence+                        & unFingerprint+                 in show (dimensionValue, boundaryFingerprint)+            )+   in fingerprintTokens dimensionTokens++verifyDeterministicFingerprints :: [DeterminismFingerprint] -> Either HomologyFailure DeterminismFingerprint+verifyDeterministicFingerprints fingerprints =+  case fingerprints of+    [] -> Left (LawViolation DeterminismLaw)+    expectedFingerprint : remainder ->+      if all (== expectedFingerprint) remainder+        then Right expectedFingerprint+        else Left (LawViolation DeterminismLaw)
+ src-laws/Moonlight/Homology/Effect/Laws.hs view
@@ -0,0 +1,230 @@+module Moonlight.Homology.Effect.Laws+  ( BlockSchurHomologyAgreement (..),+    BlockSchurHomologyAgreementFailure (..),+    checkBlockSchurHomologyAgreement,+    checkBoundaryNilpotence,+    checkReductionLeftInverse,+    checkReductionHomotopy,+    checkReductionProjectionChainMap,+    checkReductionInclusionChainMap,+    mkReductionChecksFromSamples,+    normalizeCombination,+  )+where++import Data.Bifunctor (first)+import Data.Function ((&))+import Data.Kind (Type)+import Moonlight.Core (Ring)+import Moonlight.Homology.Pure.Backend+  ( HomologyBackend,+    HomologyBackendTag,+    homologyBackendTag,+    runHomologyBackend,+  )+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw (..))+import Moonlight.Homology.Pure.Group (HomologyGroup)+import Moonlight.Homology.Pure.LinearCombination qualified as LC+import Moonlight.Homology.Pure.Reductions+  ( ChainHomotopy (..),+    ChainMap (..),+    Reduction (..),+    ReductionChecks (..),+    ReductionLawContext (..),+    ReductionViolation (..),+  )+import Moonlight.Homology.Pure.Topology.BlockSchur+  ( BlockSchurReduction (..),+  )++type BlockSchurHomologyAgreement :: Type -> Type+data BlockSchurHomologyAgreement groupCoefficient = BlockSchurHomologyAgreement+  { bshaBackend :: !HomologyBackendTag,+    bshaGroupsByDegree :: ![(Int, HomologyGroup groupCoefficient)]+  }+  deriving stock (Eq, Show)++type BlockSchurHomologyAgreementFailure :: Type -> Type+data BlockSchurHomologyAgreementFailure groupCoefficient+  = BlockSchurOriginalBackendFailed !HomologyBackendTag !HomologyFailure+  | BlockSchurReducedBackendFailed !HomologyBackendTag !HomologyFailure+  | BlockSchurHomologyMismatch+      !HomologyBackendTag+      ![(Int, HomologyGroup groupCoefficient)]+      ![(Int, HomologyGroup groupCoefficient)]+  deriving stock (Eq, Show)++checkBlockSchurHomologyAgreement ::+  Eq groupCoefficient =>+  HomologyBackend coefficient groupCoefficient ->+  BlockSchurReduction coefficient ->+  Either (BlockSchurHomologyAgreementFailure groupCoefficient) (BlockSchurHomologyAgreement groupCoefficient)+checkBlockSchurHomologyAgreement backend reduction = do+  let backendTag = homologyBackendTag backend+  originalGroups <-+    first (BlockSchurOriginalBackendFailed backendTag) $+      homologyGroupsByDegree <$> runHomologyBackend backend (bsrOriginalComplex reduction)+  reducedGroups <-+    first (BlockSchurReducedBackendFailed backendTag) $+      homologyGroupsByDegree <$> runHomologyBackend backend (bsrReducedComplex reduction)+  if originalGroups == reducedGroups+    then+      Right+        BlockSchurHomologyAgreement+          { bshaBackend = backendTag,+            bshaGroupsByDegree = originalGroups+          }+    else Left (BlockSchurHomologyMismatch backendTag originalGroups reducedGroups)++normalizeCombination :: (Eq r, Ring r, Ord basis) => [(r, basis)] -> [(r, basis)]+normalizeCombination =+  LC.normalizeWith LC.ringArithmetic++composeCombination ::+  (Eq r, Ring r, Ord targetBasis) =>+  (sourceBasis -> [(r, targetBasis)]) ->+  [(r, sourceBasis)] ->+  [(r, targetBasis)]+composeCombination mapping combination =+  LC.composeWith LC.ringArithmetic mapping combination++checkBoundaryNilpotence ::+  (Eq r, Ring r, Ord basis) =>+  (basis -> [(r, basis)]) ->+  [basis] ->+  Either HomologyFailure ()+checkBoundaryNilpotence boundaryOf basisElements =+  LC.checkLawWith+    LC.ringArithmetic+    ChainNilpotenceLaw+    basisElements+    (const [])+    (composeCombination boundaryOf . boundaryOf)++checkReductionLeftInverse ::+  (Eq r, Ring r, Ord smallBasis) =>+  Reduction large small r largeBasis smallBasis ->+  [smallBasis] ->+  Either HomologyFailure ()+checkReductionLeftInverse reduction smallBasisElements =+  LC.checkLawWith+    LC.ringArithmetic+    ReductionLeftInverseLaw+    smallBasisElements+    (LC.identityWith LC.ringArithmetic)+    ( \smallBasisValue ->+        runChainMap (inclusion reduction) smallBasisValue+          & composeCombination (runChainMap (projection reduction))+    )++checkReductionHomotopy ::+  (Eq r, Ring r, Ord largeBasis) =>+  (largeBasis -> [(r, largeBasis)]) ->+  Reduction large small r largeBasis smallBasis ->+  [largeBasis] ->+  Either HomologyFailure ()+checkReductionHomotopy boundaryOf reduction largeBasisElements =+  LC.checkLawWith+    LC.ringArithmetic+    ReductionHomotopyLaw+    largeBasisElements+    ( \largeBasisValue ->+        LC.subtractWith+          LC.ringArithmetic+          (LC.identityWith LC.ringArithmetic largeBasisValue)+          ( runChainMap (projection reduction) largeBasisValue+              & composeCombination (runChainMap (inclusion reduction))+          )+    )+    ( \largeBasisValue ->+        LC.addWith+          LC.ringArithmetic+          (runChainHomotopy (homotopy reduction) largeBasisValue & composeCombination boundaryOf)+          (boundaryOf largeBasisValue & composeCombination (runChainHomotopy (homotopy reduction)))+    )++checkReductionProjectionChainMap ::+  (Eq r, Ring r, Ord smallBasis) =>+  (largeBasis -> [(r, largeBasis)]) ->+  (smallBasis -> [(r, smallBasis)]) ->+  Reduction large small r largeBasis smallBasis ->+  [largeBasis] ->+  Either HomologyFailure ()+checkReductionProjectionChainMap largeBoundaryOf smallBoundaryOf reduction largeBasisElements =+  LC.checkLawWith+    LC.ringArithmetic+    ReductionProjectionChainMapLaw+    largeBasisElements+    ( \largeBasisValue ->+        runChainMap (projection reduction) largeBasisValue+          & composeCombination smallBoundaryOf+    )+    ( \largeBasisValue ->+        largeBoundaryOf largeBasisValue+          & composeCombination (runChainMap (projection reduction))+    )++checkReductionInclusionChainMap ::+  (Eq r, Ring r, Ord largeBasis) =>+  (largeBasis -> [(r, largeBasis)]) ->+  (smallBasis -> [(r, smallBasis)]) ->+  Reduction large small r largeBasis smallBasis ->+  [smallBasis] ->+  Either HomologyFailure ()+checkReductionInclusionChainMap largeBoundaryOf smallBoundaryOf reduction smallBasisElements =+  LC.checkLawWith+    LC.ringArithmetic+    ReductionInclusionChainMapLaw+    smallBasisElements+    ( \smallBasisValue ->+        runChainMap (inclusion reduction) smallBasisValue+          & composeCombination largeBoundaryOf+    )+    ( \smallBasisValue ->+        smallBoundaryOf smallBasisValue+          & composeCombination (runChainMap (inclusion reduction))+    )++mkReductionChecksFromSamples ::+  (Eq r, Ring r, Ord largeBasis, Ord smallBasis) =>+  ReductionLawContext largeBasis smallBasis r ->+  ReductionChecks largeBasis smallBasis r+mkReductionChecksFromSamples lawContext =+  ReductionChecks+    { checkProjectionInclusionIdentity = \projectionMap inclusionMap ->+        Reduction+          { projection = projectionMap,+            inclusion = inclusionMap,+            homotopy = ChainHomotopy (const [])+          }+          & (\reduction -> checkReductionLeftInverse reduction (sampledSmallBasis lawContext))+          & first ProjectionInclusionIdentityViolation,+      checkInclusionProjectionHomotopy = \projectionMap inclusionMap homotopyMap ->+        Reduction+          { projection = projectionMap,+            inclusion = inclusionMap,+            homotopy = homotopyMap+          }+          & (\reduction -> checkReductionHomotopy (largeBoundary lawContext) reduction (sampledLargeBasis lawContext))+          & first InclusionProjectionHomotopyViolation,+      checkProjectionChainMap = \projectionMap ->+        Reduction+          { projection = projectionMap,+            inclusion = ChainMap (const []),+            homotopy = ChainHomotopy (const [])+          }+          & (\reduction -> checkReductionProjectionChainMap (largeBoundary lawContext) (smallBoundary lawContext) reduction (sampledLargeBasis lawContext))+          & first ProjectionChainMapViolation,+      checkInclusionChainMap = \inclusionMap ->+        Reduction+          { projection = ChainMap (const []),+            inclusion = inclusionMap,+            homotopy = ChainHomotopy (const [])+          }+          & (\reduction -> checkReductionInclusionChainMap (largeBoundary lawContext) (smallBoundary lawContext) reduction (sampledSmallBasis lawContext))+          & first InclusionChainMapViolation+    }++homologyGroupsByDegree :: [HomologyGroup groupCoefficient] -> [(Int, HomologyGroup groupCoefficient)]+homologyGroupsByDegree =+  zip [0 ..]
+ src-matrix/Moonlight/Homology/Boundary/Finite.hs view
@@ -0,0 +1,229 @@+module Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    mkFiniteChainComplex,+    mkFiniteChainComplexChecked,+    maxHomologicalDegree,+    incidenceMatrixAt,+    degreeCardinality,+    basisCellNodeId,+    finiteChainBasisRefsAtDegree,+    basisIndexCellMapAtDegree,+    inverseBasisRefMap,+    validateFiniteChainComplexShape,+    restrictComplex,+  )+where++import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.Kind (Type)+import Data.Maybe (mapMaybe)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Moonlight.Core (Semiring)+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryIncidence,+    boundaryCoefficient,+    boundaryEntries,+    composeBoundaryIncidence,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    materializeIncidenceBoundary,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..), decrementDegree)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))++type FiniteChainComplex :: Type -> Type+data FiniteChainComplex r = FiniteChainComplex+  { maxDimension :: Int,+    incidenceMatrix :: Int -> BoundaryIncidence r+  }++mkFiniteChainComplex :: HomologicalDegree -> (HomologicalDegree -> BoundaryIncidence r) -> FiniteChainComplex r+mkFiniteChainComplex (HomologicalDegree maxDimensionValue) incidenceLookup =+  FiniteChainComplex+    { maxDimension = maxDimensionValue,+      incidenceMatrix = incidenceLookup . HomologicalDegree+    }++mkFiniteChainComplexChecked ::+  (Eq r, Num r, Semiring r) =>+  HomologicalDegree ->+  (HomologicalDegree -> BoundaryIncidence r) ->+  Either HomologyFailure (FiniteChainComplex r)+mkFiniteChainComplexChecked maxDegree incidenceLookup = do+  let finite = mkFiniteChainComplex maxDegree incidenceLookup+  validateFiniteChainComplexShape finite+  traverse_ (adjacentNilpotenceAt finite) [0 .. maxDimension finite - 1]+  pure finite++adjacentNilpotenceAt ::+  (Eq r, Num r, Semiring r) =>+  FiniteChainComplex r ->+  Int ->+  Either HomologyFailure ()+adjacentNilpotenceAt finite degreeIndex =+  composeBoundaryIncidence+    (incidenceMatrixAt finite (HomologicalDegree degreeIndex))+    (incidenceMatrixAt finite (HomologicalDegree (degreeIndex + 1)))+    & either+      (Left . InvalidBoundaryIncidence . show)+      ( \composed ->+          if null (boundaryEntries composed)+            then Right ()+            else Left (ChainComplexNilpotenceViolation degreeIndex)+      )++maxHomologicalDegree :: FiniteChainComplex r -> HomologicalDegree+maxHomologicalDegree =+  HomologicalDegree . maxDimension++incidenceMatrixAt :: FiniteChainComplex r -> HomologicalDegree -> BoundaryIncidence r+incidenceMatrixAt finite =+  incidenceMatrix finite . unHomologicalDegree++degreeCardinality :: FiniteChainComplex r -> HomologicalDegree -> Int+degreeCardinality finite degreeValue@(HomologicalDegree degreeIndex) =+  case maxHomologicalDegree finite of+    HomologicalDegree maxDegreeValue+      | degreeIndex < 0 -> 0+      | degreeIndex > maxDegreeValue -> 0+      | otherwise -> sourceCardinality (incidenceMatrixAt finite degreeValue)++basisCellNodeId :: FiniteChainComplex r -> BasisCellRef -> Int+basisCellNodeId finite basisCellRef =+  case cellDegree basisCellRef of+    HomologicalDegree degreeValue ->+      sum+        (fmap (degreeCardinality finite . HomologicalDegree) [0 .. degreeValue - 1])+        + cellIndex basisCellRef++finiteChainBasisRefsAtDegree :: FiniteChainComplex r -> HomologicalDegree -> [BasisCellRef]+finiteChainBasisRefsAtDegree finite degreeValue =+  fmap+    (\cellIndexValue -> BasisCellRef {cellDegree = degreeValue, cellIndex = cellIndexValue})+    [0 .. degreeCardinality finite degreeValue - 1]++basisIndexCellMapAtDegree ::+  HomologicalDegree ->+  Map.Map cell BasisCellRef ->+  Map.Map Int cell+basisIndexCellMapAtDegree degreeValue =+  Map.foldrWithKey+    ( \cellValue basisCellRef ->+        if cellDegree basisCellRef == degreeValue+          then Map.insert (cellIndex basisCellRef) cellValue+          else id+    )+    Map.empty++inverseBasisRefMap :: Map.Map cell BasisCellRef -> Map.Map BasisCellRef cell+inverseBasisRefMap =+  Map.fromList . fmap (\(cellValue, basisRef) -> (basisRef, cellValue)) . Map.toList++validateFiniteChainComplexShape :: FiniteChainComplex r -> Either HomologyFailure ()+validateFiniteChainComplexShape finite =+  dimensionsOf finite+    & mapMaybe (shapeViolation finite)+    & safeHead+    & maybe (Right ()) Left++dimensionsOf :: FiniteChainComplex r -> [HomologicalDegree]+dimensionsOf finite =+  fmap HomologicalDegree [0 .. maxDimension finite]++shapeViolation :: FiniteChainComplex r -> HomologicalDegree -> Maybe HomologyFailure+shapeViolation finite degreeValue@(HomologicalDegree degreeIndex) =+  let incidence = incidenceMatrixAt finite degreeValue+      expectedTarget =+        if degreeIndex <= 0+          then 0+          else sourceCardinality (incidenceMatrixAt finite (decrementDegree degreeValue))+   in if targetCardinality incidence == expectedTarget+        then Nothing+        else Just (ChainComplexShapeMismatch degreeIndex expectedTarget (targetCardinality incidence))++-- | Restrict a complex to the given active cells. Every retained degree is+-- materialized exactly once up front (the previous incarnation re-ran a full+-- entry-list scan per source cell on every incidence access), and any+-- materialization failure propagates as a 'Left' instead of being collapsed+-- into a silently empty boundary matrix.+restrictComplex :: Set BasisCellRef -> FiniteChainComplex Int -> Either HomologyFailure (FiniteChainComplex Int)+restrictComplex activeCells finiteComplex = do+  let retainedByDegree = groupByDegree (Set.toAscList activeCells)+      maxDimensionValue = maximum (0 : Map.keys retainedByDegree)+  restrictedBoundaries <-+    traverse+      (restrictedBoundaryAt activeCells retainedByDegree finiteComplex)+      [0 .. maxDimensionValue]+  let boundaryByDegree = Map.fromList (zip [0 .. maxDimensionValue] restrictedBoundaries)+  mkFiniteChainComplexChecked+    (HomologicalDegree maxDimensionValue)+    ( \(HomologicalDegree degreeValue) ->+        Map.findWithDefault emptyBoundaryIncidence degreeValue boundaryByDegree+    )++restrictedBoundaryAt ::+  Set BasisCellRef ->+  Map.Map Int [BasisCellRef] ->+  FiniteChainComplex Int ->+  Int ->+  Either HomologyFailure (BoundaryIncidence Int)+restrictedBoundaryAt activeCells retainedByDegree finiteComplex dimensionValue+  | dimensionValue <= 0 =+      Right+        ( emptyBoundaryIncidenceOf+            (fromIntegral (length (Map.findWithDefault [] 0 retainedByDegree)))+            0+        )+  | otherwise =+      let incidence = incidenceMatrixAt finiteComplex (HomologicalDegree dimensionValue)+          entriesBySource =+            foldl'+              ( \accumulator entryValue ->+                  Map.insertWith (<>) (sourceIndex entryValue) [entryValue] accumulator+              )+              Map.empty+              (boundaryEntries incidence)+          restrictedEntriesOf sourceCell =+            Map.findWithDefault [] (cellIndex sourceCell) entriesBySource+              & mapMaybe+                ( \entryValue ->+                    let targetCell =+                          BasisCellRef+                            { cellDegree = HomologicalDegree (dimensionValue - 1),+                              cellIndex = targetIndex entryValue+                            }+                     in if Set.member targetCell activeCells+                          then Just (boundaryCoefficient entryValue, targetCell)+                          else Nothing+                )+       in materializeIncidenceBoundary+            restrictedEntriesOf+            (Map.findWithDefault [] dimensionValue retainedByDegree)+            (Map.findWithDefault [] (dimensionValue - 1) retainedByDegree)++groupByDegree :: [BasisCellRef] -> Map.Map Int [BasisCellRef]+groupByDegree cellRefs =+  -- Strict left fold with O(1) prepends, then one reversal per bucket:+  -- preserves the ascending order 'Set.toAscList' delivers without either a+  -- foldr thunk spine or quadratic list appends.+  Map.map+    reverse+    ( foldl'+        (\accumulator cellRef -> Map.insertWith (<>) (unHomologicalDegree (cellDegree cellRef)) [cellRef] accumulator)+        Map.empty+        cellRefs+    )++safeHead :: [a] -> Maybe a+safeHead values =+  case values of+    firstValue : _ -> Just firstValue+    [] -> Nothing
+ src-matrix/Moonlight/Homology/Boundary/LinAlg.hs view
@@ -0,0 +1,664 @@+module Moonlight.Homology.Boundary.LinAlg+  ( BoundaryScope (..),+    ScopedBoundary (..),+    BoundaryIncidenceShapeError (..),+    BoundaryEntry,+    sourceIndex,+    targetIndex,+    boundaryCoefficient,+    mkBoundaryEntry,+    mkBoundaryEntryFromInts,+    BoundaryIncidence,+    sourceCardinality,+    targetCardinality,+    boundaryEntries,+    mkBoundaryIncidence,+    mkBoundaryIncidenceFromOrderedEntries,+    overlapBoundaryIncidence,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    identityBoundaryIncidenceOf,+    directSumBoundaryIncidence,+    reindexBoundaryIncidenceWith,+    boundaryIncidenceApply,+    transposeBoundaryIncidence,+    composeBoundaryIncidence,+    boundaryIncidenceDiagonal,+    addBoundaryIncidence,+    mapBoundaryCoefficients,+    BlockBoundaryEntry,+    blockSourceIndex,+    blockTargetIndex,+    blockSubmatrix,+    mkBlockBoundaryEntry,+    BlockBoundaryIncidence,+    blockSourceDimensions,+    blockTargetDimensions,+    blockEntries,+    mkBlockBoundaryIncidence,+    flattenBlockIncidence,+    scaleBoundaryIncidence,+    materializeIncidenceBoundary,+    materializeBoundary,+  )+where++import Data.Function ((&))+import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import Data.Maybe (listToMaybe, mapMaybe)+import Moonlight.Core (AdditiveMonoid (..), Semiring)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw (..))+import Numeric.Natural (Natural)+import Moonlight.Pale.Diagnostic.Topology.Boundary (BoundaryIncidenceShapeError (..))++type BoundaryScope :: Type+data BoundaryScope+  = IncidenceScope+  | PortalScope+  deriving stock (Eq, Ord, Show)++type ScopedBoundary :: Type -> Type+data ScopedBoundary boundary = ScopedBoundary+  { boundaryScope :: BoundaryScope,+    boundaryValue :: boundary+  }+  deriving stock (Eq, Ord, Show)++type BoundaryEntry :: Type -> Type+data BoundaryEntry r = BoundaryEntry+  { sourceIndex :: Int,+    targetIndex :: Int,+    boundaryCoefficient :: r+  }+  deriving stock (Eq, Show)++mkBoundaryEntry :: Natural -> Natural -> r -> BoundaryEntry r+mkBoundaryEntry sourceIndexValue targetIndexValue coefficientValue =+  BoundaryEntry+    { sourceIndex = fromIntegral sourceIndexValue,+      targetIndex = fromIntegral targetIndexValue,+      boundaryCoefficient = coefficientValue+    }++mkBoundaryEntryFromInts :: Int -> Int -> r -> BoundaryEntry r+mkBoundaryEntryFromInts sourceIndexValue targetIndexValue coefficientValue =+  BoundaryEntry+    { sourceIndex = sourceIndexValue,+      targetIndex = targetIndexValue,+      boundaryCoefficient = coefficientValue+    }++type BoundaryIncidence :: Type -> Type+data BoundaryIncidence r = BoundaryIncidence+  { sourceCardinality :: Int,+    targetCardinality :: Int,+    boundaryEntries :: [BoundaryEntry r]+  }+  deriving stock (Eq, Show)++mkBoundaryIncidence :: (Eq r, Semiring r) => Natural -> Natural -> [BoundaryEntry r] -> Either BoundaryIncidenceShapeError (BoundaryIncidence r)+mkBoundaryIncidence sourceCardinalityValue targetCardinalityValue entries =+  let sourceDimension = fromIntegral sourceCardinalityValue+      targetDimension = fromIntegral targetCardinalityValue+   in case firstOutOfBoundsEntry sourceDimension targetDimension entries of+        Just entryValue -> Left (entryOutOfBoundsError sourceDimension targetDimension entryValue)+        Nothing -> Right (uncheckedBoundaryIncidence sourceDimension targetDimension (canonicalizeEntries entries))++-- | Canonicalize already ordered sparse entries without constructing a map.+-- If the entries are not ordered by @(sourceIndex, targetIndex)@, this falls+-- back to the fully general constructor, preserving the exact semantics of+-- 'mkBoundaryIncidence' while giving inspected/preallocated callers a linear+-- hot path.+mkBoundaryIncidenceFromOrderedEntries :: (Eq r, Semiring r) => Natural -> Natural -> [BoundaryEntry r] -> Either BoundaryIncidenceShapeError (BoundaryIncidence r)+mkBoundaryIncidenceFromOrderedEntries sourceCardinalityValue targetCardinalityValue entries =+  let sourceDimension = fromIntegral sourceCardinalityValue+      targetDimension = fromIntegral targetCardinalityValue+   in case firstOutOfBoundsEntry sourceDimension targetDimension entries of+        Just entryValue -> Left (entryOutOfBoundsError sourceDimension targetDimension entryValue)+        Nothing ->+          case canonicalizeOrderedEntries entries of+            Nothing ->+              mkBoundaryIncidence sourceCardinalityValue targetCardinalityValue entries+            Just canonicalEntries ->+              Right (uncheckedBoundaryIncidence sourceDimension targetDimension canonicalEntries)++overlapBoundaryIncidence :: (Ord atom, Eq r, Semiring r) => r -> [atom] -> [atom] -> BoundaryIncidence r+overlapBoundaryIncidence coefficient sourceBasis targetBasis =+  uncheckedBoundaryIncidence (length sourceBasis) (length targetBasis)+    . canonicalizeEntries+    . Map.elems+    $ Map.intersectionWith+      (\sourceIdx targetIdx -> mkBoundaryEntry sourceIdx targetIdx coefficient)+      (basisIndex sourceBasis)+      (basisIndex targetBasis)++basisIndex :: Ord atom => [atom] -> Map.Map atom Natural+basisIndex =+  Map.fromList . flip zip [0 ..]++canonicalizeEntries :: (Eq r, Semiring r) => [BoundaryEntry r] -> [BoundaryEntry r]+canonicalizeEntries entries =+  entries+    & fmap (\entry -> ((sourceIndex entry, targetIndex entry), boundaryCoefficient entry))+    & Map.fromListWith add+    & Map.toAscList+    & mapMaybe+      ( \((sourceValue, targetValue), coefficientValue) ->+          if coefficientValue == zero+            then Nothing+            else+              Just+                ( mkBoundaryEntry+                    (fromIntegral sourceValue)+                    (fromIntegral targetValue)+                    coefficientValue+                )+      )++data OrderedCanonicalization r+  = OrderedEntriesOutOfOrder+  | OrderedCanonicalization !(Maybe (BoundaryEntry r)) ![BoundaryEntry r]++canonicalizeOrderedEntries :: (Eq r, Semiring r) => [BoundaryEntry r] -> Maybe [BoundaryEntry r]+canonicalizeOrderedEntries entries =+  finalizeOrderedCanonicalization+    ( foldl'+        appendOrderedEntry+        (OrderedCanonicalization Nothing [])+        entries+    )++appendOrderedEntry :: (Eq r, Semiring r) => OrderedCanonicalization r -> BoundaryEntry r -> OrderedCanonicalization r+appendOrderedEntry OrderedEntriesOutOfOrder _ =+  OrderedEntriesOutOfOrder+appendOrderedEntry (OrderedCanonicalization Nothing reversedCanonicalEntries) entry =+  OrderedCanonicalization (Just entry) reversedCanonicalEntries+appendOrderedEntry (OrderedCanonicalization (Just pendingEntry) reversedCanonicalEntries) entry =+  case compareBoundaryEntryCoordinate pendingEntry entry of+    GT ->+      OrderedEntriesOutOfOrder+    EQ ->+      -- Force the summed coefficient: a run of equal-coordinate entries on+      -- this advertised linear hot path must not chain 'add' thunks.+      let !summedCoefficient =+            add+              (boundaryCoefficient pendingEntry)+              (boundaryCoefficient entry)+       in OrderedCanonicalization+            (Just (pendingEntry {boundaryCoefficient = summedCoefficient}))+            reversedCanonicalEntries+    LT ->+      OrderedCanonicalization+        (Just entry)+        (prependNonZeroBoundaryEntry pendingEntry reversedCanonicalEntries)++finalizeOrderedCanonicalization :: (Eq r, Semiring r) => OrderedCanonicalization r -> Maybe [BoundaryEntry r]+finalizeOrderedCanonicalization OrderedEntriesOutOfOrder =+  Nothing+finalizeOrderedCanonicalization (OrderedCanonicalization pendingEntry reversedCanonicalEntries) =+  Just+    ( reverse+        ( maybe+            reversedCanonicalEntries+            (`prependNonZeroBoundaryEntry` reversedCanonicalEntries)+            pendingEntry+        )+    )++prependNonZeroBoundaryEntry :: (Eq r, Semiring r) => BoundaryEntry r -> [BoundaryEntry r] -> [BoundaryEntry r]+prependNonZeroBoundaryEntry entry entries =+  if boundaryCoefficient entry == zero+    then entries+    else entry : entries++compareBoundaryEntryCoordinate :: BoundaryEntry r -> BoundaryEntry r -> Ordering+compareBoundaryEntryCoordinate left right =+  compare+    (sourceIndex left, targetIndex left)+    (sourceIndex right, targetIndex right)+++emptyBoundaryIncidence :: BoundaryIncidence r+emptyBoundaryIncidence =+  uncheckedBoundaryIncidence 0 0 []++emptyBoundaryIncidenceOf :: Natural -> Natural -> BoundaryIncidence r+emptyBoundaryIncidenceOf sourceCardinalityValue targetCardinalityValue =+  uncheckedBoundaryIncidence+    (fromIntegral sourceCardinalityValue)+    (fromIntegral targetCardinalityValue)+    []++identityBoundaryIncidenceOf :: Num r => Natural -> BoundaryIncidence r+identityBoundaryIncidenceOf dimensionValue =+  uncheckedBoundaryIncidence dimension dimension entries+  where+    dimension = fromIntegral dimensionValue+    entries =+      fmap+        (\index -> mkBoundaryEntry (fromIntegral index) (fromIntegral index) 1)+        (take dimension [0 :: Int ..])++directSumBoundaryIncidence :: BoundaryIncidence r -> BoundaryIncidence r -> BoundaryIncidence r+directSumBoundaryIncidence left right =+  uncheckedBoundaryIncidence+    (sourceCardinality left + sourceCardinality right)+    (targetCardinality left + targetCardinality right)+    ( boundaryEntries left+        <> fmap+          ( \entry ->+              mkBoundaryEntry+                (fromIntegral (sourceCardinality left + sourceIndex entry))+                (fromIntegral (targetCardinality left + targetIndex entry))+                (boundaryCoefficient entry)+          )+          (boundaryEntries right)+    )++reindexBoundaryIncidenceWith ::+  (Int -> Maybe Natural) ->+  (Int -> Maybe Natural) ->+  (BoundaryEntry a -> Maybe b) ->+  BoundaryIncidence a ->+  BoundaryIncidence b+reindexBoundaryIncidenceWith sourceReindex targetReindex coefficientAt incidence =+  uncheckedBoundaryIncidence+    (mappingDimension sourceReindex (sourceCardinality incidence))+    (mappingDimension targetReindex (targetCardinality incidence))+    ( mapMaybe+        ( \entry ->+            mkBoundaryEntry+              <$> sourceReindex (sourceIndex entry)+              <*> targetReindex (targetIndex entry)+              <*> coefficientAt entry+        )+        (boundaryEntries incidence)+    )++boundaryIncidenceApply :: Num r => BoundaryIncidence r -> Map.Map Int r -> Map.Map Int r+boundaryIncidenceApply incidence vectorValues =+  boundaryEntries incidence+    & fmap+      ( \entry ->+          ( targetIndex entry,+            boundaryCoefficient entry * Map.findWithDefault 0 (sourceIndex entry) vectorValues+          )+      )+    & Map.fromListWith (+)++transposeBoundaryIncidence :: BoundaryIncidence r -> BoundaryIncidence r+transposeBoundaryIncidence incidence =+  uncheckedBoundaryIncidence+    (targetCardinality incidence)+    (sourceCardinality incidence)+    ( boundaryEntries incidence+        & fmap+          ( \entry ->+              mkBoundaryEntry+                (fromIntegral (targetIndex entry))+                (fromIntegral (sourceIndex entry))+                (boundaryCoefficient entry)+          )+    )++composeBoundaryIncidence :: (Eq r, Num r, Semiring r) => BoundaryIncidence r -> BoundaryIncidence r -> Either BoundaryIncidenceShapeError (BoundaryIncidence r)+composeBoundaryIncidence left right =+  if targetCardinality right /= sourceCardinality left+    then+      Left+        ( BoundaryIncidenceShapeMismatch+            (sourceCardinality left)+            (targetCardinality left)+            (sourceCardinality right)+            (targetCardinality right)+        )+    else+      if null (boundaryEntries left) || null (boundaryEntries right)+        then+          Right+            ( emptyBoundaryIncidenceOf+                (fromIntegral (sourceCardinality right))+                (fromIntegral (targetCardinality left))+            )+        else+          let rightByTarget =+                boundaryEntries right+                  & fmap (\entry -> (targetIndex entry, [entry]))+                  & Map.fromListWith (<>)+              leftBySource =+                boundaryEntries left+                  & fmap (\entry -> (sourceIndex entry, [entry]))+                  & Map.fromListWith (<>)+              productTerms =+                Map.intersectionWith (,) rightByTarget leftBySource+                  & Map.elems+                  >>= ( \(rightBucket, leftBucket) ->+                          rightBucket+                            >>= ( \rightEntry ->+                                    leftBucket+                                      & fmap+                                        ( \leftEntry ->+                                            ( (sourceIndex rightEntry, targetIndex leftEntry),+                                              boundaryCoefficient leftEntry * boundaryCoefficient rightEntry+                                            )+                                        )+                                )+                      )+              composedEntries =+                productTerms+                  & Map.fromListWith (+)+                  & Map.toList+                  & fmap+                    ( \((sourceValue, targetValue), coefficientValue) ->+                        mkBoundaryEntry+                          (fromIntegral sourceValue)+                          (fromIntegral targetValue)+                          coefficientValue+                    )+           in mkBoundaryIncidence+                (fromIntegral (sourceCardinality right))+                (fromIntegral (targetCardinality left))+                composedEntries++boundaryIncidenceDiagonal :: Num r => BoundaryIncidence r -> Map.Map Int r+boundaryIncidenceDiagonal incidence =+  boundaryEntries incidence+    & filter (\entry -> sourceIndex entry == targetIndex entry)+    & fmap (\entry -> (sourceIndex entry, boundaryCoefficient entry))+    & Map.fromListWith (+)++addBoundaryIncidence ::+  (Eq r, Num r, Semiring r) =>+  BoundaryIncidence r ->+  BoundaryIncidence r ->+  Either BoundaryIncidenceShapeError (BoundaryIncidence r)+addBoundaryIncidence left right =+  if sourceCardinality left == sourceCardinality right+      && targetCardinality left == targetCardinality right+    then+      let mergedEntries =+            boundaryEntries left+              <> boundaryEntries right+              & fmap+                ( \entry ->+                    ( (sourceIndex entry, targetIndex entry),+                      boundaryCoefficient entry+                    )+                )+              & Map.fromListWith (+)+       in+        mkBoundaryIncidence+          (fromIntegral (sourceCardinality left))+          (fromIntegral (targetCardinality left))+          ( mergedEntries+              & Map.toList+              & fmap+                ( \((sourceValue, targetValue), coefficientValue) ->+                    mkBoundaryEntry+                      (fromIntegral sourceValue)+                      (fromIntegral targetValue)+                      coefficientValue+                )+          )+    else+      Left+        ( BoundaryIncidenceShapeMismatch+            (sourceCardinality left)+            (targetCardinality left)+            (sourceCardinality right)+            (targetCardinality right)+        )++mapBoundaryCoefficients :: (a -> b) -> BoundaryIncidence a -> BoundaryIncidence b+mapBoundaryCoefficients f incidence =+  uncheckedBoundaryIncidence+    (sourceCardinality incidence)+    (targetCardinality incidence)+    ( fmap+        (\entry -> mkBoundaryEntry (fromIntegral (sourceIndex entry)) (fromIntegral (targetIndex entry)) (f (boundaryCoefficient entry)))+        (boundaryEntries incidence)+    )++type BlockBoundaryEntry :: Type -> Type+data BlockBoundaryEntry r = BlockBoundaryEntry+  { blockSourceIndex :: Int,+    blockTargetIndex :: Int,+    blockSubmatrix :: BoundaryIncidence r+  }+  deriving stock (Eq, Show)++mkBlockBoundaryEntry :: Natural -> Natural -> BoundaryIncidence r -> BlockBoundaryEntry r+mkBlockBoundaryEntry blockSourceIndexValue blockTargetIndexValue submatrix =+  BlockBoundaryEntry+    { blockSourceIndex = fromIntegral blockSourceIndexValue,+      blockTargetIndex = fromIntegral blockTargetIndexValue,+      blockSubmatrix = submatrix+    }++type BlockBoundaryIncidence :: Type -> Type+data BlockBoundaryIncidence r = BlockBoundaryIncidence+  { blockSourceDimensions :: [Int],+    blockTargetDimensions :: [Int],+    blockEntries :: [BlockBoundaryEntry r]+  }+  deriving stock (Eq, Show)++mkBlockBoundaryIncidence :: [Natural] -> [Natural] -> [BlockBoundaryEntry r] -> Either BoundaryIncidenceShapeError (BlockBoundaryIncidence r)+mkBlockBoundaryIncidence sourceDimensionsValue targetDimensionsValue entries =+  let sourceDimensions = fmap fromIntegral sourceDimensionsValue+      targetDimensions = fmap fromIntegral targetDimensionsValue+      blockIncidence =+        BlockBoundaryIncidence+          { blockSourceDimensions = sourceDimensions,+            blockTargetDimensions = targetDimensions,+            blockEntries = entries+          }+   in do+        _ <- traverse (validateBlockEntry blockIncidence) entries+        pure blockIncidence++flattenBlockIncidence :: (Eq r, Semiring r) => BlockBoundaryIncidence r -> Either BoundaryIncidenceShapeError (BoundaryIncidence r)+flattenBlockIncidence block =+  let sourceOffsets = prefixSums (blockSourceDimensions block)+      targetOffsets = prefixSums (blockTargetDimensions block)+      totalSourceDim = sum (blockSourceDimensions block)+      totalTargetDim = sum (blockTargetDimensions block)+   in do+        expandedEntries <-+          fmap concat+            (traverse (expandBlockEntry sourceOffsets targetOffsets block) (blockEntries block))+        mkBoundaryIncidence+          (fromIntegral totalSourceDim)+          (fromIntegral totalTargetDim)+          expandedEntries++scaleBoundaryIncidence :: Num r => r -> BoundaryIncidence r -> BoundaryIncidence r+scaleBoundaryIncidence scalar =+  mapBoundaryCoefficients (* scalar)++prefixSums :: [Int] -> [Int]+prefixSums = scanl (+) 0++materializeIncidenceBoundary ::+  (Eq r, Semiring r, Ord target) =>+  (source -> [(r, target)]) ->+  [source] ->+  [target] ->+  Either HomologyFailure (BoundaryIncidence r)+materializeIncidenceBoundary boundaryOf sourceBasis targetBasis =+  materializeBoundary+    (\sourceValue -> boundaryOf sourceValue & fmap (\(coefficientValue, targetValue) -> (coefficientValue, ScopedBoundary IncidenceScope targetValue)))+    sourceBasis+    targetBasis++materializeBoundary ::+  (Eq r, Semiring r, Ord target) =>+  (source -> [(r, ScopedBoundary target)]) ->+  [source] ->+  [target] ->+  Either HomologyFailure (BoundaryIncidence r)+materializeBoundary boundaryOf sourceBasis targetBasis =+  -- The user boundary function is evaluated exactly once per basis element;+  -- the portal-scope gate and the materialization both read the same+  -- precomputed list rather than each paying for a full traversal.+  let boundariesBySource = fmap boundaryOf sourceBasis+      hasPortalTargets =+        boundariesBySource+          & concat+          & any (\(_, scopedTarget) -> boundaryScope scopedTarget == PortalScope)+   in if hasPortalTargets+        then Left (LawViolation IncidenceScopeLaw)+        else materializeIncidence boundariesBySource targetBasis++materializeIncidence ::+  (Eq r, Semiring r, Ord target) =>+  [[(r, ScopedBoundary target)]] ->+  [target] ->+  Either HomologyFailure (BoundaryIncidence r)+materializeIncidence boundariesBySource targetBasis =+  let targetIndexByBasis = Map.fromList (zip targetBasis [0 :: Int ..])+   in do+        entries <-+          fmap concat $+            traverse+              ( \(sourceIndexValue, sourceBoundary) ->+                  traverse+                    ( \(coefficientValue, scopedTarget) ->+                        maybe+                          (Left (InvalidBoundaryIncidence "boundary target is absent from the target basis"))+                          ( \targetIndexValue ->+                              Right+                                ( mkBoundaryEntry+                                    (fromIntegral sourceIndexValue)+                                    (fromIntegral targetIndexValue)+                                    coefficientValue+                                )+                          )+                          (Map.lookup (boundaryValue scopedTarget) targetIndexByBasis)+                    )+                    sourceBoundary+              )+              (zip [0 :: Int ..] boundariesBySource)+        either+          (Left . InvalidBoundaryIncidence . show)+          Right+          ( mkBoundaryIncidence+              (fromIntegral (length boundariesBySource))+              (fromIntegral (length targetBasis))+              entries+          )++uncheckedBoundaryIncidence :: Int -> Int -> [BoundaryEntry r] -> BoundaryIncidence r+uncheckedBoundaryIncidence sourceDimension targetDimension entries =+  BoundaryIncidence+    { sourceCardinality = sourceDimension,+      targetCardinality = targetDimension,+      boundaryEntries = entries+    }++firstOutOfBoundsEntry :: Int -> Int -> [BoundaryEntry r] -> Maybe (BoundaryEntry r)+firstOutOfBoundsEntry sourceDimension targetDimension =+  listToMaybe . filter (not . entryWithinBounds sourceDimension targetDimension)++entryWithinBounds :: Int -> Int -> BoundaryEntry r -> Bool+entryWithinBounds sourceDimension targetDimension entry =+  sourceIndex entry >= 0+    && sourceIndex entry < sourceDimension+    && targetIndex entry >= 0+    && targetIndex entry < targetDimension++entryOutOfBoundsError :: Int -> Int -> BoundaryEntry r -> BoundaryIncidenceShapeError+entryOutOfBoundsError sourceDimension targetDimension entry =+  BoundaryIncidenceEntryOutOfBounds+    (sourceIndex entry)+    (targetIndex entry)+    sourceDimension+    targetDimension++mappingDimension :: (Int -> Maybe Natural) -> Int -> Int+mappingDimension reindex dimension =+  [0 .. dimension - 1]+    & fmap reindex+    & mapMaybe (fmap fromIntegral)+    & maximumMaybe+    & maybe 0 (+ 1)++maximumMaybe :: Ord a => [a] -> Maybe a+maximumMaybe =+  foldr+    ( \value ->+        Just+          . maybe value (max value)+    )+    Nothing++validateBlockEntry :: BlockBoundaryIncidence r -> BlockBoundaryEntry r -> Either BoundaryIncidenceShapeError (BlockBoundaryEntry r)+validateBlockEntry blockIncidence blockEntry = do+  expectedSourceDim <-+    dimensionAt+      (blockSourceDimensions blockIncidence)+      (blockSourceIndex blockEntry)+      (blockIndexError blockIncidence blockEntry)+  expectedTargetDim <-+    dimensionAt+      (blockTargetDimensions blockIncidence)+      (blockTargetIndex blockEntry)+      (blockIndexError blockIncidence blockEntry)+  let submatrix = blockSubmatrix blockEntry+  if sourceCardinality submatrix /= expectedSourceDim || targetCardinality submatrix /= expectedTargetDim+    then+      Left+        ( BoundaryIncidenceBlockShapeMismatch+            expectedSourceDim+            expectedTargetDim+            (sourceCardinality submatrix)+            (targetCardinality submatrix)+        )+    else pure blockEntry++blockIndexError :: BlockBoundaryIncidence r -> BlockBoundaryEntry r -> BoundaryIncidenceShapeError+blockIndexError blockIncidence blockEntry =+  BoundaryIncidenceEntryOutOfBounds+    (blockSourceIndex blockEntry)+    (blockTargetIndex blockEntry)+    (length (blockSourceDimensions blockIncidence))+    (length (blockTargetDimensions blockIncidence))++expandBlockEntry :: [Int] -> [Int] -> BlockBoundaryIncidence r -> BlockBoundaryEntry r -> Either BoundaryIncidenceShapeError [BoundaryEntry r]+expandBlockEntry sourceOffsets targetOffsets blockIncidence blockEntry = do+  _ <- validateBlockEntry blockIncidence blockEntry+  sourceOffset <- offsetAt sourceOffsets (blockSourceIndex blockEntry) (blockIndexError blockIncidence blockEntry)+  targetOffset <- offsetAt targetOffsets (blockTargetIndex blockEntry) (blockIndexError blockIncidence blockEntry)+  traverse (expandScalarEntry sourceOffset targetOffset (blockSubmatrix blockEntry)) (boundaryEntries (blockSubmatrix blockEntry))++dimensionAt :: [Int] -> Int -> errorValue -> Either errorValue Int+dimensionAt dimensions idx errorValue+  | idx < 0 = Left errorValue+  | otherwise =+      case drop idx dimensions of+        dimensionValue : _ -> Right dimensionValue+        [] -> Left errorValue++offsetAt :: [Int] -> Int -> errorValue -> Either errorValue Int+offsetAt offsets idx errorValue+  | idx < 0 = Left errorValue+  | otherwise =+      case drop idx offsets of+        offsetValue : remainingOffsets ->+          if null remainingOffsets+            then Left errorValue+            else Right offsetValue+        [] -> Left errorValue++expandScalarEntry :: Int -> Int -> BoundaryIncidence r -> BoundaryEntry r -> Either BoundaryIncidenceShapeError (BoundaryEntry r)+expandScalarEntry sourceOffset targetOffset submatrix scalarEntry =+  if entryWithinBounds (sourceCardinality submatrix) (targetCardinality submatrix) scalarEntry+    then+      Right+        ( mkBoundaryEntry+            (fromIntegral (sourceIndex scalarEntry + sourceOffset))+            (fromIntegral (targetIndex scalarEntry + targetOffset))+            (boundaryCoefficient scalarEntry)+        )+    else Left (entryOutOfBoundsError (sourceCardinality submatrix) (targetCardinality submatrix) scalarEntry)
+ src-matrix/Moonlight/Homology/Boundary/SNF.hs view
@@ -0,0 +1,35 @@+module Moonlight.Homology.Boundary.SNF+  ( SmithNormalForm (..),+    SNFReducer (..),+    SNFCapability,+    computeSmithNormalForm,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Boundary.LinAlg (BoundaryIncidence)+import Moonlight.Core (Capability, withCapability)+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Phase (HomologyPhase, RequirePhase2)++type SmithNormalForm :: Type -> Type+data SmithNormalForm r = SmithNormalForm+  { leftRank :: Int,+    rightRank :: Int,+    diagonalEntries :: [r]+  }+  deriving stock (Eq, Show)++type SNFReducer :: Type -> Type+newtype SNFReducer r = SNFReducer+  { runSNFReducer :: BoundaryIncidence r -> Either HomologyFailure (SmithNormalForm r)+  }++type SNFCapability :: HomologyPhase -> Type -> Type+type SNFCapability phase r =+  Capability RequirePhase2 phase (SNFReducer r)++computeSmithNormalForm :: SNFCapability phase r -> BoundaryIncidence r -> Either HomologyFailure (SmithNormalForm r)+computeSmithNormalForm capability boundaryIncidence =+  withCapability capability+    (\reducer -> runSNFReducer reducer boundaryIncidence)
+ src-matrix/Moonlight/Homology/Pure/Effective.hs view
@@ -0,0 +1,37 @@+module Moonlight.Homology.Pure.Effective+  ( EffectiveHomology,+    sourceComplex,+    reducedComplex,+    reductionWitness,+    finiteBoundary,+    mkEffectiveHomology,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex)+import Moonlight.Homology.Pure.Reductions+  ( Reduction,+    ReductionChecks,+    ReductionValidation,+    ReductionWitness,+    mkReductionWitness,+  )++type EffectiveHomology :: Type -> Type -> Type -> Type -> Type -> Type+data EffectiveHomology large small r largeBasis smallBasis = EffectiveHomology+  { sourceComplex :: large,+    reducedComplex :: small,+    reductionWitness :: ReductionWitness large small r largeBasis smallBasis,+    finiteBoundary :: FiniteChainComplex r+  }++mkEffectiveHomology ::+  large ->+  small ->+  Reduction large small r largeBasis smallBasis ->+  ReductionChecks largeBasis smallBasis r ->+  FiniteChainComplex r ->+  ReductionValidation (EffectiveHomology large small r largeBasis smallBasis)+mkEffectiveHomology source reduced reduction checks finite =+  (\witness -> EffectiveHomology source reduced witness finite) <$> mkReductionWitness reduction checks
+ src-matrix/Moonlight/Homology/Pure/Matrix/Reducer.hs view
@@ -0,0 +1,52 @@+module Moonlight.Homology.Pure.Matrix.Reducer+  ( BettiReducer (..),+    BettiCapability,+    computeBettiNumbers,+    TopologyWitnessReducer (..),+    TopologyWitnessCapability,+    computeTopologyWitness,+  )+where++import Data.Kind (Type)+import Moonlight.Core (Capability, withCapability)+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex)+import Moonlight.Homology.Pure.Chain (TopologyWitness)+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Group (HomologyGroup)+import Moonlight.Homology.Pure.Phase (HomologyPhase, RequirePhase2)++type BettiReducer :: Type -> Type+newtype BettiReducer r = BettiReducer+  { runBettiReducer :: FiniteChainComplex r -> Either HomologyFailure [HomologyGroup r]+  }++type BettiCapability :: HomologyPhase -> Type -> Type+type BettiCapability phase r =+  Capability RequirePhase2 phase (BettiReducer r)++computeBettiNumbers :: BettiCapability phase r -> FiniteChainComplex r -> Either HomologyFailure [HomologyGroup r]+computeBettiNumbers capability finite =+  withCapability capability+    (\reducer -> runBettiReducer reducer finite)++type TopologyWitnessReducer ::+  Type -> Type -> Type -> Type -> Type -> Type -> Type+newtype TopologyWitnessReducer scaffold spectral persistence coefficient r basis = TopologyWitnessReducer+  { runTopologyWitnessReducer ::+      FiniteChainComplex r ->+      Either HomologyFailure (TopologyWitness scaffold spectral persistence coefficient basis)+  }++type TopologyWitnessCapability ::+  HomologyPhase -> Type -> Type -> Type -> Type -> Type -> Type -> Type+type TopologyWitnessCapability phase scaffold spectral persistence coefficient r basis =+  Capability RequirePhase2 phase (TopologyWitnessReducer scaffold spectral persistence coefficient r basis)++computeTopologyWitness ::+  TopologyWitnessCapability phase scaffold spectral persistence coefficient r basis ->+  FiniteChainComplex r ->+  Either HomologyFailure (TopologyWitness scaffold spectral persistence coefficient basis)+computeTopologyWitness capability finite =+  withCapability capability+    (\reducer -> runTopologyWitnessReducer reducer finite)
+ src-matrix/Moonlight/Homology/Pure/Matrix/Shape.hs view
@@ -0,0 +1,22 @@+module Moonlight.Homology.Pure.Matrix.Shape+  ( cellCountAtDegree,+    dimensionsOf,+  )+where++import Data.Function ((&))+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    degreeCardinality,+    maxHomologicalDegree,+  )+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))+import Moonlight.Homology.Pure.Filtration (enumerateFromZero)++cellCountAtDegree :: FiniteChainComplex r -> HomologicalDegree -> Int+cellCountAtDegree = degreeCardinality++dimensionsOf :: FiniteChainComplex r -> [HomologicalDegree]+dimensionsOf finite =+  enumerateFromZero (unHomologicalDegree (maxHomologicalDegree finite) + 1)+    & fmap HomologicalDegree
+ src-matrix/Moonlight/Homology/Pure/Matrix/SparseLinAlg.hs view
@@ -0,0 +1,1008 @@+module Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseRow,+    SparseMatrix (..),+    sparseBoundaryMatrixWith,+    sparseBoundaryMatrix,+    sparseTransposeMatrix,+    SparseRref (..),+    sparseRref,+    sparseKernelBasisFromRref,+    sparseKernelBasisOf,+    sparseKernelVector,+    sparseImageBasisFromRref,+    sparseImageBasisOf,+    SparseEchelonBasis (..),+    sparseEchelonBasis,+    sparseEchelonContains,+    sparseEchelonRank,+    sparseIndependentModulo,+    sparseIndependentModuloWithBasis,+    sparseSpanRank,+    SparseCoordinateBasis (..),+    sparseCoordinateBasis,+    sparseCoordinatesInBasis,+    compactSparseRow,+    scaleSparseRow,+    addScaledSparseRow,+    sparseMatrixFromRows,+    sparseRowFromDense,+    sparseRowToDense,+    sparseRowLookup,+  )+where++import Data.Function ((&))+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+import Data.Kind (Type)+import qualified Data.List as List+import Data.Ratio (denominator, numerator)+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryIncidence,+    boundaryCoefficient,+    boundaryEntries,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Filtration (enumerateFromZero)++type SparseRow :: Type+type SparseRow = IntMap Rational++type SparseMatrix :: Type+data SparseMatrix = SparseMatrix+  { smRows :: ![SparseRow],+    smColumnCount :: !Int+  }+  deriving stock (Eq, Show)++sparseBoundaryMatrixWith :: (r -> Rational) -> BoundaryIncidence r -> SparseMatrix+sparseBoundaryMatrixWith convert incidence =+  let rowCount = targetCardinality incidence+      columnCount = sourceCardinality incidence+      rowBuckets =+        boundaryEntries incidence+          & List.foldl'+            ( \accumulator entry ->+                let rowIndex = targetIndex entry+                    columnIndex = sourceIndex entry+                    coefficient = convert (boundaryCoefficient entry)+                 in IntMap.insertWith+                      (IntMap.unionWith (+))+                      rowIndex+                      (IntMap.singleton columnIndex coefficient)+                      accumulator+            )+            IntMap.empty+   in SparseMatrix+        { smRows =+            enumerateFromZero rowCount+              & fmap+                ( \rowIndex ->+                    IntMap.filter+                      (/= 0)+                      (IntMap.findWithDefault IntMap.empty rowIndex rowBuckets)+                ),+          smColumnCount = columnCount+        }++sparseBoundaryMatrix :: Integral r => BoundaryIncidence r -> SparseMatrix+sparseBoundaryMatrix =+  sparseBoundaryMatrixWith fromIntegral++sparseTransposeMatrix :: SparseMatrix -> SparseMatrix+sparseTransposeMatrix matrix =+  let transposedBuckets =+        smRows matrix+          & zip [0 :: Int ..]+          & List.foldl'+            ( \accumulator (rowIndex, rowValue) ->+                IntMap.foldlWithKey'+                  ( \innerAccumulator columnIndex coefficient ->+                      IntMap.insertWith+                        (IntMap.unionWith (+))+                        columnIndex+                        (IntMap.singleton rowIndex coefficient)+                        innerAccumulator+                  )+                  accumulator+                  rowValue+            )+            IntMap.empty+      newRowCount = smColumnCount matrix+      newColumnCount = length (smRows matrix)+   in SparseMatrix+        { smRows =+            enumerateFromZero newRowCount+              & fmap (\rowIndex -> IntMap.findWithDefault IntMap.empty rowIndex transposedBuckets),+          smColumnCount = newColumnCount+        }++type SparseRref :: Type+data SparseRref = SparseRref+  { srrefPivots :: ![(Int, SparseRow)],+    srrefColumnCount :: !Int+  }+  deriving stock (Eq, Show)++type SparseEchelonBasis :: Type+data SparseEchelonBasis = SparseEchelonBasis+  { sebColumnCount :: !Int,+    sebPivotRows :: !(IntMap SparseRow)+  }+  deriving stock (Eq, Show)++type SparseCoordinatePivot :: Type+data SparseCoordinatePivot = SparseCoordinatePivot+  { scpVector :: !SparseRow,+    scpCoordinates :: !SparseRow+  }+  deriving stock (Eq, Show)++type SparseCoordinateBasis :: Type+data SparseCoordinateBasis = SparseCoordinateBasis+  { scbAmbientDimension :: !Int,+    scbGeneratorCount :: !Int,+    scbPivotRows :: !(IntMap SparseCoordinatePivot)+  }+  deriving stock (Eq, Show)++type SparseCoordinateResidual :: Type+data SparseCoordinateResidual = SparseCoordinateResidual+  { scrVector :: !SparseRow,+    scrCoordinates :: !SparseRow+  }+  deriving stock (Eq, Show)++type SparseSupportIndex :: Type+data SparseSupportIndex = SparseSupportIndex+  { ssiColumnRows :: !(IntMap IntSet.IntSet),+    ssiSupportBuckets :: !(IntMap IntSet.IntSet),+    ssiRowBuckets :: !(IntMap IntSet.IntSet)+  }+  deriving stock (Eq, Show)++type SparseEliminationState :: Type+data SparseEliminationState = SparseEliminationState+  { sesActiveRows :: !(IntMap SparseRow),+    sesSupportIndex :: !SparseSupportIndex,+    sesSelectedPivots :: ![(Int, SparseRow)]+  }+  deriving stock (Eq, Show)++type PivotScore :: Type+data PivotScore = PivotScore+  { pivotMarkowitzFill :: !Int,+    pivotUnitPenalty :: !Int,+    pivotCoefficientHeight :: !Integer,+    pivotRowDegree :: !Int,+    pivotColumnScore :: !Int,+    pivotRowIdScore :: !Int+  }+  deriving stock (Eq, Ord, Show)++type PivotCandidate :: Type+data PivotCandidate = PivotCandidate+  { pcScore :: !PivotScore,+    pcRowId :: !Int,+    pcColumn :: !Int,+    pcRow :: !SparseRow+  }+  deriving stock (Eq, Show)++sparseRref :: SparseMatrix -> SparseRref+sparseRref matrix =+  let finalState = convergeSparseElimination (initialSparseEliminationState matrix)+      -- 'sesSelectedPivots' is already in reverse-selection order, which is+      -- exactly the order 'canonicalRrefPivots' consumes (latest pivot+      -- first); no re-reversal is needed on either side.+      pivots = canonicalRrefPivots (sesSelectedPivots finalState)+   in SparseRref+        { srrefPivots = pivots,+          srrefColumnCount = smColumnCount matrix+        }++initialSparseEliminationState :: SparseMatrix -> SparseEliminationState+initialSparseEliminationState matrix =+  let activeRows =+        smRows matrix+          & zip [0 :: Int ..]+          & List.foldl'+            ( \accumulator (rowId, rowValue) ->+                let compactRow = compactSparseRow rowValue+                 in if IntMap.null compactRow+                      then accumulator+                      else IntMap.insert rowId compactRow accumulator+            )+            IntMap.empty+      supportIndex = buildSparseSupportIndex activeRows+   in SparseEliminationState+        { sesActiveRows = activeRows,+          sesSupportIndex = supportIndex,+          sesSelectedPivots = []+        }++convergeSparseElimination :: SparseEliminationState -> SparseEliminationState+convergeSparseElimination state =+  case sparseEliminationStep state of+    Nothing -> state+    Just nextState -> convergeSparseElimination nextState++sparseEliminationStep :: SparseEliminationState -> Maybe SparseEliminationState+sparseEliminationStep state =+  case choosePivot state of+    Nothing -> Nothing+    Just pivot ->+      let pivotColumn = pcColumn pivot+          pivotRowId = pcRowId pivot+          normalizedPivot = normalizeSparseRow pivotColumn (pcRow pivot)+          affectedRows =+            sesSupportIndex state+              & ssiColumnRows+              & IntMap.findWithDefault IntSet.empty pivotColumn+              & IntSet.delete pivotRowId+          withoutPivot = removeActiveRow pivotRowId state+          reducedState =+            IntSet.foldl'+              (eliminateTargetRow pivotColumn normalizedPivot)+              withoutPivot+              affectedRows+       in Just+            reducedState+              { sesSelectedPivots =+                  (pivotColumn, normalizedPivot) : sesSelectedPivots reducedState+              }++choosePivot :: SparseEliminationState -> Maybe PivotCandidate+choosePivot state =+  case chooseZeroFillPivot state of+    Just pivot -> Just pivot+    Nothing ->+      case firstSupportBucket (ssiRowBuckets (sesSupportIndex state)) of+        Nothing -> Nothing+        Just (minimumRowDegree, _) ->+          choosePivotFromSupportBuckets+            state+            minimumRowDegree+            (ssiSupportBuckets (sesSupportIndex state))+            Nothing++chooseZeroFillPivot :: SparseEliminationState -> Maybe PivotCandidate+chooseZeroFillPivot state =+  case IntMap.lookup 1 (ssiSupportBuckets (sesSupportIndex state)) of+    Nothing -> chooseSingletonRowPivot state+    Just singletonColumns ->+      choosePivotFromColumns+        state+        1+        (chooseSingletonRowPivot state)+        singletonColumns++firstSupportBucket :: IntMap IntSet.IntSet -> Maybe (Int, IntSet.IntSet)+firstSupportBucket buckets =+  case IntMap.lookupMin buckets of+    Nothing -> Nothing+    Just (supportCount, candidateColumns)+      | IntSet.null candidateColumns ->+          firstSupportBucket (IntMap.delete supportCount buckets)+      | otherwise ->+          Just (supportCount, candidateColumns)++choosePivotFromColumns ::+  SparseEliminationState ->+  Int ->+  Maybe PivotCandidate ->+  IntSet.IntSet ->+  Maybe PivotCandidate+choosePivotFromColumns state columnDegree bestCandidate =+  IntSet.foldl'+    ( \currentBestCandidate columnIndex ->+        choosePivotFromColumn state columnDegree columnIndex currentBestCandidate+    )+    bestCandidate++choosePivotFromSupportBuckets ::+  SparseEliminationState ->+  Int ->+  IntMap IntSet.IntSet ->+  Maybe PivotCandidate ->+  Maybe PivotCandidate+choosePivotFromSupportBuckets state minimumRowDegree supportBuckets bestCandidate =+  case firstSupportBucket supportBuckets of+    Nothing -> bestCandidate+    Just (columnDegree, candidateColumns) ->+      if pivotLowerBoundExceedsBest minimumRowDegree columnDegree bestCandidate+        then bestCandidate+        else+          choosePivotFromSupportBuckets+            state+            minimumRowDegree+            (IntMap.delete columnDegree supportBuckets)+            (choosePivotFromColumns state columnDegree bestCandidate candidateColumns)++pivotLowerBoundExceedsBest :: Int -> Int -> Maybe PivotCandidate -> Bool+pivotLowerBoundExceedsBest _ _ Nothing =+  False+pivotLowerBoundExceedsBest minimumRowDegree columnDegree (Just bestCandidate) =+  let lowerBound =+        max 0 (minimumRowDegree - 1) * max 0 (columnDegree - 1)+   in lowerBound > pivotMarkowitzFill (pcScore bestCandidate)++chooseSingletonRowPivot :: SparseEliminationState -> Maybe PivotCandidate+chooseSingletonRowPivot state =+  case IntMap.lookup 1 (ssiRowBuckets (sesSupportIndex state)) of+    Nothing -> Nothing+    Just singletonRows ->+      IntSet.foldl'+        ( \bestCandidate rowId ->+            case singletonRowPivotCandidate state rowId of+              Nothing -> bestCandidate+              Just candidate -> betterPivotCandidate bestCandidate candidate+        )+        Nothing+        singletonRows++singletonRowPivotCandidate :: SparseEliminationState -> Int -> Maybe PivotCandidate+singletonRowPivotCandidate state rowId =+  case IntMap.lookup rowId (sesActiveRows state) of+    Nothing -> Nothing+    Just rowValue ->+      case IntMap.lookupMin rowValue of+        Nothing -> Nothing+        Just (columnIndex, _) ->+          pivotCandidateAt+            state+            (columnSupportCount state columnIndex)+            columnIndex+            rowId++columnSupportCount :: SparseEliminationState -> Int -> Int+columnSupportCount state columnIndex =+  state+    & sesSupportIndex+    & ssiColumnRows+    & IntMap.findWithDefault IntSet.empty columnIndex+    & IntSet.size++choosePivotFromColumn ::+  SparseEliminationState ->+  Int ->+  Int ->+  Maybe PivotCandidate ->+  Maybe PivotCandidate+choosePivotFromColumn state columnDegree columnIndex bestCandidate =+  IntSet.foldl'+    ( \currentBestCandidate rowId ->+        case pivotCandidateAt state columnDegree columnIndex rowId of+          Nothing -> currentBestCandidate+          Just candidate -> betterPivotCandidate currentBestCandidate candidate+    )+    bestCandidate+    columnRows+  where+    columnRows =+      state+        & sesSupportIndex+        & ssiColumnRows+        & IntMap.findWithDefault IntSet.empty columnIndex++pivotCandidateAt ::+  SparseEliminationState ->+  Int ->+  Int ->+  Int ->+  Maybe PivotCandidate+pivotCandidateAt state columnDegree columnIndex rowId =+  case IntMap.lookup rowId (sesActiveRows state) of+    Nothing -> Nothing+    Just rowValue ->+      case IntMap.lookup columnIndex rowValue of+        Nothing -> Nothing+        Just coefficient+          | coefficient == 0 -> Nothing+          | otherwise ->+              Just+                PivotCandidate+                  { pcScore =+                      pivotScore+                        columnDegree+                        columnIndex+                        rowId+                        rowValue+                        coefficient,+                    pcRowId = rowId,+                    pcColumn = columnIndex,+                    pcRow = rowValue+                  }++pivotScore :: Int -> Int -> Int -> SparseRow -> Rational -> PivotScore+pivotScore columnDegree columnIndex rowId rowValue coefficient =+  let rowDegree = IntMap.size rowValue+   in PivotScore+        { pivotMarkowitzFill =+            max 0 (rowDegree - 1) * max 0 (columnDegree - 1),+          pivotUnitPenalty =+            if abs coefficient == 1+              then 0+              else 1,+          pivotCoefficientHeight =+            abs (numerator coefficient) + denominator coefficient,+          pivotRowDegree = rowDegree,+          pivotColumnScore = columnIndex,+          pivotRowIdScore = rowId+        }++betterPivotCandidate :: Maybe PivotCandidate -> PivotCandidate -> Maybe PivotCandidate+betterPivotCandidate Nothing candidate =+  Just candidate+betterPivotCandidate (Just incumbent) candidate =+  if pcScore candidate < pcScore incumbent+    then Just candidate+    else Just incumbent++buildSparseSupportIndex :: IntMap SparseRow -> SparseSupportIndex+buildSparseSupportIndex =+  IntMap.foldlWithKey'+    ( \supportIndex rowId rowValue ->+        addActiveRowSupport rowId rowValue supportIndex+    )+    emptySparseSupportIndex++emptySparseSupportIndex :: SparseSupportIndex+emptySparseSupportIndex =+  SparseSupportIndex+    { ssiColumnRows = IntMap.empty,+      ssiSupportBuckets = IntMap.empty,+      ssiRowBuckets = IntMap.empty+    }++removeActiveRow :: Int -> SparseEliminationState -> SparseEliminationState+removeActiveRow rowId state =+  case IntMap.lookup rowId (sesActiveRows state) of+    Nothing -> state+    Just rowValue ->+      state+        { sesActiveRows = IntMap.delete rowId (sesActiveRows state),+          sesSupportIndex =+            removeActiveRowSupport rowId rowValue (sesSupportIndex state)+        }++replaceActiveRow ::+  Int ->+  SparseRow ->+  SparseRow ->+  SparseEliminationState ->+  SparseEliminationState+replaceActiveRow rowId oldRow newRow state =+  let compactNewRow = compactSparseRow newRow+      withoutOldSupport = removeActiveRowSupport rowId oldRow (sesSupportIndex state)+   in if IntMap.null compactNewRow+        then+          state+            { sesActiveRows = IntMap.delete rowId (sesActiveRows state),+              sesSupportIndex = withoutOldSupport+            }+        else+          state+            { sesActiveRows = IntMap.insert rowId compactNewRow (sesActiveRows state),+              sesSupportIndex = addActiveRowSupport rowId compactNewRow withoutOldSupport+            }++eliminateTargetRow ::+  Int ->+  SparseRow ->+  SparseEliminationState ->+  Int ->+  SparseEliminationState+eliminateTargetRow pivotColumn pivotRow state rowId =+  case IntMap.lookup rowId (sesActiveRows state) of+    Nothing -> state+    Just targetRow ->+      replaceActiveRow+        rowId+        targetRow+        (eliminateColumnFromRow pivotColumn pivotRow targetRow)+        state++addRowSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+addRowSupport rowId rowValue supportIndex =+  IntMap.foldlWithKey'+    ( \currentSupportIndex columnIndex coefficient ->+        if coefficient == 0+          then currentSupportIndex+          else addRowToColumn rowId columnIndex currentSupportIndex+    )+    supportIndex+    rowValue++removeRowSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+removeRowSupport rowId rowValue supportIndex =+  IntMap.foldlWithKey'+    ( \currentSupportIndex columnIndex _ ->+        removeRowFromColumn rowId columnIndex currentSupportIndex+    )+    supportIndex+    rowValue++addActiveRowSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+addActiveRowSupport rowId rowValue =+  addRowDegreeSupport rowId rowValue . addRowSupport rowId rowValue++removeActiveRowSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+removeActiveRowSupport rowId rowValue =+  removeRowDegreeSupport rowId rowValue . removeRowSupport rowId rowValue++addRowDegreeSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+addRowDegreeSupport rowId rowValue supportIndex =+  let rowDegree = IntMap.size rowValue+   in if rowDegree <= 0+        then supportIndex+        else+          supportIndex+            { ssiRowBuckets =+                updateSupportBucket rowDegree (IntSet.insert rowId) (ssiRowBuckets supportIndex)+            }++removeRowDegreeSupport :: Int -> SparseRow -> SparseSupportIndex -> SparseSupportIndex+removeRowDegreeSupport rowId rowValue supportIndex =+  let rowDegree = IntMap.size rowValue+   in if rowDegree <= 0+        then supportIndex+        else+          supportIndex+            { ssiRowBuckets =+                updateSupportBucket rowDegree (IntSet.delete rowId) (ssiRowBuckets supportIndex)+            }++addRowToColumn :: Int -> Int -> SparseSupportIndex -> SparseSupportIndex+addRowToColumn rowId columnIndex supportIndex =+  let columnRows = ssiColumnRows supportIndex+      existingRows = IntMap.findWithDefault IntSet.empty columnIndex columnRows+      oldCount = IntSet.size existingRows+      newRows = IntSet.insert rowId existingRows+      newCount = IntSet.size newRows+   in if oldCount == newCount+        then supportIndex+        else+          supportIndex+            { ssiColumnRows = IntMap.insert columnIndex newRows columnRows,+              ssiSupportBuckets =+                moveColumnSupport columnIndex oldCount newCount (ssiSupportBuckets supportIndex)+            }++removeRowFromColumn :: Int -> Int -> SparseSupportIndex -> SparseSupportIndex+removeRowFromColumn rowId columnIndex supportIndex =+  case IntMap.lookup columnIndex (ssiColumnRows supportIndex) of+    Nothing -> supportIndex+    Just existingRows ->+      let oldCount = IntSet.size existingRows+          newRows = IntSet.delete rowId existingRows+          newCount = IntSet.size newRows+          columnRows =+            if IntSet.null newRows+              then IntMap.delete columnIndex (ssiColumnRows supportIndex)+              else IntMap.insert columnIndex newRows (ssiColumnRows supportIndex)+       in if oldCount == newCount+            then supportIndex+            else+              supportIndex+                { ssiColumnRows = columnRows,+                  ssiSupportBuckets =+                    moveColumnSupport columnIndex oldCount newCount (ssiSupportBuckets supportIndex)+                }++moveColumnSupport :: Int -> Int -> Int -> IntMap IntSet.IntSet -> IntMap IntSet.IntSet+moveColumnSupport columnIndex oldCount newCount buckets =+  if oldCount == newCount+    then buckets+    else+      let withoutOld =+            if oldCount <= 0+              then buckets+              else updateSupportBucket oldCount (IntSet.delete columnIndex) buckets+       in if newCount <= 0+            then withoutOld+            else updateSupportBucket newCount (IntSet.insert columnIndex) withoutOld++updateSupportBucket ::+  Int ->+  (IntSet.IntSet -> IntSet.IntSet) ->+  IntMap IntSet.IntSet ->+  IntMap IntSet.IntSet+updateSupportBucket count transform buckets =+  let updatedColumns = transform (IntMap.findWithDefault IntSet.empty count buckets)+   in if IntSet.null updatedColumns+        then IntMap.delete count buckets+        else IntMap.insert count updatedColumns buckets++-- | Back-substitute pivots into canonical (fully reduced) form. Input must+-- be in reverse-selection order: each pivot is reduced against the+-- later-selected pivots, which provably have zeros in earlier pivot columns.+canonicalRrefPivots :: [(Int, SparseRow)] -> [(Int, SparseRow)]+canonicalRrefPivots selectedPivots =+  selectedPivots+    & List.foldl'+      ( \laterPivots pivot ->+          reduceAgainstLaterPivot pivot laterPivots+      )+      IntMap.empty+    & IntMap.toAscList++reduceAgainstLaterPivot :: (Int, SparseRow) -> IntMap SparseRow -> IntMap SparseRow+reduceAgainstLaterPivot (pivotColumn, pivotRow) laterPivots =+  let reducedRow =+        IntMap.foldlWithKey'+          ( \rowValue laterPivotColumn laterPivotRow ->+              eliminateColumnFromRow laterPivotColumn laterPivotRow rowValue+          )+          pivotRow+          laterPivots+   in IntMap.insert pivotColumn reducedRow laterPivots++rowLeadingColumn :: SparseRow -> Maybe Int+rowLeadingColumn = fmap fst . IntMap.lookupMin++normalizeSparseRow :: Int -> SparseRow -> SparseRow+normalizeSparseRow pivotColumn rowValue =+  case IntMap.lookup pivotColumn rowValue of+    Nothing -> rowValue+    Just pivotCoefficient+      | pivotCoefficient == 0 -> rowValue+      | otherwise ->+          IntMap.mapMaybe+            ( \coefficient ->+                let normalizedCoefficient = coefficient / pivotCoefficient+                 in if normalizedCoefficient == 0+                      then Nothing+                      else Just normalizedCoefficient+            )+            rowValue++eliminateColumnFromRow :: Int -> SparseRow -> SparseRow -> SparseRow+eliminateColumnFromRow pivotColumn pivotRow rowValue =+  case IntMap.lookup pivotColumn rowValue of+    Nothing -> rowValue+    Just coefficient+      | coefficient == 0 -> rowValue+      | otherwise ->+          IntMap.mergeWithKey+            ( \_ leftValue rightValue ->+                nonZeroSparseCoefficient (leftValue - coefficient * rightValue)+            )+            (IntMap.filter (/= 0))+            (IntMap.mapMaybe (nonZeroSparseCoefficient . negate . (* coefficient)))+            rowValue+            pivotRow++compactSparseRow :: SparseRow -> SparseRow+compactSparseRow = IntMap.filter (/= 0)++nonZeroSparseCoefficient :: Rational -> Maybe Rational+nonZeroSparseCoefficient coefficient =+  if coefficient == 0+    then Nothing+    else Just coefficient++sparseRowLookup :: Int -> SparseRow -> Rational+sparseRowLookup columnIndex rowValue =+  IntMap.findWithDefault 0 columnIndex rowValue++sparseKernelBasisOf :: Int -> SparseMatrix -> [SparseRow]+sparseKernelBasisOf ambientDimension matrix =+  sparseKernelBasisFromRref ambientDimension (sparseRref matrix)++sparseKernelBasisFromRref :: Int -> SparseRref -> [SparseRow]+sparseKernelBasisFromRref ambientDimension reduced =+  if ambientDimension <= 0+    then []+    else+      let pivotColumnSet = IntMap.fromList (fmap (\(columnIndex, _) -> (columnIndex, ())) (srrefPivots reduced))+          freeColumns =+            enumerateFromZero ambientDimension+              & filter (\columnIndex -> not (IntMap.member columnIndex pivotColumnSet))+       in fmap (sparseKernelVector reduced) freeColumns++sparseKernelVector :: SparseRref -> Int -> SparseRow+sparseKernelVector reduced freeColumn =+  let pivotContributions =+        srrefPivots reduced+          & fmap+            ( \(pivotColumn, rowValue) ->+                (pivotColumn, negate (sparseRowLookup freeColumn rowValue))+            )+          & filter (\(_, coefficient) -> coefficient /= 0)+   in IntMap.insert freeColumn 1 (IntMap.fromList pivotContributions)++sparseImageBasisOf :: SparseMatrix -> [SparseRow]+sparseImageBasisOf matrix =+  sparseImageBasisFromRref matrix (sparseRref matrix)++sparseImageBasisFromRref :: SparseMatrix -> SparseRref -> [SparseRow]+sparseImageBasisFromRref matrix reduced =+  let columnCount = smColumnCount matrix+      validPivotColumns =+        srrefPivots reduced+          & fmap fst+          & filter (< columnCount)+      pivotColumnSet = IntSet.fromList validPivotColumns+      selectedColumns =+        smRows matrix+          & zip [0 :: Int ..]+          & List.foldl'+            ( \columnBuckets (rowIndex, rowValue) ->+                IntMap.foldlWithKey'+                  ( \innerBuckets columnIndex coefficient ->+                      if coefficient == 0 || not (IntSet.member columnIndex pivotColumnSet)+                        then innerBuckets+                        else+                          IntMap.insertWith+                            (IntMap.unionWith (+))+                            columnIndex+                            (IntMap.singleton rowIndex coefficient)+                            innerBuckets+                  )+                  columnBuckets+                  rowValue+            )+            IntMap.empty+   in fmap+        (\columnIndex -> IntMap.findWithDefault IntMap.empty columnIndex selectedColumns)+        validPivotColumns++sparseIndependentModulo :: Int -> [SparseRow] -> [SparseRow] -> [SparseRow]+sparseIndependentModulo ambientDimension imageBasis kernelBasis =+  sparseIndependentModuloWithBasis (sparseEchelonBasis ambientDimension imageBasis) kernelBasis++sparseIndependentModuloWithBasis :: SparseEchelonBasis -> [SparseRow] -> [SparseRow]+sparseIndependentModuloWithBasis spanBasis kernelBasis =+  let initialSelection =+        SparseModuloSelection+          { smsSpanBasis = spanBasis,+            smsSelectedRows = []+          }+   in kernelBasis+        & List.foldl' selectIndependentModulo initialSelection+        & reverse . smsSelectedRows++type SparseModuloSelection :: Type+data SparseModuloSelection = SparseModuloSelection+  { smsSpanBasis :: !SparseEchelonBasis,+    smsSelectedRows :: ![SparseRow]+  }+  deriving stock (Eq, Show)++selectIndependentModulo :: SparseModuloSelection -> SparseRow -> SparseModuloSelection+selectIndependentModulo selection candidateVector =+  case adjoinSparseEchelonRow (smsSpanBasis selection) candidateVector of+    (Nothing, unchangedBasis) ->+      selection {smsSpanBasis = unchangedBasis}+    (Just _residualVector, extendedBasis) ->+      SparseModuloSelection+        { smsSpanBasis = extendedBasis,+          smsSelectedRows = candidateVector : smsSelectedRows selection+        }++sparseEchelonBasis :: Int -> [SparseRow] -> SparseEchelonBasis+sparseEchelonBasis ambientDimension =+  List.foldl'+    ( \basis rowValue ->+        snd (adjoinSparseEchelonRow basis rowValue)+    )+    (emptySparseEchelonBasis ambientDimension)++emptySparseEchelonBasis :: Int -> SparseEchelonBasis+emptySparseEchelonBasis ambientDimension =+  SparseEchelonBasis+    { sebColumnCount = ambientDimension,+      sebPivotRows = IntMap.empty+    }++sparseEchelonContains :: SparseEchelonBasis -> SparseRow -> Bool+sparseEchelonContains basis =+  IntMap.null . reduceSparseEchelonRow basis++sparseEchelonRank :: SparseEchelonBasis -> Int+sparseEchelonRank =+  IntMap.size . sebPivotRows++adjoinSparseEchelonRow :: SparseEchelonBasis -> SparseRow -> (Maybe SparseRow, SparseEchelonBasis)+adjoinSparseEchelonRow basis rowValue =+  let residualRow =+        reduceSparseEchelonRow basis rowValue+   in case rowLeadingColumn residualRow of+        Nothing ->+          (Nothing, basis)+        Just pivotColumn ->+          let pivotRow =+                normalizeSparseRow pivotColumn residualRow+           in ( Just pivotRow,+                basis {sebPivotRows = IntMap.insert pivotColumn pivotRow (sebPivotRows basis)}+              )++-- | Reduce a row against every pivot of the basis. The input is compacted+-- first: 'SparseRow' is a naked alias, so callers can pass rows carrying+-- explicit zero entries, and an uncompacted row whose leading entry is an+-- explicit zero would otherwise be admitted as a phantom pivot (inflating+-- ranks and corrupting containment answers).+reduceSparseEchelonRow :: SparseEchelonBasis -> SparseRow -> SparseRow+reduceSparseEchelonRow basis rowValue =+  IntMap.foldlWithKey'+    ( \residualRow pivotColumn pivotRow ->+        eliminateColumnFromRow pivotColumn pivotRow residualRow+    )+    (compactSparseRow rowValue)+    (sebPivotRows basis)++sparseSpanRank :: Int -> [SparseRow] -> Int+sparseSpanRank ambientDimension vectorList =+  sparseEchelonRank (sparseEchelonBasis ambientDimension vectorList)++sparseCoordinateBasis :: Int -> [SparseRow] -> SparseCoordinateBasis+sparseCoordinateBasis ambientDimension generatorRows =+  generatorRows+    & zip [0 :: Int ..]+    & List.foldl'+      adjoinSparseCoordinateGenerator+      SparseCoordinateBasis+        { scbAmbientDimension = ambientDimension,+          scbGeneratorCount = length generatorRows,+          scbPivotRows = IntMap.empty+        }++adjoinSparseCoordinateGenerator :: SparseCoordinateBasis -> (Int, SparseRow) -> SparseCoordinateBasis+adjoinSparseCoordinateGenerator basis (generatorIndex, generatorRow) =+  let residual =+        reduceSparseCoordinateGenerator+          basis+          SparseCoordinateResidual+            { scrVector = compactSparseRow generatorRow,+              scrCoordinates = IntMap.singleton generatorIndex 1+            }+   in case rowLeadingColumn (scrVector residual) of+        Nothing -> basis+        Just pivotColumn ->+          let pivot =+                normalizeSparseCoordinatePivot+                  pivotColumn+                  residual+           in basis+                { scbPivotRows =+                    IntMap.insert pivotColumn pivot (scbPivotRows basis)+                }++reduceSparseCoordinateGenerator ::+  SparseCoordinateBasis ->+  SparseCoordinateResidual ->+  SparseCoordinateResidual+reduceSparseCoordinateGenerator basis residual =+  IntMap.foldlWithKey'+    eliminateCoordinateGeneratorPivot+    residual+    (scbPivotRows basis)++eliminateCoordinateGeneratorPivot ::+  SparseCoordinateResidual ->+  Int ->+  SparseCoordinatePivot ->+  SparseCoordinateResidual+eliminateCoordinateGeneratorPivot residual pivotColumn pivot =+  case IntMap.lookup pivotColumn (scrVector residual) of+    Nothing -> residual+    Just coefficient+      | coefficient == 0 -> residual+      | otherwise ->+          SparseCoordinateResidual+            { scrVector =+                eliminateColumnFromRow pivotColumn (scpVector pivot) (scrVector residual),+              scrCoordinates =+                addScaledSparseRow+                  (negate coefficient)+                  (scrCoordinates residual)+                  (scpCoordinates pivot)+            }++normalizeSparseCoordinatePivot ::+  Int ->+  SparseCoordinateResidual ->+  SparseCoordinatePivot+normalizeSparseCoordinatePivot pivotColumn residual =+  case IntMap.lookup pivotColumn (scrVector residual) of+    Nothing ->+      SparseCoordinatePivot+        { scpVector = scrVector residual,+          scpCoordinates = scrCoordinates residual+        }+    Just pivotCoefficient+      | pivotCoefficient == 0 ->+          SparseCoordinatePivot+            { scpVector = scrVector residual,+              scpCoordinates = scrCoordinates residual+            }+      | otherwise ->+          SparseCoordinatePivot+            { scpVector = scaleSparseRow (recip pivotCoefficient) (scrVector residual),+              scpCoordinates = scaleSparseRow (recip pivotCoefficient) (scrCoordinates residual)+            }++sparseCoordinatesInBasis :: SparseCoordinateBasis -> SparseRow -> Maybe SparseRow+sparseCoordinatesInBasis basis rowValue =+  let residual =+        IntMap.foldlWithKey'+          eliminateCoordinateCandidatePivot+          SparseCoordinateResidual+            { scrVector = compactSparseRow rowValue,+              scrCoordinates = IntMap.empty+            }+          (scbPivotRows basis)+   in if IntMap.null (scrVector residual)+        then Just (scrCoordinates residual)+        else Nothing++eliminateCoordinateCandidatePivot ::+  SparseCoordinateResidual ->+  Int ->+  SparseCoordinatePivot ->+  SparseCoordinateResidual+eliminateCoordinateCandidatePivot residual pivotColumn pivot =+  case IntMap.lookup pivotColumn (scrVector residual) of+    Nothing -> residual+    Just coefficient+      | coefficient == 0 -> residual+      | otherwise ->+          SparseCoordinateResidual+            { scrVector =+                eliminateColumnFromRow pivotColumn (scpVector pivot) (scrVector residual),+              scrCoordinates =+                addScaledSparseRow+                  coefficient+                  (scrCoordinates residual)+                  (scpCoordinates pivot)+            }++scaleSparseRow :: Rational -> SparseRow -> SparseRow+scaleSparseRow scalarValue =+  if scalarValue == 0+    then const IntMap.empty+    else+      IntMap.mapMaybe+        ( \coefficient ->+            nonZeroSparseCoefficient (scalarValue * coefficient)+        )++addScaledSparseRow :: Rational -> SparseRow -> SparseRow -> SparseRow+addScaledSparseRow scalarValue leftRow rightRow =+  IntMap.mergeWithKey+    ( \_ leftCoefficient rightCoefficient ->+        nonZeroSparseCoefficient (leftCoefficient + scalarValue * rightCoefficient)+    )+    (IntMap.filter (/= 0))+    (IntMap.mapMaybe (nonZeroSparseCoefficient . (scalarValue *)))+    leftRow+    rightRow++sparseMatrixFromRows :: Int -> [[Rational]] -> SparseMatrix+sparseMatrixFromRows columnCount rows =+  SparseMatrix+    { smRows = fmap sparseRowFromDense rows,+      smColumnCount = columnCount+    }++sparseRowFromDense :: [Rational] -> SparseRow+sparseRowFromDense values =+  values+    & zip [0 :: Int ..]+    & List.foldl'+      ( \rowValue (columnIndex, coefficient) ->+          if coefficient == 0+            then rowValue+            else IntMap.insert columnIndex coefficient rowValue+      )+      IntMap.empty++sparseRowToDense :: Int -> SparseRow -> [Rational]+sparseRowToDense ambientDimension rowValue =+  enumerateFromZero ambientDimension+    & fmap (\columnIndex -> sparseRowLookup columnIndex rowValue)
+ src-matrix/Moonlight/Homology/Pure/Matrix/Validated.hs view
@@ -0,0 +1,197 @@+module Moonlight.Homology.Pure.Matrix.Validated+  ( ValidatedMatrix,+    matrixRowCount,+    matrixColumnCount,+    matrixRows,+    mkValidatedMatrix,+    validatedMatrixFromRows,+    zeroValidatedMatrix,+    validatedMatrixFromColumns,+    transposeValidatedMatrix,+    validatedDiagonal,+    validatedColumnAt,+    selectValidatedRows,+    selectValidatedColumns,+    applyValidatedMatrix,+  )+where++import Data.Kind (Type)+import Data.Function ((&))+import qualified Data.List as List+import Data.Maybe (mapMaybe)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))++type ValidatedMatrix :: Type -> Type+data ValidatedMatrix a = ValidatedMatrix+  { matrixRowCount :: Int,+    matrixColumnCount :: Int,+    matrixRows :: [[a]]+  }+  deriving stock (Eq, Show)++mkValidatedMatrix :: Int -> Int -> [[a]] -> Either HomologyFailure (ValidatedMatrix a)+mkValidatedMatrix rowCount columnCount rows+  | rowCount < 0 || columnCount < 0 =+      Left (InvalidMatrixShape "validated matrix received a negative shape")+  | length rows /= rowCount =+      Left+        ( InvalidMatrixShape+            ( "validated matrix expected "+                <> show rowCount+                <> " rows but received "+                <> show (length rows)+            )+        )+  | not (all ((== columnCount) . length) rows) =+      Left+        ( InvalidMatrixShape+            ( "validated matrix expected every row to have width "+                <> show columnCount+            )+        )+  | otherwise =+      Right+        ValidatedMatrix+          { matrixRowCount = rowCount,+            matrixColumnCount = columnCount,+            matrixRows = rows+          }++validatedMatrixFromRows :: [[a]] -> Either HomologyFailure (ValidatedMatrix a)+validatedMatrixFromRows rows =+  mkValidatedMatrix+    (length rows)+    (inferredColumnCount rows)+    rows++zeroValidatedMatrix :: Num a => Int -> Int -> Either HomologyFailure (ValidatedMatrix a)+zeroValidatedMatrix rowCount columnCount =+  mkValidatedMatrix+    rowCount+    columnCount+    (replicate rowCount (replicate columnCount 0))++validatedMatrixFromColumns :: Int -> [[a]] -> Either HomologyFailure (ValidatedMatrix a)+validatedMatrixFromColumns rowCount columnVectors = do+  _ <- traverse (validateVectorDimension rowCount) columnVectors+  mkValidatedMatrix+    rowCount+    (length columnVectors)+    ( if null columnVectors+        then replicate rowCount []+        else List.transpose columnVectors+    )++transposeValidatedMatrix :: ValidatedMatrix a -> ValidatedMatrix a+transposeValidatedMatrix matrixValue =+  ValidatedMatrix+    { matrixRowCount = matrixColumnCount matrixValue,+      matrixColumnCount = matrixRowCount matrixValue,+      matrixRows =+        if matrixRowCount matrixValue == 0+          then replicate (matrixColumnCount matrixValue) []+          else List.transpose (matrixRows matrixValue)+    }++validatedDiagonal :: ValidatedMatrix a -> [a]+validatedDiagonal matrixValue =+  matrixRows matrixValue+    & zip [0 :: Int ..]+    & mapMaybe (\(indexValue, rowValue) -> safeElementAt indexValue rowValue)++validatedColumnAt ::+  Int ->+  ValidatedMatrix a ->+  Either HomologyFailure [a]+validatedColumnAt columnIndexValue matrixValue+  | columnIndexValue < 0 || columnIndexValue >= matrixColumnCount matrixValue =+      Left (InvalidMatrixShape "column selection index is outside the matrix bounds")+  | otherwise =+      -- Every row is validated to width 'matrixColumnCount', so after the+      -- bounds check the element exists in each row; for a zero-row matrix+      -- the column is correctly []. (Going through 'List.transpose' here+      -- loses legal columns of 0×n matrices: transpose [] = [].)+      Right (mapMaybe (safeElementAt columnIndexValue) (matrixRows matrixValue))++selectValidatedRows ::+  [Int] ->+  ValidatedMatrix a ->+  Either HomologyFailure (ValidatedMatrix a)+selectValidatedRows rowIndices matrixValue = do+  selectedRows <-+    traverse+      ( \rowIndexValue ->+          maybe+            (Left (InvalidMatrixShape "row selection index is outside the matrix bounds"))+            Right+            (safeElementAt rowIndexValue (matrixRows matrixValue))+      )+      rowIndices+  mkValidatedMatrix+    (length selectedRows)+    (matrixColumnCount matrixValue)+    selectedRows++selectValidatedColumns ::+  [Int] ->+  ValidatedMatrix a ->+  Either HomologyFailure (ValidatedMatrix a)+selectValidatedColumns columnIndices matrixValue = do+  selectedRows <-+    traverse+      ( \rowValue ->+          traverse+            ( \columnIndexValue ->+                maybe+                  (Left (InvalidMatrixShape "column selection index is outside the matrix bounds"))+                  Right+                  (safeElementAt columnIndexValue rowValue)+            )+            columnIndices+      )+      (matrixRows matrixValue)+  mkValidatedMatrix+    (matrixRowCount matrixValue)+    (length columnIndices)+    selectedRows++applyValidatedMatrix ::+  Num a =>+  ValidatedMatrix a ->+  [a] ->+  Either HomologyFailure [a]+applyValidatedMatrix matrixValue vectorValue = do+  _ <- validateVectorDimension (matrixColumnCount matrixValue) vectorValue+  pure+    ( matrixRows matrixValue+        & fmap (\rowValue -> sum (zipWith (*) rowValue vectorValue))+    )++safeElementAt :: Int -> [a] -> Maybe a+safeElementAt indexValue _+  | indexValue < 0 = Nothing+safeElementAt indexValue values =+  case drop indexValue values of+    value : _ -> Just value+    [] -> Nothing++validateVectorDimension :: Int -> [a] -> Either HomologyFailure [a]+validateVectorDimension expectedDimension vectorValue =+  if length vectorValue == expectedDimension+    then Right vectorValue+    else+      Left+        ( InvalidMatrixShape+            ( "vector length "+                <> show (length vectorValue)+                <> " does not match the expected matrix width "+                <> show expectedDimension+            )+        )++inferredColumnCount :: [[a]] -> Int+inferredColumnCount rows =+  case rows of+    rowValue : _ -> length rowValue+    [] -> 0
+ src-matrix/Moonlight/Homology/Pure/Rank/Field.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Homology.Pure.Rank.Field+  ( FieldRankBackend (..),+    fieldBettiCapability,+  )+where++import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Kind (Type)+import Data.Maybe (listToMaybe)+import Moonlight.Core (Semiring, mkCapability)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    degreeCardinality,+    incidenceMatrixAt,+    maxHomologicalDegree,+    validateFiniteChainComplexShape,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryIncidence,+    BoundaryIncidenceShapeError,+    boundaryEntries,+    composeBoundaryIncidence,+  )+import Moonlight.Homology.Pure.Matrix.Reducer+  ( BettiCapability,+    BettiReducer (..),+  )+import Moonlight.Homology.Pure.Degree+  ( HomologicalDegree (..),+  )+import Moonlight.Homology.Pure.Failure+  ( HomologyFailure (..),+  )+import Moonlight.Homology.Pure.Group+  ( HomologyGroup (..),+  )+import Moonlight.Homology.Pure.Phase+  ( RequirePhase2,+  )+import Moonlight.Homology.Pure.Rank.GF2+  ( GF2RankFailure,+    gf2BoundaryRank,+  )+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseRref (..),+    sparseBoundaryMatrixWith,+    sparseRref,+  )+import Moonlight.LinAlg.Pure.Dense.GF2+  ( GF2,+  )++type FieldRankBackend :: Type -> Type+data FieldRankBackend coeff where+  RationalFieldRankBackend :: FieldRankBackend Rational+  GF2FieldRankBackend :: FieldRankBackend GF2++deriving stock instance Eq (FieldRankBackend coeff)++deriving stock instance Show (FieldRankBackend coeff)++type FieldRankFailure :: Type+data FieldRankFailure+  = FieldRankGF2Failed !GF2RankFailure+  deriving stock (Eq, Show)++type FieldHomologyFailure :: Type -> Type+data FieldHomologyFailure coeff+  = FieldHomologyInvalidChainShape !HomologyFailure+  | FieldHomologyBoundaryShapeFailed !HomologicalDegree !BoundaryIncidenceShapeError+  | FieldHomologyNonNilpotent !HomologicalDegree !(BoundaryIncidence coeff)+  | FieldHomologyRankFailed !HomologicalDegree !FieldRankFailure+  | FieldHomologyRankMissing !HomologicalDegree+  | FieldHomologyNegativeDimension !HomologicalDegree !Int !Int !Int+  deriving stock (Eq, Show)++fieldBettiCapability ::+  RequirePhase2 phase =>+  FieldRankBackend coeff ->+  BettiCapability phase coeff+fieldBettiCapability backend =+  mkCapability (fieldBettiReducer backend)+{-# INLINEABLE fieldBettiCapability #-}++fieldBettiReducer ::+  FieldRankBackend coeff ->+  BettiReducer coeff+fieldBettiReducer backend =+  BettiReducer $+    first fieldHomologyFailureToHomologyFailure+      . fieldBettiGroups backend+{-# INLINEABLE fieldBettiReducer #-}++fieldBettiGroups ::+  FieldRankBackend coeff ->+  FiniteChainComplex coeff ->+  Either (FieldHomologyFailure coeff) [HomologyGroup coeff]+fieldBettiGroups backend finite =+  IntMap.elems <$> fieldBettiGroupsByDegree backend finite+{-# INLINEABLE fieldBettiGroups #-}++fieldBettiGroupsByDegree ::+  FieldRankBackend coeff ->+  FiniteChainComplex coeff ->+  Either (FieldHomologyFailure coeff) (IntMap (HomologyGroup coeff))+fieldBettiGroupsByDegree backend finite =+  case backend of+    RationalFieldRankBackend ->+      fieldBettiGroupsWith rationalRank finite+    GF2FieldRankBackend ->+      fieldBettiGroupsWith rankGF2Boundary finite+{-# INLINEABLE fieldBettiGroupsByDegree #-}++fieldBettiGroupsWith ::+  (Eq coeff, Num coeff, Semiring coeff) =>+  (BoundaryIncidence coeff -> Either FieldRankFailure Int) ->+  FiniteChainComplex coeff ->+  Either (FieldHomologyFailure coeff) (IntMap (HomologyGroup coeff))+fieldBettiGroupsWith rankBoundary finite = do+  first FieldHomologyInvalidChainShape $+    validateFiniteChainComplexShape finite+  traverse_ (validateNilpotenceAt finite) (positiveDegrees finite)+  rankByDegree <- rankBoundariesByDegree rankBoundary finite+  IntMap.fromAscList+    <$> traverse (fieldHomologyAt rankByDegree) (degrees finite)+  where+    fieldHomologyAt rankByDegree degreeValue@(HomologicalDegree degreeInt) = do+      let chainDimension =+            degreeCardinality finite degreeValue+      boundaryRank <-+        rankAt rankByDegree degreeValue+      nextBoundaryRank <-+        rankAt rankByDegree (HomologicalDegree (degreeInt + 1))+      let homologyDimension =+            chainDimension - boundaryRank - nextBoundaryRank+      if homologyDimension < 0+        then+          Left+            ( FieldHomologyNegativeDimension+                degreeValue+                chainDimension+                boundaryRank+                nextBoundaryRank+            )+        else+          Right+            ( degreeInt,+              HomologyGroup+                { freeRank = homologyDimension,+                  torsionInvariants = []+                }+            )++-- | Ranks of every boundary map the homology formula consults. Degrees above+-- 'maxHomologicalDegree' are zero by the complex's own convention+-- ('degreeCardinality' clamps them to cardinality 0), so the rank at+-- @max + 1@ is 0 by definition — it is deliberately NOT read from the raw+-- incidence function, which is unvalidated beyond the top degree and would+-- otherwise silently corrupt the top homology group.+rankBoundariesByDegree ::+  (BoundaryIncidence coeff -> Either FieldRankFailure Int) ->+  FiniteChainComplex coeff ->+  Either (FieldHomologyFailure coeff) (IntMap Int)+rankBoundariesByDegree rankBoundary finite =+  IntMap.insert (maxDegreeInt + 1) 0 . IntMap.fromAscList+    <$> traverse rankBoundaryAt (degrees finite)+  where+    HomologicalDegree maxDegreeInt = maxHomologicalDegree finite+    rankBoundaryAt degreeValue@(HomologicalDegree degreeInt) =+      fmap+        (\rankValue -> (degreeInt, rankValue))+        ( first (FieldHomologyRankFailed degreeValue) $+            rankBoundary (incidenceMatrixAt finite degreeValue)+        )+{-# INLINEABLE rankBoundariesByDegree #-}++rankAt ::+  IntMap Int ->+  HomologicalDegree ->+  Either (FieldHomologyFailure coeff) Int+rankAt rankByDegree degreeValue@(HomologicalDegree degreeInt) =+  maybe+    (Left (FieldHomologyRankMissing degreeValue))+    Right+    (IntMap.lookup degreeInt rankByDegree)+{-# INLINE rankAt #-}++degrees ::+  FiniteChainComplex coeff ->+  [HomologicalDegree]+degrees finite =+  case maxHomologicalDegree finite of+    HomologicalDegree maxDegreeValue ->+      fmap HomologicalDegree [0 .. maxDegreeValue]+{-# INLINE degrees #-}++positiveDegrees ::+  FiniteChainComplex coeff ->+  [HomologicalDegree]+positiveDegrees finite =+  case maxHomologicalDegree finite of+    HomologicalDegree maxDegreeValue ->+      fmap HomologicalDegree [1 .. maxDegreeValue]+{-# INLINE positiveDegrees #-}++validateNilpotenceAt ::+  (Eq coeff, Num coeff, Semiring coeff) =>+  FiniteChainComplex coeff ->+  HomologicalDegree ->+  Either (FieldHomologyFailure coeff) ()+validateNilpotenceAt finite degreeValue@(HomologicalDegree degreeInt) =+  case+    composeBoundaryIncidence+      (incidenceMatrixAt finite (HomologicalDegree (degreeInt - 1)))+      (incidenceMatrixAt finite degreeValue)+  of+    Left shapeError ->+      Left (FieldHomologyBoundaryShapeFailed degreeValue shapeError)+    Right composite ->+      case listToMaybe (boundaryEntries composite) of+        Nothing ->+          Right ()+        Just _ ->+          Left (FieldHomologyNonNilpotent degreeValue composite)+{-# INLINEABLE validateNilpotenceAt #-}++rationalRank ::+  BoundaryIncidence Rational ->+  Either FieldRankFailure Int+rationalRank =+  Right+    . length+    . srrefPivots+    . sparseRref+    . sparseBoundaryMatrixWith id+{-# INLINE rationalRank #-}++rankGF2Boundary ::+  BoundaryIncidence GF2 ->+  Either FieldRankFailure Int+rankGF2Boundary =+  first FieldRankGF2Failed . gf2BoundaryRank+{-# INLINEABLE rankGF2Boundary #-}++fieldHomologyFailureToHomologyFailure ::+  FieldHomologyFailure coeff ->+  HomologyFailure+fieldHomologyFailureToHomologyFailure failureValue =+  case failureValue of+    FieldHomologyInvalidChainShape failure ->+      failure+    FieldHomologyBoundaryShapeFailed degreeValue shapeError ->+      InvalidBoundaryIncidence+        ("field homology boundary composition failed at " <> show degreeValue <> ": " <> show shapeError)+    FieldHomologyNonNilpotent (HomologicalDegree degreeInt) _composite ->+      -- 'validateNilpotenceAt' composes ∂ at (degree - 1, degree); the+      -- convention (matching 'adjacentNilpotenceAt' in Boundary.Finite)+      -- names the lower degree of the composed pair, so the same failure+      -- surfaces as the same constructor on every detection path.+      ChainComplexNilpotenceViolation (degreeInt - 1)+    FieldHomologyRankFailed degreeValue rankFailure ->+      BackendFailure+        ("field homology rank failed at " <> show degreeValue <> ": " <> show rankFailure)+    FieldHomologyRankMissing degreeValue ->+      BackendFailure+        ("field homology rank cache missed degree " <> show degreeValue)+    FieldHomologyNegativeDimension degreeValue chainDimension boundaryRank nextBoundaryRank ->+      InvalidTopologyInput+        ( "field homology dimension went negative at "+            <> show degreeValue+            <> ": chain="+            <> show chainDimension+            <> ", boundaryRank="+            <> show boundaryRank+            <> ", nextBoundaryRank="+            <> show nextBoundaryRank+        )+{-# INLINE fieldHomologyFailureToHomologyFailure #-}
+ src-matrix/Moonlight/Homology/Pure/Rank/GF2.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Homology.Pure.Rank.GF2+  ( GF2RankFailure (..),+    PreparedGF2Boundary,+    pgbIncidence,+    pgbPackedMatrix,+    prepareGF2Boundary,+    rankPreparedGF2Boundary,+    gf2BoundaryRank,+  )+where++import Data.Bifunctor+  ( first,+  )+import Data.Kind+  ( Type,+  )+import Data.Maybe+  ( mapMaybe,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    BoundaryIncidence,+    BoundaryIncidenceShapeError,+    boundaryCoefficient,+    boundaryEntries,+    mkBoundaryIncidence,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.LinAlg.Pure.Dense.GF2+  ( GF2 (..),+    GF2MatrixEntry (..),+    GF2PackedMatrix,+    GF2PackedMatrixFailure,+    mkGF2PackedMatrix,+    rankGF2PackedMatrix,+  )+import Numeric.Natural+  ( Natural,+  )++type GF2RankFailure :: Type+data GF2RankFailure+  = GF2RankNegativeSourceCardinality !Int+  | GF2RankNegativeTargetCardinality !Int+  | GF2RankBoundaryShapeInvalid !BoundaryIncidenceShapeError+  | GF2RankPackedMatrixInvalid !GF2PackedMatrixFailure+  deriving stock (Eq, Show)++type PreparedGF2Boundary :: Type+data PreparedGF2Boundary = PreparedGF2Boundary+  { preparedBoundaryIncidence :: !(BoundaryIncidence GF2),+    preparedBoundaryPackedMatrix :: !GF2PackedMatrix+  }+  deriving stock (Eq, Show)++pgbIncidence :: PreparedGF2Boundary -> BoundaryIncidence GF2+pgbIncidence =+  preparedBoundaryIncidence++pgbPackedMatrix :: PreparedGF2Boundary -> GF2PackedMatrix+pgbPackedMatrix =+  preparedBoundaryPackedMatrix++prepareGF2Boundary ::+  BoundaryIncidence GF2 ->+  Either GF2RankFailure PreparedGF2Boundary+prepareGF2Boundary incidence = do+  sourceDimension <- sourceCardinalityNatural incidence+  targetDimension <- targetCardinalityNatural incidence+  canonicalIncidence <-+    first GF2RankBoundaryShapeInvalid $+      mkBoundaryIncidence sourceDimension targetDimension (boundaryEntries incidence)+  packedMatrix <-+    first GF2RankPackedMatrixInvalid $+      mkGF2PackedMatrix+        targetDimension+        sourceDimension+        (boundaryEntryMatrixEntry <$> nonzeroEntries canonicalIncidence)+  Right+    PreparedGF2Boundary+      { preparedBoundaryIncidence = canonicalIncidence,+        preparedBoundaryPackedMatrix = packedMatrix+      }+{-# INLINEABLE prepareGF2Boundary #-}++rankPreparedGF2Boundary :: PreparedGF2Boundary -> Int+rankPreparedGF2Boundary =+  rankGF2PackedMatrix . preparedBoundaryPackedMatrix+{-# INLINE rankPreparedGF2Boundary #-}++gf2BoundaryRank ::+  BoundaryIncidence GF2 ->+  Either GF2RankFailure Int+gf2BoundaryRank =+  fmap rankPreparedGF2Boundary . prepareGF2Boundary+{-# INLINEABLE gf2BoundaryRank #-}++nonzeroEntries :: BoundaryIncidence GF2 -> [BoundaryEntry GF2]+nonzeroEntries =+  mapMaybe nonzeroEntry . boundaryEntries+  where+    nonzeroEntry entry =+      case boundaryCoefficient entry of+        GF2Zero -> Nothing+        GF2One -> Just entry+{-# INLINE nonzeroEntries #-}++boundaryEntryMatrixEntry :: BoundaryEntry GF2 -> GF2MatrixEntry+boundaryEntryMatrixEntry entry =+  GF2MatrixEntry+    { gf2EntryRow = targetIndex entry,+      gf2EntryColumn = sourceIndex entry+    }+{-# INLINE boundaryEntryMatrixEntry #-}++sourceCardinalityNatural ::+  BoundaryIncidence r ->+  Either GF2RankFailure Natural+sourceCardinalityNatural incidence =+  nonnegativeNatural+    (GF2RankNegativeSourceCardinality (sourceCardinality incidence))+    (sourceCardinality incidence)+{-# INLINE sourceCardinalityNatural #-}++targetCardinalityNatural ::+  BoundaryIncidence r ->+  Either GF2RankFailure Natural+targetCardinalityNatural incidence =+  nonnegativeNatural+    (GF2RankNegativeTargetCardinality (targetCardinality incidence))+    (targetCardinality incidence)+{-# INLINE targetCardinalityNatural #-}++nonnegativeNatural ::+  failure ->+  Int ->+  Either failure Natural+nonnegativeNatural failureValue value =+  if value < 0+    then Left failureValue+    else Right (fromIntegral value)+{-# INLINE nonnegativeNatural #-}
+ src-public/Moonlight/Homology.hs view
@@ -0,0 +1,506 @@+module Moonlight.Homology+  ( HomologyBackendTag (..),+    HomologyBackend (..),+    homologyBackendTag,+    runHomologyBackend,+    GraphBoundaryGF2,+    gbgf2VertexIndex,+    gbgf2Edges,+    gbgf2Boundary,+    GraphBoundaryGF2Failure (..),+    prepareGraphBoundaryGF2,+    graphBoundaryRankDefectGF2,+    FiniteChainComplex,+    mkFiniteChainComplexChecked,+    maxHomologicalDegree,+    incidenceMatrixAt,+    degreeCardinality,+    basisCellNodeId,+    finiteChainBasisRefsAtDegree,+    basisIndexCellMapAtDegree,+    inverseBasisRefMap,+    validateFiniteChainComplexShape,+    restrictComplex,+    BoundaryScope (..),+    ScopedBoundary (..),+    BoundaryIncidenceShapeError (..),+    BoundaryEntry,+    sourceIndex,+    targetIndex,+    boundaryCoefficient,+    mkBoundaryEntry,+    mkBoundaryEntryFromInts,+    BoundaryIncidence,+    sourceCardinality,+    targetCardinality,+    boundaryEntries,+    mkBoundaryIncidence,+    mkBoundaryIncidenceFromOrderedEntries,+    overlapBoundaryIncidence,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    identityBoundaryIncidenceOf,+    directSumBoundaryIncidence,+    reindexBoundaryIncidenceWith,+    boundaryIncidenceApply,+    transposeBoundaryIncidence,+    composeBoundaryIncidence,+    boundaryIncidenceDiagonal,+    addBoundaryIncidence,+    mapBoundaryCoefficients,+    BlockBoundaryEntry,+    blockSourceIndex,+    blockTargetIndex,+    blockSubmatrix,+    mkBlockBoundaryEntry,+    BlockBoundaryIncidence,+    blockSourceDimensions,+    blockTargetDimensions,+    blockEntries,+    mkBlockBoundaryIncidence,+    flattenBlockIncidence,+    scaleBoundaryIncidence,+    materializeIncidenceBoundary,+    materializeBoundary,+    FieldRankBackend (..),+    fieldBettiCapability,+    GF2RankFailure (..),+    PreparedGF2Boundary,+    pgbIncidence,+    pgbPackedMatrix,+    prepareGF2Boundary,+    rankPreparedGF2Boundary,+    gf2BoundaryRank,+    SmithNormalForm (..),+    SNFReducer (..),+    SNFCapability,+    computeSmithNormalForm,+    HomologicalDegree (..),+    incrementDegree,+    decrementDegree,+    EulerCharacteristic (..),+    PersistencePair (..),+    RepresentativeChain (..),+    RepresentativeCycle,+    RepresentativeCocycle,+    HarmonicBasisElement (..),+    ExactRepresentativeClass (..),+    TopologyWitness (..),+    emptyTopologyWitness,+    mergeTopologyWitness,+    mergeTopologyWitnessChecked,+    topologyRepresentativeCycles,+    topologyRepresentativeCocycles,+    topologyWitnessFromBetti,+    BettiReducer (..),+    BettiCapability,+    computeBettiNumbers,+    TopologyWitnessReducer (..),+    TopologyWitnessCapability,+    computeTopologyWitness,+    EffectiveHomology,+    sourceComplex,+    reducedComplex,+    reductionWitness,+    finiteBoundary,+    mkEffectiveHomology,+    HomologyLaw (..),+    NonEffectiveCause (..),+    TopologyInputObstruction (..),+    HomologyFailure (..),+    FiniteAbelianTorsion,+    mkFiniteAbelianTorsion,+    torsionFromHomologyGroup,+    finiteAbelianInvariants,+    normalizeTorsionOrders,+    finiteAbelianSummandCount,+    finiteAbelianCyclicSummandMultiplicity,+    finiteAbelianFilteredCardinality,+    finiteAbelianCardinality,+    finiteAbelianExponent,+    finiteAbelianOrderSupport,+    finiteAbelianPrimaryOrderSupport,+    finiteAbelianExactOrderElementCount,+    isPrime,+    matchesOptional,+    DegreeSelection (..),+    GradedAggregation (..),+    GradedQuery (..),+    selectAllDegrees,+    selectDegree,+    degreeSelectionFromMaybe,+    combineSelectedQuery,+    preserveDegreewiseQuery,+    matchesDegreeSelection,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    selectDegreeIndexed,+    selectGradedMembers,+    countGradedMembers,+    directProductQuery,+    degreewiseUnionQuery,+    GradedTorsionFamily,+    mkGradedTorsionFamily,+    gradedTorsionPresent,+    gradedTorsionAtDegree,+    gradedTorsionCombined,+    gradedTorsionOrderSupport,+    gradedTorsionPrimaryOrderSupport,+    HomologyGroup (..),+    HomologyPhase (..),+    RequirePhase2,+    RequirePhase4,+    requirePhase2Witness,+    requirePhase4Witness,+    ChainMap (..),+    ChainHomotopy (..),+    Reduction (..),+    ReductionWitness,+    checkedReduction,+    ReductionLawContext (..),+    ReductionViolation (..),+    Validation (..),+    ReductionValidation,+    ReductionChecks (..),+    mkReductionWitness,+    MayerVietorisReducer (..),+    MayerVietorisCapability,+    mayerVietoris,+    FiltrationFunction,+    Bidegree,+    mkBidegree,+    bidegreeFromTotalDegree,+    bidegreeCoordinates,+    bidegreeFiltrationDegree,+    bidegreeComplementaryDegree,+    bidegreeTotalDegree,+    targetBidegreeAfterDifferential,+    FormalMap (..),+    RationalFormalMap,+    SpectralEntry (..),+    RationalSpectralEntry,+    SpectralPage (..),+    RationalSpectralPage,+    SpectralChain,+    SpectralFamily (..),+    RationalSpectralFamily,+    SpectralAdvance (..),+    SpectralCapability,+    nextPage,+    computeRationalSpectralFamily,+    computeRationalSpectralPages,+    stableSpectralPage,+    convergenceDepth,+    isKPassParseable,+    SkeletonSignature (..),+    skeletonSignatureWithinTolerance,+    macroScaffoldSignature,+    macroScaffoldSummaryAlgebra,+    mkMacroScaffoldTopologyView,+    mkMacroScaffoldWitnessInterpreter,+    TopologyObserver,+    runTopologyObserver,+    WitnessInterpreter,+    mkWitnessInterpreter,+    runWitnessInterpreter,+    observeEulerCharacteristic,+    observeBettiVector,+    observeIntegralHomology,+    observeIntegralHomologyAt,+    observeTorsionFamily,+    observeExactRepresentativeClasses,+    observeExactRepresentativeClassCount,+    observePersistencePairs,+    observePersistenceCount,+    observeCoefficientRepresentativeCycles,+    observeCoefficientRepresentativeCycleCount,+    observeCoefficientRepresentativeCocycles,+    observeCoefficientRepresentativeCocycleCount,+    observeHarmonicBasis,+    observeHarmonicCount,+    observeMacroScaffold,+    observeScaffoldSummary,+    observeLowSpectralModes,+    ScaffoldSummaryAlgebra,+    mkScaffoldSummaryAlgebra,+    runScaffoldSummaryAlgebra,+    TopologyView,+    WitnessSlice,+    mkTopologyView,+    runWitnessSlice,+    topologyViewTorsionFamily,+    sliceEulerCharacteristic,+    sliceBettiVector,+    sliceIntegralHomology,+    sliceIntegralHomologyAt,+    sliceExactRepresentativeClasses,+    slicePersistencePairs,+    sliceCoefficientRepresentativeCycles,+    sliceCoefficientRepresentativeCocycles,+    sliceHarmonicBasis,+    sliceMacroScaffold,+    sliceScaffoldSummary,+    sliceLowSpectralModes,+    CellTypes (..),+    Dimension (..),+    CellRef (..),+    cellDimension,+    OrientedEdge (..),+    CellComplex2D (..),+    ValidateComplex2D (..),+    isBoundaryEdge,+    isInteriorEdge,+    eulerCharacteristic,+    BasisCellRef (..),+    MorsePivotOps (..),+    TopologyObservationConfig (..),+    defaultTopologyObservationConfig,+    TopologyWitnessSeed (..),+    CriticalKind (..),+    PotentialValue,+    PotentialValueError (..),+    unPotentialValue,+    mkPotentialValue,+    PotentialNormalization (..),+    CellCarrier,+    CellCarrierError (..),+    carrierDegree,+    carrierCells,+    mkCellCarrier,+    ScalarPotentialField,+    ScalarPotentialFieldError (..),+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+    mkScalarPotentialField,+    mkScalarPotentialFieldFromSamples,+    DirectionSymmetryOrder,+    DirectionSymmetryOrderError (..),+    unDirectionSymmetryOrder,+    mkDirectionSymmetryOrder,+    DirectionPhase,+    DirectionPhaseError (..),+    unDirectionPhase,+    mkDirectionPhase,+    DirectionCoefficient,+    DirectionCoefficientError (..),+    unDirectionCoefficient,+    mkDirectionCoefficient,+    DirectionFieldEncoding (..),+    DirectionField,+    DirectionFieldError (..),+    directionFieldCarrier,+    directionFieldSymmetryOrder,+    directionFieldEncoding,+    mkDirectionField,+    mkDirectionAngleField,+    mkDirectionCochainField,+    ReebNodeId (..),+    ReebArcId (..),+    MorseReebNode (..),+    Monotonicity (..),+    MorseReebArc (..),+    MorseReebScaffold (..),+    SingularityIndex (..),+    SingularityId (..),+    Singularity (..),+    HarmonicLoopId (..),+    HarmonicLoopWeight (..),+    HarmonicLoopPeriod (..),+    HarmonicLoop (..),+    MacroScaffoldIR (..),+    MacroScaffoldCompositionError (..),+    StitchRoute (..),+    StitchRouteKey (..),+    StitchBoundarySide (..),+    StitchSupportSelection (..),+    StitchSupportRefinement (..),+    StitchSemantics (..),+    MacroScaffoldStitchError (..),+    composeMacroScaffoldsWithScopes,+    composeMacroScaffolds,+    stitchMacroScaffoldRoutes,+    GraphEdge (..),+    Graph1Skeleton (..),+    graphAdjacency,+    GraphSkeletonExtractionFailure (..),+    GraphSpectralMode (..),+    eulerCharacteristicOf,+    integralHomologyGroupsOf,+    exactRepresentativeClassesOf,+    freeBettiVector,+    representativeCyclesOverQ,+    representativeCocyclesOverQ,+    homologyBasisAt,+    cohomologyBasisAt,+    sparseHomologyBasisAt,+    sparseCohomologyBasisAt,+    sparseFreeBettiVector,+    sparseQuotientRepresentatives,+    QuotientPresentation (..),+    mkQuotientPresentation,+    presentationCoordinates,+    quotientRepresentatives,+    vectorToRepresentative,+    representativeToVector,+    exactTopologyWitness,+    TopologyTarget (..),+    TargetViolation (..),+    topologyTargetConstraints,+    validateTarget,+    validateTargets,+    validateTopologyTarget,+    validateTopologyTargets,+    graphFromEdgeSupports,+    graph1SkeletonFromComplex,+    graphFiniteChainComplex,+    graphMacroScaffold,+    graphSpectralModes,+    graphTopologyWitness,+    criticalKindAt,+    lowerNeighborEdges,+    lowerNeighbors,+    higherNeighborEdges,+    higherNeighbors,+    addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+    observeGraphTopologyWitness,+    observeTopologyWitnessSeed,+    observeTopologyWitness,+    Orientation (..),+    RawCellData (..),+    RawCellScopes (..),+    RealizationBudget (..),+    realizeScaffoldRawWithScopes,+    realizeScaffoldRaw,+    intUnitMorsePivotOps,+    integerUnitMorsePivotOps,+    rationalMorsePivotOps,+    gf2MorsePivotOps,+    AlgebraicMorsePair,+    AlgebraicMorseMatching,+    AlgebraicMorseComplex,+    AcyclicPair (..),+    IntegralAcyclicPair,+    LocalizedAcyclicPair (..),+    RationalAcyclicPair,+    CollapseObstruction (..),+    LocalizedCollapseObstruction (..),+    AcyclicMatching (..),+    LocalizedAcyclicMatching (..),+    MorseComplex (..),+    LocalizedMorseComplex (..),+    RefinedMatchingStage,+    RefinedAcyclicMatching,+    RefinedMorseComplex (..),+    FilteredMorsePairWitness (..),+    FilteredMorseCompatibility (..),+    FilteredRefinedMorseComplex (..),+    RefinedMatchingSummary (..),+    acyclicMatching,+    acyclicMatchingLocalized,+    refinedAcyclicMatchingTranscript,+    refinedMorseComplex,+    filteredRefinedMorseComplex,+    reducedFiltrationByCriticalBasis,+    filteredReducedFiltration,+    rationalizeFiniteChainComplex,+    foldRefinedAcyclicMatching,+    traverseRefinedStages,+    mapRefinedStages,+    summarizeRefinedMatching,+    refinedMatchingSummary,+    refinedStageCount,+    hasRefinedStages,+    isTerminalRefinedMatching,+    finalRefinedCriticalDegrees,+    finalRefinedCriticalCellCount,+    finalRefinedCriticalDegreeHistogram,+    finalRefinedHomologicalSupport,+    finalRefinedMaxCriticalDegree,+    refinedMatchingCriticalCells,+    refinedStageMatching,+    refinedStageReducedComplex,+    refinedStageCriticalBasis,+    flattenRefinedAcyclicMatching,+    refinedAcyclicMatching,+    acyclicMatchingWith,+    morseComplexWith,+    isAcyclicMatchingWith,+    extractCandidatePairsWith,+    reverseCandidateEdgeWith,+    morseComplex,+    morseComplexLocalized,+    isAcyclicMatching,+    isAcyclicMatchingLocalized,+    extractCandidatePairsLocalized,+    reverseCandidateEdgeLocalized,+    BasisBlock (..),+    BlockSchurPivot (..),+    BlockPivotOps (..),+    integerUnimodularBlockPivotOps,+    rationalBlockPivotOps,+    gf2BlockPivotOps,+    BlockSchurTranscript (..),+    BlockSchurReduction (..),+    BlockSchurFailure (..),+    blockSchurReduceWith,+    BiFilteredCell (..),+    BiPersistencePair (..),+    FiltrationValue (..),+    FilteredFiniteChainComplex (..),+    mkFilteredFiniteChainComplex,+    mod2PersistentPairs,+    mod2PersistenceTopologyWitness,+    Bound (..),+    TargetBetti (..),+    PersistenceBudget (..),+    EulerBound (..),+    LoopSemanticRole (..),+    LoopRole (..),+    RequireTorsionInvariant (..),+    RequireElementOrder (..),+    RequireOrderSupport (..),+    PrimaryOrderSupportBudget (..),+    RequirePrimaryOrderSupport (..),+    TorsionBudgetMeasure (..),+    TorsionBudget (..),+    RequireCyclicOrder (..),+    SingularityBudget (..),+    HarmonicLoopBudget (HarmonicLoopBudget, harmonicLoopCountBound),+    SkeletonAdherence (..),+    TopologicalConstraint (..),+    TopologicalViolation (..),+    evaluateTopologicalConstraint,+    evaluateTopologicalConstraints+  )+where++import Moonlight.Homology.Backend as BackendX+import Moonlight.Homology.Boundary.GraphGF2 as GraphGF2X+import Moonlight.Homology.Boundary.Finite as FiniteX+import Moonlight.Homology.Boundary.LinAlg as LinAlgX+import Moonlight.Homology.Boundary.SNF as SnfX+import Moonlight.Homology.Pure.Topology.Morse as MorseX+import Moonlight.Homology.Pure.Topology.BlockSchur as BlockSchurX+import Moonlight.Homology.Persistence as PersistenceX+import Moonlight.Homology.Rank.Field as FieldRankX+import Moonlight.Homology.Rank.GF2 as GF2RankX+import Moonlight.Homology.Pure.Chain as ChainX+import Moonlight.Homology.Pure.Matrix.Reducer as ReducerX+import Moonlight.Homology.Pure.Constraint+import Moonlight.Homology.Pure.Effective as EffectiveX+import Moonlight.Homology.Pure.Failure as FailureX+import Moonlight.Homology.Pure.FiniteAbelian as FiniteAbelianX+import Moonlight.Homology.Pure.Graded.Query as GradedQueryX+import Moonlight.Homology.Pure.GradedTorsion as GradedTorsionX+import Moonlight.Homology.Pure.Group as GroupX+import Moonlight.Homology.Pure.Phase as PhaseX+import Moonlight.Homology.Pure.Reductions as ReductionsX+import Moonlight.Homology.Pure.Sequence.Exact as ExactX+import Moonlight.Homology.Pure.Sequence.Spectral as SpectralX+import Moonlight.Homology.Pure.Skeleton as SkeletonX+import Moonlight.Homology.Pure.Topology.ScaffoldSummary as ScaffoldSummaryX+import Moonlight.Homology.Pure.TopologyObserver as TopologyObserverX+import Moonlight.Homology.Pure.TopologyView as TopologyViewX+import Moonlight.Homology.Topology as TopologyX
+ src-public/Moonlight/Homology/Backend.hs view
@@ -0,0 +1,9 @@+module Moonlight.Homology.Backend+  ( HomologyBackendTag (..),+    HomologyBackend (..),+    homologyBackendTag,+    runHomologyBackend+  )+where++import Moonlight.Homology.Pure.Backend as X
+ src-public/Moonlight/Homology/Boundary.hs view
@@ -0,0 +1,71 @@+module Moonlight.Homology.Boundary+  ( FiniteChainComplex,+    mkFiniteChainComplexChecked,+    maxHomologicalDegree,+    incidenceMatrixAt,+    degreeCardinality,+    basisCellNodeId,+    finiteChainBasisRefsAtDegree,+    basisIndexCellMapAtDegree,+    inverseBasisRefMap,+    validateFiniteChainComplexShape,+    restrictComplex,+    GraphBoundaryGF2,+    gbgf2VertexIndex,+    gbgf2Edges,+    gbgf2Boundary,+    GraphBoundaryGF2Failure (..),+    prepareGraphBoundaryGF2,+    graphBoundaryRankDefectGF2,+    BoundaryScope (..),+    ScopedBoundary (..),+    BoundaryIncidenceShapeError (..),+    BoundaryEntry,+    sourceIndex,+    targetIndex,+    boundaryCoefficient,+    mkBoundaryEntry,+    mkBoundaryEntryFromInts,+    BoundaryIncidence,+    sourceCardinality,+    targetCardinality,+    boundaryEntries,+    mkBoundaryIncidence,+    mkBoundaryIncidenceFromOrderedEntries,+    overlapBoundaryIncidence,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    identityBoundaryIncidenceOf,+    directSumBoundaryIncidence,+    reindexBoundaryIncidenceWith,+    boundaryIncidenceApply,+    transposeBoundaryIncidence,+    composeBoundaryIncidence,+    boundaryIncidenceDiagonal,+    addBoundaryIncidence,+    mapBoundaryCoefficients,+    BlockBoundaryEntry,+    blockSourceIndex,+    blockTargetIndex,+    blockSubmatrix,+    mkBlockBoundaryEntry,+    BlockBoundaryIncidence,+    blockSourceDimensions,+    blockTargetDimensions,+    blockEntries,+    mkBlockBoundaryIncidence,+    flattenBlockIncidence,+    scaleBoundaryIncidence,+    materializeIncidenceBoundary,+    materializeBoundary,+    SmithNormalForm (..),+    SNFReducer (..),+    SNFCapability,+    computeSmithNormalForm+  )+where++import Moonlight.Homology.Boundary.Finite as X+import Moonlight.Homology.Boundary.GraphGF2 as X+import Moonlight.Homology.Boundary.LinAlg as X+import Moonlight.Homology.Boundary.SNF as X
+ src-public/Moonlight/Homology/Boundary/GraphGF2.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Homology.Boundary.GraphGF2+  ( GraphBoundaryGF2,+    gbgf2VertexIndex,+    gbgf2Edges,+    gbgf2Boundary,+    GraphBoundaryGF2Failure (..),+    prepareGraphBoundaryGF2,+    graphBoundaryRankDefectGF2,+  )+where++import Data.Bifunctor+  ( first,+  )+import Data.IntMap.Strict+  ( IntMap,+  )+import Data.IntMap.Strict qualified as IntMap+import Data.Kind+  ( Type,+  )+import Data.Map.Strict+  ( Map,+  )+import Data.Map.Strict qualified as Map+import Data.Set+  ( Set,+  )+import Data.Set qualified as Set+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    BoundaryIncidenceShapeError,+    mkBoundaryEntry,+    mkBoundaryIncidenceFromOrderedEntries,+  )+import Moonlight.Homology.Rank.GF2+  ( GF2RankFailure,+    PreparedGF2Boundary,+    prepareGF2Boundary,+    rankPreparedGF2Boundary,+  )+import Moonlight.LinAlg.Pure.Dense.GF2+  ( GF2 (..),+  )++type GraphBoundaryGF2 :: Type -> Type+data GraphBoundaryGF2 cell = GraphBoundaryGF2+  { graphBoundaryVertexIndex :: !(Map cell Int),+    graphBoundaryEdges :: !(IntMap (cell, cell)),+    graphBoundaryPrepared :: !PreparedGF2Boundary+  }+  deriving stock (Eq, Show)++gbgf2VertexIndex :: GraphBoundaryGF2 cell -> Map cell Int+gbgf2VertexIndex =+  graphBoundaryVertexIndex++gbgf2Edges :: GraphBoundaryGF2 cell -> IntMap (cell, cell)+gbgf2Edges =+  graphBoundaryEdges++gbgf2Boundary :: GraphBoundaryGF2 cell -> PreparedGF2Boundary+gbgf2Boundary =+  graphBoundaryPrepared++type GraphBoundaryGF2Failure :: Type -> Type+data GraphBoundaryGF2Failure cell+  = GraphBoundaryGF2EndpointMissing !Int !cell !(cell, cell)+  | GraphBoundaryGF2BoundaryShapeFailed !BoundaryIncidenceShapeError+  | GraphBoundaryGF2RankFailed !GF2RankFailure+  deriving stock (Eq, Show)++prepareGraphBoundaryGF2 ::+  Ord cell =>+  Set cell ->+  [(cell, cell)] ->+  Either (GraphBoundaryGF2Failure cell) (GraphBoundaryGF2 cell)+prepareGraphBoundaryGF2 vertices edges = do+  edgeTerms <- traverse edgeBoundaryTerms indexedEdges+  incidence <-+    first GraphBoundaryGF2BoundaryShapeFailed $+      mkBoundaryIncidenceFromOrderedEntries+        (fromIntegral edgeCount)+        (fromIntegral vertexCount)+        (concat edgeTerms)+  preparedBoundary <-+    first GraphBoundaryGF2RankFailed $+      prepareGF2Boundary incidence+  Right+    GraphBoundaryGF2+      { graphBoundaryVertexIndex = vertexIndex,+        graphBoundaryEdges = IntMap.fromAscList indexedEdges,+        graphBoundaryPrepared = preparedBoundary+      }+  where+    vertexIndex =+      Map.fromList (zip (Set.toAscList vertices) [0 :: Int ..])++    vertexCount =+      Set.size vertices++    indexedEdges =+      zip [0 :: Int ..] edges++    edgeCount =+      length edges++    edgeBoundaryTerms (edgeIndex, edgeValue@(sourceCell, targetCell)) = do+      sourceOffset <- endpointOffset edgeIndex sourceCell edgeValue+      targetOffset <- endpointOffset edgeIndex targetCell edgeValue+      Right (boundaryTermsForEdge edgeIndex sourceOffset targetOffset)++    endpointOffset edgeIndex endpointCell edgeValue =+      maybe+        (Left (GraphBoundaryGF2EndpointMissing edgeIndex endpointCell edgeValue))+        Right+        (Map.lookup endpointCell vertexIndex)++graphBoundaryRankDefectGF2 :: GraphBoundaryGF2 cell -> Int+graphBoundaryRankDefectGF2 boundaryValue =+  IntMap.size (graphBoundaryEdges boundaryValue)+    - rankPreparedGF2Boundary (graphBoundaryPrepared boundaryValue)+{-# INLINE graphBoundaryRankDefectGF2 #-}++boundaryTermsForEdge :: Int -> Int -> Int -> [BoundaryEntry GF2]+boundaryTermsForEdge edgeIndex sourceOffset targetOffset =+  fmap+    (\targetOffsetValue -> mkBoundaryEntry (fromIntegral edgeIndex) (fromIntegral targetOffsetValue) GF2One)+    [min sourceOffset targetOffset, max sourceOffset targetOffset]
+ src-public/Moonlight/Homology/Chain.hs view
@@ -0,0 +1,113 @@+module Moonlight.Homology.Chain+  ( HomologicalDegree (..),+    incrementDegree,+    decrementDegree,+    EulerCharacteristic (..),+    PersistencePair (..),+    RepresentativeChain (..),+    RepresentativeCycle,+    RepresentativeCocycle,+    HarmonicBasisElement (..),+    ExactRepresentativeClass (..),+    TopologyWitness (..),+    emptyTopologyWitness,+    mergeTopologyWitness,+    mergeTopologyWitnessChecked,+    topologyRepresentativeCycles,+    topologyRepresentativeCocycles,+    topologyWitnessFromBetti,+    BettiReducer (..),+    BettiCapability,+    computeBettiNumbers,+    TopologyWitnessReducer (..),+    TopologyWitnessCapability,+    computeTopologyWitness,+    EffectiveHomology,+    sourceComplex,+    reducedComplex,+    reductionWitness,+    finiteBoundary,+    mkEffectiveHomology,+    HomologyLaw (..),+    NonEffectiveCause (..),+    TopologyInputObstruction (..),+    HomologyFailure (..),+    FiniteAbelianTorsion,+    mkFiniteAbelianTorsion,+    torsionFromHomologyGroup,+    finiteAbelianInvariants,+    normalizeTorsionOrders,+    finiteAbelianSummandCount,+    finiteAbelianCyclicSummandMultiplicity,+    finiteAbelianFilteredCardinality,+    finiteAbelianCardinality,+    finiteAbelianExponent,+    finiteAbelianOrderSupport,+    finiteAbelianPrimaryOrderSupport,+    finiteAbelianExactOrderElementCount,+    isPrime,+    matchesOptional,+    DegreeSelection (..),+    GradedAggregation (..),+    GradedQuery (..),+    selectAllDegrees,+    selectDegree,+    degreeSelectionFromMaybe,+    combineSelectedQuery,+    preserveDegreewiseQuery,+    matchesDegreeSelection,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    selectDegreeIndexed,+    selectGradedMembers,+    countGradedMembers,+    directProductQuery,+    degreewiseUnionQuery,+    GradedTorsionFamily,+    mkGradedTorsionFamily,+    gradedTorsionPresent,+    gradedTorsionAtDegree,+    gradedTorsionCombined,+    gradedTorsionOrderSupport,+    gradedTorsionPrimaryOrderSupport,+    HomologyGroup (..),+    LinearCombination,+    LinearCombinationArithmetic (..),+    numArithmetic,+    ringArithmetic,+    normalizeWith,+    composeWith,+    addWith,+    subtractWith,+    identityWith,+    checkLawWith,+    HomologyPhase (..),+    RequirePhase2,+    RequirePhase4,+    requirePhase2Witness,+    requirePhase4Witness,+    ChainMap (..),+    ChainHomotopy (..),+    Reduction (..),+    ReductionWitness,+    checkedReduction,+    ReductionLawContext (..),+    ReductionViolation (..),+    Validation (..),+    ReductionValidation,+    ReductionChecks (..),+    mkReductionWitness+  )+where++import Moonlight.Homology.Pure.Chain as X+import Moonlight.Homology.Pure.Matrix.Reducer as X+import Moonlight.Homology.Pure.Effective as X+import Moonlight.Homology.Pure.Failure as X+import Moonlight.Homology.Pure.FiniteAbelian as X+import Moonlight.Homology.Pure.Graded.Query as X+import Moonlight.Homology.Pure.GradedTorsion as X+import Moonlight.Homology.Pure.Group as X+import Moonlight.Homology.Pure.LinearCombination as X+import Moonlight.Homology.Pure.Phase as X+import Moonlight.Homology.Pure.Reductions as X
+ src-public/Moonlight/Homology/Matrix.hs view
@@ -0,0 +1,19 @@+module Moonlight.Homology.Matrix+  ( ValidatedMatrix,+    matrixRowCount,+    matrixColumnCount,+    matrixRows,+    mkValidatedMatrix,+    validatedMatrixFromRows,+    zeroValidatedMatrix,+    validatedMatrixFromColumns,+    transposeValidatedMatrix,+    validatedDiagonal,+    validatedColumnAt,+    selectValidatedRows,+    selectValidatedColumns,+    applyValidatedMatrix+  )+where++import Moonlight.Homology.Pure.Matrix.Validated as X
+ src-public/Moonlight/Homology/Persistence.hs view
@@ -0,0 +1,43 @@+module Moonlight.Homology.Persistence+  ( BiFilteredCell (..),+    BiPersistencePair (..),+    FiltrationValue (..),+    FilteredFiniteChainComplex (..),+    mkFilteredFiniteChainComplex,+    mod2PersistentPairs,+    mod2PersistenceTopologyWitness,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Chain (HomologicalDegree)+import Moonlight.Homology.Topology (BasisCellRef)+import Moonlight.Homology.Pure.Filtration (FiltrationValue (..))+import Moonlight.Homology.Pure.Topology.Core (FilteredFiniteChainComplex (..))+import Moonlight.Homology.Pure.Topology.Persistence+  ( mkFilteredFiniteChainComplex,+    mod2PersistentPairs,+    mod2PersistenceTopologyWitness,+  )++-- | A cell with two independent filtration parameters. Forward-looking+-- vocabulary for two-parameter persistence: no function in this package+-- produces or consumes these values yet — they fix the types downstream+-- multi-parameter code will speak.+type BiFilteredCell :: Type+data BiFilteredCell = BiFilteredCell+  { bfcCell :: BasisCellRef,+    bfcBirth1 :: FiltrationValue,+    bfcBirth2 :: FiltrationValue+  }+  deriving stock (Eq, Show)++-- | A two-parameter birth/death pair. Forward-looking vocabulary; see+-- 'BiFilteredCell'.+type BiPersistencePair :: Type+data BiPersistencePair = BiPersistencePair+  { bppDegree :: HomologicalDegree,+    bppBirth :: (FiltrationValue, FiltrationValue),+    bppDeath :: Maybe (FiltrationValue, FiltrationValue)+  }+  deriving stock (Eq, Show)
+ src-public/Moonlight/Homology/Presentation.hs view
@@ -0,0 +1,111 @@+module Moonlight.Homology.Presentation+  ( ChainSpec (..),+    ChainBuildError (..),+    compileChain,+  )+where++import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import Moonlight.Core (Semiring)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    mkFiniteChainComplexChecked,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryIncidence,+    BoundaryIncidenceShapeError,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    mkBoundaryEntryFromInts,+    mkBoundaryIncidence,+  )+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure)++type ChainSpec :: Type -> Type+data ChainSpec r = ChainSpec+  { chainCellCounts :: [Int],+    chainBoundaries :: [[(Int, Int, r)]]+  }+  deriving stock (Eq, Show)++type ChainBuildError :: Type+data ChainBuildError+  = ChainBuildEmptySpec+  | ChainBuildNegativeCellCount Int Int+  | ChainBuildBoundaryCountMismatch Int Int+  | ChainBuildIncidenceFault Int BoundaryIncidenceShapeError+  | ChainBuildComplexFault HomologyFailure+  deriving stock (Eq, Show)++compileChain ::+  (Eq r, Num r, Semiring r) =>+  ChainSpec r ->+  Either ChainBuildError (FiniteChainComplex r)+compileChain spec = do+  cellCounts <- declaredCellCounts spec+  incidences <- incidenceTable cellCounts (chainBoundaries spec)+  first+    ChainBuildComplexFault+    ( mkFiniteChainComplexChecked+        (HomologicalDegree (length cellCounts - 1))+        (incidenceFor cellCounts incidences)+    )++declaredCellCounts :: ChainSpec r -> Either ChainBuildError [Int]+declaredCellCounts spec =+  case chainCellCounts spec of+    [] -> Left ChainBuildEmptySpec+    cellCounts -> do+      traverse_+        ( \(degreeIndex, cellCount) ->+            if cellCount < 0+              then Left (ChainBuildNegativeCellCount degreeIndex cellCount)+              else Right ()+        )+        (zip [0 ..] cellCounts)+      let expectedBoundaryCount = length cellCounts - 1+          observedBoundaryCount = length (chainBoundaries spec)+      if observedBoundaryCount == expectedBoundaryCount+        then Right cellCounts+        else Left (ChainBuildBoundaryCountMismatch expectedBoundaryCount observedBoundaryCount)++incidenceTable ::+  (Eq r, Semiring r) =>+  [Int] ->+  [[(Int, Int, r)]] ->+  Either ChainBuildError (Map.Map Int (BoundaryIncidence r))+incidenceTable cellCounts boundaries =+  Map.fromList+    <$> traverse+      ( \(degreeIndex, (sourceCount, targetCount), entryTriples) ->+          (,) degreeIndex+            <$> first+              (ChainBuildIncidenceFault degreeIndex)+              ( mkBoundaryIncidence+                  (fromIntegral sourceCount)+                  (fromIntegral targetCount)+                  ( fmap+                      ( \(sourceValue, targetValue, coefficientValue) ->+                          mkBoundaryEntryFromInts sourceValue targetValue coefficientValue+                      )+                      entryTriples+                  )+              )+      )+      (zip3 [1 ..] (zip (drop 1 cellCounts) cellCounts) boundaries)++incidenceFor ::+  [Int] ->+  Map.Map Int (BoundaryIncidence r) ->+  HomologicalDegree ->+  BoundaryIncidence r+incidenceFor cellCounts incidences (HomologicalDegree degreeIndex)+  | degreeIndex == 0 =+      case cellCounts of+        zeroCellCount : _ -> emptyBoundaryIncidenceOf (fromIntegral zeroCellCount) 0+        [] -> emptyBoundaryIncidence+  | otherwise = Map.findWithDefault emptyBoundaryIncidence degreeIndex incidences
+ src-public/Moonlight/Homology/Rank.hs view
@@ -0,0 +1,15 @@+module Moonlight.Homology.Rank+  ( FieldRankBackend (..),+    fieldBettiCapability,+    GF2RankFailure (..),+    PreparedGF2Boundary,+    pgbIncidence,+    pgbPackedMatrix,+    prepareGF2Boundary,+    rankPreparedGF2Boundary,+    gf2BoundaryRank+  )+where++import Moonlight.Homology.Pure.Rank.Field as X+import Moonlight.Homology.Pure.Rank.GF2 as X
+ src-public/Moonlight/Homology/Rank/Field.hs view
@@ -0,0 +1,7 @@+module Moonlight.Homology.Rank.Field+  ( FieldRankBackend (..),+    fieldBettiCapability+  )+where++import Moonlight.Homology.Pure.Rank.Field as X
+ src-public/Moonlight/Homology/Rank/GF2.hs view
@@ -0,0 +1,12 @@+module Moonlight.Homology.Rank.GF2+  ( GF2RankFailure (..),+    PreparedGF2Boundary,+    pgbIncidence,+    pgbPackedMatrix,+    prepareGF2Boundary,+    rankPreparedGF2Boundary,+    gf2BoundaryRank+  )+where++import Moonlight.Homology.Pure.Rank.GF2 as X
+ src-public/Moonlight/Homology/Sequence.hs view
@@ -0,0 +1,64 @@+module Moonlight.Homology.Sequence+  ( MayerVietorisReducer (..),+    MayerVietorisCapability,+    mayerVietoris,+    FiltrationFunction,+    Bidegree,+    mkBidegree,+    bidegreeFromTotalDegree,+    bidegreeCoordinates,+    bidegreeFiltrationDegree,+    bidegreeComplementaryDegree,+    bidegreeTotalDegree,+    targetBidegreeAfterDifferential,+    FormalMap (..),+    RationalFormalMap,+    SpectralEntry (..),+    RationalSpectralEntry,+    SpectralPage (..),+    RationalSpectralPage,+    SpectralChain,+    SpectralFamily (..),+    RationalSpectralFamily,+    SpectralAdvance (..),+    SpectralCapability,+    nextPage,+    computeRationalSpectralFamily,+    computeRationalSpectralPages,+    stableSpectralPage,+    convergenceDepth,+    isKPassParseable,+    graphLaplacian,+    laplacianEntry,+    weightedGraphLaplacian,+    weightedGraphSparseLaplacian,+    SparseSpectralConfig (..),+    defaultSparseSpectralConfig,+    weightedGraphSpectralModes,+    weightedGraphSparseSpectralModes,+    weightedGraphSpectralGap,+    gapFromModes,+    leadingModeTransport,+    smallestEigenpairs,+    largestEigenpairs,+    powerIteration,+    traceMatrix,+    subtractFromDiagonal,+    basisVector,+    BasisBlock (..),+    BlockSchurPivot (..),+    BlockPivotOps (..),+    integerUnimodularBlockPivotOps,+    rationalBlockPivotOps,+    gf2BlockPivotOps,+    BlockSchurTranscript (..),+    BlockSchurReduction (..),+    BlockSchurFailure (..),+    blockSchurReduceWith+  )+where++import Moonlight.Homology.Pure.Sequence.Exact as X+import Moonlight.Homology.Pure.Sequence.Spectral as X+import Moonlight.Homology.Pure.Topology.BlockSchur as X+import Moonlight.Homology.Pure.Topology.Spectral as X
+ src-public/Moonlight/Homology/Topology.hs view
@@ -0,0 +1,142 @@+module Moonlight.Homology.Topology+  ( CellTypes (..),+    Dimension (..),+    CellRef (..),+    cellDimension,+    OrientedEdge (..),+    CellComplex2D (..),+    ValidateComplex2D (..),+    isBoundaryEdge,+    isInteriorEdge,+    eulerCharacteristic,+    BasisCellRef (..),+    TopologyObservationConfig (..),+    defaultTopologyObservationConfig,+    TopologyWitnessSeed (..),+    CriticalKind (..),+    PotentialValue,+    PotentialValueError (..),+    unPotentialValue,+    mkPotentialValue,+    PotentialNormalization (..),+    CellCarrier,+    CellCarrierError (..),+    carrierDegree,+    carrierCells,+    mkCellCarrier,+    ScalarPotentialField,+    ScalarPotentialFieldError (..),+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+    mkScalarPotentialField,+    mkScalarPotentialFieldFromSamples,+    DirectionSymmetryOrder,+    DirectionSymmetryOrderError (..),+    unDirectionSymmetryOrder,+    mkDirectionSymmetryOrder,+    DirectionPhase,+    DirectionPhaseError (..),+    unDirectionPhase,+    mkDirectionPhase,+    DirectionCoefficient,+    DirectionCoefficientError (..),+    unDirectionCoefficient,+    mkDirectionCoefficient,+    DirectionFieldEncoding (..),+    DirectionField,+    DirectionFieldError (..),+    directionFieldCarrier,+    directionFieldSymmetryOrder,+    directionFieldEncoding,+    mkDirectionField,+    mkDirectionAngleField,+    mkDirectionCochainField,+    ReebNodeId (..),+    ReebArcId (..),+    MorseReebNode (..),+    Monotonicity (..),+    MorseReebArc (..),+    MorseReebScaffold (..),+    SingularityIndex (..),+    SingularityId (..),+    Singularity (..),+    HarmonicLoopId (..),+    HarmonicLoopWeight (..),+    HarmonicLoopPeriod (..),+    HarmonicLoop (..),+    MacroScaffoldIR (..),+    MacroScaffoldCompositionError (..),+    StitchRoute (..),+    StitchRouteKey (..),+    StitchBoundarySide (..),+    StitchSupportSelection (..),+    StitchSupportRefinement (..),+    StitchSemantics (..),+    MacroScaffoldStitchError (..),+    composeMacroScaffoldsWithScopes,+    composeMacroScaffolds,+    stitchMacroScaffoldRoutes,+    GraphEdge (..),+    Graph1Skeleton (..),+    graphAdjacency,+    GraphSkeletonExtractionFailure (..),+    GraphSpectralMode (..),+    eulerCharacteristicOf,+    integralHomologyGroupsOf,+    exactRepresentativeClassesOf,+    freeBettiVector,+    representativeCyclesOverQ,+    representativeCocyclesOverQ,+    homologyBasisAt,+    cohomologyBasisAt,+    sparseHomologyBasisAt,+    sparseCohomologyBasisAt,+    sparseFreeBettiVector,+    sparseQuotientRepresentatives,+    QuotientPresentation (..),+    mkQuotientPresentation,+    presentationCoordinates,+    quotientRepresentatives,+    vectorToRepresentative,+    representativeToVector,+    exactTopologyWitness,+    TopologyTarget (..),+    TargetViolation (..),+    topologyTargetConstraints,+    validateTarget,+    validateTargets,+    validateTopologyTarget,+    validateTopologyTargets,+    graphFromEdgeSupports,+    vertexBasisCellRef,+    edgeBasisCellRef,+    graph1SkeletonFromComplex,+    graphFiniteChainComplex,+    graphMacroScaffold,+    graphSpectralModes,+    graphTopologyWitness,+    criticalKindAt,+    lowerNeighborEdges,+    lowerNeighbors,+    higherNeighborEdges,+    higherNeighbors,+    addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+    observeGraphTopologyWitness,+    observeTopologyWitnessSeed,+    observeTopologyWitness,+    Orientation (..),+    RawCellData (..),+    RawCellScopes (..),+    RealizationBudget (..),+    realizeScaffoldRawWithScopes,+    realizeScaffoldRaw+  )+where++import Moonlight.Homology.Pure.Topology as X+import Moonlight.Homology.Pure.Topology.Graph.Skeleton+  ( edgeBasisCellRef,+    vertexBasisCellRef,+  )
+ src-sequence/Moonlight/Homology/Pure/Sequence/Exact.hs view
@@ -0,0 +1,25 @@+module Moonlight.Homology.Pure.Sequence.Exact+  ( MayerVietorisReducer (..),+    MayerVietorisCapability,+    mayerVietoris,+  )+where++import Data.Kind (Type)+import Moonlight.Core (Capability, withCapability)+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Phase (HomologyPhase, RequirePhase2)++type MayerVietorisReducer :: Type -> Type+newtype MayerVietorisReducer space = MayerVietorisReducer+  { runMayerVietorisReducer :: space -> space -> space -> Either HomologyFailure space+  }++type MayerVietorisCapability :: HomologyPhase -> Type -> Type+type MayerVietorisCapability phase space =+  Capability RequirePhase2 phase (MayerVietorisReducer space)++mayerVietoris :: MayerVietorisCapability phase space -> space -> space -> space -> Either HomologyFailure space+mayerVietoris capability a b c =+  withCapability capability+    (\reducer -> runMayerVietorisReducer reducer a b c)
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral.hs view
@@ -0,0 +1,123 @@+module Moonlight.Homology.Pure.Sequence.Spectral+  ( FiltrationFunction,+    Bidegree,+    mkBidegree,+    bidegreeFromTotalDegree,+    bidegreeCoordinates,+    bidegreeFiltrationDegree,+    bidegreeComplementaryDegree,+    bidegreeTotalDegree,+    targetBidegreeAfterDifferential,+    FormalMap (..),+    RationalFormalMap,+    SpectralEntry (..),+    RationalSpectralEntry,+    SpectralPage (..),+    RationalSpectralPage,+    SpectralChain,+    SpectralFamily (..),+    RationalSpectralFamily,+    SpectralAdvance (..),+    SpectralCapability,+    nextPage,+    computeRationalSpectralFamily,+    computeRationalSpectralPages,+    stableSpectralPage,+    convergenceDepth,+    isKPassParseable,+  )+where++import Data.Function ((&))+import qualified Data.List as List+import Moonlight.Core (withCapability)+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex)+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Sequence.Spectral.Bidegree+  ( Bidegree,+    bidegreeComplementaryDegree,+    bidegreeCoordinates,+    bidegreeFiltrationDegree,+    bidegreeFromTotalDegree,+    bidegreeTotalDegree,+    mkBidegree,+    targetBidegreeAfterDifferential,+  )+import Moonlight.Homology.Pure.Sequence.Spectral.Build+  ( buildSpectralFamily,+    mkRationalSpectralSource,+  )+import Moonlight.Homology.Pure.Sequence.Spectral.Types+  ( FiltrationFunction,+    FormalMap (..),+    RationalFormalMap,+    RationalSpectralEntry,+    RationalSpectralFamily,+    RationalSpectralPage,+    SpectralAdvance (..),+    SpectralCapability,+    SpectralChain,+    SpectralEntry (..),+    SpectralFamily (..),+    SpectralPage (..),+    SpectralSource,+  )++nextPage :: SpectralCapability phase r -> SpectralPage r -> Either HomologyFailure (SpectralPage r)+nextPage capability page =+  withCapability capability+    (\advance -> runSpectralAdvance advance page)++computeRationalSpectralFamily ::+  FiniteChainComplex Rational ->+  FiltrationFunction ->+  Either HomologyFailure RationalSpectralFamily+computeRationalSpectralFamily finite filtration =+  mkRationalSpectralSource finite filtration >>= computeFamilyFromSource++computeFamilyFromSource ::+  SpectralSource ->+  Either HomologyFailure RationalSpectralFamily+computeFamilyFromSource =+  buildSpectralFamily++computeRationalSpectralPages ::+  FiniteChainComplex Rational ->+  FiltrationFunction ->+  Either HomologyFailure [RationalSpectralPage]+computeRationalSpectralPages finite filtration =+  spectralFamilyPages <$> computeRationalSpectralFamily finite filtration++stableSpectralPage :: [SpectralPage Rational] -> Maybe (SpectralPage Rational)+stableSpectralPage pages =+  let stableIndex = convergenceDepth pages+   in List.find ((== stableIndex) . pageIndex) pages++convergenceDepth :: [SpectralPage Rational] -> Int+convergenceDepth = stabilizationIndex++isKPassParseable :: Int -> [SpectralPage Rational] -> Bool+isKPassParseable passBudget pages =+  convergenceDepth pages <= passBudget++stabilizationIndex :: [SpectralPage Rational] -> Int+stabilizationIndex pages =+  case List.reverse pages of+    [] -> 0+    limitPage : _ ->+      List.reverse pages+        & List.takeWhile (pageSemanticallyEqual limitPage)+        & List.reverse+        & \stableSuffix ->+          case stableSuffix of+            earliestStablePage : _ -> pageIndex earliestStablePage+            [] -> 0++pageSemanticallyEqual :: SpectralPage Rational -> SpectralPage Rational -> Bool+pageSemanticallyEqual leftPage rightPage =+  fmap entryGroupValue (pageEntryMap leftPage) == fmap entryGroupValue (pageEntryMap rightPage)+    && fmap formalMapVanishes (pageDifferentialMap leftPage) == fmap formalMapVanishes (pageDifferentialMap rightPage)++formalMapVanishes :: FormalMap Rational -> Bool+formalMapVanishes =+  all (all (== 0)) . formalMatrix
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Bidegree.hs view
@@ -0,0 +1,44 @@+module Moonlight.Homology.Pure.Sequence.Spectral.Bidegree+  ( Bidegree,+    mkBidegree,+    bidegreeFromTotalDegree,+    bidegreeCoordinates,+    bidegreeFiltrationDegree,+    bidegreeComplementaryDegree,+    bidegreeTotalDegree,+    targetBidegreeAfterDifferential,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))++type Bidegree :: Type+newtype Bidegree = Bidegree+  { bidegreeCoordinates :: (Int, Int)+  }+  deriving stock (Eq, Ord, Show)++mkBidegree :: Int -> Int -> Bidegree+mkBidegree filtrationDegreeValue complementaryDegreeValue =+  Bidegree (filtrationDegreeValue, complementaryDegreeValue)++bidegreeFromTotalDegree :: Int -> HomologicalDegree -> Bidegree+bidegreeFromTotalDegree filtrationDegreeValue (HomologicalDegree totalDegreeValue) =+  mkBidegree filtrationDegreeValue (totalDegreeValue - filtrationDegreeValue)++bidegreeFiltrationDegree :: Bidegree -> Int+bidegreeFiltrationDegree = fst . bidegreeCoordinates++bidegreeComplementaryDegree :: Bidegree -> Int+bidegreeComplementaryDegree = snd . bidegreeCoordinates++bidegreeTotalDegree :: Bidegree -> HomologicalDegree+bidegreeTotalDegree bidegreeValue =+  HomologicalDegree (bidegreeFiltrationDegree bidegreeValue + bidegreeComplementaryDegree bidegreeValue)++targetBidegreeAfterDifferential :: Int -> Bidegree -> Bidegree+targetBidegreeAfterDifferential pageNumber bidegreeValue =+  mkBidegree+    (bidegreeFiltrationDegree bidegreeValue + pageNumber)+    (bidegreeComplementaryDegree bidegreeValue - pageNumber + 1)
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Build.hs view
@@ -0,0 +1,566 @@+module Moonlight.Homology.Pure.Sequence.Spectral.Build+  ( advanceSpectralPage,+    buildEntryFromBases,+    buildInitialSpectralPage,+    buildConstantFiltrationSpectralFamily,+    buildSpectralFamily,+    buildSpectralPage,+    buildSpectralPages,+    filtrationWidth,+    homologicalPageBound,+    mkRationalSpectralSource,+  )+where++import Data.Function ((&))+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    maxHomologicalDegree,+  )+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..), RepresentativeCocycle)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Group (HomologyGroup (..))+import Moonlight.Homology.Pure.Sequence.Spectral.Bidegree+  ( Bidegree,+    bidegreeCoordinates,+    bidegreeFromTotalDegree,+    bidegreeTotalDegree,+    mkBidegree,+    targetBidegreeAfterDifferential,+  )+import Moonlight.Homology.Pure.Sequence.Spectral.Linear+  ( FiltrationPivot (..),+    FiltrationReducedColumn (..),+    FiltrationReduction (..),+    boundaryMatrixAtRational,+    filtrationOrderedReduction,+    firstVectorOutsideSpan,+    independentModuloBasis,+    reduceBasisChecked,+    reshapeSparseMatrix,+    zeroSparseMatrix,+  )+import Moonlight.Homology.Pure.Sequence.Spectral.Support+  ( supportWindowBidegree,+    supportWindows,+  )+import Moonlight.Homology.Pure.Sequence.Spectral.Types+  ( AmbientVector,+    FiltrationFunction,+    FormalMap (..),+    SpectralChain (..),+    SpectralEntry (..),+    SpectralFamily (..),+    SpectralPage (..),+    SpectralSource,+    mkSpectralSource,+    spectralBaseComplex,+    spectralLevelsByDegree,+    spectralMaxLevel,+    spectralMinLevel,+    spectralSupportRegistry,+  )+import Moonlight.Homology.Pure.Topology.Algebra+  ( QuotientPresentation,+    mkQuotientPresentation,+    vectorToRepresentative,+  )+import Moonlight.Homology.Pure.Matrix.Shape (cellCountAtDegree)+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseMatrix,+    sparseRowToDense,+    sparseTransposeMatrix,+  )++data SpectralResolution = SpectralResolution+  { spectralResolutionSource :: !SpectralSource,+    spectralResolutionPairs :: ![SpectralPair],+    spectralResolutionUnpaired :: ![SpectralUnpairedGenerator]+  }++data SpectralDegreeReduction = SpectralDegreeReduction+  { spectralDegreePairs :: ![SpectralPair],+    spectralDegreeZeroColumns :: ![SpectralUnpairedGenerator]+  }++data SpectralPairId = SpectralPairId+  { spectralPairIdDegree :: !HomologicalDegree,+    spectralPairIdSourceIndex :: !Int+  }+  deriving stock (Eq, Ord, Show)++data SpectralPair = SpectralPair+  { spectralPairIdentifier :: !SpectralPairId,+    spectralPairSourceLevel :: !Int,+    spectralPairSourceVector :: !AmbientVector,+    spectralPairTargetDegree :: !HomologicalDegree,+    spectralPairTargetIndex :: !Int,+    spectralPairTargetLevel :: !Int,+    spectralPairTargetVector :: !AmbientVector,+    spectralPairPage :: !Int+  }++data SpectralUnpairedGenerator = SpectralUnpairedGenerator+  { spectralUnpairedDegree :: !HomologicalDegree,+    spectralUnpairedIndex :: !Int,+    spectralUnpairedLevel :: !Int,+    spectralUnpairedVector :: !AmbientVector+  }++newtype SpectralPairedTargetCell = SpectralPairedTargetCell (HomologicalDegree, Int)+  deriving stock (Eq, Ord, Show)++data SpectralEndpointRole+  = SpectralSourceEndpoint !SpectralPairId+  | SpectralTargetEndpoint !SpectralPairId+  | SpectralUnpairedEndpoint !HomologicalDegree !Int+  deriving stock (Eq, Ord, Show)++data SpectralPageBasisVector = SpectralPageBasisVector+  { spectralPageBasisRole :: !SpectralEndpointRole,+    spectralPageBasisDegree :: !HomologicalDegree,+    spectralPageBasisLevel :: !Int,+    spectralPageBasisAnchor :: !Int,+    spectralPageBasisVector :: !AmbientVector+  }+  deriving stock (Eq, Show)++buildInitialSpectralPage :: SpectralSource -> Either HomologyFailure (SpectralPage Rational)+buildInitialSpectralPage source =+  buildSpectralPage source 0++buildConstantFiltrationSpectralFamily :: SpectralSource -> Either HomologyFailure (SpectralFamily Rational)+buildConstantFiltrationSpectralFamily =+  buildSpectralFamily++buildSpectralFamily :: SpectralSource -> Either HomologyFailure (SpectralFamily Rational)+buildSpectralFamily source = do+  resolution <- buildSpectralResolution source+  let pages = spectralPagesFromResolution resolution+  case List.reverse pages of+    limitPage : _ ->+      Right+        SpectralFamily+          { spectralFamilyPages = pages,+            spectralFamilyStableFrom = stableFromResolution resolution,+            spectralFamilyLimitPage = limitPage+          }+    [] ->+      Left (BackendFailure "spectral family unexpectedly empty")++buildSpectralPages :: SpectralSource -> Either HomologyFailure [SpectralPage Rational]+buildSpectralPages source =+  spectralPagesFromResolution <$> buildSpectralResolution source++spectralPagesFromResolution :: SpectralResolution -> [SpectralPage Rational]+spectralPagesFromResolution resolution =+  fmap+    (spectralPageFromResolution resolution)+    [0 .. homologicalPageBound (spectralResolutionSource resolution)]++buildSpectralPage :: SpectralSource -> Int -> Either HomologyFailure (SpectralPage Rational)+buildSpectralPage source pageNumber =+  spectralPageFromResolution <$> buildSpectralResolution source <*> pure pageNumber++advanceSpectralPage :: SpectralPage Rational -> Either HomologyFailure (SpectralPage Rational)+advanceSpectralPage page =+  case pageAdvanceSource page of+    Just source -> buildSpectralPage source (pageIndex page + 1)+    Nothing ->+      case pageAdvanceState page of+        Just chain -> buildSpectralPage (spectralChainSource chain) (pageIndex page + 1)+        Nothing -> Left (BackendFailure "spectral page cannot advance without source data")++spectralPageFromResolution :: SpectralResolution -> Int -> SpectralPage Rational+spectralPageFromResolution resolution pageNumber =+  let source = spectralResolutionSource resolution+      basisByBidegree = pageBasisByBidegree resolution pageNumber+      entries = buildEntriesFromPageBasis source basisByBidegree+      differentials = buildDifferentialsFromPageBasis resolution pageNumber basisByBidegree+   in spectralPageFromEntries source pageNumber entries differentials++spectralPageFromEntries ::+  SpectralSource ->+  Int ->+  Map.Map Bidegree (SpectralEntry Rational) ->+  Map.Map Bidegree (FormalMap Rational) ->+  SpectralPage Rational+spectralPageFromEntries source pageNumber entries differentials =+  let zeroGroup :: HomologyGroup Rational+      zeroGroup = HomologyGroup {freeRank = 0, torsionInvariants = []}+      zeroFormalMap :: FormalMap Rational+      zeroFormalMap = FormalMap [] [] []+   in SpectralPage+        { pageIndex = pageNumber,+          groupAt =+            \filtrationDegreeValue complementaryDegreeValue ->+              Map.lookup (mkBidegree filtrationDegreeValue complementaryDegreeValue) entries+                & maybe zeroGroup entryGroupValue,+          diffMap =+            \filtrationDegreeValue complementaryDegreeValue ->+              Map.findWithDefault zeroFormalMap (mkBidegree filtrationDegreeValue complementaryDegreeValue) differentials,+          pageEntryMap = entries,+          pageDifferentialMap = differentials,+          pageAdvanceSource = Just source,+          pageAdvanceState = Nothing+        }++buildSpectralResolution :: SpectralSource -> Either HomologyFailure SpectralResolution+buildSpectralResolution source = do+  degreeReductions <- traverse (buildSpectralDegreeReduction source) (Map.keys (spectralLevelsByDegree source))+  let pairs = degreeReductions >>= spectralDegreePairs+      pairedTargets = Set.fromList (fmap pairedTargetCell pairs)+      unpairedGenerators =+        degreeReductions+          >>= spectralDegreeZeroColumns+          & filter (not . (`Set.member` pairedTargets) . unpairedTargetCell)+  pure+    SpectralResolution+      { spectralResolutionSource = source,+        spectralResolutionPairs = pairs,+        spectralResolutionUnpaired = unpairedGenerators+      }++buildSpectralDegreeReduction :: SpectralSource -> HomologicalDegree -> Either HomologyFailure SpectralDegreeReduction+buildSpectralDegreeReduction source sourceDegree = do+  matrixValue <- safeCoboundaryMatrixAt source sourceDegree+  reductionValue <-+    filtrationOrderedReduction+      (levelsAtDegree source sourceDegree)+      (levelsAtDegree source (successorDegree sourceDegree))+      matrixValue+  pure+    SpectralDegreeReduction+      { spectralDegreePairs = filtrationReductionColumns reductionValue >>= spectralPairFromReducedColumn sourceDegree,+        spectralDegreeZeroColumns = filtrationReductionColumns reductionValue >>= spectralZeroColumnFromReducedColumn sourceDegree+      }++spectralPairFromReducedColumn :: HomologicalDegree -> FiltrationReducedColumn -> [SpectralPair]+spectralPairFromReducedColumn sourceDegree columnValue =+  case filtrationColumnPivot columnValue of+    Nothing -> []+    Just pivotValue ->+      [ SpectralPair+          { spectralPairIdentifier =+              SpectralPairId+                { spectralPairIdDegree = sourceDegree,+                  spectralPairIdSourceIndex = filtrationColumnSourceIndex columnValue+                },+            spectralPairSourceLevel = filtrationColumnSourceLevel columnValue,+            spectralPairSourceVector = filtrationColumnSourceVector columnValue,+            spectralPairTargetDegree = successorDegree sourceDegree,+            spectralPairTargetIndex = filtrationPivotTargetIndex pivotValue,+            spectralPairTargetLevel = filtrationPivotTargetLevel pivotValue,+            spectralPairTargetVector = filtrationColumnTargetVector columnValue,+            spectralPairPage = filtrationPivotDistance pivotValue+          }+      ]++spectralZeroColumnFromReducedColumn :: HomologicalDegree -> FiltrationReducedColumn -> [SpectralUnpairedGenerator]+spectralZeroColumnFromReducedColumn degreeValue columnValue =+  case filtrationColumnPivot columnValue of+    Just _ -> []+    Nothing ->+      [ SpectralUnpairedGenerator+          { spectralUnpairedDegree = degreeValue,+            spectralUnpairedIndex = filtrationColumnSourceIndex columnValue,+            spectralUnpairedLevel = filtrationColumnSourceLevel columnValue,+            spectralUnpairedVector = filtrationColumnSourceVector columnValue+          }+      ]++pairedTargetCell :: SpectralPair -> SpectralPairedTargetCell+pairedTargetCell pairValue =+  SpectralPairedTargetCell+    (spectralPairTargetDegree pairValue, spectralPairTargetIndex pairValue)++unpairedTargetCell :: SpectralUnpairedGenerator -> SpectralPairedTargetCell+unpairedTargetCell generatorValue =+  SpectralPairedTargetCell+    (spectralUnpairedDegree generatorValue, spectralUnpairedIndex generatorValue)++stableFromResolution :: SpectralResolution -> Int+stableFromResolution resolution+  | filtrationWidth (spectralResolutionSource resolution) == 0 = 1+  | otherwise =+      case fmap spectralPairPage (spectralResolutionPairs resolution) of+        [] -> 0+        firstPage : remainingPages -> List.foldl' max firstPage remainingPages + 1++pageBasisByBidegree :: SpectralResolution -> Int -> Map.Map Bidegree [SpectralPageBasisVector]+pageBasisByBidegree resolution pageNumber =+  let source = spectralResolutionSource resolution+      groupedBasis =+        activePageBasis resolution pageNumber+          & fmap (\basisValue -> (pageBasisBidegree basisValue, [basisValue]))+          & Map.fromListWith (<>)+          & fmap sortPageBasis+   in supportWindows (spectralSupportRegistry source)+        & fmap+          ( \windowValue ->+              let bidegreeValue = supportWindowBidegree windowValue+               in (bidegreeValue, Map.findWithDefault [] bidegreeValue groupedBasis)+          )+        & Map.fromList++activePageBasis :: SpectralResolution -> Int -> [SpectralPageBasisVector]+activePageBasis resolution pageNumber =+  sortPageBasis+    ( (spectralResolutionPairs resolution >>= activePairEndpoints pageNumber)+        <> fmap unpairedPageBasis (spectralResolutionUnpaired resolution)+    )++activePairEndpoints :: Int -> SpectralPair -> [SpectralPageBasisVector]+activePairEndpoints pageNumber pairValue =+  if pageNumber <= spectralPairPage pairValue+    then+      [ SpectralPageBasisVector+          { spectralPageBasisRole = SpectralSourceEndpoint (spectralPairIdentifier pairValue),+            spectralPageBasisDegree = spectralPairIdDegree (spectralPairIdentifier pairValue),+            spectralPageBasisLevel = spectralPairSourceLevel pairValue,+            spectralPageBasisAnchor = spectralPairIdSourceIndex (spectralPairIdentifier pairValue),+            spectralPageBasisVector = spectralPairSourceVector pairValue+          },+        SpectralPageBasisVector+          { spectralPageBasisRole = SpectralTargetEndpoint (spectralPairIdentifier pairValue),+            spectralPageBasisDegree = spectralPairTargetDegree pairValue,+            spectralPageBasisLevel = spectralPairTargetLevel pairValue,+            spectralPageBasisAnchor = spectralPairTargetIndex pairValue,+            spectralPageBasisVector = spectralPairTargetVector pairValue+          }+      ]+    else []++unpairedPageBasis :: SpectralUnpairedGenerator -> SpectralPageBasisVector+unpairedPageBasis generatorValue =+  SpectralPageBasisVector+    { spectralPageBasisRole = SpectralUnpairedEndpoint (spectralUnpairedDegree generatorValue) (spectralUnpairedIndex generatorValue),+      spectralPageBasisDegree = spectralUnpairedDegree generatorValue,+      spectralPageBasisLevel = spectralUnpairedLevel generatorValue,+      spectralPageBasisAnchor = spectralUnpairedIndex generatorValue,+      spectralPageBasisVector = spectralUnpairedVector generatorValue+    }++pageBasisBidegree :: SpectralPageBasisVector -> Bidegree+pageBasisBidegree basisValue =+  bidegreeFromTotalDegree+    (spectralPageBasisLevel basisValue)+    (spectralPageBasisDegree basisValue)++sortPageBasis :: [SpectralPageBasisVector] -> [SpectralPageBasisVector]+sortPageBasis =+  List.sortOn+    ( \basisValue ->+        ( spectralPageBasisDegree basisValue,+          spectralPageBasisLevel basisValue,+          spectralPageBasisAnchor basisValue,+          spectralPageBasisRole basisValue+        )+    )++buildEntriesFromPageBasis :: SpectralSource -> Map.Map Bidegree [SpectralPageBasisVector] -> Map.Map Bidegree (SpectralEntry Rational)+buildEntriesFromPageBasis source basisByBidegree =+  supportWindows (spectralSupportRegistry source)+    & fmap+      ( \windowValue ->+          let bidegreeValue = supportWindowBidegree windowValue+           in ( bidegreeValue,+                buildEntryFromPageBasis+                  source+                  bidegreeValue+                  (Map.findWithDefault [] bidegreeValue basisByBidegree)+              )+      )+    & Map.fromList++buildEntryFromPageBasis :: SpectralSource -> Bidegree -> [SpectralPageBasisVector] -> SpectralEntry Rational+buildEntryFromPageBasis source bidegreeValue basisVectors =+  let ambientDimension = degreeDimension source (bidegreeTotalDegree bidegreeValue)+      denseBasis = fmap (sparseRowToDense ambientDimension . spectralPageBasisVector) basisVectors+      representatives = fmap (basisRepresentativeValue source) basisVectors+      presentation = mkQuotientPresentation ambientDimension denseBasis representatives []+   in SpectralEntry+        { entryPresentation = presentation,+          entryGroupValue =+            HomologyGroup+              { freeRank = length basisVectors,+                torsionInvariants = []+              }+        }++buildDifferentialsFromPageBasis :: SpectralResolution -> Int -> Map.Map Bidegree [SpectralPageBasisVector] -> Map.Map Bidegree (FormalMap Rational)+buildDifferentialsFromPageBasis resolution pageNumber basisByBidegree =+  supportWindows (spectralSupportRegistry (spectralResolutionSource resolution))+    & fmap+      ( \windowValue ->+          let bidegreeValue = supportWindowBidegree windowValue+           in (bidegreeValue, buildDifferentialFromPageBasis resolution pageNumber basisByBidegree bidegreeValue)+      )+    & Map.fromList++buildDifferentialFromPageBasis ::+  SpectralResolution ->+  Int ->+  Map.Map Bidegree [SpectralPageBasisVector] ->+  Bidegree ->+  FormalMap Rational+buildDifferentialFromPageBasis resolution pageNumber basisByBidegree sourceBidegree =+  let source = spectralResolutionSource resolution+      targetBidegree = targetBidegreeAfterDifferential pageNumber sourceBidegree+      domainBasis = Map.findWithDefault [] sourceBidegree basisByBidegree+      codomainBasis = Map.findWithDefault [] targetBidegree basisByBidegree+      livePairIds = differentialPairIdsAt resolution pageNumber sourceBidegree+   in FormalMap+        { formalMatrix =+            fmap+              ( \targetBasisValue ->+                  fmap+                    (\domainBasisValue -> differentialCoefficient livePairIds domainBasisValue targetBasisValue)+                    domainBasis+              )+              codomainBasis,+          formalDomainBasis = fmap (basisRepresentativeValue source) domainBasis,+          formalCodomainBasis = fmap (basisRepresentativeValue source) codomainBasis+        }++differentialPairIdsAt :: SpectralResolution -> Int -> Bidegree -> Set.Set SpectralPairId+differentialPairIdsAt resolution pageNumber sourceBidegree =+  spectralResolutionPairs resolution+    & filter+      ( \pairValue ->+          spectralPairPage pairValue == pageNumber+            && pairSourceBidegree pairValue == sourceBidegree+      )+    & fmap spectralPairIdentifier+    & Set.fromList++differentialCoefficient :: Set.Set SpectralPairId -> SpectralPageBasisVector -> SpectralPageBasisVector -> Rational+differentialCoefficient livePairIds domainBasisValue targetBasisValue =+  case (spectralPageBasisRole domainBasisValue, spectralPageBasisRole targetBasisValue) of+    (SpectralSourceEndpoint sourcePairId, SpectralTargetEndpoint targetPairId)+      | sourcePairId == targetPairId && Set.member sourcePairId livePairIds -> 1+    _ -> 0++pairSourceBidegree :: SpectralPair -> Bidegree+pairSourceBidegree pairValue =+  bidegreeFromTotalDegree+    (spectralPairSourceLevel pairValue)+    (spectralPairIdDegree (spectralPairIdentifier pairValue))++basisRepresentativeValue :: SpectralSource -> SpectralPageBasisVector -> RepresentativeCocycle Rational Int+basisRepresentativeValue source basisValue =+  let degreeValue = spectralPageBasisDegree basisValue+      ambientDimension = degreeDimension source degreeValue+   in vectorToRepresentative+        degreeValue+        (sparseRowToDense ambientDimension (spectralPageBasisVector basisValue))++buildEntryFromBases ::+  Bidegree ->+  Int ->+  [AmbientVector] ->+  [AmbientVector] ->+  Either HomologyFailure (SpectralEntry Rational)+buildEntryFromBases bidegreeValue ambientDimension numeratorBasis denominatorBasis = do+  reducedNumerator <- reduceBasisChecked ambientDimension numeratorBasis+  reducedDenominator <- reduceBasisChecked ambientDimension denominatorBasis+  assertDenominatorSubset bidegreeValue ambientDimension reducedNumerator reducedDenominator+  let quotientBasis = independentModuloBasis ambientDimension reducedDenominator reducedNumerator+      presentation =+        presentationFromSparseBases+          (bidegreeTotalDegree bidegreeValue)+          ambientDimension+          quotientBasis+          reducedDenominator+      groupValue =+        HomologyGroup+          { freeRank = length quotientBasis,+            torsionInvariants = []+          }+  pure+    SpectralEntry+      { entryPresentation = presentation,+        entryGroupValue = groupValue+      }++presentationFromSparseBases ::+  HomologicalDegree ->+  Int ->+  [AmbientVector] ->+  [AmbientVector] ->+  QuotientPresentation Rational+presentationFromSparseBases degreeValue ambientDimension quotientBasis denominatorBasis =+  let basisVectors = fmap (sparseRowToDense ambientDimension) quotientBasis+      denominatorVectors = fmap (sparseRowToDense ambientDimension) denominatorBasis+      basisRepresentatives = fmap (vectorToRepresentative degreeValue) basisVectors+   in mkQuotientPresentation+        ambientDimension+        basisVectors+        basisRepresentatives+        denominatorVectors++assertDenominatorSubset ::+  Bidegree ->+  Int ->+  [AmbientVector] ->+  [AmbientVector] ->+  Either HomologyFailure ()+assertDenominatorSubset bidegreeValue ambientDimension numeratorBasis denominatorBasis =+  case firstVectorOutsideSpan ambientDimension numeratorBasis denominatorBasis of+    Nothing -> Right ()+    Just denominatorVector ->+      Left+        ( SpectralQuotientDenominatorNotSubspace+            (bidegreeCoordinates bidegreeValue)+            ambientDimension+            (sparseRowToDense ambientDimension denominatorVector)+        )++filtrationWidth :: SpectralSource -> Int+filtrationWidth source =+  max 0 (spectralMaxLevel source - spectralMinLevel source)++homologicalPageBound :: SpectralSource -> Int+homologicalPageBound source =+  filtrationWidth source + 1++mkRationalSpectralSource :: FiniteChainComplex Rational -> FiltrationFunction -> Either HomologyFailure SpectralSource+mkRationalSpectralSource =+  mkSpectralSource++degreeDimension :: SpectralSource -> HomologicalDegree -> Int+degreeDimension source degreeValue =+  cellCountAtDegree (spectralBaseComplex source) degreeValue++levelsAtDegree :: SpectralSource -> HomologicalDegree -> [Int]+levelsAtDegree source degreeValue =+  Map.findWithDefault [] degreeValue (spectralLevelsByDegree source)++successorDegree :: HomologicalDegree -> HomologicalDegree+successorDegree (HomologicalDegree degreeValue) =+  HomologicalDegree (degreeValue + 1)++safeCoboundaryMatrixAt ::+  SpectralSource ->+  HomologicalDegree ->+  Either HomologyFailure SparseMatrix+safeCoboundaryMatrixAt source degreeValue+  | unHomologicalDegree degreeValue < 0 =+      zeroSparseMatrix+        (degreeDimension source (successorDegree degreeValue))+        0+  | unHomologicalDegree degreeValue >= unHomologicalDegree (maxHomologicalDegree (spectralBaseComplex source)) =+      zeroSparseMatrix+        0+        (degreeDimension source degreeValue)+  | otherwise = do+      let targetDegreeValue = successorDegree degreeValue+          boundaryRowCount = degreeDimension source degreeValue+          boundaryColumnCount = degreeDimension source targetDegreeValue+      boundaryMatrix <-+        boundaryMatrixAtRational (spectralBaseComplex source) targetDegreeValue+          >>= reshapeSparseMatrix boundaryRowCount boundaryColumnCount+      pure (sparseTransposeMatrix boundaryMatrix)
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Linear.hs view
@@ -0,0 +1,548 @@+module Moonlight.Homology.Pure.Sequence.Spectral.Linear+  ( coordinateUnitVectors,+    FiltrationPivot (..),+    FiltrationReducedColumn (..),+    FiltrationReduction (..),+    filtrationOrderedReduction,+    reduceBasisChecked,+    intersectionBasisChecked,+    kernelBasisOfMatrix,+    imageBasisOfMatrix,+    independentModuloBasis,+    firstVectorOutsideSpan,+    spanRankOfBasis,+    boundaryMatrixAtRational,+    zeroSparseMatrix,+    reshapeSparseMatrix,+    sparseMatrixDenseRows,+    sparseMatrixFromRowsChecked,+    sparseMatrixFromColumnsChecked,+    selectSparseRows,+    selectSparseColumns,+    applySparseMatrixChecked,+    sparseLinearCombination,+  )+where++import Data.Function ((&))+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as List+import qualified Data.Vector as Vector+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( boundaryEntries,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Sequence.Spectral.Types (AmbientVector)+import Moonlight.Homology.Pure.Matrix.Shape (cellCountAtDegree)+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseMatrix (..),+    addScaledSparseRow,+    compactSparseRow,+    scaleSparseRow,+    sparseBoundaryMatrixWith,+    sparseEchelonBasis,+    sparseEchelonContains,+    sparseImageBasisOf,+    sparseIndependentModulo,+    sparseKernelBasisOf,+    sparseRowLookup,+    sparseRowToDense,+    sparseSpanRank,+    sparseTransposeMatrix,+  )++data FiltrationPivot = FiltrationPivot+  { filtrationPivotTargetIndex :: !Int,+    filtrationPivotTargetLevel :: !Int,+    filtrationPivotDistance :: !Int+  }+  deriving stock (Eq, Show)++data FiltrationReducedColumn = FiltrationReducedColumn+  { filtrationColumnSourceIndex :: !Int,+    filtrationColumnSourceLevel :: !Int,+    filtrationColumnSourceVector :: !AmbientVector,+    filtrationColumnTargetVector :: !AmbientVector,+    filtrationColumnPivot :: !(Maybe FiltrationPivot)+  }+  deriving stock (Eq, Show)++data FiltrationReduction = FiltrationReduction+  { filtrationReductionSourceDimension :: !Int,+    filtrationReductionTargetDimension :: !Int,+    filtrationReductionColumns :: ![FiltrationReducedColumn]+  }+  deriving stock (Eq, Show)++data FiltrationReductionPivotColumn = FiltrationReductionPivotColumn+  { frpcSourceVector :: !AmbientVector,+    frpcTargetVector :: !AmbientVector+  }+  deriving stock (Eq, Show)++data FiltrationReductionColumnState = FiltrationReductionColumnState+  { frcsSourceVector :: !AmbientVector,+    frcsTargetVector :: !AmbientVector+  }+  deriving stock (Eq, Show)++data FiltrationReductionState = FiltrationReductionState+  { frsPivotColumns :: !(IntMap.IntMap FiltrationReductionPivotColumn),+    frsReducedColumns :: ![FiltrationReducedColumn]+  }+  deriving stock (Eq, Show)++coordinateUnitVectors :: Int -> [Int] -> [AmbientVector]+coordinateUnitVectors ambientDimension =+  fmap (sparseUnitVector ambientDimension)++sparseUnitVector :: Int -> Int -> AmbientVector+sparseUnitVector ambientDimension selectedIndex =+  if selectedIndex < 0 || selectedIndex >= ambientDimension+    then IntMap.empty+    else IntMap.singleton selectedIndex 1++filtrationOrderedReduction ::+  [Int] ->+  [Int] ->+  SparseMatrix ->+  Either HomologyFailure FiltrationReduction+filtrationOrderedReduction sourceLevels targetLevels matrixValue = do+  compactMatrix <- validateFiltrationReductionMatrix sourceLevels targetLevels matrixValue+  let sourceLevelVector = Vector.fromList sourceLevels+      targetLevelVector = Vector.fromList targetLevels+      columnRows =+        Vector.fromList (smRows (sparseTransposeMatrix compactMatrix))+      orderedColumns =+        filtrationOrderedIndices sourceLevelVector+      finalState =+        List.foldl'+          (reduceFiltrationColumn sourceLevelVector targetLevelVector columnRows)+          emptyFiltrationReductionState+          orderedColumns+  pure+    FiltrationReduction+      { filtrationReductionSourceDimension = Vector.length sourceLevelVector,+        filtrationReductionTargetDimension = Vector.length targetLevelVector,+        filtrationReductionColumns = reverse (frsReducedColumns finalState)+      }++validateFiltrationReductionMatrix ::+  [Int] ->+  [Int] ->+  SparseMatrix ->+  Either HomologyFailure SparseMatrix+validateFiltrationReductionMatrix sourceLevels targetLevels matrixValue =+  if smColumnCount matrixValue /= length sourceLevels || length (smRows matrixValue) /= length targetLevels+    then Left (InvalidMatrixShape "filtration reduction matrix shape does not match the filtration cardinalities")+    else do+      compactRows <- traverse (validateAmbientVector (length sourceLevels)) (smRows matrixValue)+      pure+        SparseMatrix+          { smRows = compactRows,+            smColumnCount = length sourceLevels+          }++emptyFiltrationReductionState :: FiltrationReductionState+emptyFiltrationReductionState =+  FiltrationReductionState+    { frsPivotColumns = IntMap.empty,+      frsReducedColumns = []+    }++reduceFiltrationColumn ::+  Vector.Vector Int ->+  Vector.Vector Int ->+  Vector.Vector AmbientVector ->+  FiltrationReductionState ->+  Int ->+  FiltrationReductionState+reduceFiltrationColumn sourceLevels targetLevels columnRows state sourceIndexValue =+  let initialColumn =+        FiltrationReductionColumnState+          { frcsSourceVector = sparseUnitVector (Vector.length sourceLevels) sourceIndexValue,+            frcsTargetVector =+              maybe IntMap.empty compactSparseRow (columnRows Vector.!? sourceIndexValue)+          }+      reducedColumn =+        reduceColumnAgainstFiltrationPivots targetLevels (frsPivotColumns state) initialColumn+      sourceLevelValue = levelAtIndex sourceLevels sourceIndexValue+   in case filtrationPivotIndex targetLevels (frcsTargetVector reducedColumn) of+        Nothing ->+          state+            { frsReducedColumns =+                FiltrationReducedColumn+                  { filtrationColumnSourceIndex = sourceIndexValue,+                    filtrationColumnSourceLevel = sourceLevelValue,+                    filtrationColumnSourceVector = compactSparseRow (frcsSourceVector reducedColumn),+                    filtrationColumnTargetVector = IntMap.empty,+                    filtrationColumnPivot = Nothing+                  }+                  : frsReducedColumns state+            }+        Just targetIndexValue ->+          let pivotCoefficient =+                sparseRowLookup targetIndexValue (frcsTargetVector reducedColumn)+              normalizedSource =+                scaleSparseRow (recip pivotCoefficient) (frcsSourceVector reducedColumn)+              normalizedTarget =+                scaleSparseRow (recip pivotCoefficient) (frcsTargetVector reducedColumn)+              targetLevelValue = levelAtIndex targetLevels targetIndexValue+              pivotValue =+                FiltrationPivot+                  { filtrationPivotTargetIndex = targetIndexValue,+                    filtrationPivotTargetLevel = targetLevelValue,+                    filtrationPivotDistance = targetLevelValue - sourceLevelValue+                  }+              reducedValue =+                FiltrationReducedColumn+                  { filtrationColumnSourceIndex = sourceIndexValue,+                    filtrationColumnSourceLevel = sourceLevelValue,+                    filtrationColumnSourceVector = normalizedSource,+                    filtrationColumnTargetVector = normalizedTarget,+                    filtrationColumnPivot = Just pivotValue+                  }+           in state+                { frsPivotColumns =+                    IntMap.insert+                      targetIndexValue+                      FiltrationReductionPivotColumn+                        { frpcSourceVector = normalizedSource,+                          frpcTargetVector = normalizedTarget+                        }+                      (frsPivotColumns state),+                  frsReducedColumns = reducedValue : frsReducedColumns state+                }++reduceColumnAgainstFiltrationPivots ::+  Vector.Vector Int ->+  IntMap.IntMap FiltrationReductionPivotColumn ->+  FiltrationReductionColumnState ->+  FiltrationReductionColumnState+reduceColumnAgainstFiltrationPivots targetLevels pivotColumns columnState =+  case filtrationPivotIndex targetLevels (frcsTargetVector columnState) of+    Nothing -> columnState+    Just targetIndexValue ->+      case IntMap.lookup targetIndexValue pivotColumns of+        Nothing -> columnState+        Just pivotColumn ->+          let pivotCoefficient =+                sparseRowLookup targetIndexValue (frcsTargetVector columnState)+              nextColumnState =+                FiltrationReductionColumnState+                  { frcsSourceVector =+                      addScaledSparseRow+                        (negate pivotCoefficient)+                        (frcsSourceVector columnState)+                        (frpcSourceVector pivotColumn),+                    frcsTargetVector =+                      addScaledSparseRow+                        (negate pivotCoefficient)+                        (frcsTargetVector columnState)+                        (frpcTargetVector pivotColumn)+                  }+           in reduceColumnAgainstFiltrationPivots targetLevels pivotColumns nextColumnState++filtrationOrderedIndices :: Vector.Vector Int -> [Int]+filtrationOrderedIndices levels =+  [0 .. Vector.length levels - 1]+    & List.sortOn (filtrationOrderKey levels)++filtrationPivotIndex :: Vector.Vector Int -> AmbientVector -> Maybe Int+filtrationPivotIndex levels rowValue =+  case IntMap.keys (compactSparseRow rowValue) of+    [] -> Nothing+    pivotIndex : remainingIndices ->+      Just+        ( List.foldl'+            ( \bestIndex candidateIndex ->+                if filtrationOrderKey levels candidateIndex > filtrationOrderKey levels bestIndex+                  then candidateIndex+                  else bestIndex+            )+            pivotIndex+            remainingIndices+        )++filtrationOrderKey :: Vector.Vector Int -> Int -> (Int, Int)+filtrationOrderKey levels indexValue =+  (negate (levelAtIndex levels indexValue), indexValue)++levelAtIndex :: Vector.Vector Int -> Int -> Int+levelAtIndex levels indexValue =+  maybe 0 id (levels Vector.!? indexValue)++reduceBasisChecked :: Int -> [AmbientVector] -> Either HomologyFailure [AmbientVector]+reduceBasisChecked ambientDimension basisVectors = do+  compactBasis <- traverse (validateAmbientVector ambientDimension) basisVectors+  pure (independentModuloBasis ambientDimension [] compactBasis)++intersectionBasisChecked ::+  Int ->+  [AmbientVector] ->+  [AmbientVector] ->+  Either HomologyFailure [AmbientVector]+intersectionBasisChecked ambientDimension leftBasis rightBasis = do+  compactLeftBasis <- traverse (validateAmbientVector ambientDimension) leftBasis+  compactRightBasis <- traverse (validateAmbientVector ambientDimension) rightBasis+  if null compactLeftBasis || null compactRightBasis+    then pure []+    else do+      relationMatrix <-+        sparseMatrixFromColumnsChecked+          ambientDimension+          (compactLeftBasis <> fmap negateSparseRow compactRightBasis)+      let relationKernel =+            kernelBasisOfMatrix+              (length compactLeftBasis + length compactRightBasis)+              relationMatrix+          intersectionVectors =+            relationKernel+              & fmap+                ( \relationVector ->+                    sparseLinearCombination+                      compactLeftBasis+                      (coordinatePrefix (length compactLeftBasis) relationVector)+                )+      reduceBasisChecked ambientDimension intersectionVectors++kernelBasisOfMatrix :: Int -> SparseMatrix -> [AmbientVector]+kernelBasisOfMatrix =+  sparseKernelBasisOf++imageBasisOfMatrix :: SparseMatrix -> [AmbientVector]+imageBasisOfMatrix =+  sparseImageBasisOf++independentModuloBasis :: Int -> [AmbientVector] -> [AmbientVector] -> [AmbientVector]+independentModuloBasis =+  sparseIndependentModulo++firstVectorOutsideSpan :: Int -> [AmbientVector] -> [AmbientVector] -> Maybe AmbientVector+firstVectorOutsideSpan ambientDimension spanBasis candidateVectors =+  let echelonBasis =+        sparseEchelonBasis ambientDimension spanBasis+   in List.find+        (not . sparseEchelonContains echelonBasis)+        candidateVectors++spanRankOfBasis :: Int -> [AmbientVector] -> Int+spanRankOfBasis =+  sparseSpanRank++boundaryMatrixAtRational ::+  FiniteChainComplex Rational ->+  HomologicalDegree ->+  Either HomologyFailure SparseMatrix+boundaryMatrixAtRational finite degreeValue@(HomologicalDegree degreeIndex) =+  let incidence = incidenceMatrixAt finite degreeValue+      sourceDimension = cellCountAtDegree finite degreeValue+      targetDimension = cellCountAtDegree finite (HomologicalDegree (degreeIndex - 1))+      invalidEntry =+        boundaryEntries incidence+          & List.find+            ( \entry ->+                sourceIndex entry < 0+                  || sourceIndex entry >= sourceCardinality incidence+                  || targetIndex entry < 0+                  || targetIndex entry >= targetCardinality incidence+                  || sourceIndex entry >= sourceDimension+                  || targetIndex entry >= targetDimension+            )+   in case invalidEntry of+        Just _ ->+          Left (InvalidBoundaryIncidence "boundary incidence entry index is outside the declared cardinalities")+        Nothing ->+          reshapeSparseMatrix targetDimension sourceDimension (sparseBoundaryMatrixWith id incidence)++zeroSparseMatrix :: Int -> Int -> Either HomologyFailure SparseMatrix+zeroSparseMatrix rowCount columnCount+  | rowCount < 0 || columnCount < 0 =+      Left (InvalidMatrixShape "validated matrix received a negative shape")+  | otherwise =+      Right+        SparseMatrix+          { smRows = replicate rowCount IntMap.empty,+            smColumnCount = columnCount+          }++reshapeSparseMatrix :: Int -> Int -> SparseMatrix -> Either HomologyFailure SparseMatrix+reshapeSparseMatrix rowCount columnCount matrixValue = do+  _ <- zeroSparseMatrix rowCount columnCount+  let resizedRows =+        take rowCount (smRows matrixValue)+          <> replicate (max 0 (rowCount - length (smRows matrixValue))) IntMap.empty+  compactRows <- traverse (validateAmbientVector columnCount) resizedRows+  pure+    SparseMatrix+      { smRows = compactRows,+        smColumnCount = columnCount+      }++sparseMatrixDenseRows :: SparseMatrix -> [[Rational]]+sparseMatrixDenseRows matrixValue =+  fmap (sparseRowToDense (smColumnCount matrixValue)) (smRows matrixValue)++sparseMatrixFromRowsChecked :: Int -> [AmbientVector] -> Either HomologyFailure SparseMatrix+sparseMatrixFromRowsChecked columnCount rows = do+  compactRows <- traverse (validateAmbientVector columnCount) rows+  pure+    SparseMatrix+      { smRows = compactRows,+        smColumnCount = columnCount+      }++sparseMatrixFromColumnsChecked :: Int -> [AmbientVector] -> Either HomologyFailure SparseMatrix+sparseMatrixFromColumnsChecked rowCount columnVectors = do+  compactColumns <- traverse (validateAmbientVector rowCount) columnVectors+  pure (sparseTransposeMatrix (SparseMatrix {smRows = compactColumns, smColumnCount = rowCount}))++selectSparseRows ::+  [Int] ->+  SparseMatrix ->+  Either HomologyFailure SparseMatrix+selectSparseRows rowIndices matrixValue = do+  selectedRows <-+    traverse+      ( \rowIndexValue ->+          maybe+            (Left (InvalidMatrixShape "row selection index is outside the matrix bounds"))+            Right+            (elementAt rowIndexValue (smRows matrixValue))+      )+      rowIndices+  sparseMatrixFromRowsChecked (smColumnCount matrixValue) selectedRows++selectSparseColumns ::+  [Int] ->+  SparseMatrix ->+  Either HomologyFailure SparseMatrix+selectSparseColumns columnIndices matrixValue = do+  _ <- traverse (validateColumnIndex matrixValue) columnIndices+  sparseMatrixFromRowsChecked+    (length columnIndices)+    (fmap (selectSparseRowColumns columnIndices) (smRows matrixValue))++applySparseMatrixChecked ::+  SparseMatrix ->+  AmbientVector ->+  Either HomologyFailure AmbientVector+applySparseMatrixChecked matrixValue vectorValue = do+  compactVector <- validateMatrixVector matrixValue vectorValue+  pure+    ( smRows matrixValue+        & zip [0 :: Int ..]+        & List.foldl'+          ( \imageRow (rowIndex, rowValue) ->+              let coefficientValue = sparseDot rowValue compactVector+               in if coefficientValue == 0+                    then imageRow+                    else IntMap.insert rowIndex coefficientValue imageRow+          )+          IntMap.empty+    )++sparseLinearCombination :: [AmbientVector] -> AmbientVector -> AmbientVector+sparseLinearCombination basisVectors coefficients =+  IntMap.foldlWithKey'+    ( \combinedVector basisIndex coefficientValue ->+        case elementAt basisIndex basisVectors of+          Nothing -> combinedVector+          Just basisVector ->+            addScaledSparseRow coefficientValue combinedVector basisVector+    )+    IntMap.empty+    coefficients++validateColumnIndex :: SparseMatrix -> Int -> Either HomologyFailure Int+validateColumnIndex matrixValue columnIndexValue =+  if columnIndexValue < 0 || columnIndexValue >= smColumnCount matrixValue+    then Left (InvalidMatrixShape "column selection index is outside the matrix bounds")+    else Right columnIndexValue++selectSparseRowColumns :: [Int] -> AmbientVector -> AmbientVector+selectSparseRowColumns columnIndices rowValue =+  columnIndices+    & zip [0 :: Int ..]+    & List.foldl'+      ( \selectedRow (selectedColumnIndex, sourceColumnIndex) ->+          let coefficientValue = sparseRowLookup sourceColumnIndex rowValue+           in if coefficientValue == 0+                then selectedRow+                else IntMap.insert selectedColumnIndex coefficientValue selectedRow+      )+      IntMap.empty++validateMatrixVector :: SparseMatrix -> AmbientVector -> Either HomologyFailure AmbientVector+validateMatrixVector matrixValue vectorValue =+  case validateAmbientVector (smColumnCount matrixValue) vectorValue of+    Right compactVector -> Right compactVector+    Left _ ->+      Left+        ( InvalidMatrixShape+            ( "vector length "+                <> show (observedSparseDimension vectorValue)+                <> " does not match the expected matrix width "+                <> show (smColumnCount matrixValue)+            )+        )++validateAmbientVector :: Int -> AmbientVector -> Either HomologyFailure AmbientVector+validateAmbientVector expectedDimension vectorValue =+  let compactVector = compactSparseRow vectorValue+      observedDimension = observedSparseDimension compactVector+      supported =+        IntMap.keys compactVector+          & all (\columnIndex -> columnIndex >= 0 && columnIndex < expectedDimension)+   in if expectedDimension < 0+        then Left (InvalidMatrixShape "validated matrix received a negative shape")+        else+          if supported+            then Right compactVector+            else+              Left+                ( InvalidMatrixShape+                    ( "vector length "+                        <> show observedDimension+                        <> " does not match the expected ambient dimension "+                        <> show expectedDimension+                    )+                )++coordinatePrefix :: Int -> AmbientVector -> AmbientVector+coordinatePrefix prefixLength =+  IntMap.filterWithKey (\columnIndex _ -> columnIndex < prefixLength)++negateSparseRow :: AmbientVector -> AmbientVector+negateSparseRow =+  scaleSparseRow (-1)++sparseDot :: AmbientVector -> AmbientVector -> Rational+sparseDot leftRow rightRow =+  IntMap.foldlWithKey'+    ( \dotValue columnIndex coefficientValue ->+        dotValue + coefficientValue * sparseRowLookup columnIndex rightRow+    )+    0+    leftRow++elementAt :: Int -> [a] -> Maybe a+elementAt indexValue _+  | indexValue < 0 = Nothing+elementAt indexValue values =+  case drop indexValue values of+    value : _ -> Just value+    [] -> Nothing++observedSparseDimension :: AmbientVector -> Int+observedSparseDimension vectorValue =+  maybe 0 ((+ 1) . fst) (IntMap.lookupMax (compactSparseRow vectorValue))
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Support.hs view
@@ -0,0 +1,145 @@+module Moonlight.Homology.Pure.Sequence.Spectral.Support+  ( SpectralWindow (..),+    SpectralRestrictionKind (..),+    SpectralRestriction (..),+    SpectralWindowCover (..),+    SpectralSupportRegistry,+    mkSpectralSupportRegistry,+    supportWindows,+    supportWindowBidegree,+    supportLookupWindow,+    supportIncomingRestrictions,+    supportWindowCover,+    supportDifferentialTargetWindow,+  )+where++import Data.Function ((&))+import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Moonlight.Homology.Pure.Degree (HomologicalDegree)+import Moonlight.Homology.Pure.Sequence.Spectral.Bidegree+  ( Bidegree,+    bidegreeFromTotalDegree,+    targetBidegreeAfterDifferential,+  )++type SpectralWindow :: Type+data SpectralWindow = SpectralWindow+  { spectralWindowDegree :: HomologicalDegree,+    spectralWindowFiltration :: Int+  }+  deriving stock (Eq, Ord, Show)++type SpectralRestrictionKind :: Type+data SpectralRestrictionKind+  = FiltrationRestriction+  deriving stock (Eq, Ord, Show)++type SpectralRestriction :: Type+data SpectralRestriction = SpectralRestriction+  { spectralRestrictionKind :: SpectralRestrictionKind,+    spectralRestrictionSourceWindow :: SpectralWindow,+    spectralRestrictionTargetWindow :: SpectralWindow+  }+  deriving stock (Eq, Ord, Show)++type SpectralWindowCover :: Type+data SpectralWindowCover = SpectralWindowCover+  { spectralCoverWindow :: SpectralWindow,+    spectralCoverIncomingRestrictions :: [SpectralRestriction]+  }+  deriving stock (Eq, Show)++type SpectralSupportRegistry :: Type+data SpectralSupportRegistry = SpectralSupportRegistry+  { registryWindows :: [SpectralWindow],+    registryByBidegree :: Map.Map Bidegree SpectralWindow,+    registryRestrictionsByTarget :: Map.Map SpectralWindow [SpectralRestriction]+  }++mkSpectralSupportRegistry :: Map.Map HomologicalDegree [Int] -> SpectralSupportRegistry+mkSpectralSupportRegistry levelsByDegree =+  let windows =+        Map.toAscList levelsByDegree+          >>= \(degreeValue, levelsAtDegree) ->+            distinctLevels levelsAtDegree+              & fmap+                ( \filtrationDegreeValue ->+                    SpectralWindow+                      { spectralWindowDegree = degreeValue,+                        spectralWindowFiltration = filtrationDegreeValue+                      }+                )+      byBidegree =+        windows+          & fmap (\windowValue -> (supportWindowBidegree windowValue, windowValue))+          & Map.fromList+      restrictions =+        windows+          >>= \targetWindow ->+            shiftedWindow byBidegree 1 targetWindow+              & maybe+                []+                ( \sourceWindow ->+                    [ SpectralRestriction+                        { spectralRestrictionKind = FiltrationRestriction,+                          spectralRestrictionSourceWindow = sourceWindow,+                          spectralRestrictionTargetWindow = targetWindow+                        }+                    ]+                )+      restrictionsByTarget =+        restrictions+          & fmap (\restrictionValue -> (spectralRestrictionTargetWindow restrictionValue, [restrictionValue]))+          & Map.fromListWith (<>)+   in SpectralSupportRegistry+        { registryWindows = windows,+          registryByBidegree = byBidegree,+          registryRestrictionsByTarget = restrictionsByTarget+        }++supportWindows :: SpectralSupportRegistry -> [SpectralWindow]+supportWindows =+  registryWindows++supportWindowBidegree :: SpectralWindow -> Bidegree+supportWindowBidegree windowValue =+  bidegreeFromTotalDegree+    (spectralWindowFiltration windowValue)+    (spectralWindowDegree windowValue)++supportLookupWindow :: SpectralSupportRegistry -> Bidegree -> Maybe SpectralWindow+supportLookupWindow registry =+  (`Map.lookup` registryByBidegree registry)++supportIncomingRestrictions :: SpectralSupportRegistry -> SpectralWindow -> [SpectralRestriction]+supportIncomingRestrictions registry windowValue =+  Map.findWithDefault [] windowValue (registryRestrictionsByTarget registry)++supportWindowCover :: SpectralSupportRegistry -> SpectralWindow -> SpectralWindowCover+supportWindowCover registry windowValue =+  SpectralWindowCover+    { spectralCoverWindow = windowValue,+      spectralCoverIncomingRestrictions = supportIncomingRestrictions registry windowValue+    }++supportDifferentialTargetWindow :: SpectralSupportRegistry -> Int -> SpectralWindow -> Maybe SpectralWindow+supportDifferentialTargetWindow registry pageNumber windowValue =+  supportLookupWindow+    registry+    (targetBidegreeAfterDifferential pageNumber (supportWindowBidegree windowValue))++shiftedWindow :: Map.Map Bidegree SpectralWindow -> Int -> SpectralWindow -> Maybe SpectralWindow+shiftedWindow byBidegree filtrationDelta windowValue =+  Map.lookup+    ( bidegreeFromTotalDegree+        (spectralWindowFiltration windowValue + filtrationDelta)+        (spectralWindowDegree windowValue)+    )+    byBidegree++distinctLevels :: [Int] -> [Int]+distinctLevels =+  Set.toAscList . Set.fromList
+ src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Types.hs view
@@ -0,0 +1,260 @@+module Moonlight.Homology.Pure.Sequence.Spectral.Types+  ( FiltrationFunction,+    AmbientVector,+    FormalMap (..),+    RationalFormalMap,+    SpectralEntry (..),+    RationalSpectralEntry,+    SpectralSource,+    mkSpectralSource,+    spectralBaseComplex,+    spectralLevelsByDegree,+    spectralSupportRegistry,+    spectralMinLevel,+    spectralMaxLevel,+    SpectralSlice (..),+    SpectralChain (..),+    SpectralPage (..),+    RationalSpectralPage,+    SpectralFamily (..),+    RationalSpectralFamily,+    SpectralAdvance (..),+    SpectralCapability,+  )+where++import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Data.Kind (Type)+import qualified Data.List as List+import Moonlight.Core (Capability)+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex, incidenceMatrixAt)+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    boundaryCoefficient,+    boundaryEntries,+    sourceIndex,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain (RepresentativeCocycle)+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Group (HomologyGroup)+import Moonlight.Homology.Pure.Phase (HomologyPhase, RequirePhase4)+import Moonlight.Homology.Pure.Sequence.Spectral.Bidegree (Bidegree)+import Moonlight.Homology.Pure.Sequence.Spectral.Support (SpectralSupportRegistry, SpectralWindow, mkSpectralSupportRegistry)+import Moonlight.Homology.Pure.Topology.Algebra (QuotientPresentation)+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Filtration (enumerateFromZero)+import Moonlight.Homology.Pure.Matrix.Shape+  ( cellCountAtDegree,+    dimensionsOf,+  )+import Moonlight.Homology.Pure.Matrix.SparseLinAlg (SparseRow)++type FiltrationFunction :: Type+type FiltrationFunction = BasisCellRef -> Int++type AmbientVector :: Type+type AmbientVector = SparseRow++type FormalMap :: Type -> Type+data FormalMap r = FormalMap+  { formalMatrix :: [[r]],+    formalDomainBasis :: [RepresentativeCocycle r Int],+    formalCodomainBasis :: [RepresentativeCocycle r Int]+  }+  deriving stock (Eq, Show)++type RationalFormalMap :: Type+type RationalFormalMap = FormalMap Rational++type SpectralEntry :: Type -> Type+data SpectralEntry r = SpectralEntry+  { entryPresentation :: QuotientPresentation r,+    entryGroupValue :: HomologyGroup r+  }+  deriving stock (Eq, Show)++type RationalSpectralEntry :: Type+type RationalSpectralEntry = SpectralEntry Rational++type SpectralSource :: Type+data SpectralSource = UnsafeSpectralSource+  { spectralBaseComplex :: FiniteChainComplex Rational,+    spectralLevelsByDegree :: Map.Map HomologicalDegree [Int],+    spectralSupportRegistry :: SpectralSupportRegistry,+    spectralMinLevel :: Int,+    spectralMaxLevel :: Int+  }++mkSpectralSource :: FiniteChainComplex Rational -> FiltrationFunction -> Either HomologyFailure SpectralSource+mkSpectralSource rationalFinite filtration = do+  let levelMap = spectralLevelMap rationalFinite filtration+  validateSpectralFiltration rationalFinite levelMap+  pure+    UnsafeSpectralSource+      { spectralBaseComplex = rationalFinite,+        spectralLevelsByDegree = levelMap,+        spectralSupportRegistry = mkSpectralSupportRegistry levelMap,+        spectralMinLevel = minimumSpectralLevel levelMap,+        spectralMaxLevel = maximumSpectralLevel levelMap+      }++spectralLevelMap ::+  FiniteChainComplex Rational ->+  FiltrationFunction ->+  Map.Map HomologicalDegree [Int]+spectralLevelMap rationalFinite filtration =+  dimensionsOf rationalFinite+    & fmap+      ( \degreeValue ->+          ( degreeValue,+            enumerateFromZero (cellCountAtDegree rationalFinite degreeValue)+              & fmap+                ( \cellIndexValue ->+                    filtration+                      BasisCellRef+                        { cellDegree = degreeValue,+                          cellIndex = cellIndexValue+                        }+                )+          )+      )+    & Map.fromList++minimumSpectralLevel :: Map.Map HomologicalDegree [Int] -> Int+minimumSpectralLevel =+  extremalSpectralLevel (List.foldl' min)++maximumSpectralLevel :: Map.Map HomologicalDegree [Int] -> Int+maximumSpectralLevel =+  extremalSpectralLevel (List.foldl' max)++extremalSpectralLevel :: (Int -> [Int] -> Int) -> Map.Map HomologicalDegree [Int] -> Int+extremalSpectralLevel foldLevels levelMap =+  case Map.elems levelMap & concat of+    [] -> 0+    levelValue : remainingLevels -> foldLevels levelValue remainingLevels++validateSpectralFiltration ::+  FiniteChainComplex Rational ->+  Map.Map HomologicalDegree [Int] ->+  Either HomologyFailure ()+validateSpectralFiltration rationalFinite levelMap =+  spectralFiltrationViolations rationalFinite levelMap+    & List.find (const True)+    & maybe (Right ()) Left++spectralFiltrationViolations ::+  FiniteChainComplex Rational ->+  Map.Map HomologicalDegree [Int] ->+  [HomologyFailure]+spectralFiltrationViolations rationalFinite levelMap =+  dimensionsOf rationalFinite+    >>= spectralFiltrationViolationsAtDegree rationalFinite levelMap++spectralFiltrationViolationsAtDegree ::+  FiniteChainComplex Rational ->+  Map.Map HomologicalDegree [Int] ->+  HomologicalDegree ->+  [HomologyFailure]+spectralFiltrationViolationsAtDegree rationalFinite levelMap degreeValue =+  if unHomologicalDegree degreeValue <= 0+    then []+    else+      boundaryEntries (incidenceMatrixAt rationalFinite degreeValue)+        >>= spectralFiltrationViolationAtBoundaryEntry levelMap degreeValue++spectralFiltrationViolationAtBoundaryEntry ::+  Map.Map HomologicalDegree [Int] ->+  HomologicalDegree ->+  BoundaryEntry Rational ->+  [HomologyFailure]+spectralFiltrationViolationAtBoundaryEntry levelMap degreeValue entryValue =+  let upperCell =+        BasisCellRef+          { cellDegree = degreeValue,+            cellIndex = sourceIndex entryValue+          }+      lowerCell =+        BasisCellRef+          { cellDegree = HomologicalDegree (unHomologicalDegree degreeValue - 1),+            cellIndex = targetIndex entryValue+          }+   in if boundaryCoefficient entryValue == 0+        then []+        else+          case (levelAt levelMap lowerCell, levelAt levelMap upperCell) of+            (Just lowerLevel, Just upperLevel)+              | lowerLevel <= upperLevel -> []+              | otherwise ->+                  [FiltrationNotPreserved lowerCell upperCell lowerLevel upperLevel]+            _ ->+              [ InvalidBoundaryIncidence+                  ( "boundary incidence entry references a cell outside the spectral filtration: "+                      <> show (lowerCell, upperCell)+                  )+              ]++levelAt :: Map.Map HomologicalDegree [Int] -> BasisCellRef -> Maybe Int+levelAt levelMap basisCellRef =+  Map.lookup (cellDegree basisCellRef) levelMap+    >>= elementAt (cellIndex basisCellRef)++elementAt :: Int -> [a] -> Maybe a+elementAt indexValue values =+  if indexValue < 0+    then Nothing+    else+      case drop indexValue values of+        value : _ -> Just value+        [] -> Nothing++type SpectralSlice :: Type+data SpectralSlice = SpectralSlice+  { spectralSliceCyclesBasis :: [AmbientVector],+    spectralSliceImageBasis :: [AmbientVector],+    spectralSliceBoundariesBasis :: [AmbientVector]+  }++type SpectralChain :: Type+data SpectralChain = SpectralChain+  { spectralChainSource :: SpectralSource,+    spectralChainPageIndex :: Int,+    spectralChainPreviousSlices :: Maybe (Map.Map SpectralWindow SpectralSlice),+    spectralChainSlices :: Map.Map SpectralWindow SpectralSlice+  }++type SpectralPage :: Type -> Type+data SpectralPage r = SpectralPage+  { pageIndex :: Int,+    groupAt :: Int -> Int -> HomologyGroup r,+    diffMap :: Int -> Int -> FormalMap r,+    pageEntryMap :: Map.Map Bidegree (SpectralEntry r),+    pageDifferentialMap :: Map.Map Bidegree (FormalMap r),+    pageAdvanceSource :: Maybe SpectralSource,+    pageAdvanceState :: Maybe SpectralChain+  }++type RationalSpectralPage :: Type+type RationalSpectralPage = SpectralPage Rational++type SpectralFamily :: Type -> Type+data SpectralFamily r = SpectralFamily+  { spectralFamilyPages :: [SpectralPage r],+    spectralFamilyStableFrom :: Int,+    spectralFamilyLimitPage :: SpectralPage r+  }++type RationalSpectralFamily :: Type+type RationalSpectralFamily = SpectralFamily Rational++type SpectralAdvance :: Type -> Type+newtype SpectralAdvance r = SpectralAdvance+  { runSpectralAdvance :: SpectralPage r -> Either HomologyFailure (SpectralPage r)+  }++type SpectralCapability :: HomologyPhase -> Type -> Type+type SpectralCapability phase r =+  Capability RequirePhase4 phase (SpectralAdvance r)
+ src-topology/Moonlight/Homology/Pure/Backend.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Homology.Pure.Backend+  ( HomologyBackendTag (..),+    HomologyBackend (..),+    homologyBackendTag,+    runHomologyBackend,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+  )+import Moonlight.Homology.Pure.Matrix.Reducer+  ( BettiCapability,+    computeBettiNumbers,+  )+import Moonlight.Homology.Pure.Failure+  ( HomologyFailure,+  )+import Moonlight.Homology.Pure.Group+  ( HomologyGroup,+  )+import Moonlight.Homology.Pure.Phase+  ( HomologyPhase (Phase2),+  )+import Moonlight.Homology.Pure.Topology.Integral+  ( integralHomologyGroupsOf,+  )+import Moonlight.Homology.Pure.Rank.Field+  ( FieldRankBackend (..),+    fieldBettiCapability,+  )+import Moonlight.LinAlg.Pure.Dense.GF2+  ( GF2,+  )++type HomologyBackendTag :: Type+data HomologyBackendTag+  = IntegralSmithBackendTag+  | RationalRankBackendTag+  | GF2RankBackendTag+  deriving stock (Eq, Ord, Show)++type HomologyBackend :: Type -> Type -> Type+data HomologyBackend chainCoeff groupCoeff where+  IntegralSmithBackend :: Integral chainCoeff => HomologyBackend chainCoeff Integer+  RationalRankBackend :: HomologyBackend Rational Rational+  GF2RankBackend :: HomologyBackend GF2 GF2++deriving stock instance Show (HomologyBackend chainCoeff groupCoeff)++homologyBackendTag :: HomologyBackend chainCoeff groupCoeff -> HomologyBackendTag+homologyBackendTag backend =+  case backend of+    IntegralSmithBackend -> IntegralSmithBackendTag+    RationalRankBackend -> RationalRankBackendTag+    GF2RankBackend -> GF2RankBackendTag+{-# INLINE homologyBackendTag #-}++runHomologyBackend ::+  HomologyBackend chainCoeff groupCoeff ->+  FiniteChainComplex chainCoeff ->+  Either HomologyFailure [HomologyGroup groupCoeff]+runHomologyBackend backend finite =+  case backend of+    IntegralSmithBackend ->+      integralHomologyGroupsOf finite+    RationalRankBackend ->+      computeBettiNumbers+        (fieldBettiCapability RationalFieldRankBackend :: BettiCapability 'Phase2 Rational)+        finite+    GF2RankBackend ->+      computeBettiNumbers+        (fieldBettiCapability GF2FieldRankBackend :: BettiCapability 'Phase2 GF2)+        finite+{-# INLINEABLE runHomologyBackend #-}
+ src-topology/Moonlight/Homology/Pure/Constraint.hs view
@@ -0,0 +1,29 @@+module Moonlight.Homology.Pure.Constraint+  ( Bound (..),+    TargetBetti (..),+    PersistenceBudget (..),+    EulerBound (..),+    LoopSemanticRole (..),+    LoopRole (..),+    RequireTorsionInvariant (..),+    RequireElementOrder (..),+    RequireOrderSupport (..),+    PrimaryOrderSupportBudget (..),+    RequirePrimaryOrderSupport (..),+    TorsionBudgetMeasure (..),+    TorsionBudget (..),+    RequireCyclicOrder (..),+    SingularityBudget (..),+    HarmonicLoopBudget (..),+    SkeletonSignature (..),+    SkeletonAdherence (..),+    TopologicalConstraint (..),+    TopologicalViolation (..),+    evaluateTopologicalConstraint,+    evaluateTopologicalConstraints,+  )+where++import Moonlight.Homology.Pure.Constraint.Algebra+import Moonlight.Homology.Pure.Constraint.Core+import Moonlight.Homology.Pure.Skeleton (SkeletonSignature (..))
+ src-topology/Moonlight/Homology/Pure/Constraint/Algebra.hs view
@@ -0,0 +1,291 @@+module Moonlight.Homology.Pure.Constraint.Algebra+  ( evaluateTopologicalConstraint,+    evaluateTopologicalConstraints,+  )+where++import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Moonlight.Homology.Pure.Chain+  ( EulerCharacteristic (..),+    HomologicalDegree (..),+    PersistencePair (..),+    TopologyWitness (..),+  )+import Moonlight.Homology.Pure.Constraint.Core+import Moonlight.Homology.Pure.FiniteAbelian+  ( finiteAbelianCardinality,+    finiteAbelianCyclicSummandMultiplicity,+    finiteAbelianExactOrderElementCount,+    finiteAbelianFilteredCardinality,+    finiteAbelianSummandCount,+    isPrime,+    matchesOptional,+    normalizeTorsionOrders,+  )+import Moonlight.Homology.Pure.Graded.Query+  ( degreeSelectionFromMaybe,+    preserveDegreewiseQuery,+    selectAllDegrees,+    selectDegree,+  )+import Moonlight.Homology.Pure.GradedTorsion+  ( GradedTorsionFamily,+    gradedTorsionAtDegree,+    gradedTorsionCombined,+    gradedTorsionOrderSupport,+    gradedTorsionPresent,+    gradedTorsionPrimaryOrderSupport,+  )+import Moonlight.Homology.Pure.Filtration (FiltrationValue (..))+import Moonlight.Homology.Pure.Skeleton+  ( SkeletonSignature (..),+    skeletonSignatureWithinTolerance,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold (MacroScaffoldIR)+import Moonlight.Homology.Pure.Topology.ScaffoldSummary (mkMacroScaffoldTopologyView)+import Moonlight.Homology.Pure.TopologyObserver+  ( observeBettiVector,+    observeCoefficientRepresentativeCycleCount,+    observeEulerCharacteristic,+    observeExactRepresentativeClassCount,+    observeHarmonicCount,+    observePersistencePairs,+    observeScaffoldSummary,+    observeTorsionFamily,+    runTopologyObserver,+  )++evaluateTopologicalConstraint ::+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  TopologicalConstraint ->+  [TopologicalViolation]+evaluateTopologicalConstraint witnessValue constraintValue =+  let topologyView = mkMacroScaffoldTopologyView witnessValue+      torsionFamily = runTopologyObserver observeTorsionFamily topologyView+   in case constraintValue of+    TargetBettiConstraint targetValue ->+      let observedBetti = runTopologyObserver observeBettiVector topologyView+       in if observedBetti == targetBettiVector targetValue+        then []+        else [BettiViolation targetValue observedBetti]+    PersistenceBudgetConstraint budgetValue ->+      let observedCount =+            countPersistentFeatures+              budgetValue+              (runTopologyObserver+                (observePersistencePairs (degreeSelectionFromMaybe (persistenceBudgetDegree budgetValue)))+                topologyView)+       in checkBound (persistenceBudgetCountBound budgetValue) observedCount+            (PersistenceBudgetViolation budgetValue observedCount)+    EulerBoundConstraint eulerBoundValue ->+      case runTopologyObserver observeEulerCharacteristic topologyView of+        Nothing -> [EulerWitnessMissing eulerBoundValue]+        Just observedEuler ->+          checkBound (requiredEulerBound eulerBoundValue) (unEulerCharacteristic observedEuler)+            (EulerBoundViolation eulerBoundValue observedEuler)+    LoopRoleConstraint loopRoleValue ->+      let degreeSelectionValue = selectDegree (loopTargetDegree loopRoleValue)+          observedCount =+            if runTopologyObserver (observeExactRepresentativeClassCount selectAllDegrees) topologyView == 0+              then+                runTopologyObserver (observeCoefficientRepresentativeCycleCount degreeSelectionValue) topologyView+              else+                runTopologyObserver (observeExactRepresentativeClassCount degreeSelectionValue) topologyView+       in checkBound (loopCountBound loopRoleValue) observedCount+            (LoopRoleViolation loopRoleValue observedCount)+    RequireTorsionInvariantConstraint torsionConstraintValue ->+      case gradedTorsionAtDegree+        (requiredTorsionDegree torsionConstraintValue)+        torsionFamily of+        Nothing ->+          [IntegralHomologyWitnessMissing constraintValue]+        Just torsionValue ->+          let observedCount =+                torsionValue+                  & finiteAbelianCyclicSummandMultiplicity+                    (requiredTorsionInvariant torsionConstraintValue)+           in checkBound (requiredTorsionMultiplicity torsionConstraintValue) observedCount+                (RequireTorsionInvariantViolation torsionConstraintValue observedCount)+    RequireElementOrderConstraint elementConstraintValue ->+      withTorsionPresent constraintValue torsionFamily $ \_ ->+        let observedCount =+              gradedTorsionCombined+                (selectDegree (requiredElementDegree elementConstraintValue))+                torsionFamily+                & finiteAbelianExactOrderElementCount+                  (requiredElementOrder elementConstraintValue)+         in checkBound (requiredElementMultiplicity elementConstraintValue) observedCount+              (RequireElementOrderViolation elementConstraintValue observedCount)+    RequireOrderSupportConstraint supportConstraintValue ->+      withTorsionPresent constraintValue torsionFamily $ \_ ->+        let observedSupport =+              gradedTorsionOrderSupport+                (preserveDegreewiseQuery (degreeSelectionFromMaybe (requiredOrderSupportDegree supportConstraintValue)))+                torsionFamily+            missingOrders =+              requiredSupportedOrders supportConstraintValue+                & normalizeTorsionOrders+                & filter (`notElem` observedSupport)+            forbiddenOrders =+              requiredForbiddenOrders supportConstraintValue+                & normalizeTorsionOrders+                & filter (`elem` observedSupport)+         in if null missingOrders && null forbiddenOrders+              then []+              else [RequireOrderSupportViolation supportConstraintValue missingOrders forbiddenOrders]+    PrimaryOrderSupportBudgetConstraint budgetValue ->+      if not (isPrime (primarySupportBudgetPrime budgetValue))+        then [InvalidPrimaryPrime constraintValue (primarySupportBudgetPrime budgetValue)]+        else+          withTorsionPresent constraintValue torsionFamily $ \_ ->+            let observedCount =+                  maybe [] id+                    (gradedTorsionPrimaryOrderSupport+                    (primarySupportBudgetPrime budgetValue)+                    (preserveDegreewiseQuery (degreeSelectionFromMaybe (primarySupportBudgetDegree budgetValue)))+                    torsionFamily)+                    & length+                    & toInteger+             in checkBound (primarySupportBudgetBound budgetValue) observedCount+                  (PrimaryOrderSupportBudgetViolation budgetValue observedCount)+    RequirePrimaryOrderSupportConstraint supportConstraintValue ->+      if not (isPrime (requiredPrimarySupportPrime supportConstraintValue))+        then [InvalidPrimaryPrime constraintValue (requiredPrimarySupportPrime supportConstraintValue)]+        else+          withTorsionPresent constraintValue torsionFamily $ \_ ->+            let observedSupport =+                  maybe [] id+                    (gradedTorsionPrimaryOrderSupport+                    (requiredPrimarySupportPrime supportConstraintValue)+                    (preserveDegreewiseQuery (degreeSelectionFromMaybe (requiredPrimarySupportDegree supportConstraintValue)))+                    torsionFamily)+                missingOrders =+                  requiredPrimarySupportedOrders supportConstraintValue+                    & normalizeTorsionOrders+                    & filter (`notElem` observedSupport)+                forbiddenOrders =+                  requiredPrimaryForbiddenOrders supportConstraintValue+                    & normalizeTorsionOrders+                    & filter (`elem` observedSupport)+             in if null missingOrders && null forbiddenOrders+                  then []+                  else [RequirePrimaryOrderSupportViolation supportConstraintValue missingOrders forbiddenOrders]+    TorsionBudgetConstraint budgetValue ->+      withTorsionPresent constraintValue torsionFamily $ \_ ->+        let observedCount =+              observeTorsionBudget+                (torsionBudgetDegree budgetValue)+                (torsionBudgetOrder budgetValue)+                (torsionBudgetMeasure budgetValue)+                torsionFamily+         in checkBound (torsionBudgetBound budgetValue) observedCount+              (TorsionBudgetViolation budgetValue observedCount)+    RequireCyclicOrderConstraint cyclicOrderValue ->+      withTorsionPresent constraintValue torsionFamily $ \_ ->+        case gradedTorsionAtDegree+          (requiredCyclicDegree cyclicOrderValue)+          torsionFamily of+          Nothing ->+            [IntegralHomologyWitnessMissing constraintValue]+          Just torsionValue ->+            let observedCount =+                  torsionValue+                    & finiteAbelianCyclicSummandMultiplicity+                      (requiredCyclicOrder cyclicOrderValue)+             in checkBound (requiredCyclicMultiplicity cyclicOrderValue) observedCount+                  (RequireCyclicOrderViolation cyclicOrderValue observedCount)+    SingularityBudgetConstraint singularityBudgetValue ->+      case runTopologyObserver observeScaffoldSummary topologyView of+        Nothing -> [MacroScaffoldMissing constraintValue]+        Just scaffoldSummaryValue ->+          singularityBounds singularityBudgetValue+            & Map.toList+            >>= ( \(criticalKindValue, boundValue) ->+                    let observedCount =+                          signatureCriticalCounts scaffoldSummaryValue+                            & Map.findWithDefault 0 criticalKindValue+                     in checkBound boundValue observedCount+                          (SingularityBudgetViolation criticalKindValue boundValue observedCount)+               )+    HarmonicLoopBudgetConstraint harmonicBudgetValue ->+      let observedCount =+            runTopologyObserver+              (observeHarmonicCount (selectDegree (harmonicLoopDegree harmonicBudgetValue)))+              topologyView+       in checkBound (harmonicLoopCountBound harmonicBudgetValue) observedCount+            (HarmonicLoopBudgetViolation harmonicBudgetValue observedCount)+    SkeletonAdherenceConstraint adherenceValue ->+      case runTopologyObserver observeScaffoldSummary topologyView of+        Nothing -> [MacroScaffoldMissing constraintValue]+        Just scaffoldSummaryValue ->+          if skeletonWithinTolerance adherenceValue scaffoldSummaryValue+                then []+                else [SkeletonAdherenceViolation adherenceValue scaffoldSummaryValue]++evaluateTopologicalConstraints ::+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  [TopologicalConstraint] ->+  [TopologicalViolation]+evaluateTopologicalConstraints witnessValue =+  foldMap (evaluateTopologicalConstraint witnessValue)++countPersistentFeatures :: PersistenceBudget -> [PersistencePair FiltrationValue] -> Int+countPersistentFeatures budgetValue persistencePairsValue =+  persistencePairsValue+    & filter (meetsLifetimeBudget (persistenceBudgetMinimumLifetime budgetValue))+    & length++meetsLifetimeBudget :: FiltrationValue -> PersistencePair FiltrationValue -> Bool+meetsLifetimeBudget minimumLifetime pairValue =+  case persistenceDeath pairValue of+    Nothing -> True+    Just deathValue ->+      filtrationDifference deathValue (persistenceBirth pairValue) >= unFiltrationValue minimumLifetime++filtrationDifference :: FiltrationValue -> FiltrationValue -> Double+filtrationDifference endValue startValue =+  unFiltrationValue endValue - unFiltrationValue startValue++observeTorsionBudget ::+  Maybe HomologicalDegree ->+  Maybe Integer ->+  TorsionBudgetMeasure ->+  GradedTorsionFamily ->+  Integer+observeTorsionBudget degreeConstraint orderConstraint measure torsionFamily =+  let selectionValue = degreeSelectionFromMaybe degreeConstraint+      observedTorsion =+        gradedTorsionCombined selectionValue torsionFamily+   in case measure of+        TorsionSummandCount ->+          finiteAbelianSummandCount orderConstraint observedTorsion+        TorsionTotalCardinality ->+          finiteAbelianFilteredCardinality orderConstraint observedTorsion+        TorsionElementOrderCount ->+          case orderConstraint of+            Nothing -> finiteAbelianCardinality observedTorsion+            Just orderValue ->+              finiteAbelianExactOrderElementCount orderValue observedTorsion+        TorsionOrderSupportCount ->+          gradedTorsionOrderSupport (preserveDegreewiseQuery selectionValue) torsionFamily+            & filter (matchesOptional (fmap abs orderConstraint) . abs)+            & length+            & toInteger++withTorsionPresent ::+  TopologicalConstraint ->+  GradedTorsionFamily ->+  (GradedTorsionFamily -> [TopologicalViolation]) ->+  [TopologicalViolation]+withTorsionPresent constraintValue torsionFamily evaluator =+  if gradedTorsionPresent torsionFamily+    then evaluator torsionFamily+    else [IntegralHomologyWitnessMissing constraintValue]++skeletonWithinTolerance :: SkeletonAdherence -> SkeletonSignature -> Bool+skeletonWithinTolerance adherenceValue observedSignature =+  skeletonSignatureWithinTolerance+    (skeletonTolerance adherenceValue)+    (skeletonTargetSignature adherenceValue)+    observedSignature
+ src-topology/Moonlight/Homology/Pure/Topology.hs view
@@ -0,0 +1,286 @@+module Moonlight.Homology.Pure.Topology+  ( CellTypes (..),+    Dimension (..),+    CellRef (..),+    cellDimension,+    OrientedEdge (..),+    CellComplex2D (..),+    ValidateComplex2D (..),+    isBoundaryEdge,+    isInteriorEdge,+    eulerCharacteristic,+    BasisCellRef (..),+    MorsePivotOps (..),+    intUnitMorsePivotOps,+    integerUnitMorsePivotOps,+    rationalMorsePivotOps,+    gf2MorsePivotOps,+    AlgebraicMorsePair,+    AlgebraicMorseMatching,+    AlgebraicMorseComplex,+    AcyclicPair (..),+    IntegralAcyclicPair,+    LocalizedAcyclicPair (..),+    RationalAcyclicPair,+    CollapseObstruction (..),+    LocalizedCollapseObstruction (..),+    AcyclicMatching (..),+    LocalizedAcyclicMatching (..),+    MorseComplex (..),+    LocalizedMorseComplex (..),+    RefinedMatchingStage,+    RefinedAcyclicMatching,+    RefinedMatchingSummary (..),+    FiltrationValue (..),+    FilteredFiniteChainComplex (..),+    TopologyObservationConfig (..),+    defaultTopologyObservationConfig,+    TopologyWitnessSeed (..),+    CriticalKind (..),+    PotentialValue,+    PotentialValueError (..),+    unPotentialValue,+    mkPotentialValue,+    PotentialNormalization (..),+    CellCarrier,+    CellCarrierError (..),+    carrierDegree,+    carrierCells,+    mkCellCarrier,+    ScalarPotentialField,+    ScalarPotentialFieldError (..),+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+    mkScalarPotentialField,+    mkScalarPotentialFieldFromSamples,+    DirectionSymmetryOrder,+    DirectionSymmetryOrderError (..),+    unDirectionSymmetryOrder,+    mkDirectionSymmetryOrder,+    DirectionPhase,+    DirectionPhaseError (..),+    unDirectionPhase,+    mkDirectionPhase,+    DirectionCoefficient,+    DirectionCoefficientError (..),+    unDirectionCoefficient,+    mkDirectionCoefficient,+    DirectionFieldEncoding (..),+    DirectionField,+    DirectionFieldError (..),+    directionFieldCarrier,+    directionFieldSymmetryOrder,+    directionFieldEncoding,+    mkDirectionField,+    mkDirectionAngleField,+    mkDirectionCochainField,+    ReebNodeId (..),+    ReebArcId (..),+    MorseReebNode (..),+    Monotonicity (..),+    MorseReebArc (..),+    MorseReebScaffold (..),+    SingularityIndex (..),+    SingularityId (..),+    Singularity (..),+    HarmonicLoopId (..),+    HarmonicLoopWeight (..),+    HarmonicLoopPeriod (..),+    HarmonicLoop (..),+    MacroScaffoldIR (..),+    MacroScaffoldCompositionError (..),+    StitchRoute (..),+    StitchRouteKey (..),+    StitchBoundarySide (..),+    StitchSupportSelection (..),+    StitchSupportRefinement (..),+    StitchSemantics (..),+    MacroScaffoldStitchError (..),+    composeMacroScaffoldsWithScopes,+    composeMacroScaffolds,+    stitchMacroScaffoldRoutes,+    GraphEdge (..),+    Graph1Skeleton (..),+    graphAdjacency,+    GraphSkeletonExtractionFailure (..),+    GraphSpectralMode (..),+    mkFilteredFiniteChainComplex,+    eulerCharacteristicOf,+    integralHomologyGroupsOf,+    exactRepresentativeClassesOf,+    freeBettiVector,+    representativeCyclesOverQ,+    representativeCocyclesOverQ,+    homologyBasisAt,+    cohomologyBasisAt,+    sparseHomologyBasisAt,+    sparseCohomologyBasisAt,+    sparseFreeBettiVector,+    sparseQuotientRepresentatives,+    QuotientPresentation (..),+    mkQuotientPresentation,+    presentationCoordinates,+    quotientRepresentatives,+    vectorToRepresentative,+    representativeToVector,+    exactTopologyWitness,+    mod2PersistentPairs,+    mod2PersistenceTopologyWitness,+    TopologyTarget (..),+    TargetViolation (..),+    topologyTargetConstraints,+    validateTarget,+    validateTargets,+    validateTopologyTarget,+    validateTopologyTargets,+    graphFromEdgeSupports,+    graph1SkeletonFromComplex,+    graphFiniteChainComplex,+    graphMacroScaffold,+    acyclicMatching,+    acyclicMatchingLocalized,+    refinedAcyclicMatchingTranscript,+    foldRefinedAcyclicMatching,+    traverseRefinedStages,+    mapRefinedStages,+    summarizeRefinedMatching,+    refinedMatchingSummary,+    refinedStageCount,+    hasRefinedStages,+    isTerminalRefinedMatching,+    finalRefinedCriticalDegrees,+    finalRefinedCriticalCellCount,+    finalRefinedCriticalDegreeHistogram,+    finalRefinedHomologicalSupport,+    finalRefinedMaxCriticalDegree,+    refinedMatchingCriticalCells,+    refinedStageMatching,+    refinedStageReducedComplex,+    refinedStageCriticalBasis,+    flattenRefinedAcyclicMatching,+    refinedAcyclicMatching,+    acyclicMatchingWith,+    morseComplexWith,+    isAcyclicMatchingWith,+    extractCandidatePairsWith,+    reverseCandidateEdgeWith,+    graphSpectralModes,+    graphTopologyWitness,+    criticalKindAt,+    lowerNeighborEdges,+    lowerNeighbors,+    higherNeighborEdges,+    higherNeighbors,+    isAcyclicMatching,+    isAcyclicMatchingLocalized,+    morseComplex,+    morseComplexLocalized,+    extractCandidatePairsLocalized,+    reverseCandidateEdgeLocalized,+    addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+    observeGraphTopologyWitness,+    observeTopologyWitnessSeed,+    observeTopologyWitness,+    Orientation (..),+    RawCellData (..),+    RawCellScopes (..),+    RealizationBudget (..),+    realizeScaffoldRawWithScopes,+    realizeScaffoldRaw,+  )+where++import Data.Function ((&))+import Data.Kind (Type)+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex)+import Moonlight.Homology.Pure.Chain+  ( TopologyWitness (..),+    emptyTopologyWitness,+    mergeTopologyWitness,+  )+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Topology.Algebra+import Moonlight.Homology.Pure.Topology.SparseAlgebra+import Moonlight.Homology.Pure.Topology.CellComplex+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.Homology.Pure.Topology.Graph+import Moonlight.Homology.Pure.Topology.Harmonic (attachDiscoveredHarmonicLoops)+import Moonlight.Homology.Pure.Topology.Integral (exactRepresentativeClassesOf, integralHomologyGroupsOf)+import Moonlight.Homology.Pure.Topology.MacroScaffold+import Moonlight.Homology.Pure.Topology.Morse+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose+import Moonlight.Homology.Pure.Topology.Observation+import Moonlight.Homology.Pure.Topology.Persistence+import Moonlight.Homology.Pure.Topology.Realize+import Moonlight.Homology.Pure.Topology.Target++type TopologyWitnessSeed :: Type -> Type+data TopologyWitnessSeed r+  = GraphTopologySeed Graph1Skeleton (Maybe (FilteredFiniteChainComplex r)) (Maybe ScalarPotentialField) Int+  | FiniteTopologySeed (FiniteChainComplex r) (TopologyObservationConfig r)++observeTopologyWitnessSeed ::+  Integral r =>+  TopologyWitnessSeed r ->+  Either HomologyFailure (TopologyWitness MacroScaffoldIR GraphSpectralMode FiltrationValue Rational Int)+observeTopologyWitnessSeed topologySeed =+  case topologySeed of+    GraphTopologySeed skeleton maybeFiltered maybePotential requestedModeCount ->+      observeGraphTopologyWitness maybeFiltered maybePotential requestedModeCount skeleton+    FiniteTopologySeed finite config ->+      observeTopologyWitness config finite++observeGraphTopologyWitness ::+  Integral r =>+  Maybe (FilteredFiniteChainComplex r) ->+  Maybe ScalarPotentialField ->+  Int ->+  Graph1Skeleton ->+  Either HomologyFailure (TopologyWitness MacroScaffoldIR GraphSpectralMode FiltrationValue Rational Int)+observeGraphTopologyWitness maybeFiltered maybePotential requestedModeCount skeleton = do+  graphComplex <- (graphFiniteChainComplex skeleton :: Either HomologyFailure (FiniteChainComplex Integer))+  exactWitness <- exactTopologyWitness graphComplex+  persistenceWitness <-+    maybe+      (Right emptyTopologyWitness)+      mod2PersistenceTopologyWitness+      maybeFiltered+  graphWitness <- graphTopologyWitness requestedModeCount maybePotential skeleton+  pure+    ( exactWitness+        `mergeTopologyWitness` persistenceWitness+        `mergeTopologyWitness` graphWitness+        & attachDiscoveredHarmonicLoops graphComplex+    )++observeTopologyWitness ::+  Integral r =>+  TopologyObservationConfig r ->+  FiniteChainComplex r ->+  Either HomologyFailure (TopologyWitness MacroScaffoldIR GraphSpectralMode FiltrationValue Rational Int)+observeTopologyWitness config finite = do+  exactWitness <- exactTopologyWitness finite+  persistenceWitness <-+    maybe+      (Right emptyTopologyWitness)+      mod2PersistenceTopologyWitness+      (observationFiltration config)+  graphWitness <-+    case graph1SkeletonFromComplex finite of+      Right skeleton ->+        graphTopologyWitness+          (observationLowModeCount config)+          (observationPotential config)+          skeleton+      Left extractionFailure ->+        if observationLowModeCount config > 0 || maybe False (const True) (observationPotential config)+          then Left (InvalidTopologyInput ("graph extraction requires explicit oriented unit two-endpoint 1-cell boundaries: " <> show extractionFailure))+          else Right emptyTopologyWitness+  pure+    ( exactWitness+        `mergeTopologyWitness` persistenceWitness+        `mergeTopologyWitness` graphWitness+        & attachDiscoveredHarmonicLoops finite+    )
+ src-topology/Moonlight/Homology/Pure/Topology/Algebra.hs view
@@ -0,0 +1,331 @@+module Moonlight.Homology.Pure.Topology.Algebra+  ( eulerCharacteristicOf,+    freeBettiVector,+    representativeCyclesOverQ,+    representativeCocyclesOverQ,+    exactTopologyWitness,+    homologyBasisAt,+    cohomologyBasisAt,+    QuotientPresentation (..),+    mkQuotientPresentation,+    presentationCoordinates,+    quotientRepresentatives,+    vectorToRepresentative,+    representativeToVector,+  )+where++import Data.Function ((&))+import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type)+import qualified Data.Map.Strict as Map+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex, incidenceMatrixAt)+import Moonlight.Homology.Pure.Chain+  ( EulerCharacteristic (..),+    HarmonicBasisElement,+    HomologicalDegree (..),+    RepresentativeChain (..),+    RepresentativeCocycle,+    RepresentativeCycle,+    TopologyWitness (..),+    emptyTopologyWitness,+  )+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Group (HomologyGroup (..))+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.Homology.Pure.Topology.Integral (IntegralHomologyDegreeWitness (integralWitnessClasses, integralWitnessGroup), integralHomologyWitnessesOf)+import Moonlight.Homology.Pure.Topology.MacroScaffold (MacroScaffoldIR)+import Moonlight.Homology.Pure.Topology.SparseAlgebra+  ( sparseCohomologyBasisAt,+    sparseHomologyBasisAt,+  )+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseCoordinateBasis,+    SparseMatrix (..),+    SparseRow,+    sparseBoundaryMatrix,+    sparseCoordinateBasis,+    sparseCoordinatesInBasis,+    sparseImageBasisOf,+    sparseImageBasisFromRref,+    sparseIndependentModulo,+    sparseKernelBasisOf,+    sparseKernelBasisFromRref,+    sparseMatrixFromRows,+    sparseRref,+    sparseRowFromDense,+    sparseRowLookup,+    sparseTransposeMatrix,+  )++eulerCharacteristicOf :: FiniteChainComplex r -> EulerCharacteristic+eulerCharacteristicOf finite =+  EulerCharacteristic+    ( alternatingSignedSum+        (fmap (cellCountAtDegree finite) (dimensionsOf finite))+    )++freeBettiVector :: Integral r => FiniteChainComplex r -> [Int]+freeBettiVector finite =+  dimensionsOf finite+    & fmap (length . homologyBasisAt finite)++representativeCyclesOverQ :: Integral r => FiniteChainComplex r -> [RepresentativeCycle Rational Int]+representativeCyclesOverQ finite =+  dimensionsOf finite+    >>= homologyBasisAt finite++representativeCocyclesOverQ :: Integral r => FiniteChainComplex r -> [RepresentativeCocycle Rational Int]+representativeCocyclesOverQ finite =+  dimensionsOf finite+    >>= cohomologyBasisAt finite++exactTopologyWitness ::+  Integral r =>+  FiniteChainComplex r ->+  Either HomologyFailure (TopologyWitness MacroScaffoldIR GraphSpectralMode FiltrationValue Rational Int)+exactTopologyWitness finite = do+  integralWitnesses <- integralHomologyWitnessesOf finite+  rationalBoundaries <- rationalBoundaryDecompositions finite+  let integralGroups = fmap integralWitnessGroup integralWitnesses+      integralClasses = integralWitnesses >>= integralWitnessClasses+  pure+    emptyTopologyWitness+      { topologyEulerCharacteristic = Just (eulerCharacteristicOf finite),+        topologyBettiVector = fmap freeRank integralGroups,+        topologyIntegralHomologyGroups = integralGroups,+        topologyExactRepresentativeClasses = integralClasses,+        topologyCoefficientRepresentativeCycles = representativeCyclesOverQPrepared finite rationalBoundaries,+        topologyCoefficientRepresentativeCocycles = representativeCocyclesOverQPrepared finite rationalBoundaries,+        topologyHarmonicBasis = [] :: [HarmonicBasisElement Rational Int]+      }++type QuotientPresentation :: Type -> Type+data QuotientPresentation r = QuotientPresentation+  { presentationAmbientDimension :: Int,+    presentationBasisVectors :: [[Rational]],+    presentationDenominatorBasis :: [[Rational]],+    presentationCoordinateBasis :: SparseCoordinateBasis,+    presentationRepresentatives :: [RepresentativeCocycle r Int]+  }+  deriving stock (Eq, Show)++type RationalBoundaryDecomposition :: Type+data RationalBoundaryDecomposition = RationalBoundaryDecomposition+  { rationalBoundaryDegree :: HomologicalDegree,+    rationalBoundaryKernelBasis :: [SparseRow],+    rationalBoundaryImageBasis :: [SparseRow],+    rationalCoboundaryKernelBasis :: [SparseRow],+    rationalCoboundaryImageBasis :: [SparseRow]+  }+  deriving stock (Eq, Show)++homologyBasisAt :: Integral r => FiniteChainComplex r -> HomologicalDegree -> [RepresentativeCycle Rational Int]+homologyBasisAt =+  sparseHomologyBasisAt++cohomologyBasisAt :: Integral r => FiniteChainComplex r -> HomologicalDegree -> [RepresentativeCocycle Rational Int]+cohomologyBasisAt =+  sparseCohomologyBasisAt++mkQuotientPresentation ::+  Int ->+  [[Rational]] ->+  [RepresentativeCocycle Rational Int] ->+  [[Rational]] ->+  QuotientPresentation Rational+mkQuotientPresentation ambientDimension basisVectors representatives denominatorBasis =+  QuotientPresentation+    { presentationAmbientDimension = ambientDimension,+      presentationBasisVectors = basisVectors,+      presentationDenominatorBasis = denominatorBasis,+      presentationCoordinateBasis =+        sparseCoordinateBasis+          ambientDimension+          (fmap sparseRowFromDense (basisVectors <> denominatorBasis)),+      presentationRepresentatives = representatives+    }++presentationCoordinates :: QuotientPresentation Rational -> [Rational] -> Maybe [Rational]+presentationCoordinates presentation vectorValue =+  if length vectorValue /= presentationAmbientDimension presentation+    then Nothing+    else+      sparseCoordinatesInBasis+        (presentationCoordinateBasis presentation)+        (sparseRowFromDense vectorValue)+        & fmap+          ( \coordinates ->+              enumerateFromZero (length (presentationBasisVectors presentation))+                & fmap (\indexValue -> sparseRowLookup indexValue coordinates)+          )++quotientRepresentatives ::+  HomologicalDegree ->+  Int ->+  [[Rational]] ->+  [[Rational]] ->+  [RepresentativeChain Rational Int]+quotientRepresentatives degreeValue ambientDimension currentMatrix incomingMatrix =+  let currentSparse =+        sparseMatrixFromRows ambientDimension currentMatrix+      incomingSparse =+        sparseMatrixFromRows (matrixColumnCount incomingMatrix) incomingMatrix+      kernelBasis = sparseKernelBasisOf ambientDimension currentSparse+      imageBasis = sparseImageBasisOf incomingSparse+      quotientBasis = sparseIndependentModulo ambientDimension imageBasis kernelBasis+   in quotientBasis+        & fmap (sparseVectorToRepresentative degreeValue)++vectorToRepresentative :: HomologicalDegree -> [Rational] -> RepresentativeChain Rational Int+vectorToRepresentative degreeValue vectorValue =+  RepresentativeChain+    { representativeDegree = degreeValue,+      representativeTerms =+        vectorValue+          & zip [0 :: Int ..]+          & filter (\(_, coefficientValue) -> coefficientValue /= 0)+          & fmap (\(basisIndexValue, coefficientValue) -> (coefficientValue, basisIndexValue))+    }++representativeToVector :: Int -> RepresentativeChain Rational Int -> [Rational]+representativeToVector ambientDimension representative =+  let coefficientMap =+        representativeTerms representative+          & foldr+            ( \(coefficientValue, basisIndexValue) mapValue ->+                Map.insertWith (+) basisIndexValue coefficientValue mapValue+            )+            Map.empty+   in enumerateFromZero ambientDimension+        & fmap (\indexValue -> Map.findWithDefault 0 indexValue coefficientMap)++rationalBoundaryDecompositions ::+  Integral r =>+  FiniteChainComplex r ->+  Either HomologyFailure (IntMap.IntMap RationalBoundaryDecomposition)+rationalBoundaryDecompositions finite =+  traverse+    ( \degreeValue@(HomologicalDegree degreeIndex) ->+        rationalBoundaryDecompositionAt finite degreeValue+          & fmap (\boundaryValue -> (degreeIndex, boundaryValue))+    )+    (dimensionsOf finite <> [nextRationalDegreeAfterFinite finite])+    & fmap IntMap.fromList++nextRationalDegreeAfterFinite :: FiniteChainComplex r -> HomologicalDegree+nextRationalDegreeAfterFinite finite =+  case dimensionsOf finite of+    [] -> HomologicalDegree 0+    degreeValues ->+      HomologicalDegree+        ( 1+            + maximum+              (fmap (\(HomologicalDegree degreeIndex) -> degreeIndex) degreeValues)+        )++rationalBoundaryDecompositionAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Either HomologyFailure RationalBoundaryDecomposition+rationalBoundaryDecompositionAt finite degreeValue@(HomologicalDegree degreeIndex) =+  let sourceDimension = cellCountAtDegree finite degreeValue+      targetDimension = cellCountAtDegree finite (HomologicalDegree (degreeIndex - 1))+      boundaryMatrix =+        (sparseBoundaryMatrix (incidenceMatrixAt finite degreeValue))+          { smColumnCount = sourceDimension+          }+      boundaryRref = sparseRref boundaryMatrix+      coboundaryMatrix =+        (sparseTransposeMatrix boundaryMatrix)+          { smColumnCount = targetDimension+          }+      coboundaryRref = sparseRref coboundaryMatrix+   in Right+        RationalBoundaryDecomposition+          { rationalBoundaryDegree = degreeValue,+            rationalBoundaryKernelBasis =+              sparseKernelBasisFromRref (smColumnCount boundaryMatrix) boundaryRref,+            rationalBoundaryImageBasis =+              sparseImageBasisFromRref boundaryMatrix boundaryRref,+            rationalCoboundaryKernelBasis =+              sparseKernelBasisFromRref (smColumnCount coboundaryMatrix) coboundaryRref,+            rationalCoboundaryImageBasis =+              sparseImageBasisFromRref coboundaryMatrix coboundaryRref+          }++representativeCyclesOverQPrepared ::+  FiniteChainComplex r ->+  IntMap.IntMap RationalBoundaryDecomposition ->+  [RepresentativeCycle Rational Int]+representativeCyclesOverQPrepared finite preparedBoundaries =+  dimensionsOf finite+    >>= homologyBasisAtPrepared finite preparedBoundaries++representativeCocyclesOverQPrepared ::+  FiniteChainComplex r ->+  IntMap.IntMap RationalBoundaryDecomposition ->+  [RepresentativeCocycle Rational Int]+representativeCocyclesOverQPrepared finite preparedBoundaries =+  dimensionsOf finite+    >>= cohomologyBasisAtPrepared finite preparedBoundaries++homologyBasisAtPrepared ::+  FiniteChainComplex r ->+  IntMap.IntMap RationalBoundaryDecomposition ->+  HomologicalDegree ->+  [RepresentativeCycle Rational Int]+homologyBasisAtPrepared finite preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) =+  let ambientDimension = cellCountAtDegree finite degreeValue+      currentKernel =+        rationalBoundaryKernelBasis+          (rationalBoundaryAt preparedBoundaries degreeValue)+      incomingImage =+        rationalBoundaryImageBasis+          (rationalBoundaryAt preparedBoundaries (HomologicalDegree (degreeIndex + 1)))+   in sparseIndependentModulo ambientDimension incomingImage currentKernel+        & fmap (sparseVectorToRepresentative degreeValue)++cohomologyBasisAtPrepared ::+  FiniteChainComplex r ->+  IntMap.IntMap RationalBoundaryDecomposition ->+  HomologicalDegree ->+  [RepresentativeCocycle Rational Int]+cohomologyBasisAtPrepared finite preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) =+  let ambientDimension = cellCountAtDegree finite degreeValue+      currentKernel =+        rationalCoboundaryKernelBasis+          (rationalBoundaryAt preparedBoundaries (HomologicalDegree (degreeIndex + 1)))+      incomingImage =+        rationalCoboundaryImageBasis+          (rationalBoundaryAt preparedBoundaries degreeValue)+   in sparseIndependentModulo ambientDimension incomingImage currentKernel+        & fmap (sparseVectorToRepresentative degreeValue)++rationalBoundaryAt ::+  IntMap.IntMap RationalBoundaryDecomposition ->+  HomologicalDegree ->+  RationalBoundaryDecomposition+rationalBoundaryAt preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) =+  case IntMap.lookup degreeIndex preparedBoundaries of+    Just boundaryValue -> boundaryValue+    Nothing ->+      RationalBoundaryDecomposition+        { rationalBoundaryDegree = degreeValue,+          rationalBoundaryKernelBasis = [],+          rationalBoundaryImageBasis = [],+          rationalCoboundaryKernelBasis = [],+          rationalCoboundaryImageBasis = []+        }++sparseVectorToRepresentative :: HomologicalDegree -> SparseRow -> RepresentativeChain Rational Int+sparseVectorToRepresentative degreeValue rowValue =+  RepresentativeChain+    { representativeDegree = degreeValue,+      representativeTerms =+        rowValue+          & IntMap.toAscList+          & filter (\(_, coefficientValue) -> coefficientValue /= 0)+          & fmap (\(basisIndexValue, coefficientValue) -> (coefficientValue, basisIndexValue))+    }
+ src-topology/Moonlight/Homology/Pure/Topology/BlockSchur.hs view
@@ -0,0 +1,724 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneKindSignatures #-}++module Moonlight.Homology.Pure.Topology.BlockSchur+  ( BasisBlock (..),+    BlockSchurPivot (..),+    BlockPivotOps (..),+    integerUnimodularBlockPivotOps,+    rationalBlockPivotOps,+    gf2BlockPivotOps,+    BlockSchurTranscript (..),+    BlockSchurReduction (..),+    BlockSchurFailure (..),+    blockSchurReduceWith,+  )+where++import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.IntMap.Strict qualified as IntMap+import Data.Kind (Type)+import Data.List (transpose)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Moonlight.Core (Semiring)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    degreeCardinality,+    incidenceMatrixAt,+    maxHomologicalDegree,+    mkFiniteChainComplex,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    BoundaryIncidence,+    BoundaryIncidenceShapeError (..),+    boundaryCoefficient,+    boundaryEntries,+    composeBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    mkBoundaryEntry,+    mkBoundaryIncidenceFromOrderedEntries,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyLaw (..))+import Moonlight.Homology.Pure.LinearCombination qualified as LC+import Moonlight.Homology.Pure.Reductions (ChainHomotopy (..), ChainMap (..))+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Topology.Core (allBasisCellRefs, dimensionsOf)+import Moonlight.LinAlg.Pure.Dense.Block+  ( BlockMatrixFailure (..),+    invertGF2Block,+    invertRationalBlock,+    invertUnimodularIntegerBlock,+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2 (..))++-- | A finite ordered block of basis coordinates inside one chain degree.+type BasisBlock :: Type+data BasisBlock = BasisBlock+  { basisBlockDegree :: !HomologicalDegree,+    basisBlockIndices :: ![Int]+  }+  deriving stock (Eq, Ord, Show)++-- | A cancellable block in d_n: upper degree n sources contract with lower+-- degree n-1 targets through an invertible square submatrix.+type BlockSchurPivot :: Type+data BlockSchurPivot = BlockSchurPivot+  { bspUpperBlock :: !BasisBlock,+    bspLowerBlock :: !BasisBlock+  }+  deriving stock (Eq, Ord, Show)++type BlockPivotOps :: Type -> Type+data BlockPivotOps coefficient = BlockPivotOps+  { bpoZero :: !coefficient,+    bpoOne :: !coefficient,+    bpoIsZero :: coefficient -> Bool,+    bpoAdd :: coefficient -> coefficient -> coefficient,+    bpoNegate :: coefficient -> coefficient,+    bpoMultiply :: coefficient -> coefficient -> coefficient,+    bpoInvertBlock :: [[coefficient]] -> Either BlockMatrixFailure [[coefficient]]+  }++integerUnimodularBlockPivotOps :: BlockPivotOps Integer+integerUnimodularBlockPivotOps =+  BlockPivotOps+    { bpoZero = 0,+      bpoOne = 1,+      bpoIsZero = (== 0),+      bpoAdd = (+),+      bpoNegate = negate,+      bpoMultiply = (*),+      bpoInvertBlock = invertUnimodularIntegerBlock+    }++rationalBlockPivotOps :: BlockPivotOps Rational+rationalBlockPivotOps =+  BlockPivotOps+    { bpoZero = 0,+      bpoOne = 1,+      bpoIsZero = (== 0),+      bpoAdd = (+),+      bpoNegate = negate,+      bpoMultiply = (*),+      bpoInvertBlock = invertRationalBlock+    }++gf2BlockPivotOps :: BlockPivotOps GF2+gf2BlockPivotOps =+  BlockPivotOps+    { bpoZero = GF2Zero,+      bpoOne = GF2One,+      bpoIsZero = (== GF2Zero),+      bpoAdd = (+),+      bpoNegate = id,+      bpoMultiply = (*),+      bpoInvertBlock = invertGF2Block+    }++type BlockSchurTranscript :: Type -> Type+data BlockSchurTranscript coefficient = BlockSchurTranscript+  { bstPivot :: !BlockSchurPivot,+    bstPivotMatrix :: ![[coefficient]],+    bstPivotInverse :: ![[coefficient]],+    bstResidualBoundary :: !(BoundaryIncidence coefficient),+    bstRemainingSourceIndices :: ![Int],+    bstRemainingTargetIndices :: ![Int]+  }+  deriving stock (Eq, Show)++type BlockSchurReduction :: Type -> Type+data BlockSchurReduction coefficient = BlockSchurReduction+  { bsrOriginalComplex :: !(FiniteChainComplex coefficient),+    bsrReducedComplex :: !(FiniteChainComplex coefficient),+    bsrTranscript :: !(BlockSchurTranscript coefficient),+    bsrProjection :: !(ChainMap BasisCellRef BasisCellRef coefficient),+    bsrInclusion :: !(ChainMap BasisCellRef BasisCellRef coefficient),+    bsrHomotopy :: !(ChainHomotopy BasisCellRef coefficient)+  }++type BlockSchurFailure :: Type -> Type+data BlockSchurFailure coefficient+  = BlockSchurUpperBlockEmpty !BasisBlock+  | BlockSchurLowerBlockEmpty !BasisBlock+  | BlockSchurPivotDegreeMismatch !HomologicalDegree !HomologicalDegree+  | BlockSchurPivotSizeMismatch !Int !Int+  | BlockSchurPivotIndexOutOfBounds !HomologicalDegree !Int !Int+  | BlockSchurPivotDuplicateIndex !BasisBlock+  | BlockSchurPivotMatrixFailed !BlockMatrixFailure+  | BlockSchurBoundaryShapeFailed !BoundaryIncidenceShapeError+  | BlockSchurReducedNilpotenceFailed !HomologicalDegree !HomologicalDegree !Int !Int !coefficient+  | BlockSchurReductionLawFailed !HomologyLaw+  deriving stock (Eq, Show)++blockSchurReduceWith ::+  (Eq coefficient, Num coefficient, Semiring coefficient) =>+  BlockPivotOps coefficient ->+  FiniteChainComplex coefficient ->+  BlockSchurPivot ->+  Either (BlockSchurFailure coefficient) (BlockSchurReduction coefficient)+blockSchurReduceWith ops complex pivot = do+  validatePivotBlocks complex pivot+  let upperBlock = bspUpperBlock pivot+      lowerBlock = bspLowerBlock pivot+      upperDegree = basisBlockDegree upperBlock+      boundary = incidenceMatrixAt complex upperDegree+      boundaryCoefficients = boundaryCoefficientMap boundary+      upperIndices = basisBlockIndices upperBlock+      lowerIndices = basisBlockIndices lowerBlock+      remainingSources = remainingIndices upperIndices (sourceCardinality boundary)+      remainingTargets = remainingIndices lowerIndices (targetCardinality boundary)+      pivotMatrix = submatrixOf ops boundaryCoefficients upperIndices lowerIndices+      aMatrix = submatrixOf ops boundaryCoefficients remainingSources lowerIndices+      bMatrix = submatrixOf ops boundaryCoefficients upperIndices remainingTargets+      cMatrix = submatrixOf ops boundaryCoefficients remainingSources remainingTargets+  pivotInverse <- first BlockSchurPivotMatrixFailed (bpoInvertBlock ops pivotMatrix)+  residualMatrix <- residualSchurMatrix ops cMatrix bMatrix pivotInverse aMatrix+  residualBoundary <-+    first BlockSchurBoundaryShapeFailed $+      matrixBoundaryIncidence ops (length remainingSources) (length remainingTargets) residualMatrix+  let reindexing = blockSchurReindexing complex pivot+      reducedComplex =+        mkFiniteChainComplex+          (maxHomologicalDegree complex)+          (reducedBoundaryFor ops complex pivot reindexing residualBoundary)+      transcript =+        BlockSchurTranscript+          { bstPivot = pivot,+            bstPivotMatrix = pivotMatrix,+            bstPivotInverse = pivotInverse,+            bstResidualBoundary = residualBoundary,+            bstRemainingSourceIndices = remainingSources,+            bstRemainingTargetIndices = remainingTargets+          }+      projectionMap = projectionFor ops pivot reindexing bMatrix pivotInverse+      inclusionMap = inclusionFor ops pivot reindexing pivotInverse aMatrix+      homotopyMap = homotopyFor ops pivot pivotInverse+  validateReducedNilpotence ops reducedComplex+  validateReductionLaws ops complex reducedComplex projectionMap inclusionMap homotopyMap+  pure+    BlockSchurReduction+      { bsrOriginalComplex = complex,+        bsrReducedComplex = reducedComplex,+        bsrTranscript = transcript,+        bsrProjection = projectionMap,+        bsrInclusion = inclusionMap,+        bsrHomotopy = homotopyMap+      }++validatePivotBlocks ::+  FiniteChainComplex coefficient ->+  BlockSchurPivot ->+  Either (BlockSchurFailure coefficient) ()+validatePivotBlocks complex pivot = do+  validateBlockNotEmpty BlockSchurUpperBlockEmpty upperBlock+  validateBlockNotEmpty BlockSchurLowerBlockEmpty lowerBlock+  validateDuplicateFree upperBlock+  validateDuplicateFree lowerBlock+  validateDegree+  validateSize+  traverse_ (validateIndex upperDegree upperDimension) upperIndices+  traverse_ (validateIndex lowerDegree lowerDimension) lowerIndices+  where+    upperBlock = bspUpperBlock pivot+    lowerBlock = bspLowerBlock pivot+    upperDegree@(HomologicalDegree upperDegreeInt) = basisBlockDegree upperBlock+    lowerDegree@(HomologicalDegree lowerDegreeInt) = basisBlockDegree lowerBlock+    upperIndices = basisBlockIndices upperBlock+    lowerIndices = basisBlockIndices lowerBlock+    upperDimension = degreeCardinality complex upperDegree+    lowerDimension = degreeCardinality complex lowerDegree++    validateDegree =+      if upperDegreeInt == lowerDegreeInt + 1+        then Right ()+        else Left (BlockSchurPivotDegreeMismatch upperDegree lowerDegree)++    validateSize =+      if length upperIndices == length lowerIndices+        then Right ()+        else Left (BlockSchurPivotSizeMismatch (length upperIndices) (length lowerIndices))++    validateIndex :: HomologicalDegree -> Int -> Int -> Either (BlockSchurFailure coefficient) ()+    validateIndex degreeValue dimension indexValue =+      if indexValue >= 0 && indexValue < dimension+        then Right ()+        else Left (BlockSchurPivotIndexOutOfBounds degreeValue indexValue dimension)++validateBlockNotEmpty ::+  (BasisBlock -> BlockSchurFailure coefficient) ->+  BasisBlock ->+  Either (BlockSchurFailure coefficient) ()+validateBlockNotEmpty failure block =+  case basisBlockIndices block of+    [] -> Left (failure block)+    _ : _ -> Right ()++validateDuplicateFree ::+  BasisBlock ->+  Either (BlockSchurFailure coefficient) ()+validateDuplicateFree block =+  if Set.size (Set.fromList (basisBlockIndices block)) == length (basisBlockIndices block)+    then Right ()+    else Left (BlockSchurPivotDuplicateIndex block)++remainingIndices :: [Int] -> Int -> [Int]+remainingIndices removed dimension =+  let removedSet = Set.fromList removed+   in filter (`Set.notMember` removedSet) [0 .. dimension - 1]+{-# INLINEABLE remainingIndices #-}++type BlockSchurReindexing :: Type+data BlockSchurReindexing = BlockSchurReindexing+  { bsrOldToNewByDegree :: !(Map HomologicalDegree (Map Int Int)),+    bsrNewToOldByDegree :: !(Map HomologicalDegree (Map Int Int))+  }+  deriving stock (Eq, Show)++blockSchurReindexing :: FiniteChainComplex coefficient -> BlockSchurPivot -> BlockSchurReindexing+blockSchurReindexing complex pivot =+  BlockSchurReindexing+    { bsrOldToNewByDegree = oldToNew,+      bsrNewToOldByDegree = newToOld+    }+  where+    HomologicalDegree maxDegreeInt = maxHomologicalDegree complex+    degrees = fmap HomologicalDegree [0 .. maxDegreeInt]+    upperBlock = bspUpperBlock pivot+    lowerBlock = bspLowerBlock pivot+    removedAt degreeValue+      | degreeValue == basisBlockDegree upperBlock = basisBlockIndices upperBlock+      | degreeValue == basisBlockDegree lowerBlock = basisBlockIndices lowerBlock+      | otherwise = []+    remainingAt degreeValue = remainingIndices (removedAt degreeValue) (degreeCardinality complex degreeValue)+    oldToNew = Map.fromList [(degreeValue, Map.fromList (zip (remainingAt degreeValue) [0 ..])) | degreeValue <- degrees]+    newToOld = Map.fromList [(degreeValue, Map.fromList (zip [0 ..] (remainingAt degreeValue))) | degreeValue <- degrees]++reducedCardinalityAt :: BlockSchurReindexing -> HomologicalDegree -> Int+reducedCardinalityAt reindexing degreeValue =+  maybe 0 Map.size (Map.lookup degreeValue (bsrOldToNewByDegree reindexing))+{-# INLINEABLE reducedCardinalityAt #-}++oldToNewIndex :: BlockSchurReindexing -> HomologicalDegree -> Int -> Maybe Int+oldToNewIndex reindexing degreeValue indexValue = do+  degreeMap <- Map.lookup degreeValue (bsrOldToNewByDegree reindexing)+  Map.lookup indexValue degreeMap+{-# INLINEABLE oldToNewIndex #-}++newToOldIndex :: BlockSchurReindexing -> HomologicalDegree -> Int -> Maybe Int+newToOldIndex reindexing degreeValue indexValue = do+  degreeMap <- Map.lookup degreeValue (bsrNewToOldByDegree reindexing)+  Map.lookup indexValue degreeMap+{-# INLINEABLE newToOldIndex #-}++reducedBoundaryFor ::+  (Eq coefficient, Semiring coefficient) =>+  BlockPivotOps coefficient ->+  FiniteChainComplex coefficient ->+  BlockSchurPivot ->+  BlockSchurReindexing ->+  BoundaryIncidence coefficient ->+  HomologicalDegree ->+  BoundaryIncidence coefficient+reducedBoundaryFor ops complex pivot reindexing residualBoundary degreeValue@(HomologicalDegree degreeInt)+  | degreeInt <= 0 =+      emptyBoundaryIncidenceOf+        (fromIntegral (reducedCardinalityAt reindexing (HomologicalDegree 0)))+        0+  | degreeValue == basisBlockDegree (bspUpperBlock pivot) =+      residualBoundary+  | otherwise =+      either+        (const (emptyBoundaryIncidenceOf sourceCount targetCount))+        id+        ( mkBoundaryIncidenceFromOrderedEntries+            sourceCount+            targetCount+            (restrictedBoundaryEntries (incidenceMatrixAt complex degreeValue))+        )+  where+    targetDegree = HomologicalDegree (degreeInt - 1)+    sourceCount = fromIntegral (reducedCardinalityAt reindexing degreeValue)+    targetCount = fromIntegral (reducedCardinalityAt reindexing targetDegree)++    restrictedBoundaryEntries incidence =+      mapMaybe+        ( \entry -> do+            newSource <- oldToNewIndex reindexing degreeValue (sourceIndex entry)+            newTarget <- oldToNewIndex reindexing targetDegree (targetIndex entry)+            if bpoIsZero ops (boundaryCoefficient entry)+              then Nothing+              else+                Just+                  ( mkBoundaryEntry+                      (fromIntegral newSource)+                      (fromIntegral newTarget)+                      (boundaryCoefficient entry)+                  )+        )+        (boundaryEntries incidence)++submatrixOf :: BlockPivotOps coefficient -> Map (Int, Int) coefficient -> [Int] -> [Int] -> [[coefficient]]+submatrixOf ops coefficients sourceIndices targetIndices =+  [ [ Map.findWithDefault (bpoZero ops) (sourceValue, targetValue) coefficients+      | sourceValue <- sourceIndices+    ]+    | targetValue <- targetIndices+  ]+{-# INLINEABLE submatrixOf #-}++boundaryCoefficientMap :: BoundaryIncidence coefficient -> Map (Int, Int) coefficient+boundaryCoefficientMap =+  Map.fromListWith const+    . fmap (\entry -> ((sourceIndex entry, targetIndex entry), boundaryCoefficient entry))+    . boundaryEntries+{-# INLINEABLE boundaryCoefficientMap #-}++residualSchurMatrix ::+  BlockPivotOps coefficient ->+  [[coefficient]] ->+  [[coefficient]] ->+  [[coefficient]] ->+  [[coefficient]] ->+  Either (BlockSchurFailure coefficient) [[coefficient]]+residualSchurMatrix ops cMatrix bMatrix pivotInverse aMatrix = do+  pivotTimesA <- matrixProduct ops pivotInverse aMatrix+  correction <- matrixProduct ops bMatrix pivotTimesA+  pure (matrixSubtract ops cMatrix correction)+{-# INLINEABLE residualSchurMatrix #-}++matrixProduct ::+  BlockPivotOps coefficient ->+  [[coefficient]] ->+  [[coefficient]] ->+  Either (BlockSchurFailure coefficient) [[coefficient]]+matrixProduct ops left right =+  let leftWidths = fmap length left+      rightRowCount = length right+   in if all (== rightRowCount) leftWidths+        then Right (matrixProductUnchecked ops left right)+        else Left (BlockSchurPivotMatrixFailed (BlockMatrixNotSquare rightRowCount leftWidths))+{-# INLINEABLE matrixProduct #-}++matrixProductUnchecked :: BlockPivotOps coefficient -> [[coefficient]] -> [[coefficient]] -> [[coefficient]]+matrixProductUnchecked ops left right =+  let rightColumns = transpose right+   in fmap+        (\leftRow -> fmap (dotWith ops leftRow) rightColumns)+        left+{-# INLINEABLE matrixProductUnchecked #-}++matrixSubtract :: BlockPivotOps coefficient -> [[coefficient]] -> [[coefficient]] -> [[coefficient]]+matrixSubtract ops left right =+  zipWith+    (zipWith (\leftEntry rightEntry -> bpoAdd ops leftEntry (bpoNegate ops rightEntry)))+    left+    right+{-# INLINEABLE matrixSubtract #-}++dotWith :: BlockPivotOps coefficient -> [coefficient] -> [coefficient] -> coefficient+dotWith ops left right =+  foldl'+    (bpoAdd ops)+    (bpoZero ops)+    (zipWith (bpoMultiply ops) left right)+{-# INLINEABLE dotWith #-}++matrixBoundaryIncidence ::+  (Eq coefficient, Semiring coefficient) =>+  BlockPivotOps coefficient ->+  Int ->+  Int ->+  [[coefficient]] ->+  Either BoundaryIncidenceShapeError (BoundaryIncidence coefficient)+matrixBoundaryIncidence ops sourceCount targetCount matrix+  | length matrix /= targetCount || any (/= sourceCount) (fmap length matrix) =+      Left+        ( BoundaryIncidenceBlockShapeMismatch+            sourceCount+            targetCount+            (maximumMaybe 0 (fmap length matrix))+            (length matrix)+        )+  | otherwise =+      mkBoundaryIncidenceFromOrderedEntries+        (fromIntegral sourceCount)+        (fromIntegral targetCount)+        entries+  where+    entries =+      [ mkBoundaryEntry (fromIntegral sourceLocal) (fromIntegral targetLocal) coefficientValue+        | (targetLocal, rowValues) <- zip [0 :: Int ..] matrix,+          (sourceLocal, coefficientValue) <- zip [0 :: Int ..] rowValues,+          not (bpoIsZero ops coefficientValue)+      ]+{-# INLINEABLE matrixBoundaryIncidence #-}++maximumMaybe :: Int -> [Int] -> Int+maximumMaybe fallback =+  foldr max fallback+{-# INLINE maximumMaybe #-}++projectionFor ::+  BlockPivotOps coefficient ->+  BlockSchurPivot ->+  BlockSchurReindexing ->+  [[coefficient]] ->+  [[coefficient]] ->+  ChainMap BasisCellRef BasisCellRef coefficient+projectionFor ops pivot reindexing bMatrix pivotInverse =+  ChainMap projectBasisRef+  where+    lowerBlock = bspLowerBlock pivot+    upperBlock = bspUpperBlock pivot+    upperDegree = basisBlockDegree upperBlock+    lowerDegree = basisBlockDegree lowerBlock+    lowerIndices = basisBlockIndices lowerBlock+    bPinv = matrixProductUnchecked ops bMatrix pivotInverse+    lowerProjectionColumns =+      Map.fromList+        [ ( lowerIndex,+            [ (bpoNegate ops coefficientValue, basisRefAt lowerDegree rowLocal)+              | (rowLocal, rowValues) <- zip [0 ..] bPinv,+                (colLocal, coefficientValue) <- zip [0 :: Int ..] rowValues,+                maybe False (== lowerIndex) (entryAt colLocal lowerIndices),+                not (bpoIsZero ops coefficientValue)+            ]+          )+          | lowerIndex <- lowerIndices+        ]++    projectBasisRef basisRef+      | cellDegree basisRef == lowerDegree =+          case oldToNewIndex reindexing lowerDegree (cellIndex basisRef) of+            Just newIndex -> [(bpoOne ops, basisRefAt lowerDegree newIndex)]+            Nothing -> Map.findWithDefault [] (cellIndex basisRef) lowerProjectionColumns+      | cellDegree basisRef == upperDegree =+          identityProjection basisRef+      | otherwise =+          identityProjection basisRef++    identityProjection basisRef =+      maybe [] (\newIndex -> [(bpoOne ops, basisRefAt (cellDegree basisRef) newIndex)]) (oldToNewIndex reindexing (cellDegree basisRef) (cellIndex basisRef))++inclusionFor ::+  BlockPivotOps coefficient ->+  BlockSchurPivot ->+  BlockSchurReindexing ->+  [[coefficient]] ->+  [[coefficient]] ->+  ChainMap BasisCellRef BasisCellRef coefficient+inclusionFor ops pivot reindexing pivotInverse aMatrix =+  ChainMap includeBasisRef+  where+    upperBlock = bspUpperBlock pivot+    upperDegree = basisBlockDegree upperBlock+    upperIndices = basisBlockIndices upperBlock+    pInvA = matrixProductUnchecked ops pivotInverse aMatrix++    includeBasisRef basisRef+      | cellDegree basisRef == upperDegree =+          case newToOldIndex reindexing upperDegree (cellIndex basisRef) of+            Nothing -> []+            Just oldSourceIndex ->+              (bpoOne ops, basisRefAt upperDegree oldSourceIndex)+                : [ (bpoNegate ops coefficientValue, basisRefAt upperDegree upperIndex)+                    | (upperLocal, rowValues) <- zip [0 ..] pInvA,+                      (sourceLocal, coefficientValue) <- zip [0 :: Int ..] rowValues,+                      sourceLocal == cellIndex basisRef,+                      Just upperIndex <- [entryAt upperLocal upperIndices],+                      not (bpoIsZero ops coefficientValue)+                  ]+      | otherwise =+          maybe [] (\oldIndex -> [(bpoOne ops, basisRefAt (cellDegree basisRef) oldIndex)]) (newToOldIndex reindexing (cellDegree basisRef) (cellIndex basisRef))++homotopyFor ::+  BlockPivotOps coefficient ->+  BlockSchurPivot ->+  [[coefficient]] ->+  ChainHomotopy BasisCellRef coefficient+homotopyFor ops pivot pivotInverse =+  ChainHomotopy homotopyBasisRef+  where+    upperBlock = bspUpperBlock pivot+    lowerBlock = bspLowerBlock pivot+    upperDegree = basisBlockDegree upperBlock+    lowerDegree = basisBlockDegree lowerBlock+    upperIndices = basisBlockIndices upperBlock+    lowerIndices = basisBlockIndices lowerBlock++    homotopyBasisRef basisRef+      | cellDegree basisRef == lowerDegree =+          case indexOf (cellIndex basisRef) lowerIndices of+            Nothing -> []+            Just lowerLocal ->+              [ (coefficientValue, basisRefAt upperDegree upperIndex)+                | (upperLocal, rowValues) <- zip [0 ..] pivotInverse,+                  (lowerLocalCandidate, coefficientValue) <- zip [0 :: Int ..] rowValues,+                  lowerLocalCandidate == lowerLocal,+                  Just upperIndex <- [entryAt upperLocal upperIndices],+                  not (bpoIsZero ops coefficientValue)+              ]+      | otherwise = []++basisRefAt :: HomologicalDegree -> Int -> BasisCellRef+basisRefAt degreeValue indexValue =+  BasisCellRef+    { cellDegree = degreeValue,+      cellIndex = indexValue+    }+{-# INLINE basisRefAt #-}++entryAt :: Int -> [entry] -> Maybe entry+entryAt indexValue entries+  | indexValue < 0 = Nothing+  | otherwise =+      case drop indexValue entries of+        entryValue : _ -> Just entryValue+        [] -> Nothing+{-# INLINE entryAt #-}++indexOf :: Eq value => value -> [value] -> Maybe Int+indexOf target =+  fmap fst . findFirst ((== target) . snd) . zip [0 ..]+{-# INLINEABLE indexOf #-}++findFirst :: (a -> Bool) -> [a] -> Maybe a+findFirst predicate =+  foldr (\value rest -> if predicate value then Just value else rest) Nothing+{-# INLINE findFirst #-}++validateReducedNilpotence ::+  (Eq coefficient, Num coefficient, Semiring coefficient) =>+  BlockPivotOps coefficient ->+  FiniteChainComplex coefficient ->+  Either (BlockSchurFailure coefficient) ()+validateReducedNilpotence ops complex =+  traverse_ validateDegree [1 .. maxDegreeInt]+  where+    HomologicalDegree maxDegreeInt = maxHomologicalDegree complex++    validateDegree degreeInt = do+      let rightDegree = HomologicalDegree degreeInt+          leftDegree = HomologicalDegree (degreeInt - 1)+      composite <-+        first BlockSchurBoundaryShapeFailed $+          composeBoundaryIncidence+            (incidenceMatrixAt complex leftDegree)+            (incidenceMatrixAt complex rightDegree)+      case firstNonZeroBoundaryEntry ops composite of+        Nothing -> Right ()+        Just entry ->+          Left+            ( BlockSchurReducedNilpotenceFailed+                rightDegree+                leftDegree+                (sourceIndex entry)+                (targetIndex entry)+                (boundaryCoefficient entry)+            )++firstNonZeroBoundaryEntry :: BlockPivotOps coefficient -> BoundaryIncidence coefficient -> Maybe (BoundaryEntry coefficient)+firstNonZeroBoundaryEntry ops =+  findFirst (not . bpoIsZero ops . boundaryCoefficient) . boundaryEntries+{-# INLINEABLE firstNonZeroBoundaryEntry #-}++validateReductionLaws ::+  Eq coefficient =>+  BlockPivotOps coefficient ->+  FiniteChainComplex coefficient ->+  FiniteChainComplex coefficient ->+  ChainMap BasisCellRef BasisCellRef coefficient ->+  ChainMap BasisCellRef BasisCellRef coefficient ->+  ChainHomotopy BasisCellRef coefficient ->+  Either (BlockSchurFailure coefficient) ()+validateReductionLaws ops largeComplex smallComplex projectionMap inclusionMap homotopyMap = do+  checkLaw ReductionProjectionChainMapLaw (allBasisCellRefs largeComplex) projectionLeft projectionRight+  checkLaw ReductionInclusionChainMapLaw (allBasisCellRefs smallComplex) inclusionLeft inclusionRight+  checkLaw ReductionHomotopyLaw (allBasisCellRefs largeComplex) homotopyLeft homotopyRight+  where+    arithmetic = blockArithmetic ops+    largeBoundary = boundaryOf (boundaryEntriesByDegree largeComplex)+    smallBoundary = boundaryOf (boundaryEntriesByDegree smallComplex)++    projectionLeft largeCell =+      LC.composeWith arithmetic smallBoundary (runChainMap projectionMap largeCell)+    projectionRight largeCell =+      LC.composeWith arithmetic (runChainMap projectionMap) (largeBoundary largeCell)++    inclusionLeft smallCell =+      LC.composeWith arithmetic largeBoundary (runChainMap inclusionMap smallCell)+    inclusionRight smallCell =+      LC.composeWith arithmetic (runChainMap inclusionMap) (smallBoundary smallCell)++    homotopyLeft largeCell =+      LC.subtractWith+        arithmetic+        (LC.identityWith arithmetic largeCell)+        (LC.composeWith arithmetic (runChainMap inclusionMap) (runChainMap projectionMap largeCell))+    homotopyRight largeCell =+      LC.addWith+        arithmetic+        (LC.composeWith arithmetic largeBoundary (runChainHomotopy homotopyMap largeCell))+        (LC.composeWith arithmetic (runChainHomotopy homotopyMap) (largeBoundary largeCell))++    checkLaw law basisValues leftSide rightSide =+      if all (lawHolds leftSide rightSide) basisValues+        then Right ()+        else Left (BlockSchurReductionLawFailed law)++    lawHolds leftSide rightSide basisValue =+      LC.normalizeWith arithmetic (leftSide basisValue) == LC.normalizeWith arithmetic (rightSide basisValue)++blockArithmetic :: BlockPivotOps coefficient -> LC.LinearCombinationArithmetic coefficient+blockArithmetic ops =+  LC.LinearCombinationArithmetic+    { LC.lcaZero = bpoZero ops,+      LC.lcaOne = bpoOne ops,+      LC.lcaAdd = bpoAdd ops,+      LC.lcaNegate = bpoNegate ops,+      LC.lcaMultiply = bpoMultiply ops+    }++boundaryOf ::+  Map HomologicalDegree (IntMap.IntMap [BoundaryEntry coefficient]) ->+  BasisCellRef ->+  [(coefficient, BasisCellRef)]+boundaryOf groupedBoundaryEntries basisRef =+  case cellDegree basisRef of+    HomologicalDegree degreeInt+      | degreeInt <= 0 -> []+      | otherwise ->+          let targetDegree = HomologicalDegree (degreeInt - 1)+              degreeEntries = Map.findWithDefault IntMap.empty (HomologicalDegree degreeInt) groupedBoundaryEntries+           in [ (boundaryCoefficient entry, basisRefAt targetDegree (targetIndex entry))+                | entry <- IntMap.findWithDefault [] (cellIndex basisRef) degreeEntries+              ]++boundaryEntriesByDegree ::+  FiniteChainComplex coefficient ->+  Map HomologicalDegree (IntMap.IntMap [BoundaryEntry coefficient])+boundaryEntriesByDegree complex =+  Map.fromList+    ( fmap+        (\degreeValue -> (degreeValue, entriesBySource (incidenceMatrixAt complex degreeValue)))+        (dimensionsOf complex)+    )++entriesBySource :: BoundaryIncidence coefficient -> IntMap.IntMap [BoundaryEntry coefficient]+entriesBySource incidence =+  foldr+    ( \entryValue ->+        IntMap.insertWith (<>) (sourceIndex entryValue) [entryValue]+    )+    IntMap.empty+    (boundaryEntries incidence)
+ src-topology/Moonlight/Homology/Pure/Topology/Core.hs view
@@ -0,0 +1,200 @@+module Moonlight.Homology.Pure.Topology.Core+  ( BasisCellRef (..),+    FiltrationValue (..),+    FilteredFiniteChainComplex (..),+    CriticalKind (..),+    GraphEdge (..),+    Graph1Skeleton (..),+    graphAdjacency,+    GraphSpectralMode (..),+    cellCountAtDegree,+    dimensionsOf,+    allBasisCellRefs,+    rowsRespectWidth,+    identityMatrix,+    zeroMatrix,+    chunkColumns,+    takeRows,+    dropRows,+    dropColumns,+    allZeroMatrix,+    transposeMatrix,+    matrixColumnCount,+    alternatingSignedSum,+    enumerateFromZero,+    toRationalFromIntegral,+    mapMaybeWithLookup,+    symmetricDifference,+    lowIndex,+  )+where++import Data.Kind (Type)+import Data.Function ((&))+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Ratio ((%))+import qualified Data.Set as Set+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex)+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Filtration+  ( CriticalKind (..),+    FiltrationValue (..),+    enumerateFromZero,+  )+import Moonlight.Homology.Pure.Matrix.Shape (cellCountAtDegree, dimensionsOf)+++type FilteredFiniteChainComplex :: Type -> Type+data FilteredFiniteChainComplex r = FilteredFiniteChainComplex+  { filteredBaseComplex :: FiniteChainComplex r,+    filteredCellBirths :: Map.Map BasisCellRef FiltrationValue+  }++type GraphEdge :: Type+data GraphEdge = GraphEdge+  { graphEdgeIndex :: Int,+    graphEdgeSource :: Int,+    graphEdgeTarget :: Int+  }+  deriving stock (Eq, Ord, Show)++type Graph1Skeleton :: Type+data Graph1Skeleton = Graph1Skeleton+  { graphVertexCount :: Int,+    graphEdges :: [GraphEdge],+    graphEdgeAdjacency :: Map.Map Int [GraphEdge]+  }+  deriving stock (Eq, Show)++graphAdjacency :: Graph1Skeleton -> Map.Map Int (Set.Set Int)+graphAdjacency skeleton =+  enumerateFromZero (graphVertexCount skeleton)+    & fmap+      ( \vertexValue ->+          ( vertexValue,+            graphEdgeAdjacency skeleton+              & Map.findWithDefault [] vertexValue+              & mapMaybe (oppositeGraphEdgeVertex vertexValue)+              & Set.fromList+          )+      )+    & Map.fromList++oppositeGraphEdgeVertex :: Int -> GraphEdge -> Maybe Int+oppositeGraphEdgeVertex vertexValue edgeValue =+  if graphEdgeSource edgeValue == vertexValue+    then Just (graphEdgeTarget edgeValue)+    else+      if graphEdgeTarget edgeValue == vertexValue+        then Just (graphEdgeSource edgeValue)+        else Nothing++type GraphSpectralMode :: Type+data GraphSpectralMode = GraphSpectralMode+  { spectralEigenvalue :: Double,+    spectralCoefficients :: [(Int, Double)],+    spectralPositiveSupport :: [Int],+    spectralNegativeSupport :: [Int],+    spectralSupportCriticality :: Double+  }+  deriving stock (Eq, Show)+++allBasisCellRefs :: FiniteChainComplex r -> [BasisCellRef]+allBasisCellRefs finite =+  dimensionsOf finite+    >>= ( \degreeValue ->+            enumerateFromZero (cellCountAtDegree finite degreeValue)+              & fmap+                ( \cellIndexValue ->+                    BasisCellRef+                      { cellDegree = degreeValue,+                        cellIndex = cellIndexValue+                      }+                )+       )++rowsRespectWidth :: Int -> [[a]] -> Bool+rowsRespectWidth expectedWidth =+  all ((== expectedWidth) . length)++identityMatrix :: Num a => Int -> [[a]]+identityMatrix matrixSize =+  enumerateFromZero matrixSize+    & fmap+      ( \rowIndexValue ->+          enumerateFromZero matrixSize+            & fmap (\columnIndexValue -> if rowIndexValue == columnIndexValue then 1 else 0)+      )++zeroMatrix :: Num a => Int -> Int -> [[a]]+zeroMatrix rowCount columnCount =+  enumerateFromZero rowCount+    & fmap (\_ -> enumerateFromZero columnCount & fmap (const 0))++chunkColumns :: Int -> [a] -> [[a]]+chunkColumns columnCount values =+  if columnCount <= 0+    then []+    else+      case splitAt columnCount values of+        ([], _) -> []+        (rowValues, []) -> [rowValues]+        (rowValues, remainderValues) -> rowValues : chunkColumns columnCount remainderValues++takeRows :: Int -> [[a]] -> [[a]]+takeRows = take++dropRows :: Int -> [[a]] -> [[a]]+dropRows = drop++dropColumns :: Int -> [[a]] -> [[a]]+dropColumns columnCount = fmap (drop columnCount)++allZeroMatrix :: (Eq a, Num a) => [[a]] -> Bool+allZeroMatrix =+  all (all (== 0))++transposeMatrix :: [[a]] -> [[a]]+transposeMatrix matrixRows =+  case matrixRows of+    [] -> []+    ([] : _) -> []+    _ -> List.transpose matrixRows++matrixColumnCount :: [[a]] -> Int+matrixColumnCount matrixRows =+  case matrixRows of+    rowValue : _ -> length rowValue+    [] -> 0++alternatingSignedSum :: [Int] -> Int+alternatingSignedSum values =+  values+    & zip [0 :: Int ..]+    & foldl'+      ( \accumulator (indexValue, countValue) ->+          if even indexValue+            then accumulator + countValue+            else accumulator - countValue+      )+      0+++toRationalFromIntegral :: Integral r => r -> Rational+toRationalFromIntegral coefficientValue = fromIntegral coefficientValue % 1++mapMaybeWithLookup :: Ord key => Map.Map key value -> [key] -> [value]+mapMaybeWithLookup valueMap = mapMaybe (flip Map.lookup valueMap)++symmetricDifference :: Ord a => Set.Set a -> Set.Set a -> Set.Set a+symmetricDifference left right =+  (left `Set.difference` right) `Set.union` (right `Set.difference` left)++lowIndex :: Set.Set Int -> Maybe Int+lowIndex rowSet =+  case Set.maxView rowSet of+    Nothing -> Nothing+    Just (maximumIndexValue, _) -> Just maximumIndexValue
+ src-topology/Moonlight/Homology/Pure/Topology/Graph.hs view
@@ -0,0 +1,56 @@+module Moonlight.Homology.Pure.Topology.Graph+  ( graph1SkeletonFromComplex,+    GraphSkeletonExtractionFailure (..),+    GraphOneComplex (..),+    graphOneComplexFromComplex,+    graphFiniteChainComplex,+    graphMacroScaffold,+    graphSpectralModes,+    graphTopologyWitness,+    edgeTargetsByIndex,+    endpointPair,+    graphFromEdgeSupports,+    addUndirectedEdge,+    addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+    criticalNodes,+    criticalKindAt,+    lowerNeighborEdges,+    lowerNeighbors,+    higherNeighborEdges,+    higherNeighbors,+    compareVertex,+    vertexPotential,+  )+where++import Moonlight.Homology.Pure.Topology.Graph.Algebra+  ( addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+  )+import Moonlight.Homology.Pure.Topology.Graph.Critical+  ( compareVertex,+    criticalKindAt,+    criticalNodes,+    higherNeighborEdges,+    higherNeighbors,+    lowerNeighborEdges,+    lowerNeighbors,+    vertexPotential,+  )+import Moonlight.Homology.Pure.Topology.Graph.Skeleton+  ( addUndirectedEdge,+    edgeTargetsByIndex,+    endpointPair,+    GraphSkeletonExtractionFailure (..),+    GraphOneComplex (..),+    graphFiniteChainComplex,+    graphOneComplexFromComplex,+    graph1SkeletonFromComplex,+    graphFromEdgeSupports,+  )+import Moonlight.Homology.Pure.Topology.Graph.Witness+  ( graphMacroScaffold,+    graphSpectralModes,+    graphTopologyWitness,+  )
+ src-topology/Moonlight/Homology/Pure/Topology/Graph/Algebra.hs view
@@ -0,0 +1,44 @@+module Moonlight.Homology.Pure.Topology.Graph.Algebra+  ( addUndirectedAdjacency,+    connectedComponentsFromAdjacency,+  )+where++import Algebra.Graph.AdjacencyMap qualified as AdjacencyMap+import Algebra.Graph.AdjacencyMap.Algorithm qualified as AdjacencyMapAlgorithm+import Algebra.Graph.NonEmpty.AdjacencyMap qualified as NonEmptyAdjacencyMap+import Data.Bifunctor (second)+import Data.Foldable qualified as Foldable+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set++addUndirectedAdjacency ::+  Ord label =>+  label ->+  label ->+  Map label [label] ->+  Map label [label]+addUndirectedAdjacency sourceLabel targetLabel =+  Map.insertWith (<>) sourceLabel [targetLabel]+    . Map.insertWith (<>) targetLabel [sourceLabel]++connectedComponentsFromAdjacency :: (Ord label, Foldable adjacency) => Map label (adjacency label) -> Int+connectedComponentsFromAdjacency =+  length+    . strongComponentSets+    . AdjacencyMap.symmetricClosure+    . AdjacencyMap.fromAdjacencySets+    . fmap (second (Set.fromList . Foldable.toList))+    . Map.toAscList++strongComponentSets :: Ord vertex => AdjacencyMap.AdjacencyMap vertex -> [Set.Set vertex]+strongComponentSets graph =+  List.sortOn+    Set.lookupMin+    ( fmap+        (Set.fromList . NonEmpty.toList . NonEmptyAdjacencyMap.vertexList1)+        (AdjacencyMap.vertexList (AdjacencyMapAlgorithm.scc graph))+    )
+ src-topology/Moonlight/Homology/Pure/Topology/Graph/Critical.hs view
@@ -0,0 +1,197 @@+module Moonlight.Homology.Pure.Topology.Graph.Critical+  ( criticalNodes,+    criticalKindAt,+    lowerNeighborEdges,+    lowerNeighbors,+    higherNeighborEdges,+    higherNeighbors,+    compareVertex,+    vertexPotential,+    graphDirectionField,+    scalarPotentialByVertex,+    potentialValueAtVertex,+    edgeOrientationCoefficient,+  )+where++import Data.Function ((&))+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Carrier (carrierCells)+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.Homology.Pure.Topology.Graph.Skeleton+  ( edgeBasisCellRef,+    graphEdgeCarrier,+    graphVertexCarrier,+    vertexBasisCellRef,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( DirectionField,+    MorseReebNode (..),+    ReebNodeId (..),+    ScalarPotentialField,+    mkDirectionCoefficient,+    mkDirectionCochainField,+    mkDirectionSymmetryOrder,+    scalarPotentialCarrier,+    scalarPotentialSamples,+    unPotentialValue,+    PotentialValue,+  )++criticalNodes :: ScalarPotentialField -> Map.Map Int Double -> Graph1Skeleton -> Either HomologyFailure [MorseReebNode]+criticalNodes scalarPotential potentials skeleton =+  let criticalVertices =+        enumerateFromZero (graphVertexCount skeleton)+          & mapMaybe+            ( \vertexValue ->+                criticalKindAt potentials skeleton vertexValue+                  & fmap (\criticalKindValue -> (vertexValue, criticalKindValue))+            )+   in zip (fmap ReebNodeId (enumerateFromZero (length criticalVertices))) criticalVertices+        & traverse+          ( \(nodeId, (vertexValue, criticalKindValue)) ->+              potentialValueAtVertex scalarPotential vertexValue+                & maybe+                  (Left (InvalidTopologyInput "critical node construction requires scalar samples at every graph vertex"))+                  ( \potentialValue ->+                      Right+                        MorseReebNode+                          { morseReebNodeId = nodeId,+                            morseReebNodeAnchor = vertexBasisCellRef vertexValue,+                            morseReebNodeKind = criticalKindValue,+                            morseReebNodePotential = potentialValue+                          }+                  )+          )++criticalKindAt :: Map.Map Int Double -> Graph1Skeleton -> Int -> Maybe CriticalKind+criticalKindAt potentials skeleton vertexValue =+  let lowerCount = length (lowerNeighbors potentials skeleton vertexValue)+      higherCount = length (higherNeighbors potentials skeleton vertexValue)+   in case (lowerCount, higherCount) of+        (0, 0) -> Just Isolated+        (0, _) -> Just Basin+        (_, 0) -> Just Peak+        (1, 1) -> Nothing+        (lowerValue, higherValue)+          | lowerValue > 1 && higherValue > 1 -> Just Pass+          | lowerValue > 1 -> Just Merge+          | higherValue > 1 -> Just Split+          | otherwise -> Nothing++lowerNeighbors :: Map.Map Int Double -> Graph1Skeleton -> Int -> [Int]+lowerNeighbors potentials skeleton vertexValue =+  lowerNeighborEdges potentials skeleton vertexValue+    & fmap snd++higherNeighbors :: Map.Map Int Double -> Graph1Skeleton -> Int -> [Int]+higherNeighbors potentials skeleton vertexValue =+  higherNeighborEdges potentials skeleton vertexValue+    & fmap snd++lowerNeighborEdges :: Map.Map Int Double -> Graph1Skeleton -> Int -> [(GraphEdge, Int)]+lowerNeighborEdges potentials skeleton vertexValue =+  neighborEdgesWithOrdering LT potentials skeleton vertexValue++higherNeighborEdges :: Map.Map Int Double -> Graph1Skeleton -> Int -> [(GraphEdge, Int)]+higherNeighborEdges potentials skeleton vertexValue =+  neighborEdgesWithOrdering GT potentials skeleton vertexValue++neighborEdgesWithOrdering :: Ordering -> Map.Map Int Double -> Graph1Skeleton -> Int -> [(GraphEdge, Int)]+neighborEdgesWithOrdering expectedOrdering potentials skeleton vertexValue =+  graphEdgeAdjacency skeleton+    & Map.findWithDefault [] vertexValue+    & List.sortOn graphEdgeIndex+    & mapMaybe+      ( \edgeValue ->+          fmap+            (\neighborValue -> (edgeValue, neighborValue))+            (oppositeGraphVertex vertexValue edgeValue)+      )+    & filter (\(_, neighborValue) -> compareVertex potentials neighborValue vertexValue == expectedOrdering)++oppositeGraphVertex :: Int -> GraphEdge -> Maybe Int+oppositeGraphVertex vertexValue edgeValue =+  if graphEdgeSource edgeValue == vertexValue+    then Just (graphEdgeTarget edgeValue)+    else+      if graphEdgeTarget edgeValue == vertexValue+        then Just (graphEdgeSource edgeValue)+        else Nothing++compareVertex :: Map.Map Int Double -> Int -> Int -> Ordering+compareVertex potentials leftVertex rightVertex =+  compare (vertexPotential potentials leftVertex, leftVertex) (vertexPotential potentials rightVertex, rightVertex)++vertexPotential :: Map.Map Int Double -> Int -> Double+vertexPotential potentials vertexValue = Map.findWithDefault 0.0 vertexValue potentials++graphDirectionField :: Map.Map Int Double -> Graph1Skeleton -> Either HomologyFailure DirectionField+graphDirectionField potentials skeleton =+  let edgeCells =+        graphEdges skeleton+          & fmap (edgeBasisCellRef . graphEdgeIndex)+   in do+        edgeCarrier <- graphEdgeCarrier edgeCells & either (Left . InvalidTopologyInput . show) Right+        coefficients <-+          graphEdges skeleton+            & traverse+              ( \edgeValue -> do+                  coefficientValue <-+                    mkDirectionCoefficient (edgeOrientationCoefficient potentials edgeValue)+                      & either+                        (Left . (InvalidTopologyInput . ("graph direction field requires finite coefficients: " <>) . show))+                        Right+                  pure+                    ( edgeBasisCellRef (graphEdgeIndex edgeValue),+                      coefficientValue+                    )+              )+        symmetryOrder <-+          mkDirectionSymmetryOrder 1+            & either+              (Left . (InvalidTopologyInput . ("graph direction field requires a positive symmetry order: " <>) . show))+              Right+        mkDirectionCochainField edgeCarrier symmetryOrder (Map.fromList coefficients)+          & either+            (Left . (InvalidTopologyInput . ("graph direction field requires exact carrier coverage: " <>) . show))+            Right++scalarPotentialByVertex :: Graph1Skeleton -> ScalarPotentialField -> Either HomologyFailure (Map.Map Int Double)+scalarPotentialByVertex skeleton scalarPotential = do+  expectedCarrier <- graphVertexCarrier skeleton & either (Left . InvalidTopologyInput . show) Right+  let expectedCells = carrierCells expectedCarrier+      sampleMap = scalarPotentialSamples scalarPotential+      sampleDomain = Map.keysSet sampleMap+      expectedDomain = Set.fromList expectedCells+  if scalarPotentialCarrier scalarPotential /= expectedCarrier+    then Left (InvalidTopologyInput "graph macro scaffold requires a scalar potential carried exactly by the graph 0-cells")+    else+      if sampleDomain /= expectedDomain+        then Left (InvalidTopologyInput "scalar potential samples must cover the graph 0-cell carrier exactly")+        else+          expectedCells+            & traverse+              ( \cellRefValue ->+                  fmap+                    (\potentialValue -> (cellIndex cellRefValue, unPotentialValue potentialValue))+                    (Map.lookup cellRefValue sampleMap)+              )+            & maybe+              (Left (InvalidTopologyInput "scalar potential lookup failed after carrier validation"))+              (Right . Map.fromList)++potentialValueAtVertex :: ScalarPotentialField -> Int -> Maybe PotentialValue+potentialValueAtVertex scalarPotential vertexValue =+  Map.lookup (vertexBasisCellRef vertexValue) (scalarPotentialSamples scalarPotential)++edgeOrientationCoefficient :: Map.Map Int Double -> GraphEdge -> Double+edgeOrientationCoefficient potentials edgeValue =+  case compareVertex potentials (graphEdgeSource edgeValue) (graphEdgeTarget edgeValue) of+    LT -> 1.0+    GT -> -1.0+    EQ -> 0.0
+ src-topology/Moonlight/Homology/Pure/Topology/Graph/Reeb.hs view
@@ -0,0 +1,181 @@+module Moonlight.Homology.Pure.Topology.Graph.Reeb+  ( graphReebArcs,+    graphSingularities,+    traceArc,+    followGradient,+    arcSupportCells,+    edgeCellsBetween,+  )+where++import Data.Containers.ListUtils (nubOrd)+import Data.Function ((&))+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Ratio ((%))+import Data.Set qualified as Set+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.Homology.Pure.Topology.Graph.Critical (higherNeighborEdges)+import Moonlight.Homology.Pure.Topology.Graph.Skeleton (edgeBasisCellRef, vertexBasisCellRef)+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( Monotonicity (..),+    MorseReebArc (..),+    MorseReebNode (..),+    ReebArcId (..),+    ReebNodeId,+    Singularity (..),+    SingularityId (..),+    SingularityIndex (..),+  )++graphReebArcs :: Map.Map Int Double -> Graph1Skeleton -> [MorseReebNode] -> [MorseReebArc]+graphReebArcs potentials skeleton nodes =+  let nodeIdsByVertex =+        nodes+          & fmap (\node -> (cellIndex (morseReebNodeAnchor node), morseReebNodeId node))+          & Map.fromList+      criticalKindsByVertex =+        nodes+          & fmap (\node -> (cellIndex (morseReebNodeAnchor node), morseReebNodeKind node))+          & Map.fromList+      arcSeeds =+        nodes+          >>= ( \node ->+                  let sourceVertex = cellIndex (morseReebNodeAnchor node)+                   in higherNeighborEdges potentials skeleton sourceVertex+                        & mapMaybe+                          ( \(seedEdge, seedVertex) ->+                              traceArc potentials nodeIdsByVertex criticalKindsByVertex skeleton (morseReebNodeId node) sourceVertex seedEdge seedVertex+                          )+             )+          & nubOrd+   in zip (fmap ReebArcId (enumerateFromZero (length arcSeeds))) arcSeeds+        & fmap+          ( \(arcId, (sourceNodeId, targetNodeId, monotonicityValue, supportCells)) ->+              MorseReebArc+                { morseReebArcId = arcId,+                  morseReebArcSource = sourceNodeId,+                  morseReebArcTarget = targetNodeId,+                  morseReebArcMonotonicity = monotonicityValue,+                  morseReebArcSupport = supportCells+                }+          )++graphSingularities :: [MorseReebNode] -> [MorseReebArc] -> [Singularity]+graphSingularities nodes arcs =+  let incidentArcs =+        Map.fromListWith (<>)+          ( arcs >>= \arcValue ->+              [ (morseReebArcSource arcValue, [morseReebArcId arcValue]),+                (morseReebArcTarget arcValue, [morseReebArcId arcValue])+              ]+          )+   in zip (fmap SingularityId (enumerateFromZero (length nodes))) nodes+        & fmap+          ( \(singularityIdValue, nodeValue) ->+              Singularity+                { singularityId = singularityIdValue,+                  singularityAnchor = morseReebNodeAnchor nodeValue,+                  singularityKind = morseReebNodeKind nodeValue,+                  singularityPotential = Just (morseReebNodePotential nodeValue),+                  singularityIndex = criticalKindSingularityIndex (morseReebNodeKind nodeValue),+                  singularityReebNode = Just (morseReebNodeId nodeValue),+                  singularityIncidentArcs =+                    Map.findWithDefault [] (morseReebNodeId nodeValue) incidentArcs+                }+          )++criticalKindSingularityIndex :: CriticalKind -> SingularityIndex+criticalKindSingularityIndex criticalKindValue =+  SingularityIndex+    ( case criticalKindValue of+        Basin -> 1 % 1+        Peak -> 1 % 1+        Isolated -> 1 % 1+        Merge -> (-1) % 1+        Split -> (-1) % 1+        Pass -> (-1) % 1+    )++traceArc ::+  Map.Map Int Double ->+  Map.Map Int ReebNodeId ->+  Map.Map Int CriticalKind ->+  Graph1Skeleton ->+  ReebNodeId ->+  Int ->+  GraphEdge ->+  Int ->+  Maybe (ReebNodeId, ReebNodeId, Monotonicity, [BasisCellRef])+traceArc potentials nodeIdsByVertex criticalKindsByVertex skeleton sourceNodeId sourceVertex seedEdge seedVertex =+  let pathTail = followGradientEdges potentials criticalKindsByVertex skeleton Set.empty seedVertex+      supportCells = arcSupportCellsFromEdges sourceVertex ((seedEdge, seedVertex) : pathTail)+      targetVertex =+        case reverse pathTail of+          (_, targetValue) : _ -> targetValue+          [] -> seedVertex+   in fmap+        ( \targetNodeId ->+            ( sourceNodeId,+              targetNodeId,+              Ascending,+              supportCells+            )+        )+        (Map.lookup targetVertex nodeIdsByVertex)++followGradient :: Map.Map Int Double -> Map.Map Int CriticalKind -> Graph1Skeleton -> Set.Set Int -> Int -> [Int]+followGradient potentials criticalKindsByVertex skeleton visited currentVertex =+  currentVertex : fmap snd (followGradientEdges potentials criticalKindsByVertex skeleton visited currentVertex)++followGradientEdges :: Map.Map Int Double -> Map.Map Int CriticalKind -> Graph1Skeleton -> Set.Set Int -> Int -> [(GraphEdge, Int)]+followGradientEdges potentials criticalKindsByVertex skeleton visited currentVertex =+  if Set.member currentVertex visited+    then []+    else+      case Map.lookup currentVertex criticalKindsByVertex of+        Just _ -> []+        Nothing ->+          case higherNeighborEdges potentials skeleton currentVertex of+            [] -> []+            higherOnly ->+              let nextVertex =+                    higherOnly+                      & List.find (\(_, neighborValue) -> not (Set.member neighborValue visited))+               in case nextVertex of+                    Nothing -> []+                    Just (edgeValue, nextVertexValue) ->+                      (edgeValue, nextVertexValue) : followGradientEdges potentials criticalKindsByVertex skeleton (Set.insert currentVertex visited) nextVertexValue++arcSupportCellsFromEdges :: Int -> [(GraphEdge, Int)] -> [BasisCellRef]+arcSupportCellsFromEdges sourceVertex edgePath =+  vertexBasisCellRef sourceVertex+    : ( edgePath+          >>= ( \(edgeValue, targetVertex) ->+                  [ edgeBasisCellRef (graphEdgeIndex edgeValue),+                    vertexBasisCellRef targetVertex+                  ]+              )+      )++arcSupportCells :: Graph1Skeleton -> [Int] -> [BasisCellRef]+arcSupportCells skeleton vertexPath =+  case vertexPath of+    [] -> []+    [vertexValue] -> [vertexBasisCellRef vertexValue]+    sourceVertex : targetVertex : remainingVertices ->+      [vertexBasisCellRef sourceVertex]+        <> edgeCellsBetween skeleton sourceVertex targetVertex+        <> arcSupportCells skeleton (targetVertex : remainingVertices)++edgeCellsBetween :: Graph1Skeleton -> Int -> Int -> [BasisCellRef]+edgeCellsBetween skeleton sourceVertex targetVertex =+  graphEdges skeleton+    & filter+      ( \edgeValue ->+          let edgePair = List.sort [graphEdgeSource edgeValue, graphEdgeTarget edgeValue]+              targetPair = List.sort [sourceVertex, targetVertex]+           in edgePair == targetPair+      )+    & fmap (edgeBasisCellRef . graphEdgeIndex)
+ src-topology/Moonlight/Homology/Pure/Topology/Graph/Skeleton.hs view
@@ -0,0 +1,257 @@+module Moonlight.Homology.Pure.Topology.Graph.Skeleton+  ( graph1SkeletonFromComplex,+    GraphSkeletonExtractionFailure (..),+    GraphOneComplex (..),+    graphOneComplexFromComplex,+    graphFiniteChainComplex,+    edgeTargetsByIndex,+    endpointPair,+    graphFromEdgeSupports,+    addUndirectedEdge,+    vertexBasisCellRef,+    edgeBasisCellRef,+    graphVertexCarrier,+    graphEdgeCarrier,+  )+where++import Data.Function ((&))+import Data.Graph qualified as Graph+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Tree qualified as Tree+import Moonlight.Core (Semiring)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+    mkFiniteChainComplex,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    BoundaryIncidence,+    boundaryCoefficient,+    boundaryEntries,+    emptyBoundaryIncidence,+    emptyBoundaryIncidenceOf,+    materializeIncidenceBoundary,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Carrier (CellCarrier, CellCarrierError, mkCellCarrier)+import Moonlight.Homology.Pure.Topology.Core++data GraphSkeletonExtractionFailure+  = UnsupportedGraphSkeletonDimensions [HomologicalDegree]+  | NonEmptyGraphZeroBoundary+  | GraphEdgeBoundaryTargetMismatch Int Int+  | InvalidOrientedUnitGraphEdgeBoundary Int+  deriving stock (Eq, Show)++data GraphOneComplex = GraphOneComplex+  { graphOneVertexCount :: !Int,+    graphOneEdgeCount :: !Int,+    graphOneComponents :: ![Set.Set Int]+  }+  deriving stock (Eq, Show)++graphOneComplexFromComplex :: Integral r => FiniteChainComplex r -> Maybe GraphOneComplex+graphOneComplexFromComplex finite =+  case graphOneComplexShape finite of+    Right (vertexCount, edgeCount, edgeSupports) ->+      Just (mkGraphOneComplex vertexCount edgeCount edgeSupports)+    Left _ ->+      Nothing++graphOneComplexShape :: Integral r => FiniteChainComplex r -> Either GraphSkeletonExtractionFailure (Int, Int, [(Int, Int)])+graphOneComplexShape finite =+  case dimensionsOf finite of+    [HomologicalDegree 0] ->+      graph1SkeletonShape finite+    [HomologicalDegree 0, HomologicalDegree 1] ->+      graph1SkeletonShape finite+    dimensionValues ->+      Left (UnsupportedGraphSkeletonDimensions dimensionValues)++graph1SkeletonShape :: Integral r => FiniteChainComplex r -> Either GraphSkeletonExtractionFailure (Int, Int, [(Int, Int)])+graph1SkeletonShape finite =+  case dimensionsOf finite of+    [HomologicalDegree 0] ->+      let zeroBoundary = incidenceMatrixAt finite (HomologicalDegree 0)+       in fmap+            (\vertexCount -> (vertexCount, 0, []))+            (validateZeroBoundary zeroBoundary)+    HomologicalDegree 0 : HomologicalDegree 1 : _ ->+      let zeroBoundary = incidenceMatrixAt finite (HomologicalDegree 0)+          edgeBoundary = incidenceMatrixAt finite (HomologicalDegree 1)+       in do+            vertexCount <- validateZeroBoundary zeroBoundary+            validateEdgeBoundaryTarget vertexCount edgeBoundary+            edgeSupports <- orientedUnitEdgeSupports edgeBoundary+            pure (vertexCount, sourceCardinality edgeBoundary, edgeSupports)+    dimensionValues ->+      Left (UnsupportedGraphSkeletonDimensions dimensionValues)++validateZeroBoundary :: BoundaryIncidence r -> Either GraphSkeletonExtractionFailure Int+validateZeroBoundary zeroBoundary =+  if targetCardinality zeroBoundary == 0 && null (boundaryEntries zeroBoundary)+    then Right (sourceCardinality zeroBoundary)+    else Left NonEmptyGraphZeroBoundary++validateEdgeBoundaryTarget :: Int -> BoundaryIncidence r -> Either GraphSkeletonExtractionFailure ()+validateEdgeBoundaryTarget vertexCount edgeBoundary =+  if targetCardinality edgeBoundary == vertexCount+    then Right ()+    else Left (GraphEdgeBoundaryTargetMismatch vertexCount (targetCardinality edgeBoundary))++mkGraphOneComplex :: Int -> Int -> [(Int, Int)] -> GraphOneComplex+mkGraphOneComplex vertexCount edgeCount edgeSupports =+  GraphOneComplex+    { graphOneVertexCount = vertexCount,+      graphOneEdgeCount = edgeCount,+      graphOneComponents = graphComponentsFromSupports vertexCount edgeSupports+    }++graphComponentsFromSupports :: Int -> [(Int, Int)] -> [Set.Set Int]+graphComponentsFromSupports vertexCount edgeSupports =+  if vertexCount <= 0+    then []+    else+      edgeSupports+        & foldMap (\(leftVertex, rightVertex) -> [(leftVertex, rightVertex), (rightVertex, leftVertex)])+        & Graph.buildG (0, vertexCount - 1)+        & Graph.components+        & fmap (Set.fromList . Tree.flatten)++orientedUnitEdgeSupports :: Integral r => BoundaryIncidence r -> Either GraphSkeletonExtractionFailure [(Int, Int)]+orientedUnitEdgeSupports edgeBoundary =+  enumerateFromZero (sourceCardinality edgeBoundary)+    & traverse (unitEdgeSupport (entriesBySource edgeBoundary))++entriesBySource :: BoundaryIncidence r -> IntMap.IntMap [BoundaryEntry r]+entriesBySource incidence =+  boundaryEntries incidence+    & foldr+      ( \entryValue ->+          IntMap.insertWith (<>) (sourceIndex entryValue) [entryValue]+      )+      IntMap.empty++unitEdgeSupport :: Integral r => IntMap.IntMap [BoundaryEntry r] -> Int -> Either GraphSkeletonExtractionFailure (Int, Int)+unitEdgeSupport groupedEntries edgeIndex =+  case traverse signedUnitTarget (filter ((/= 0) . boundaryCoefficient) (IntMap.findWithDefault [] edgeIndex groupedEntries)) of+    Just [(leftTarget, leftSign), (rightTarget, rightSign)]+      | leftTarget /= rightTarget && leftSign + rightSign == 0 ->+          Right (leftTarget, rightTarget)+    _ ->+      Left (InvalidOrientedUnitGraphEdgeBoundary edgeIndex)++signedUnitTarget :: Integral r => BoundaryEntry r -> Maybe (Int, Integer)+signedUnitTarget entryValue =+  let coefficientValue = fromIntegral (boundaryCoefficient entryValue) :: Integer+   in if abs coefficientValue == 1+        then Just (targetIndex entryValue, coefficientValue)+        else Nothing++graph1SkeletonFromComplex :: Integral r => FiniteChainComplex r -> Either GraphSkeletonExtractionFailure Graph1Skeleton+graph1SkeletonFromComplex finite =+  fmap+    (\(vertexCount, _, edgeSupports) -> graphFromEdgeSupports vertexCount edgeSupports)+    (graph1SkeletonShape finite)++graphFiniteChainComplex :: (Eq r, Num r, Semiring r) => Graph1Skeleton -> Either HomologyFailure (FiniteChainComplex r)+graphFiniteChainComplex skeleton = do+  edgeBoundary <-+    materializeIncidenceBoundary+      graphEdgeBoundary+      (graphEdges skeleton)+      (enumerateFromZero (graphVertexCount skeleton))+  pure+    ( mkFiniteChainComplex+        (HomologicalDegree 1)+        ( \degreeValue ->+            case degreeValue of+              HomologicalDegree 0 -> emptyBoundaryIncidenceOf (fromIntegral (graphVertexCount skeleton)) 0+              HomologicalDegree 1 -> edgeBoundary+              _ -> emptyBoundaryIncidence+        )+    )++edgeTargetsByIndex :: Integral r => BoundaryIncidence r -> Map.Map Int (Set.Set Int)+edgeTargetsByIndex incidence =+  boundaryEntries incidence+    & filter (\entry -> boundaryCoefficient entry /= 0)+    & fmap (\entry -> (sourceIndex entry, Set.singleton (targetIndex entry)))+    & Map.fromListWith Set.union++endpointPair :: Int -> Set.Set Int -> Maybe (Int, Int)+endpointPair _ endpointSet =+  case Set.toAscList endpointSet of+    [sourceVertex, targetVertex] -> Just (sourceVertex, targetVertex)+    [] -> Nothing+    [_] -> Nothing+    _ -> Nothing++addUndirectedEdge :: Map.Map Int [GraphEdge] -> GraphEdge -> Map.Map Int [GraphEdge]+addUndirectedEdge adjacency edgeValue =+  if graphEdgeSource edgeValue == graphEdgeTarget edgeValue+    then Map.insertWith (<>) (graphEdgeSource edgeValue) [edgeValue] adjacency+    else+      Map.insertWith (<>) (graphEdgeSource edgeValue) [edgeValue]+        (Map.insertWith (<>) (graphEdgeTarget edgeValue) [edgeValue] adjacency)++graphFromEdgeSupports :: Int -> [(Int, Int)] -> Graph1Skeleton+graphFromEdgeSupports vertexCount edgeSupports =+  let edges =+        edgeSupports+          & zip [0 :: Int ..]+          & fmap+            ( \(edgeIndexValue, (sourceVertex, targetVertex)) ->+                GraphEdge+                  { graphEdgeIndex = edgeIndexValue,+                    graphEdgeSource = sourceVertex,+                    graphEdgeTarget = targetVertex+                  }+            )+      edgeAdjacency =+        foldr+          (flip addUndirectedEdge)+          (Map.fromList (enumerateFromZero vertexCount & fmap (\vertex -> (vertex, []))))+          edges+   in Graph1Skeleton+        { graphVertexCount = vertexCount,+          graphEdges = edges,+          graphEdgeAdjacency = edgeAdjacency+        }++graphVertexCarrier :: Graph1Skeleton -> Either CellCarrierError CellCarrier+graphVertexCarrier skeleton =+  mkCellCarrier (HomologicalDegree 0) (vertexBasisCellRef <$> enumerateFromZero (graphVertexCount skeleton))++graphEdgeCarrier :: [BasisCellRef] -> Either CellCarrierError CellCarrier+graphEdgeCarrier edgeCells =+  mkCellCarrier (HomologicalDegree 1) edgeCells++vertexBasisCellRef :: Int -> BasisCellRef+vertexBasisCellRef vertexIndex =+  BasisCellRef+    { cellDegree = HomologicalDegree 0,+      cellIndex = vertexIndex+    }++edgeBasisCellRef :: Int -> BasisCellRef+edgeBasisCellRef edgeIndex =+  BasisCellRef+    { cellDegree = HomologicalDegree 1,+      cellIndex = edgeIndex+    }++graphEdgeBoundary :: Num r => GraphEdge -> [(r, Int)]+graphEdgeBoundary graphEdgeValue =+  [ (negate 1, graphEdgeSource graphEdgeValue),+    (1, graphEdgeTarget graphEdgeValue)+  ]
+ src-topology/Moonlight/Homology/Pure/Topology/Graph/Witness.hs view
@@ -0,0 +1,73 @@+module Moonlight.Homology.Pure.Topology.Graph.Witness+  ( graphMacroScaffold,+    graphSpectralModes,+    graphTopologyWitness,+  )+where++import Moonlight.Homology.Pure.Chain (TopologyWitness (..), emptyTopologyWitness)+import Moonlight.Homology.Pure.Failure (HomologyFailure)+import Moonlight.Homology.Pure.Topology.Core (Graph1Skeleton (..), GraphEdge (..), GraphSpectralMode)+import Moonlight.Homology.Pure.Topology.Graph.Critical+  ( criticalNodes,+    graphDirectionField,+    scalarPotentialByVertex,+  )+import Moonlight.Homology.Pure.Topology.Graph.Reeb (graphReebArcs, graphSingularities)+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( MacroScaffoldIR (..),+    MorseReebScaffold (..),+    ScalarPotentialField,+  )+import Moonlight.Homology.Pure.Topology.Spectral+  ( defaultSparseSpectralConfig,+    weightedGraphSparseSpectralModes,+  )++graphMacroScaffold :: ScalarPotentialField -> Graph1Skeleton -> Either HomologyFailure MacroScaffoldIR+graphMacroScaffold scalarPotential skeleton = do+  potentials <- scalarPotentialByVertex skeleton scalarPotential+  directionField <- graphDirectionField potentials skeleton+  nodes <- criticalNodes scalarPotential potentials skeleton+  let arcs = graphReebArcs potentials skeleton nodes+  pure+    MacroScaffoldIR+      { macroScaffoldScalarPotential = scalarPotential,+        macroScaffoldReeb =+          MorseReebScaffold+            { morseReebNodes = nodes,+              morseReebArcs = arcs+            },+        macroScaffoldDirectionField = directionField,+        macroScaffoldSingularities = graphSingularities nodes arcs,+        macroScaffoldHarmonicLoops = []+      }++graphSpectralModes :: Int -> Graph1Skeleton -> Either HomologyFailure [GraphSpectralMode]+graphSpectralModes requestedModeCount skeleton+  | requestedModeCount <= 0 = Right []+  | graphVertexCount skeleton <= 0 = Right []+  | otherwise =+      weightedGraphSparseSpectralModes+        defaultSparseSpectralConfig+        requestedModeCount+        (graphVertexCount skeleton)+        (fmap unweightedGraphEdgeSupport (graphEdges skeleton))++unweightedGraphEdgeSupport :: GraphEdge -> (Int, Int, Double)+unweightedGraphEdgeSupport edgeValue =+  (graphEdgeSource edgeValue, graphEdgeTarget edgeValue, 1.0)++graphTopologyWitness ::+  Int ->+  Maybe ScalarPotentialField ->+  Graph1Skeleton ->+  Either HomologyFailure (TopologyWitness MacroScaffoldIR GraphSpectralMode persistence coefficient basis)+graphTopologyWitness requestedModeCount potentialValues skeleton = do+  spectralModes <- graphSpectralModes requestedModeCount skeleton+  scaffoldValue <- traverse (`graphMacroScaffold` skeleton) potentialValues+  pure+    emptyTopologyWitness+      { topologyMacroScaffold = scaffoldValue,+        topologyLowSpectralModes = spectralModes+      }
+ src-topology/Moonlight/Homology/Pure/Topology/Harmonic.hs view
@@ -0,0 +1,212 @@+module Moonlight.Homology.Pure.Topology.Harmonic+  ( attachDiscoveredHarmonicLoops,+    discoverHarmonicLoops,+    harmonicBasisAt,+  )+where++import Data.Function ((&))+import Data.IntMap.Strict qualified as IntMap+import Data.Set qualified as Set+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+  )+import Moonlight.Homology.Pure.Chain+  ( HarmonicBasisElement (..),+    HomologicalDegree (..),+    incrementDegree,+    RepresentativeChain (..),+    RepresentativeCycle,+    TopologyWitness (..),+  )+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Filtration (enumerateFromZero)+import Moonlight.Homology.Pure.Matrix.Shape (cellCountAtDegree)+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( HarmonicLoop (..),+    HarmonicLoopId (..),+    HarmonicLoopPeriod (..),+    HarmonicLoopWeight (..),+    MacroScaffoldIR (..),+    MorseReebArc (..),+    MorseReebScaffold (..),+    ReebArcId,+  )+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseMatrix (..),+    SparseRow,+    sparseBoundaryMatrix,+    sparseKernelBasisOf,+    sparseTransposeMatrix,+  )++attachDiscoveredHarmonicLoops ::+  Integral r =>+  FiniteChainComplex r ->+  TopologyWitness MacroScaffoldIR spectral persistence Rational Int ->+  TopologyWitness MacroScaffoldIR spectral persistence Rational Int+attachDiscoveredHarmonicLoops finite witnessValue =+  let harmonicDegree = HomologicalDegree 1+      harmonicRows = harmonicBasisAt finite harmonicDegree+   in witnessValue+        { topologyMacroScaffold =+            fmap+              (attachLoopsWhenMissing harmonicRows)+              (topologyMacroScaffold witnessValue),+          topologyHarmonicBasis =+            if null (topologyHarmonicBasis witnessValue)+              then fmap (harmonicBasisElement harmonicDegree) harmonicRows+              else topologyHarmonicBasis witnessValue+        }++harmonicBasisAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  [SparseRow]+harmonicBasisAt finite degreeValue =+  let ambientDimension = cellCountAtDegree finite degreeValue+   in if ambientDimension == 0+        then []+        else+          sparseKernelBasisOf+            ambientDimension+            (harmonicConstraintMatrix finite degreeValue ambientDimension)++harmonicConstraintMatrix ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Int ->+  SparseMatrix+harmonicConstraintMatrix finite degreeValue ambientDimension =+  SparseMatrix+    { smRows =+        boundaryRowsAt finite degreeValue+          <> coboundaryRowsAt finite (incrementDegree degreeValue),+      smColumnCount = ambientDimension+    }++boundaryRowsAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  [SparseRow]+boundaryRowsAt finite degreeValue =+  smRows (sparseBoundaryMatrix (incidenceMatrixAt finite degreeValue))++coboundaryRowsAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  [SparseRow]+coboundaryRowsAt finite degreeValue =+  smRows+    ( sparseTransposeMatrix+        (sparseBoundaryMatrix (incidenceMatrixAt finite degreeValue))+    )++attachLoopsWhenMissing ::+  [SparseRow] ->+  MacroScaffoldIR ->+  MacroScaffoldIR+attachLoopsWhenMissing harmonicRows scaffoldValue =+  if null (macroScaffoldHarmonicLoops scaffoldValue)+    then+      scaffoldValue+        { macroScaffoldHarmonicLoops =+            discoverHarmonicLoops scaffoldValue harmonicRows+        }+    else scaffoldValue++discoverHarmonicLoops ::+  MacroScaffoldIR ->+  [SparseRow] ->+  [HarmonicLoop]+discoverHarmonicLoops scaffoldValue harmonicRows =+  zip (fmap HarmonicLoopId (enumerateFromZero (length harmonicRows))) harmonicRows+    & fmap+      ( \(loopIdValue, harmonicRow) ->+          harmonicLoopFromRow scaffoldValue loopIdValue harmonicRow+      )++harmonicLoopFromRow ::+  MacroScaffoldIR ->+  HarmonicLoopId ->+  SparseRow ->+  HarmonicLoop+harmonicLoopFromRow scaffoldValue loopIdValue harmonicRow =+  let representativeValue =+        sparseRowToRepresentative (HomologicalDegree 1) harmonicRow+      periodValue =+        harmonicRow+          & IntMap.foldl' (\accumulator coefficientValue -> accumulator + coefficientValue * coefficientValue) 0+          & fromRational+      weightValue =+        harmonicRow+          & IntMap.foldl' (\accumulator coefficientValue -> accumulator + abs coefficientValue) 0+          & fromRational+   in HarmonicLoop+        { harmonicLoopId = loopIdValue,+          harmonicLoopDegree = HomologicalDegree 1,+          harmonicLoopCycle = representativeValue,+          harmonicLoopCocycle = representativeValue,+          harmonicLoopWeight = HarmonicLoopWeight weightValue,+          harmonicLoopPeriod =+            if periodValue == 0+              then Nothing+              else Just (HarmonicLoopPeriod periodValue),+          harmonicLoopSupport = supportArcIds scaffoldValue representativeValue+        }++sparseRowToRepresentative ::+  HomologicalDegree ->+  SparseRow ->+  RepresentativeCycle Rational BasisCellRef+sparseRowToRepresentative degreeValue harmonicRow =+  RepresentativeChain+    { representativeDegree = degreeValue,+      representativeTerms =+        IntMap.toAscList harmonicRow+          & filter ((/= 0) . snd)+          & fmap+            ( \(basisIndexValue, coefficientValue) ->+                ( coefficientValue,+                  BasisCellRef+                    { cellDegree = degreeValue,+                      cellIndex = basisIndexValue+                    }+                )+            )+    }++harmonicBasisElement :: HomologicalDegree -> SparseRow -> HarmonicBasisElement Rational Int+harmonicBasisElement degreeValue harmonicRow =+  HarmonicBasisElement+    { harmonicDegree = degreeValue,+      harmonicRepresentative =+        RepresentativeChain+          { representativeDegree = degreeValue,+            representativeTerms =+              IntMap.toAscList harmonicRow+                & filter ((/= 0) . snd)+                & fmap (\(basisIndexValue, coefficientValue) -> (coefficientValue, basisIndexValue))+          }+    }++supportArcIds ::+  MacroScaffoldIR ->+  RepresentativeCycle Rational BasisCellRef ->+  [ReebArcId]+supportArcIds scaffoldValue cycleValue =+  let cycleSupport =+        representativeTerms cycleValue+          & fmap snd+          & Set.fromList+      arcSupport arcValue =+        morseReebArcSupport arcValue+          & Set.fromList+   in morseReebArcs (macroScaffoldReeb scaffoldValue)+        & filter (\arcValue -> not (Set.null (Set.intersection cycleSupport (arcSupport arcValue))))+        & fmap morseReebArcId
+ src-topology/Moonlight/Homology/Pure/Topology/Integral.hs view
@@ -0,0 +1,589 @@+module Moonlight.Homology.Pure.Topology.Integral+  ( SmithDecomposition (..),+    IntegralHomologyDegreeWitness (..),+    integralHomologyGroupsOf,+    exactRepresentativeClassesOf,+    integralHomologyWitnessesOf,+    integralHomologyWitnessAt,+    smithDecompositionOf,+    representativeClassesFromSmith,+    vectorToIntegralRepresentative,+  )+where++import Data.Bifunctor (first)+import Data.Function ((&))+import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type)+import qualified Data.List as List+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryIncidence,+    boundaryCoefficient,+    boundaryEntries,+    sourceCardinality,+    sourceIndex,+    targetCardinality,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain+  ( ExactRepresentativeClass (..),+    HomologicalDegree (..),+    RepresentativeChain (..),+    RepresentativeCycle,+  )+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw (..))+import Moonlight.Homology.Pure.Group (HomologyGroup (..))+import Moonlight.Homology.Pure.Matrix.Validated+  ( validatedColumnAt,+    validatedDiagonal,+    validatedMatrixFromRows,+  )+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.Homology.Pure.Topology.Graph+  ( GraphOneComplex (..),+    graphOneComplexFromComplex,+  )+import Moonlight.LinAlg.Pure.Dense.Dynamic (mkDynMatrix, withDynMatrix)+import Moonlight.LinAlg.Pure.Dense.Types (toListMatrix)+import Moonlight.LinAlg.Pure.Domain.Smith (SmithNormalForm (..), smithNormalForm)++type SmithDecomposition :: Type+data SmithDecomposition = SmithDecomposition+  { smithLeftRows :: [[Integer]],+    smithDiagonalRows :: [[Integer]],+    smithRightRows :: [[Integer]],+    smithLeftInverseRows :: [[Integer]],+    smithRightInverseRows :: [[Integer]],+    smithDiagonalValues :: [Integer],+    smithRankValue :: Int+  }+  deriving stock (Eq, Show)++type IntegralBoundarySummary :: Type+data IntegralBoundarySummary = IntegralBoundarySummary+  { integralBoundaryDegree :: HomologicalDegree,+    integralBoundarySourceRank :: Int,+    integralBoundaryTargetRank :: Int,+    integralBoundaryRows :: [[Integer]],+    integralBoundarySmith :: SmithDecomposition+  }+  deriving stock (Eq, Show)++type KernelCoordinateHomology :: Type+data KernelCoordinateHomology = KernelCoordinateHomology+  { kernelCoordinateGroup :: HomologyGroup Integer,+    kernelCoordinateImageSmith :: SmithDecomposition+  }++type IntegralHomologyDegreeWitness :: Type -> Type+data IntegralHomologyDegreeWitness basis = IntegralHomologyDegreeWitness+  { integralWitnessDegree :: HomologicalDegree,+    integralWitnessGroup :: HomologyGroup Integer,+    integralWitnessClasses :: [ExactRepresentativeClass basis]+  }++integralHomologyGroupsOf :: Integral r => FiniteChainComplex r -> Either HomologyFailure [HomologyGroup Integer]+integralHomologyGroupsOf finite =+  case graphIntegralHomologyGroupsOf finite of+    Just graphGroups -> graphGroups+    Nothing -> do+      preparedBoundaries <- prepareIntegralBoundarySummaries finite+      traverse (integralHomologyGroupAtPrepared preparedBoundaries) (dimensionsOf finite)++graphIntegralHomologyGroupsOf ::+  Integral r =>+  FiniteChainComplex r ->+  Maybe (Either HomologyFailure [HomologyGroup Integer])+graphIntegralHomologyGroupsOf finite =+  graphIntegralHomologyGroups (HomologicalDegree 1 `elem` dimensionsOf finite)+    <$> graphOneComplexFromComplex finite++graphIntegralHomologyGroups :: Bool -> GraphOneComplex -> Either HomologyFailure [HomologyGroup Integer]+graphIntegralHomologyGroups includesDegreeOne graph =+  let vertexCount = graphOneVertexCount graph+      edgeCount = graphOneEdgeCount graph+      componentCount = length (graphOneComponents graph)+      boundaryRank = vertexCount - componentCount+      h0 =+        HomologyGroup+          { freeRank = componentCount,+            torsionInvariants = []+          }+      h1 =+        HomologyGroup+          { freeRank = edgeCount - boundaryRank,+            torsionInvariants = []+          }+   in pure+        ( if includesDegreeOne+            then [h0, h1]+            else [h0]+        )++prepareIntegralBoundarySummaries ::+  Integral r =>+  FiniteChainComplex r ->+  Either HomologyFailure (IntMap.IntMap IntegralBoundarySummary)+prepareIntegralBoundarySummaries finite =+  traverse+    ( \degreeValue@(HomologicalDegree degreeIndex) -> do+        boundarySummary <- integralBoundarySummaryAt finite degreeValue+        pure (degreeIndex, boundarySummary)+    )+    (dimensionsOf finite <> [nextDegreeAfterFinite finite])+    & fmap IntMap.fromList++nextDegreeAfterFinite :: FiniteChainComplex r -> HomologicalDegree+nextDegreeAfterFinite finite =+  case dimensionsOf finite of+    [] -> HomologicalDegree 0+    degreeValues ->+      HomologicalDegree+        ( 1+            + maximum+              (fmap (\(HomologicalDegree degreeIndex) -> degreeIndex) degreeValues)+        )++integralBoundarySummaryAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Either HomologyFailure IntegralBoundarySummary+integralBoundarySummaryAt finite degreeValue =+  let boundaryIncidenceValue = incidenceMatrixAt finite degreeValue+      rowCount = targetCardinality boundaryIncidenceValue+      columnCount = sourceCardinality boundaryIncidenceValue+      boundaryRows = integralBoundaryMatrixRows boundaryIncidenceValue+   in do+        smithValue <- smithDecompositionOf rowCount columnCount boundaryRows+        pure+          IntegralBoundarySummary+            { integralBoundaryDegree = degreeValue,+              integralBoundarySourceRank = columnCount,+              integralBoundaryTargetRank = rowCount,+              integralBoundaryRows = boundaryRows,+              integralBoundarySmith = smithValue+            }++integralHomologyGroupAtPrepared ::+  IntMap.IntMap IntegralBoundarySummary ->+  HomologicalDegree ->+  Either HomologyFailure (HomologyGroup Integer)+integralHomologyGroupAtPrepared preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) = do+  boundarySummary <- requirePreparedBoundary preparedBoundaries degreeValue+  incomingSummary <- requirePreparedBoundary preparedBoundaries (HomologicalDegree (degreeIndex + 1))+  let chainRank = integralBoundarySourceRank boundarySummary+      boundaryRank = smithRankValue (integralBoundarySmith boundarySummary)+      incomingRank = smithRankValue (integralBoundarySmith incomingSummary)+      kernelRank = chainRank - boundaryRank+  if boundaryRank == 0+    then cokernelGroup chainRank incomingSummary+    else+      if incomingRank == 0+        then pure HomologyGroup {freeRank = kernelRank, torsionInvariants = []}+        else+          kernelCoordinateGroup+            <$> kernelCoordinateHomologyFromSummaries boundarySummary incomingSummary++requirePreparedBoundary ::+  IntMap.IntMap IntegralBoundarySummary ->+  HomologicalDegree ->+  Either HomologyFailure IntegralBoundarySummary+requirePreparedBoundary preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) =+  case IntMap.lookup degreeIndex preparedBoundaries of+    Just boundarySummary -> Right boundarySummary+    Nothing ->+      Left+        ( InvalidTopologyInput+            ( "integral homology missing prepared boundary summary at degree "+                <> show degreeValue+            )+        )++cokernelGroup ::+  Int ->+  IntegralBoundarySummary ->+  Either HomologyFailure (HomologyGroup Integer)+cokernelGroup ambientRank incomingSummary =+  if incomingBoundaryCompatibleWithAmbient ambientRank incomingSummary+    then+      let incomingSmith = integralBoundarySmith incomingSummary+       in pure+            HomologyGroup+              { freeRank = ambientRank - smithRankValue incomingSmith,+                torsionInvariants =+                  smithDiagonalValues incomingSmith+                    & take (smithRankValue incomingSmith)+                    & torsionInvariantsFromDiagonal+              }+    else incompatibleIncomingBoundary ambientRank incomingSummary++kernelCoordinateHomologyFromSummaries ::+  IntegralBoundarySummary ->+  IntegralBoundarySummary ->+  Either HomologyFailure KernelCoordinateHomology+kernelCoordinateHomologyFromSummaries boundarySummary incomingSummary =+  let chainRank = integralBoundarySourceRank boundarySummary+   in if incomingBoundaryCompatibleWithAmbient chainRank incomingSummary+        then do+          let boundarySmith = integralBoundarySmith boundarySummary+              boundaryRank = smithRankValue boundarySmith+              kernelRank = chainRank - boundaryRank+          imageCoordinatesFull <-+            integerMatrixProduct+              chainRank+              (smithRightInverseRows boundarySmith)+              chainRank+              (ambientIncomingRows chainRank incomingSummary)+          let leadingImageCoordinates = takeRows boundaryRank imageCoordinatesFull+              kernelImageCoordinates = dropRows boundaryRank imageCoordinatesFull+          if allZeroMatrix leadingImageCoordinates+            then do+              imageSmith <-+                smithDecompositionOf+                  kernelRank+                  (integralBoundarySourceRank incomingSummary)+                  kernelImageCoordinates+              pure+                KernelCoordinateHomology+                  { kernelCoordinateGroup =+                      HomologyGroup+                        { freeRank = kernelRank - smithRankValue imageSmith,+                          torsionInvariants =+                            smithDiagonalValues imageSmith+                              & take (smithRankValue imageSmith)+                              & torsionInvariantsFromDiagonal+                        },+                    kernelCoordinateImageSmith = imageSmith+                  }+            else Left (LawViolation ChainNilpotenceLaw)+        else incompatibleIncomingBoundary chainRank incomingSummary++incomingBoundaryCompatibleWithAmbient :: Int -> IntegralBoundarySummary -> Bool+incomingBoundaryCompatibleWithAmbient ambientRank incomingSummary =+  integralBoundarySourceRank incomingSummary == 0+    || integralBoundaryTargetRank incomingSummary == ambientRank++ambientIncomingRows :: Int -> IntegralBoundarySummary -> [[Integer]]+ambientIncomingRows ambientRank incomingSummary =+  if integralBoundaryTargetRank incomingSummary == ambientRank+    then integralBoundaryRows incomingSummary+    else replicate ambientRank []++incompatibleIncomingBoundary ::+  Int ->+  IntegralBoundarySummary ->+  Either HomologyFailure a+incompatibleIncomingBoundary ambientRank incomingSummary =+  Left+    ( InvalidTopologyInput+        ( "incoming boundary at degree "+            <> show (integralBoundaryDegree incomingSummary)+            <> " targets "+            <> show (integralBoundaryTargetRank incomingSummary)+            <> " cells, expected "+            <> show ambientRank+        )+    )++torsionInvariantsFromDiagonal :: [Integer] -> [Integer]+torsionInvariantsFromDiagonal =+  filter (> 1) . fmap abs++exactRepresentativeClassesOf ::+  Integral r =>+  FiniteChainComplex r ->+  Either HomologyFailure [ExactRepresentativeClass Int]+exactRepresentativeClassesOf finite =+  integralHomologyWitnessesOf finite+    & fmap (concatMap integralWitnessClasses)++integralHomologyWitnessesOf ::+  Integral r =>+  FiniteChainComplex r ->+  Either HomologyFailure [IntegralHomologyDegreeWitness Int]+integralHomologyWitnessesOf finite = do+  preparedBoundaries <- prepareIntegralBoundarySummaries finite+  traverse (integralHomologyWitnessAtPrepared preparedBoundaries) (dimensionsOf finite)++integralHomologyWitnessAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Either HomologyFailure (IntegralHomologyDegreeWitness Int)+integralHomologyWitnessAt finite degreeValue = do+  preparedBoundaries <- prepareIntegralBoundarySummaries finite+  integralHomologyWitnessAtPrepared preparedBoundaries degreeValue++integralHomologyWitnessAtPrepared ::+  IntMap.IntMap IntegralBoundarySummary ->+  HomologicalDegree ->+  Either HomologyFailure (IntegralHomologyDegreeWitness Int)+integralHomologyWitnessAtPrepared preparedBoundaries degreeValue@(HomologicalDegree degreeIndex) = do+  boundarySummary <- requirePreparedBoundary preparedBoundaries degreeValue+  incomingSummary <- requirePreparedBoundary preparedBoundaries (HomologicalDegree (degreeIndex + 1))+  integralHomologyWitnessFromSummaries degreeValue boundarySummary incomingSummary++integralHomologyWitnessFromSummaries ::+  HomologicalDegree ->+  IntegralBoundarySummary ->+  IntegralBoundarySummary ->+  Either HomologyFailure (IntegralHomologyDegreeWitness Int)+integralHomologyWitnessFromSummaries degreeValue boundarySummary incomingSummary = do+  kernelCoordinateHomology <-+    kernelCoordinateHomologyFromSummaries boundarySummary incomingSummary+  let chainRank = integralBoundarySourceRank boundarySummary+      boundarySmith = integralBoundarySmith boundarySummary+      boundaryRank = smithRankValue boundarySmith+      kernelRank = chainRank - boundaryRank+      kernelBasis = dropColumns boundaryRank (smithRightRows boundarySmith)+      imageSmith = kernelCoordinateImageSmith kernelCoordinateHomology+      homologyGroupValue = kernelCoordinateGroup kernelCoordinateHomology+  classBasis <-+    integerMatrixProduct+      kernelRank+      kernelBasis+      kernelRank+      (smithLeftInverseRows imageSmith)+  classes <-+    representativeClassesFromSmith+      degreeValue+      homologyGroupValue+      (smithDiagonalValues imageSmith)+      (smithRankValue imageSmith)+      classBasis+  pure+    IntegralHomologyDegreeWitness+      { integralWitnessDegree = degreeValue,+        integralWitnessGroup = homologyGroupValue,+        integralWitnessClasses = classes+      }++smithDecompositionOf ::+  Int ->+  Int ->+  [[Integer]] ->+  Either HomologyFailure SmithDecomposition+smithDecompositionOf rowCount columnCount matrixRows =+  if rowCount < 0 || columnCount < 0+    then Left (InvalidTopologyInput "matrix dimensions must be non-negative")+    else+      if not (rowsRespectWidth columnCount matrixRows) || length matrixRows /= rowCount+        then Left (InvalidTopologyInput "matrix rows do not match their declared shape")+        else+          if rowCount == 0 || columnCount == 0+            then+              Right+                SmithDecomposition+                  { smithLeftRows = identityMatrix rowCount,+                    smithDiagonalRows = zeroMatrix rowCount columnCount,+                    smithRightRows = identityMatrix columnCount,+                    smithLeftInverseRows = identityMatrix rowCount,+                    smithRightInverseRows = identityMatrix columnCount,+                    smithDiagonalValues = [],+                    smithRankValue = 0+                  }+            else do+              dynamicMatrix <-+                first (BackendFailure . show) (mkDynMatrix rowCount columnCount (concat matrixRows))+              (leftEntries, diagonalEntries, rightEntries, leftInverseEntries, rightInverseEntries) <-+                first (BackendFailure . show) $+                  withDynMatrix dynamicMatrix+                    ( \matrixValue ->+                        smithNormalForm matrixValue+                          >>= \smithValue ->+                            Right+                              ( toListMatrix (smithLeft smithValue),+                                toListMatrix (smithDiagonal smithValue),+                                toListMatrix (smithRight smithValue),+                                toListMatrix (smithLeftInverse smithValue),+                                toListMatrix (smithRightInverse smithValue)+                              )+                    )+                    >>= id+              let leftRows = chunkColumns rowCount leftEntries+                  diagonalRows = chunkColumns columnCount diagonalEntries+                  rightRows = chunkColumns columnCount rightEntries+                  leftInverseRows = chunkColumns rowCount leftInverseEntries+                  rightInverseRows = chunkColumns columnCount rightInverseEntries+              validatedDiagonalMatrix <- validatedMatrixFromRows diagonalRows+              let diagonalValues = validatedDiagonal validatedDiagonalMatrix+                  rankValue = length (filter (/= 0) diagonalValues)+              pure+                SmithDecomposition+                  { smithLeftRows = leftRows,+                    smithDiagonalRows = diagonalRows,+                    smithRightRows = rightRows,+                    smithLeftInverseRows = leftInverseRows,+                    smithRightInverseRows = rightInverseRows,+                    smithDiagonalValues = diagonalValues,+                    smithRankValue = rankValue+                  }++integralBoundaryMatrixRows :: Integral r => BoundaryIncidence r -> [[Integer]]+integralBoundaryMatrixRows incidence =+  let rowCount = targetCardinality incidence+      columnCount = sourceCardinality incidence+      rowBuckets =+        boundaryEntries incidence+          & List.foldl'+            ( \buckets entry ->+                IntMap.insertWith+                  (IntMap.unionWith (+))+                  (targetIndex entry)+                  (IntMap.singleton (sourceIndex entry) (fromIntegral (boundaryCoefficient entry)))+                  buckets+            )+            IntMap.empty+   in enumerateFromZero rowCount+        & fmap+          ( \rowIndexValue ->+              let rowValue = IntMap.findWithDefault IntMap.empty rowIndexValue rowBuckets+               in+              enumerateFromZero columnCount+                & fmap+                  ( \columnIndexValue ->+                      IntMap.findWithDefault 0 columnIndexValue rowValue+                  )+          )++integerMatrixProduct ::+  Int ->+  [[Integer]] ->+  Int ->+  [[Integer]] ->+  Either HomologyFailure [[Integer]]+integerMatrixProduct leftColumnCount leftRows rightRowCount rightRows =+  if leftColumnCount /= rightRowCount+    then Left (InvalidTopologyInput "integer matrix multiplication encountered mismatched inner dimensions")+    else+      if+        not (rowsRespectWidth leftColumnCount leftRows)+          || length rightRows /= rightRowCount+          || not (rowsRespectWidth (matrixColumnCount rightRows) rightRows)+        then Left (InvalidTopologyInput "integer matrix multiplication received malformed rows")+        else+          let rightColumns = integerSparseColumns (matrixColumnCount rightRows) rightRows+              leftSparseRows = fmap integerSparseRow leftRows+           in Right+                ( leftSparseRows+                    & fmap+                      ( \leftRow ->+                          rightColumns+                            & fmap (integerSparseDot leftRow)+                      )+                )++type IntegerSparseRow :: Type+type IntegerSparseRow = IntMap.IntMap Integer++integerSparseColumns :: Int -> [[Integer]] -> [IntegerSparseRow]+integerSparseColumns columnCount rows =+  let columnBuckets =+        rows+          & zip [0 :: Int ..]+          & List.foldl'+            ( \buckets (rowIndex, rowValue) ->+                rowValue+                  & zip [0 :: Int ..]+                  & List.foldl'+                    ( \innerBuckets (columnIndex, coefficient) ->+                        if coefficient == 0+                          then innerBuckets+                          else+                            IntMap.insertWith+                              IntMap.union+                              columnIndex+                              (IntMap.singleton rowIndex coefficient)+                              innerBuckets+                    )+                    buckets+            )+            IntMap.empty+   in enumerateFromZero columnCount+        & fmap (\columnIndex -> IntMap.findWithDefault IntMap.empty columnIndex columnBuckets)++integerSparseRow :: [Integer] -> IntegerSparseRow+integerSparseRow values =+  values+    & zip [0 :: Int ..]+    & List.foldl'+      ( \rowValue (columnIndex, coefficient) ->+          if coefficient == 0+            then rowValue+            else IntMap.insert columnIndex coefficient rowValue+      )+      IntMap.empty++integerSparseDot :: IntegerSparseRow -> IntegerSparseRow -> Integer+integerSparseDot leftRow rightColumn =+  IntMap.foldlWithKey'+    ( \accumulator columnIndex coefficient ->+        accumulator + coefficient * IntMap.findWithDefault 0 columnIndex rightColumn+    )+    0+    leftRow++representativeClassesFromSmith ::+  HomologicalDegree ->+  HomologyGroup Integer ->+  [Integer] ->+  Int ->+  [[Integer]] ->+  Either HomologyFailure [ExactRepresentativeClass Int]+representativeClassesFromSmith degreeValue homologyGroupValue diagonalValues imageRank classBasis =+  case validatedMatrixFromRows classBasis of+    Left failureValue -> Left failureValue+    Right validatedClassBasis -> do+      torsionValues <- torsionClasses validatedClassBasis diagonalValues imageRank+      freeValues <- freeClasses validatedClassBasis (freeRank homologyGroupValue)+      pure (torsionValues <> freeValues)+  where+    torsionClasses validatedClassBasis invariants rankValue =+      concat+        <$> traverse+          ( \(indexValue, invariantValue) ->+              if abs invariantValue > 1+                then do+                  representativeVector <- validatedColumnAt indexValue validatedClassBasis+                  pure+                    [ ExactRepresentativeClass+                        { exactClassDegree = degreeValue,+                          exactClassOrder = Just (abs invariantValue),+                          exactClassRepresentative =+                            vectorToIntegralRepresentative degreeValue representativeVector+                        }+                    ]+                else pure []+          )+          (zip [0 :: Int ..] (take rankValue invariants))+    freeClasses validatedClassBasis freeCount =+      traverse+        ( \offsetValue ->+            let classIndex = imageRank + offsetValue+             in do+                  representativeVector <- validatedColumnAt classIndex validatedClassBasis+                  pure+                    ExactRepresentativeClass+                      { exactClassDegree = degreeValue,+                        exactClassOrder = Nothing,+                        exactClassRepresentative =+                          vectorToIntegralRepresentative degreeValue representativeVector+                      }+        )+        (enumerateFromZero freeCount)++vectorToIntegralRepresentative :: HomologicalDegree -> [Integer] -> RepresentativeCycle Integer Int+vectorToIntegralRepresentative degreeValue vectorValue =+  RepresentativeChain+    { representativeDegree = degreeValue,+      representativeTerms =+        vectorValue+          & zip [0 :: Int ..]+          & filter (\(_, coefficientValue) -> coefficientValue /= 0)+          & fmap (\(basisIndexValue, coefficientValue) -> (coefficientValue, basisIndexValue))+    }
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold.hs view
@@ -0,0 +1,36 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold+  ( module X,+    BasisCellRef (..),+    CellCarrier,+    CellCarrierError (..),+    carrierDegree,+    carrierCells,+    mkCellCarrier,+    MacroScaffoldIR (..),+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef (..),+    CellCarrier,+    CellCarrierError (..),+    carrierCells,+    carrierDegree,+    mkCellCarrier,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Direction as X+import Moonlight.Homology.Pure.Topology.MacroScaffold.HarmonicLoop as X+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential as X+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb as X+import Moonlight.Homology.Pure.Topology.MacroScaffold.Singularity as X++type MacroScaffoldIR :: Type+data MacroScaffoldIR = MacroScaffoldIR+  { macroScaffoldScalarPotential :: ScalarPotentialField,+    macroScaffoldReeb :: MorseReebScaffold,+    macroScaffoldDirectionField :: DirectionField,+    macroScaffoldSingularities :: [Singularity],+    macroScaffoldHarmonicLoops :: [HarmonicLoop]+  }+  deriving stock (Eq, Show)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose.hs view
@@ -0,0 +1,125 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Compose+  ( MacroScaffoldCompositionError (..),+    StitchBoundarySide (..),+    StitchSupportSelection (..),+    StitchSupportRefinement (..),+    StitchSemantics (..),+    StitchRoute (..),+    StitchRouteKey (..),+    MacroScaffoldStitchError (..),+    composeMacroScaffoldsWithScopes,+    composeMacroScaffolds,+    stitchMacroScaffoldRoutes,+  )+where++import Control.Monad (foldM)+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( MacroScaffoldIR (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Core+  ( MacroScaffoldCompositionError (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Merge+  ( mergeScalarPotentialFields,+    mergeDirectionFields,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Reindex+  ( reebArcCardinality,+    scaffoldBasisRefs,+    traverseShiftedScaffolds,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Stitch+  ( MacroScaffoldStitchError (..),+    StitchBoundarySide (..),+    StitchRoute (..),+    StitchRouteKey (..),+    StitchSemantics (..),+    StitchSupportRefinement (..),+    StitchSupportSelection (..),+    stitchRoutePair,+    uniqueRoutePairs,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb+  ( MorseReebScaffold (..),+  )++composeMacroScaffolds :: NonEmpty MacroScaffoldIR -> Either MacroScaffoldCompositionError MacroScaffoldIR+composeMacroScaffolds scaffolds =+  fmap fst+    ( composeMacroScaffoldsWithScopes+        (fmap (\scaffoldValue -> ((), scaffoldValue)) scaffolds)+    )++composeMacroScaffoldsWithScopes ::+  Ord label =>+  NonEmpty (label, MacroScaffoldIR) ->+  Either MacroScaffoldCompositionError (MacroScaffoldIR, Map label (Set BasisCellRef))+composeMacroScaffoldsWithScopes labeledScaffolds = do+  shiftedScaffolds <- traverseShiftedScaffolds labeledScaffolds+  scalarPotential <-+    mergeScalarPotentialFields+      (macroScaffoldScalarPotential . snd <$> shiftedScaffolds)+  directionField <-+    mergeDirectionFields+      (macroScaffoldDirectionField . snd <$> shiftedScaffolds)+  pure+    ( MacroScaffoldIR+        { macroScaffoldScalarPotential = scalarPotential,+          macroScaffoldReeb =+            MorseReebScaffold+              { morseReebNodes = NonEmpty.toList shiftedScaffolds >>= (morseReebNodes . macroScaffoldReeb . snd),+                morseReebArcs = NonEmpty.toList shiftedScaffolds >>= (morseReebArcs . macroScaffoldReeb . snd)+              },+          macroScaffoldDirectionField = directionField,+          macroScaffoldSingularities = NonEmpty.toList shiftedScaffolds >>= (macroScaffoldSingularities . snd),+          macroScaffoldHarmonicLoops = NonEmpty.toList shiftedScaffolds >>= (macroScaffoldHarmonicLoops . snd)+        },+      regionScopes shiftedScaffolds+    )++stitchMacroScaffoldRoutes ::+  (Ord route, Ord label) =>+  (route -> StitchSemantics) ->+  Map label (Set BasisCellRef) ->+  [StitchRoute route label] ->+  MacroScaffoldIR ->+  Either (MacroScaffoldStitchError label) (MacroScaffoldIR, Map (StitchRouteKey route label) (Set BasisCellRef))+stitchMacroScaffoldRoutes semanticsFor regionScopeMap routes scaffoldValue =+  let stitchedPairs = uniqueRoutePairs routes+      initialArcId = reebArcCardinality scaffoldValue+   in fmap+        (\(_, stitchedArcs, stitchScopes) ->+           ( scaffoldValue+               { macroScaffoldReeb =+                   (macroScaffoldReeb scaffoldValue)+                     { morseReebArcs =+                         morseReebArcs (macroScaffoldReeb scaffoldValue)+                           <> reverse stitchedArcs+                     }+               },+             stitchScopes+           )+        )+        ( foldM+            (stitchRoutePair semanticsFor regionScopeMap scaffoldValue)+            (initialArcId, [], Map.empty)+            stitchedPairs+        )++regionScopes :: Ord label => NonEmpty (label, MacroScaffoldIR) -> Map label (Set BasisCellRef)+regionScopes shiftedScaffolds =+  shiftedScaffolds+    & NonEmpty.toList+    & fmap (\(labelValue, scaffoldValue) -> (labelValue, Set.fromList (scaffoldBasisRefs scaffoldValue)))+    & Map.fromListWith Set.union
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Core.hs view
@@ -0,0 +1,55 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Core+  ( MacroScaffoldCompositionError (..),+    ScaffoldOffsets (..),+    zeroScaffoldOffsets,+  )+where++import Data.Kind (Type)+import Data.Map.Strict (Map)+import Moonlight.Homology.Pure.Chain+  ( HomologicalDegree,+  )+import Moonlight.Homology.Pure.Carrier+  ( CellCarrierError,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Direction+  ( DirectionFieldError,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+  ( ScalarPotentialFieldError,+  )++import qualified Data.Map.Strict as Map++type MacroScaffoldCompositionError :: Type+data MacroScaffoldCompositionError+  = MismatchedScalarPotentialNormalizations+  | MismatchedScalarPotentialCarrierDegrees+  | InvalidComposedScalarPotentialCarrier CellCarrierError+  | InvalidComposedScalarPotential ScalarPotentialFieldError+  | MismatchedDirectionSymmetryOrders+  | MismatchedDirectionCarrierDegrees+  | MismatchedDirectionEncodingFamilies+  | InvalidComposedDirectionCarrier CellCarrierError+  | InvalidComposedDirectionField DirectionFieldError+  deriving stock (Eq, Show)++type ScaffoldOffsets :: Type+data ScaffoldOffsets = ScaffoldOffsets+  { soBasisOffsets :: Map HomologicalDegree Int,+    soNodeOffset :: Int,+    soArcOffset :: Int,+    soSingularityOffset :: Int,+    soLoopOffset :: Int+  }++zeroScaffoldOffsets :: ScaffoldOffsets+zeroScaffoldOffsets =+  ScaffoldOffsets+    { soBasisOffsets = Map.empty,+      soNodeOffset = 0,+      soArcOffset = 0,+      soSingularityOffset = 0,+      soLoopOffset = 0+    }
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Merge.hs view
@@ -0,0 +1,86 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Merge+  ( mergeScalarPotentialFields,+    mergeDirectionFields,+  )+where++import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict qualified as Map+import Moonlight.Homology.Pure.Carrier+  ( carrierCells,+    carrierDegree,+    mkCellCarrier,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Core+  ( MacroScaffoldCompositionError (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Direction+  ( DirectionField,+    DirectionFieldEncoding (..),+    directionFieldCarrier,+    directionFieldEncoding,+    directionFieldSymmetryOrder,+    mkDirectionField,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+  ( ScalarPotentialField,+    mkScalarPotentialField,+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+  )++mergeScalarPotentialFields :: NonEmpty ScalarPotentialField -> Either MacroScaffoldCompositionError ScalarPotentialField+mergeScalarPotentialFields fields = do+  normalization <- uniformValue MismatchedScalarPotentialNormalizations (scalarPotentialNormalization <$> fields)+  degreeValue <- uniformValue MismatchedScalarPotentialCarrierDegrees ((carrierDegree . scalarPotentialCarrier) <$> fields)+  carrierValue <-+    first+      InvalidComposedScalarPotentialCarrier+      (mkCellCarrier degreeValue (NonEmpty.toList fields >>= carrierCells . scalarPotentialCarrier))+  first+    InvalidComposedScalarPotential+    (mkScalarPotentialField carrierValue normalization (Map.unions (NonEmpty.toList (scalarPotentialSamples <$> fields))))++mergeDirectionFields :: NonEmpty DirectionField -> Either MacroScaffoldCompositionError DirectionField+mergeDirectionFields fields = do+  symmetryOrder <- uniformValue MismatchedDirectionSymmetryOrders (directionFieldSymmetryOrder <$> fields)+  degreeValue <- uniformValue MismatchedDirectionCarrierDegrees ((carrierDegree . directionFieldCarrier) <$> fields)+  encodingValue <- mergeDirectionEncodings (directionFieldEncoding <$> fields)+  carrierValue <-+    first+      InvalidComposedDirectionCarrier+      (mkCellCarrier degreeValue (NonEmpty.toList fields >>= carrierCells . directionFieldCarrier))+  first+    InvalidComposedDirectionField+    (mkDirectionField carrierValue symmetryOrder encodingValue)++mergeDirectionEncodings :: NonEmpty DirectionFieldEncoding -> Either MacroScaffoldCompositionError DirectionFieldEncoding+mergeDirectionEncodings encodings =+  case traverse angleMap encodings of+    Just angleMaps ->+      Right (DirectionAngleEncoding (Map.unions (NonEmpty.toList angleMaps)))+    Nothing ->+      case traverse cochainMap encodings of+        Just cochainMaps ->+          Right (DirectionCochainEncoding (Map.unions (NonEmpty.toList cochainMaps)))+        Nothing ->+          Left MismatchedDirectionEncodingFamilies+  where+    angleMap encodingValue =+      case encodingValue of+        DirectionAngleEncoding phaseMap -> Just phaseMap+        DirectionCochainEncoding {} -> Nothing++    cochainMap encodingValue =+      case encodingValue of+        DirectionAngleEncoding {} -> Nothing+        DirectionCochainEncoding coefficientMap -> Just coefficientMap++uniformValue :: Eq a => MacroScaffoldCompositionError -> NonEmpty a -> Either MacroScaffoldCompositionError a+uniformValue mismatchError (value :| rest) =+  if all (== value) rest+    then Right value+    else Left mismatchError
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Reindex.hs view
@@ -0,0 +1,273 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Reindex+  ( traverseShiftedScaffolds,+    scaffoldBasisRefs,+    reebArcCardinality,+  )+where++import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Moonlight.Homology.Pure.Chain+  ( HomologicalDegree,+    RepresentativeChain (..),+  )+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef (..),+    CellCarrier,+    CellCarrierError,+    carrierCells,+    carrierDegree,+    mkCellCarrier,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( MacroScaffoldIR (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Core+  ( MacroScaffoldCompositionError (..),+    ScaffoldOffsets (..),+    zeroScaffoldOffsets,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Direction+  ( DirectionField,+    DirectionFieldEncoding (..),+    directionFieldCarrier,+    directionFieldEncoding,+    directionFieldSymmetryOrder,+    mkDirectionField,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.HarmonicLoop+  ( HarmonicLoop (..),+    HarmonicLoopId (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+  ( ScalarPotentialField,+    mkScalarPotentialField,+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb+  ( MorseReebArc (..),+    MorseReebNode (..),+    MorseReebScaffold (..),+    ReebArcId (..),+    ReebNodeId (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Singularity+  ( Singularity (..),+    SingularityId (..),+  )++traverseShiftedScaffolds ::+  NonEmpty (label, MacroScaffoldIR) ->+  Either MacroScaffoldCompositionError (NonEmpty (label, MacroScaffoldIR))+traverseShiftedScaffolds ((firstLabel, firstScaffold) :| remainingScaffolds) = do+  shiftedFirst <- reindexScaffold zeroScaffoldOffsets firstScaffold+  (_, shiftedRest) <-+    foldM+      reindexStep+      (advanceOffsets zeroScaffoldOffsets firstScaffold, [])+      remainingScaffolds+  pure ((firstLabel, shiftedFirst) :| shiftedRest)+  where+    reindexStep ::+      (ScaffoldOffsets, [(label, MacroScaffoldIR)]) ->+      (label, MacroScaffoldIR) ->+      Either MacroScaffoldCompositionError (ScaffoldOffsets, [(label, MacroScaffoldIR)])+    reindexStep (offsets, shiftedScaffolds) (labelValue, scaffoldValue) = do+      shiftedScaffold <- reindexScaffold offsets scaffoldValue+      pure+        ( advanceOffsets offsets scaffoldValue,+          shiftedScaffolds <> [(labelValue, shiftedScaffold)]+        )++scaffoldBasisRefs :: MacroScaffoldIR -> [BasisCellRef]+scaffoldBasisRefs scaffoldValue =+  carrierCells (scalarPotentialCarrier (macroScaffoldScalarPotential scaffoldValue))+    <> Map.keys (scalarPotentialSamples (macroScaffoldScalarPotential scaffoldValue))+    <> carrierCells (directionFieldCarrier (macroScaffoldDirectionField scaffoldValue))+    <> directionEncodingBasisRefs (directionFieldEncoding (macroScaffoldDirectionField scaffoldValue))+    <> fmap morseReebNodeAnchor (morseReebNodes (macroScaffoldReeb scaffoldValue))+    <> (morseReebArcs (macroScaffoldReeb scaffoldValue) >>= morseReebArcSupport)+    <> fmap singularityAnchor (macroScaffoldSingularities scaffoldValue)+    <> (macroScaffoldHarmonicLoops scaffoldValue >>= representativeBasisRefs . harmonicLoopCycle)+    <> (macroScaffoldHarmonicLoops scaffoldValue >>= representativeBasisRefs . harmonicLoopCocycle)++reebArcCardinality :: MacroScaffoldIR -> Int+reebArcCardinality s = maxIdCardinality (unReebArcId . morseReebArcId) (morseReebArcs (macroScaffoldReeb s))++maxIdCardinality :: (a -> Int) -> [a] -> Int+maxIdCardinality extractId = foldr (\v acc -> max acc (extractId v + 1)) 0++reebNodeCardinality :: MacroScaffoldIR -> Int+reebNodeCardinality s = maxIdCardinality (unReebNodeId . morseReebNodeId) (morseReebNodes (macroScaffoldReeb s))++singularityCardinality :: MacroScaffoldIR -> Int+singularityCardinality s = maxIdCardinality (unSingularityId . singularityId) (macroScaffoldSingularities s)++harmonicLoopCardinality :: MacroScaffoldIR -> Int+harmonicLoopCardinality s = maxIdCardinality (unHarmonicLoopId . harmonicLoopId) (macroScaffoldHarmonicLoops s)++reindexScaffold :: ScaffoldOffsets -> MacroScaffoldIR -> Either MacroScaffoldCompositionError MacroScaffoldIR+reindexScaffold offsets scaffoldValue = do+  scalarPotential <- reindexScalarPotential offsets (macroScaffoldScalarPotential scaffoldValue)+  directionField <- reindexDirectionField offsets (macroScaffoldDirectionField scaffoldValue)+  pure+    MacroScaffoldIR+      { macroScaffoldScalarPotential = scalarPotential,+        macroScaffoldReeb = reindexReebScaffold offsets (macroScaffoldReeb scaffoldValue),+        macroScaffoldDirectionField = directionField,+        macroScaffoldSingularities = fmap (reindexSingularity offsets) (macroScaffoldSingularities scaffoldValue),+        macroScaffoldHarmonicLoops = fmap (reindexHarmonicLoop offsets) (macroScaffoldHarmonicLoops scaffoldValue)+      }++reindexScalarPotential :: ScaffoldOffsets -> ScalarPotentialField -> Either MacroScaffoldCompositionError ScalarPotentialField+reindexScalarPotential offsets scalarPotential = do+  carrierValue <- reindexCarrier InvalidComposedScalarPotentialCarrier offsets (scalarPotentialCarrier scalarPotential)+  first+    InvalidComposedScalarPotential+    ( mkScalarPotentialField+        carrierValue+        (scalarPotentialNormalization scalarPotential)+        (Map.fromAscList (reindexAssociation offsets <$> Map.toAscList (scalarPotentialSamples scalarPotential)))+    )++reindexDirectionField :: ScaffoldOffsets -> DirectionField -> Either MacroScaffoldCompositionError DirectionField+reindexDirectionField offsets directionField = do+  carrierValue <- reindexCarrier InvalidComposedDirectionCarrier offsets (directionFieldCarrier directionField)+  first+    InvalidComposedDirectionField+    ( mkDirectionField+        carrierValue+        (directionFieldSymmetryOrder directionField)+        (reindexDirectionEncoding offsets (directionFieldEncoding directionField))+    )++reindexCarrier ::+  (CellCarrierError -> MacroScaffoldCompositionError) ->+  ScaffoldOffsets ->+  CellCarrier ->+  Either MacroScaffoldCompositionError CellCarrier+reindexCarrier liftError offsets carrierValue =+  first+    liftError+    (mkCellCarrier (carrierDegree carrierValue) (reindexBasisCellRef offsets <$> carrierCells carrierValue))++reindexAssociation :: ScaffoldOffsets -> (BasisCellRef, value) -> (BasisCellRef, value)+reindexAssociation offsets (basisCellRef, value) =+  (reindexBasisCellRef offsets basisCellRef, value)++reindexDirectionEncoding :: ScaffoldOffsets -> DirectionFieldEncoding -> DirectionFieldEncoding+reindexDirectionEncoding offsets encodingValue =+  case encodingValue of+    DirectionAngleEncoding phaseMap ->+      DirectionAngleEncoding (Map.fromAscList (reindexAssociation offsets <$> Map.toAscList phaseMap))+    DirectionCochainEncoding coefficientMap ->+      DirectionCochainEncoding (Map.fromAscList (reindexAssociation offsets <$> Map.toAscList coefficientMap))++reindexReebScaffold :: ScaffoldOffsets -> MorseReebScaffold -> MorseReebScaffold+reindexReebScaffold offsets reebValue =+  MorseReebScaffold+    { morseReebNodes = reindexReebNode offsets <$> morseReebNodes reebValue,+      morseReebArcs = reindexReebArc offsets <$> morseReebArcs reebValue+    }++reindexReebNode :: ScaffoldOffsets -> MorseReebNode -> MorseReebNode+reindexReebNode offsets nodeValue =+  nodeValue+    { morseReebNodeId = offsetReebNodeId (soNodeOffset offsets) (morseReebNodeId nodeValue),+      morseReebNodeAnchor = reindexBasisCellRef offsets (morseReebNodeAnchor nodeValue)+    }++reindexReebArc :: ScaffoldOffsets -> MorseReebArc -> MorseReebArc+reindexReebArc offsets arcValue =+  arcValue+    { morseReebArcId = offsetReebArcId (soArcOffset offsets) (morseReebArcId arcValue),+      morseReebArcSource = offsetReebNodeId (soNodeOffset offsets) (morseReebArcSource arcValue),+      morseReebArcTarget = offsetReebNodeId (soNodeOffset offsets) (morseReebArcTarget arcValue),+      morseReebArcSupport = reindexBasisCellRef offsets <$> morseReebArcSupport arcValue+    }++reindexSingularity :: ScaffoldOffsets -> Singularity -> Singularity+reindexSingularity offsets singularityValue =+  singularityValue+    { singularityId = offsetSingularityId (soSingularityOffset offsets) (singularityId singularityValue),+      singularityAnchor = reindexBasisCellRef offsets (singularityAnchor singularityValue),+      singularityReebNode = offsetReebNodeId (soNodeOffset offsets) <$> singularityReebNode singularityValue,+      singularityIncidentArcs = offsetReebArcId (soArcOffset offsets) <$> singularityIncidentArcs singularityValue+    }++reindexHarmonicLoop :: ScaffoldOffsets -> HarmonicLoop -> HarmonicLoop+reindexHarmonicLoop offsets harmonicLoopValue =+  harmonicLoopValue+    { harmonicLoopId = offsetHarmonicLoopId (soLoopOffset offsets) (harmonicLoopId harmonicLoopValue),+      harmonicLoopCycle = reindexRepresentative offsets (harmonicLoopCycle harmonicLoopValue),+      harmonicLoopCocycle = reindexRepresentative offsets (harmonicLoopCocycle harmonicLoopValue),+      harmonicLoopSupport = offsetReebArcId (soArcOffset offsets) <$> harmonicLoopSupport harmonicLoopValue+    }++reindexRepresentative ::+  ScaffoldOffsets ->+  RepresentativeChain coefficient BasisCellRef ->+  RepresentativeChain coefficient BasisCellRef+reindexRepresentative offsets representativeValue =+  representativeValue+    { representativeTerms =+        fmap+          (\(coefficientValue, basisCellRef) -> (coefficientValue, reindexBasisCellRef offsets basisCellRef))+          (representativeTerms representativeValue)+    }++reindexBasisCellRef :: ScaffoldOffsets -> BasisCellRef -> BasisCellRef+reindexBasisCellRef offsets basisCellRef =+  let degreeValue = cellDegree basisCellRef+      indexOffset = Map.findWithDefault 0 degreeValue (soBasisOffsets offsets)+   in basisCellRef+        { cellIndex = cellIndex basisCellRef + indexOffset+        }++advanceOffsets :: ScaffoldOffsets -> MacroScaffoldIR -> ScaffoldOffsets+advanceOffsets offsets scaffoldValue =+  offsets+    { soBasisOffsets = Map.unionWith (+) (soBasisOffsets offsets) (basisCardinalities scaffoldValue),+      soNodeOffset = soNodeOffset offsets + reebNodeCardinality scaffoldValue,+      soArcOffset = soArcOffset offsets + reebArcCardinality scaffoldValue,+      soSingularityOffset = soSingularityOffset offsets + singularityCardinality scaffoldValue,+      soLoopOffset = soLoopOffset offsets + harmonicLoopCardinality scaffoldValue+    }++basisCardinalities :: MacroScaffoldIR -> Map HomologicalDegree Int+basisCardinalities scaffoldValue =+  Map.fromListWith max+    ( fmap+        (\basisCellRef -> (cellDegree basisCellRef, cellIndex basisCellRef + 1))+        (scaffoldBasisRefs scaffoldValue)+    )++directionEncodingBasisRefs :: DirectionFieldEncoding -> [BasisCellRef]+directionEncodingBasisRefs encodingValue =+  case encodingValue of+    DirectionAngleEncoding phaseMap -> Map.keys phaseMap+    DirectionCochainEncoding coefficientMap -> Map.keys coefficientMap++representativeBasisRefs :: RepresentativeChain coefficient BasisCellRef -> [BasisCellRef]+representativeBasisRefs = fmap snd . representativeTerms++offsetReebNodeId :: Int -> ReebNodeId -> ReebNodeId+offsetReebNodeId nodeOffset (ReebNodeId nodeIdValue) =+  ReebNodeId (nodeIdValue + nodeOffset)++offsetReebArcId :: Int -> ReebArcId -> ReebArcId+offsetReebArcId arcOffset (ReebArcId arcIdValue) =+  ReebArcId (arcIdValue + arcOffset)++offsetSingularityId :: Int -> SingularityId -> SingularityId+offsetSingularityId singularityOffset (SingularityId singularityIdValue) =+  SingularityId (singularityIdValue + singularityOffset)++offsetHarmonicLoopId :: Int -> HarmonicLoopId -> HarmonicLoopId+offsetHarmonicLoopId loopOffset (HarmonicLoopId loopIdValue) =+  HarmonicLoopId (loopIdValue + loopOffset)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Stitch.hs view
@@ -0,0 +1,264 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Compose.Stitch+  ( StitchBoundarySide (..),+    StitchSupportSelection (..),+    StitchSupportRefinement (..),+    StitchSemantics (..),+    StitchRoute (..),+    StitchRouteKey (..),+    MacroScaffoldStitchError (..),+    stitchRoutePair,+    uniqueRoutePairs,+  )+where++import Data.Containers.ListUtils (nubOrd)+import Data.Function ((&))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Moonlight.Core (note)+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( MacroScaffoldIR (..),+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+  ( PotentialValue,+  )+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb+  ( Monotonicity (..),+    MorseReebArc (..),+    MorseReebNode (..),+    MorseReebScaffold (..),+    ReebArcId (..),+  )++type StitchBoundarySide :: Type+data StitchBoundarySide+  = LowerBoundary+  | UpperBoundary+  deriving stock (Eq, Ord, Show)++type StitchSupportSelection :: Type+data StitchSupportSelection+  = BoundarySupport+  | AnchorSupport+  deriving stock (Eq, Ord, Show)++type StitchSupportRefinement :: Type+data StitchSupportRefinement+  = KernelSupportRefinement+  | BoundaryEnvelopeRefinement+  | RegionalEnvelopeRefinement+  deriving stock (Eq, Ord, Show)++type StitchSemantics :: Type+data StitchSemantics = StitchSemantics+  { ssSourceBoundary :: StitchBoundarySide,+    ssTargetBoundary :: StitchBoundarySide,+    ssSupportSelection :: StitchSupportSelection,+    ssSupportRefinement :: StitchSupportRefinement+  }+  deriving stock (Eq, Ord, Show)++type StitchRoute :: Type -> Type -> Type+data StitchRoute route label = StitchRoute+  { stitchRouteKind :: route,+    stitchRouteRegions :: NonEmpty label+  }+  deriving stock (Eq, Show)++type StitchRouteKey :: Type -> Type -> Type+data StitchRouteKey route label = StitchRouteKey+  { srkRouteKind :: route,+    srkSourceRegion :: label,+    srkTargetRegion :: label+  }+  deriving stock (Eq, Ord, Show)++type MacroScaffoldStitchError :: Type -> Type+data MacroScaffoldStitchError label+  = MissingStitchRegion label+  | MissingBoundaryNode label StitchBoundarySide+  deriving stock (Eq, Show)++stitchRoutePair ::+  (Ord route, Ord label) =>+  (route -> StitchSemantics) ->+  Map label (Set BasisCellRef) ->+  MacroScaffoldIR ->+  (Int, [MorseReebArc], Map (StitchRouteKey route label) (Set BasisCellRef)) ->+  StitchRouteKey route label ->+  Either (MacroScaffoldStitchError label) (Int, [MorseReebArc], Map (StitchRouteKey route label) (Set BasisCellRef))+stitchRoutePair semanticsFor regionScopeMap scaffoldValue (nextArcId, stitchedArcs, stitchScopes) stitchKey+  | sourceLabel == targetLabel =+      Right (nextArcId, stitchedArcs, stitchScopes)+  | otherwise = do+      let semantics = semanticsFor routeKind+      (sourceRegionBasisRefs, sourceNode, sourceSupport) <-+        boundaryNodeAndSupport regionScopeMap scaffoldValue sourceLabel (ssSourceBoundary semantics)+      (targetRegionBasisRefs, targetNode, targetSupport) <-+        boundaryNodeAndSupport regionScopeMap scaffoldValue targetLabel (ssTargetBoundary semantics)+      let supportRefs =+            combineSupportRefs+              (ssSupportSelection semantics)+              (ssSupportRefinement semantics)+              sourceRegionBasisRefs+              targetRegionBasisRefs+              sourceSupport+              targetSupport+              sourceNode+              targetNode+          stitchedArc =+            MorseReebArc+              { morseReebArcId = ReebArcId nextArcId,+                morseReebArcSource = morseReebNodeId sourceNode,+                morseReebArcTarget = morseReebNodeId targetNode,+                morseReebArcMonotonicity = monotonicityBetween sourceNode targetNode,+                morseReebArcSupport = Set.toAscList supportRefs+              }+      Right+        ( nextArcId + 1,+          stitchedArc : stitchedArcs,+          Map.insertWith Set.union stitchKey supportRefs stitchScopes+        )+  where+    routeKind = srkRouteKind stitchKey+    sourceLabel = srkSourceRegion stitchKey+    targetLabel = srkTargetRegion stitchKey++uniqueRoutePairs :: (Ord route, Ord label) => [StitchRoute route label] -> [StitchRouteKey route label]+uniqueRoutePairs = nubOrd . concatMap routeTransitions++routeTransitions :: StitchRoute route label -> [StitchRouteKey route label]+routeTransitions routeValue =+  go firstLabel remainingLabels+  where+    routeKind = stitchRouteKind routeValue+    firstLabel :| remainingLabels = stitchRouteRegions routeValue+    go _ [] = []+    go previousLabel (nextLabel : rest) =+      StitchRouteKey routeKind previousLabel nextLabel : go nextLabel rest++boundaryNodeAndSupport ::+  Ord label =>+  Map label (Set BasisCellRef) ->+  MacroScaffoldIR ->+  label ->+  StitchBoundarySide ->+  Either (MacroScaffoldStitchError label) (Set BasisCellRef, MorseReebNode, Set BasisCellRef)+boundaryNodeAndSupport regionScopeMap scaffoldValue labelValue boundarySide = do+  regionBasisRefs <-+    note (MissingStitchRegion labelValue) (Map.lookup labelValue regionScopeMap)+  boundaryNodes <-+    boundaryNodesForRegion regionBasisRefs scaffoldValue boundarySide+      & note (MissingBoundaryNode labelValue boundarySide)+  let supportRefs =+        boundarySupportRefs regionBasisRefs scaffoldValue boundaryNodes+      representativeNode = selectRepresentativeNode boundaryNodes+  Right (regionBasisRefs, representativeNode, supportRefs)++boundaryNodesForRegion ::+  Set BasisCellRef ->+  MacroScaffoldIR ->+  StitchBoundarySide ->+  Maybe (NonEmpty MorseReebNode)+boundaryNodesForRegion regionBasisRefs scaffoldValue boundarySide =+  let regionNodes =+        filter+          (\nodeValue -> Set.member (morseReebNodeAnchor nodeValue) regionBasisRefs)+          (morseReebNodes (macroScaffoldReeb scaffoldValue))+   in case regionNodes of+        [] -> Nothing+        firstNode : restNodes ->+          let boundaryPotential =+                foldr+                  (selectPotential boundarySide . morseReebNodePotential)+                  (morseReebNodePotential firstNode)+                  restNodes+              matchingNodes =+                filter+                  ((== boundaryPotential) . morseReebNodePotential)+                  regionNodes+           in NonEmpty.nonEmpty matchingNodes++selectPotential :: StitchBoundarySide -> PotentialValue -> PotentialValue -> PotentialValue+selectPotential boundarySide candidate current =+  case boundarySide of+    LowerBoundary ->+      min candidate current+    UpperBoundary ->+      max candidate current++boundarySupportRefs ::+  Set BasisCellRef ->+  MacroScaffoldIR ->+  NonEmpty MorseReebNode ->+  Set BasisCellRef+boundarySupportRefs regionBasisRefs scaffoldValue boundaryNodes =+  let boundaryNodeIds =+        Set.fromList (fmap morseReebNodeId (NonEmpty.toList boundaryNodes))+      incidentArcSupport =+        morseReebArcs (macroScaffoldReeb scaffoldValue)+          & foldr+            ( \arcValue supportRefs ->+                if Set.member (morseReebArcSource arcValue) boundaryNodeIds+                  || Set.member (morseReebArcTarget arcValue) boundaryNodeIds+                  then+                    Set.union+                      supportRefs+                      ( Set.fromList+                          ( filter (`Set.member` regionBasisRefs) (morseReebArcSupport arcValue) )+                      )+                  else supportRefs+            )+            Set.empty+      anchorSupport =+        Set.fromList (fmap morseReebNodeAnchor (NonEmpty.toList boundaryNodes))+   in Set.union anchorSupport incidentArcSupport++selectRepresentativeNode :: NonEmpty MorseReebNode -> MorseReebNode+selectRepresentativeNode (firstNode :| remainingNodes) =+  foldr+    (\nodeValue selectedNode -> if morseReebNodeId nodeValue < morseReebNodeId selectedNode then nodeValue else selectedNode)+    firstNode+    remainingNodes++combineSupportRefs ::+  StitchSupportSelection ->+  StitchSupportRefinement ->+  Set BasisCellRef ->+  Set BasisCellRef ->+  Set BasisCellRef ->+  Set BasisCellRef ->+  MorseReebNode ->+  MorseReebNode ->+  Set BasisCellRef+combineSupportRefs supportSelection supportRefinement sourceRegionBasisRefs targetRegionBasisRefs sourceSupport targetSupport sourceNode targetNode =+  case supportRefinement of+    KernelSupportRefinement ->+      kernelSupport+    BoundaryEnvelopeRefinement ->+      Set.union kernelSupport boundarySupport+    RegionalEnvelopeRefinement ->+      Set.unions [kernelSupport, boundarySupport, sourceRegionBasisRefs, targetRegionBasisRefs]+  where+    kernelSupport =+      case supportSelection of+        BoundarySupport ->+          boundarySupport+        AnchorSupport ->+          Set.fromList [morseReebNodeAnchor sourceNode, morseReebNodeAnchor targetNode]+    boundarySupport =+      Set.union sourceSupport targetSupport++monotonicityBetween :: MorseReebNode -> MorseReebNode -> Monotonicity+monotonicityBetween sourceNode targetNode =+  if morseReebNodePotential sourceNode <= morseReebNodePotential targetNode+    then Ascending+    else Descending
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Direction.hs view
@@ -0,0 +1,172 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Direction+  ( DirectionSymmetryOrder,+    DirectionSymmetryOrderError (..),+    unDirectionSymmetryOrder,+    mkDirectionSymmetryOrder,+    DirectionPhase,+    DirectionPhaseError (..),+    unDirectionPhase,+    mkDirectionPhase,+    DirectionCoefficient,+    DirectionCoefficientError (..),+    unDirectionCoefficient,+    mkDirectionCoefficient,+    DirectionFieldEncoding (..),+    DirectionField,+    DirectionFieldError (..),+    directionFieldCarrier,+    directionFieldSymmetryOrder,+    directionFieldEncoding,+    mkDirectionField,+    mkDirectionAngleField,+    mkDirectionCochainField,+  )+where++import Data.Fixed (mod')+import Data.Kind (Type)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Core+  ( mkFiniteWith,+    mkPositiveIntWith,+  )+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef,+    CellCarrier,+    carrierCells,+  )++type DirectionSymmetryOrder :: Type+newtype DirectionSymmetryOrder = DirectionSymmetryOrder+  { unDirectionSymmetryOrder :: Int+  }+  deriving stock (Eq, Ord, Show)++type DirectionSymmetryOrderError :: Type+data DirectionSymmetryOrderError+  = NonPositiveDirectionSymmetryOrder Int+  deriving stock (Eq, Show)++mkDirectionSymmetryOrder :: Int -> Either DirectionSymmetryOrderError DirectionSymmetryOrder+mkDirectionSymmetryOrder =+  mkPositiveIntWith NonPositiveDirectionSymmetryOrder DirectionSymmetryOrder++type DirectionPhase :: Type+newtype DirectionPhase = DirectionPhase+  { unDirectionPhase :: Double+  }+  deriving stock (Eq, Ord, Show)++type DirectionPhaseError :: Type+data DirectionPhaseError+  = NonFiniteDirectionPhase Double+  deriving stock (Eq, Show)++mkDirectionPhase :: Double -> Either DirectionPhaseError DirectionPhase+mkDirectionPhase =+  mkFiniteWith NonFiniteDirectionPhase DirectionPhase++type DirectionCoefficient :: Type+newtype DirectionCoefficient = DirectionCoefficient+  { unDirectionCoefficient :: Double+  }+  deriving stock (Eq, Ord, Show)++type DirectionCoefficientError :: Type+data DirectionCoefficientError+  = NonFiniteDirectionCoefficient Double+  deriving stock (Eq, Show)++mkDirectionCoefficient :: Double -> Either DirectionCoefficientError DirectionCoefficient+mkDirectionCoefficient =+  mkFiniteWith NonFiniteDirectionCoefficient DirectionCoefficient++type DirectionFieldEncoding :: Type+data DirectionFieldEncoding+  = DirectionAngleEncoding (Map.Map BasisCellRef DirectionPhase)+  | DirectionCochainEncoding (Map.Map BasisCellRef DirectionCoefficient)+  deriving stock (Eq, Show)++type DirectionField :: Type+data DirectionField = DirectionField+  { directionFieldCarrier :: CellCarrier,+    directionFieldSymmetryOrder :: DirectionSymmetryOrder,+    directionFieldEncoding :: DirectionFieldEncoding+  }+  deriving stock (Eq, Show)++type DirectionFieldError :: Type+data DirectionFieldError = DirectionFieldCoverageMismatch+  { directionFieldMissingCells :: [BasisCellRef],+    directionFieldExtraneousCells :: [BasisCellRef]+  }+  deriving stock (Eq, Show)++mkDirectionField ::+  CellCarrier ->+  DirectionSymmetryOrder ->+  DirectionFieldEncoding ->+  Either DirectionFieldError DirectionField+mkDirectionField carrierValue symmetryOrderValue encodingValue =+  let normalizedEncoding = normalizeDirectionFieldEncoding symmetryOrderValue encodingValue+      carrierDomain = Set.fromList (carrierCells carrierValue)+      encodingDomain = directionFieldEncodingDomain normalizedEncoding+      missingCells = Set.toAscList (carrierDomain `Set.difference` encodingDomain)+      extraneousCells = Set.toAscList (encodingDomain `Set.difference` carrierDomain)+   in case (missingCells, extraneousCells) of+        ([], []) ->+          Right+            DirectionField+              { directionFieldCarrier = carrierValue,+                directionFieldSymmetryOrder = symmetryOrderValue,+                directionFieldEncoding = normalizedEncoding+              }+        _ ->+          Left+            DirectionFieldCoverageMismatch+              { directionFieldMissingCells = missingCells,+                directionFieldExtraneousCells = extraneousCells+              }++mkDirectionAngleField ::+  CellCarrier ->+  DirectionSymmetryOrder ->+  Map.Map BasisCellRef DirectionPhase ->+  Either DirectionFieldError DirectionField+mkDirectionAngleField carrierValue symmetryOrderValue phaseMap =+  mkDirectionField carrierValue symmetryOrderValue (DirectionAngleEncoding phaseMap)++mkDirectionCochainField ::+  CellCarrier ->+  DirectionSymmetryOrder ->+  Map.Map BasisCellRef DirectionCoefficient ->+  Either DirectionFieldError DirectionField+mkDirectionCochainField carrierValue symmetryOrderValue coefficientMap =+  mkDirectionField carrierValue symmetryOrderValue (DirectionCochainEncoding coefficientMap)++directionFieldEncodingDomain :: DirectionFieldEncoding -> Set.Set BasisCellRef+directionFieldEncodingDomain encodingValue =+  case encodingValue of+    DirectionAngleEncoding phaseMap ->+      Map.keysSet phaseMap+    DirectionCochainEncoding coefficientMap ->+      Map.keysSet coefficientMap++normalizeDirectionFieldEncoding :: DirectionSymmetryOrder -> DirectionFieldEncoding -> DirectionFieldEncoding+normalizeDirectionFieldEncoding symmetryOrderValue encodingValue =+  case encodingValue of+    DirectionAngleEncoding phaseMap ->+      DirectionAngleEncoding (Map.map (normalizeDirectionPhase symmetryOrderValue) phaseMap)+    DirectionCochainEncoding _ ->+      encodingValue++normalizeDirectionPhase :: DirectionSymmetryOrder -> DirectionPhase -> DirectionPhase+normalizeDirectionPhase symmetryOrderValue phaseValue =+  let period = fundamentalDirectionPeriod symmetryOrderValue+      normalizedPhase = unDirectionPhase phaseValue `mod'` period+   in DirectionPhase normalizedPhase++fundamentalDirectionPeriod :: DirectionSymmetryOrder -> Double+fundamentalDirectionPeriod symmetryOrderValue =+  (2 * pi) / fromIntegral (unDirectionSymmetryOrder symmetryOrderValue)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/HarmonicLoop.hs view
@@ -0,0 +1,46 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.HarmonicLoop+  ( HarmonicLoopId (..),+    HarmonicLoopWeight (..),+    HarmonicLoopPeriod (..),+    HarmonicLoop (..),+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Chain+  ( HomologicalDegree,+    RepresentativeCocycle,+    RepresentativeCycle,+  )+import Moonlight.Homology.Pure.Carrier (BasisCellRef)+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb (ReebArcId)++type HarmonicLoopId :: Type+newtype HarmonicLoopId = HarmonicLoopId+  { unHarmonicLoopId :: Int+  }+  deriving stock (Eq, Ord, Show)++type HarmonicLoopWeight :: Type+newtype HarmonicLoopWeight = HarmonicLoopWeight+  { unHarmonicLoopWeight :: Double+  }+  deriving stock (Eq, Ord, Show)++type HarmonicLoopPeriod :: Type+newtype HarmonicLoopPeriod = HarmonicLoopPeriod+  { unHarmonicLoopPeriod :: Double+  }+  deriving stock (Eq, Ord, Show)++type HarmonicLoop :: Type+data HarmonicLoop = HarmonicLoop+  { harmonicLoopId :: HarmonicLoopId,+    harmonicLoopDegree :: HomologicalDegree,+    harmonicLoopCycle :: RepresentativeCycle Rational BasisCellRef,+    harmonicLoopCocycle :: RepresentativeCocycle Rational BasisCellRef,+    harmonicLoopWeight :: HarmonicLoopWeight,+    harmonicLoopPeriod :: Maybe HarmonicLoopPeriod,+    harmonicLoopSupport :: [ReebArcId]+  }+  deriving stock (Eq, Show)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Potential.hs view
@@ -0,0 +1,110 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Potential+  ( PotentialValue,+    PotentialValueError (..),+    unPotentialValue,+    mkPotentialValue,+    PotentialNormalization (..),+    ScalarPotentialField,+    ScalarPotentialFieldError (..),+    scalarPotentialCarrier,+    scalarPotentialNormalization,+    scalarPotentialSamples,+    mkScalarPotentialField,+    mkScalarPotentialFieldFromSamples,+  )+where++import Data.Bifunctor (first)+import Data.Function ((&))+import Data.Kind (Type)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Core+  ( collectEither,+    mkFiniteWith,+  )+import Moonlight.Homology.Pure.Carrier+  ( BasisCellRef,+    CellCarrier,+    carrierCells,+  )++type PotentialValue :: Type+newtype PotentialValue = PotentialValue+  { unPotentialValue :: Double+  }+  deriving stock (Eq, Ord, Show)++type PotentialValueError :: Type+data PotentialValueError+  = NonFinitePotentialValue Double+  deriving stock (Eq, Show)++mkPotentialValue :: Double -> Either PotentialValueError PotentialValue+mkPotentialValue =+  mkFiniteWith NonFinitePotentialValue PotentialValue++type PotentialNormalization :: Type+data PotentialNormalization+  = NativePotentialScale+  | UnitIntervalPotentialScale+  deriving stock (Eq, Ord, Show)++type ScalarPotentialField :: Type+data ScalarPotentialField = ScalarPotentialField+  { scalarPotentialCarrier :: CellCarrier,+    scalarPotentialNormalization :: PotentialNormalization,+    scalarPotentialSamples :: Map.Map BasisCellRef PotentialValue+  }+  deriving stock (Eq, Show)++type ScalarPotentialFieldError :: Type+data ScalarPotentialFieldError+  = ScalarPotentialFieldCoverageMismatch [BasisCellRef] [BasisCellRef]+  | ScalarPotentialFieldInvalidSamples [(BasisCellRef, PotentialValueError)]+  deriving stock (Eq, Show)++mkScalarPotentialField ::+  CellCarrier ->+  PotentialNormalization ->+  Map.Map BasisCellRef PotentialValue ->+  Either ScalarPotentialFieldError ScalarPotentialField+mkScalarPotentialField carrierValue normalization sampleValues =+  let carrierDomain = Set.fromList (carrierCells carrierValue)+      sampleDomain = Map.keysSet sampleValues+      missingCells = Set.toAscList (carrierDomain `Set.difference` sampleDomain)+      extraneousCells = Set.toAscList (sampleDomain `Set.difference` carrierDomain)+   in case (missingCells, extraneousCells) of+        ([], []) ->+          Right+            ScalarPotentialField+              { scalarPotentialCarrier = carrierValue,+                scalarPotentialNormalization = normalization,+                scalarPotentialSamples = sampleValues+              }+        _ ->+          Left+            (ScalarPotentialFieldCoverageMismatch missingCells extraneousCells)++mkScalarPotentialFieldFromSamples ::+  CellCarrier ->+  PotentialNormalization ->+  Map.Map BasisCellRef Double ->+  Either ScalarPotentialFieldError ScalarPotentialField+mkScalarPotentialFieldFromSamples carrierValue normalization rawSampleValues = do+  validatedSamples <-+    first+      ScalarPotentialFieldInvalidSamples+      ( collectEither+          ( rawSampleValues+              & Map.toAscList+              & fmap+                ( \(cellRefValue, rawSampleValue) ->+                    first+                      (\potentialError -> [(cellRefValue, potentialError)])+                      (mkPotentialValue rawSampleValue)+                      & fmap ((,) cellRefValue)+                )+          )+      )+  mkScalarPotentialField carrierValue normalization (Map.fromList validatedSamples)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Reeb.hs view
@@ -0,0 +1,58 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb+  ( ReebNodeId (..),+    ReebArcId (..),+    MorseReebNode (..),+    Monotonicity (..),+    MorseReebArc (..),+    MorseReebScaffold (..),+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Carrier (BasisCellRef)+import Moonlight.Homology.Pure.Filtration (CriticalKind)+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential (PotentialValue)++type ReebNodeId :: Type+newtype ReebNodeId = ReebNodeId+  { unReebNodeId :: Int+  }+  deriving stock (Eq, Ord, Show)++type ReebArcId :: Type+newtype ReebArcId = ReebArcId+  { unReebArcId :: Int+  }+  deriving stock (Eq, Ord, Show)++type MorseReebNode :: Type+data MorseReebNode = MorseReebNode+  { morseReebNodeId :: ReebNodeId,+    morseReebNodeAnchor :: BasisCellRef,+    morseReebNodeKind :: CriticalKind,+    morseReebNodePotential :: PotentialValue+  }+  deriving stock (Eq, Show)++type Monotonicity :: Type+data Monotonicity+  = Ascending+  | Descending+  deriving stock (Eq, Ord, Show, Enum, Bounded)++type MorseReebArc :: Type+data MorseReebArc = MorseReebArc+  { morseReebArcId :: ReebArcId,+    morseReebArcSource :: ReebNodeId,+    morseReebArcTarget :: ReebNodeId,+    morseReebArcMonotonicity :: Monotonicity,+    morseReebArcSupport :: [BasisCellRef]+  }+  deriving stock (Eq, Show)++type MorseReebScaffold :: Type+data MorseReebScaffold = MorseReebScaffold+  { morseReebNodes :: [MorseReebNode],+    morseReebArcs :: [MorseReebArc]+  }+  deriving stock (Eq, Show)
+ src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Singularity.hs view
@@ -0,0 +1,36 @@+module Moonlight.Homology.Pure.Topology.MacroScaffold.Singularity+  ( SingularityIndex (..),+    SingularityId (..),+    Singularity (..),+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Carrier (BasisCellRef)+import Moonlight.Homology.Pure.Filtration (CriticalKind)+import Moonlight.Homology.Pure.Topology.MacroScaffold.Potential (PotentialValue)+import Moonlight.Homology.Pure.Topology.MacroScaffold.Reeb (ReebArcId, ReebNodeId)++type SingularityIndex :: Type+newtype SingularityIndex = SingularityIndex+  { unSingularityIndex :: Rational+  }+  deriving stock (Eq, Ord, Show)++type SingularityId :: Type+newtype SingularityId = SingularityId+  { unSingularityId :: Int+  }+  deriving stock (Eq, Ord, Show)++type Singularity :: Type+data Singularity = Singularity+  { singularityId :: SingularityId,+    singularityAnchor :: BasisCellRef,+    singularityKind :: CriticalKind,+    singularityPotential :: Maybe PotentialValue,+    singularityIndex :: SingularityIndex,+    singularityReebNode :: Maybe ReebNodeId,+    singularityIncidentArcs :: [ReebArcId]+  }+  deriving stock (Eq, Show)
+ src-topology/Moonlight/Homology/Pure/Topology/Morse.hs view
@@ -0,0 +1,1485 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Homology.Pure.Topology.Morse+  ( MorsePivotOps (..),+    intUnitMorsePivotOps,+    integerUnitMorsePivotOps,+    rationalMorsePivotOps,+    gf2MorsePivotOps,+    AlgebraicMorsePair,+    AlgebraicMorseMatching,+    AlgebraicMorseComplex,+    AcyclicPair (..),+    IntegralAcyclicPair,+    LocalizedAcyclicPair (..),+    RationalAcyclicPair,+    CollapseObstruction (..),+    LocalizedCollapseObstruction (..),+    AcyclicMatching (..),+    LocalizedAcyclicMatching (..),+    MorseComplex (..),+    LocalizedMorseComplex (..),+    RefinedMatchingStage,+    RefinedAcyclicMatching,+    RefinedMorseComplex (..),+    FilteredMorsePairWitness (..),+    FilteredMorseCompatibility (..),+    FilteredRefinedMorseComplex (..),+    RefinedMatchingSummary (..),+    acyclicMatching,+    acyclicMatchingLocalized,+    refinedAcyclicMatchingTranscript,+    refinedMorseComplex,+    filteredRefinedMorseComplex,+    reducedFiltrationByCriticalBasis,+    filteredReducedFiltration,+    rationalizeFiniteChainComplex,+    foldRefinedAcyclicMatching,+    traverseRefinedStages,+    mapRefinedStages,+    summarizeRefinedMatching,+    refinedMatchingSummary,+    refinedStageCount,+    hasRefinedStages,+    isTerminalRefinedMatching,+    finalRefinedCriticalDegrees,+    finalRefinedCriticalCellCount,+    finalRefinedCriticalDegreeHistogram,+    finalRefinedHomologicalSupport,+    finalRefinedMaxCriticalDegree,+    refinedMatchingCriticalCells,+    refinedStageMatching,+    refinedStageReducedComplex,+    refinedStageCriticalBasis,+    flattenRefinedAcyclicMatching,+    refinedAcyclicMatching,+    acyclicMatchingWith,+    morseComplexWith,+    isAcyclicMatchingWith,+    extractCandidatePairsWith,+    reverseCandidateEdgeWith,+    morseComplex,+    morseComplexLocalized,+    isAcyclicMatching,+    isAcyclicMatchingLocalized,+    extractCandidatePairsLocalized,+    reverseCandidateEdgeLocalized,+  )+where++import Data.Function ((&))+import Data.Kind (Type)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Moonlight.Core (Semiring)+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+    maxHomologicalDegree,+    mkFiniteChainComplex,+    validateFiniteChainComplexShape,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( boundaryCoefficient,+    boundaryEntries,+    emptyBoundaryIncidence,+    mapBoundaryCoefficients,+    materializeIncidenceBoundary,+    sourceIndex,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain (HomologicalDegree (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure (..), HomologyLaw (..))+import Moonlight.Homology.Pure.LinearCombination qualified as LC+import Moonlight.Homology.Pure.Reductions+  ( ChainHomotopy (..),+    ChainMap (..),+  )+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Topology.Core (allBasisCellRefs)+import Moonlight.Homology.Pure.Topology.Morse.Digraph+  ( DirectedAdjacencyMap,+    DirectedEdgeMap,+    PathWeightOracle,+    adjacencyMap,+    basisCellDimension,+    basisCellKey,+    deleteAdjacencyEdge,+    graphIsAcyclic,+    insertAdjacencyEdge,+    pathWeightOracle,+    pathWeightsFromOracle,+    topologicalOrderWithVertices,+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2 (..))++type MorsePivotOps :: Type -> Type+newtype MorsePivotOps r = MorsePivotOps+  { mpoUnitInverse :: r -> Maybe r+  }++intUnitMorsePivotOps :: MorsePivotOps Int+intUnitMorsePivotOps = unitMorsePivotOps++integerUnitMorsePivotOps :: MorsePivotOps Integer+integerUnitMorsePivotOps = unitMorsePivotOps++rationalMorsePivotOps :: MorsePivotOps Rational+rationalMorsePivotOps =+  MorsePivotOps+    { mpoUnitInverse =+        \coefficientValue ->+          if coefficientValue == 0+            then Nothing+            else Just (recip coefficientValue)+    }++gf2MorsePivotOps :: MorsePivotOps GF2+gf2MorsePivotOps =+  MorsePivotOps+    { mpoUnitInverse =+        \coefficientValue ->+          case coefficientValue of+            GF2Zero -> Nothing+            GF2One -> Just GF2One+    }++unitMorsePivotOps :: (Eq r, Num r) => MorsePivotOps r+unitMorsePivotOps =+  MorsePivotOps+    { mpoUnitInverse =+        \coefficientValue ->+          case coefficientValue of+            1 -> Just 1+            -1 -> Just (-1)+            _ -> Nothing+    }++type AcyclicPair :: Type+data AcyclicPair = AcyclicPair+  { apLowerCell :: BasisCellRef,+    apUpperCell :: BasisCellRef,+    apIncidenceCoefficient :: Int+  }+  deriving stock (Eq, Show)++type IntegralAcyclicPair :: Type+type IntegralAcyclicPair = AcyclicPair++type LocalizedAcyclicPair :: Type -> Type+data LocalizedAcyclicPair r = LocalizedAcyclicPair+  { lapLowerCell :: BasisCellRef,+    lapUpperCell :: BasisCellRef,+    lapIncidenceCoefficient :: r+  }+  deriving stock (Eq, Show)++type RationalAcyclicPair :: Type+type RationalAcyclicPair = LocalizedAcyclicPair Rational++type AlgebraicMorsePair :: Type -> Type+type AlgebraicMorsePair = LocalizedAcyclicPair++type CollapseObstruction :: Type+data CollapseObstruction = CollapseObstruction+  { coCandidate :: AcyclicPair,+    coCycleWitness :: [BasisCellRef]+  }+  deriving stock (Eq, Show)++type LocalizedCollapseObstruction :: Type -> Type+data LocalizedCollapseObstruction pair = LocalizedCollapseObstruction+  { lcoCandidate :: pair,+    lcoCycleWitness :: [BasisCellRef]+  }+  deriving stock (Eq, Show)++type AcyclicMatching :: Type+data AcyclicMatching = AcyclicMatching+  { amPairs :: [AcyclicPair],+    amCriticalCells :: [BasisCellRef],+    amObstructions :: [CollapseObstruction]+  }+  deriving stock (Eq, Show)++type LocalizedAcyclicMatching :: Type -> Type+data LocalizedAcyclicMatching pair = LocalizedAcyclicMatching+  { lamPairs :: [pair],+    lamCriticalCells :: [BasisCellRef],+    lamObstructions :: [LocalizedCollapseObstruction pair]+  }+  deriving stock (Eq, Show)++type AlgebraicMorseMatching :: Type -> Type+type AlgebraicMorseMatching r = LocalizedAcyclicMatching (AlgebraicMorsePair r)++type MorseComplex :: Type -> Type+data MorseComplex r = MorseComplex+  { mcMatching :: AcyclicMatching,+    mcReducedComplex :: FiniteChainComplex r,+    mcCriticalBasis :: Map BasisCellRef BasisCellRef,+    mcProjection :: ChainMap BasisCellRef BasisCellRef r,+    mcInclusion :: ChainMap BasisCellRef BasisCellRef r,+    mcHomotopy :: ChainHomotopy BasisCellRef r+  }++type LocalizedMorseComplex :: Type -> Type+data LocalizedMorseComplex r = LocalizedMorseComplex+  { lmcMatching :: LocalizedAcyclicMatching (LocalizedAcyclicPair r),+    lmcReducedComplex :: FiniteChainComplex r,+    lmcCriticalBasis :: Map BasisCellRef BasisCellRef,+    lmcProjection :: ChainMap BasisCellRef BasisCellRef r,+    lmcInclusion :: ChainMap BasisCellRef BasisCellRef r,+    lmcHomotopy :: ChainHomotopy BasisCellRef r+  }++type AlgebraicMorseComplex :: Type -> Type+type AlgebraicMorseComplex = LocalizedMorseComplex++type RefinedMatchingStage :: Type -> Type+data RefinedMatchingStage r = RefinedMatchingStage+  { rmsMatching :: LocalizedAcyclicMatching (LocalizedAcyclicPair r),+    rmsReducedComplex :: Maybe (FiniteChainComplex r),+    rmsCriticalBasis :: Maybe (Map BasisCellRef BasisCellRef)+  }++type RefinedAcyclicMatching :: Type -> Type+data RefinedAcyclicMatching r = RefinedAcyclicMatching+  { ramStages :: [RefinedMatchingStage r],+    ramCriticalCells :: [BasisCellRef]+  }++type RefinedMorseComplex :: Type -> Type+data RefinedMorseComplex r = RefinedMorseComplex+  { rmcTranscript :: RefinedAcyclicMatching r,+    rmcReducedComplex :: FiniteChainComplex r,+    rmcCriticalBasis :: Map BasisCellRef BasisCellRef+  }++type FilteredMorsePairWitness :: Type+data FilteredMorsePairWitness = FilteredMorsePairWitness+  { fmpwLowerCell :: BasisCellRef,+    fmpwUpperCell :: BasisCellRef,+    fmpwFiltrationLevel :: Int+  }+  deriving stock (Eq, Show)++type FilteredMorseCompatibility :: Type+newtype FilteredMorseCompatibility = FilteredMorseCompatibility+  { fmcPairWitnesses :: [FilteredMorsePairWitness]+  }+  deriving stock (Eq, Show)++type FilteredRefinedMorseComplex :: Type -> Type+data FilteredRefinedMorseComplex r = FilteredRefinedMorseComplex+  { frmcRefinedMorseComplex :: RefinedMorseComplex r,+    frmcReducedFiltrationByBasis :: Map BasisCellRef Int,+    frmcCompatibility :: FilteredMorseCompatibility+  }++type RefinedMorseDescent :: Type -> Type+data RefinedMorseDescent r+  = RefinedMorseDescentComplete (RefinedMorseComplex r)+  | RefinedMorseDescentBlocked (RefinedAcyclicMatching r) HomologyFailure++type RefinedMatchingSummary :: Type+data RefinedMatchingSummary = RefinedMatchingSummary+  { rmsStageCount :: Int,+    rmsHasStages :: Bool,+    rmsIsTerminal :: Bool,+    rmsFinalCriticalCellCount :: Int,+    rmsFinalCriticalDegreeHistogram :: Map HomologicalDegree Int,+    rmsFinalHomologicalSupport :: Set.Set HomologicalDegree,+    rmsFinalMaxCriticalDegree :: Maybe HomologicalDegree+  }+  deriving stock (Eq, Show)++type GradientAcyclicState :: Type -> Type+data GradientAcyclicState edgeWeight = GradientAcyclicState+  { gasEdgeMap :: !(DirectedEdgeMap edgeWeight),+    gasAdjacency :: !DirectedAdjacencyMap,+    gasMatchedUpperByLower :: !(Map BasisCellRef BasisCellRef),+    gasGradientAdjacency :: !DirectedAdjacencyMap+  }++type AcyclicRewrite :: Type -> Type+data AcyclicRewrite edgeWeight+  = AcyclicRewriteAccepted (GradientAcyclicState edgeWeight)+  | AcyclicRewriteRejected [BasisCellRef]++acyclicMatching ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  AcyclicMatching+acyclicMatching chainComplex cellScore =+  integralMatchingFromAlgebraic+    ( acyclicMatchingFromEdgeMapWith+        integerUnitMorsePivotOps+        (const True)+        (allBasisCellRefs chainComplex)+        (integralBoundaryEdgeMap chainComplex)+        cellScore+    )++acyclicMatchingWith ::+  (Eq r, Num r) =>+  MorsePivotOps r ->+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  AlgebraicMorseMatching r+acyclicMatchingWith pivotOps chainComplex =+  acyclicMatchingFromEdgeMapWith+    pivotOps+    (const True)+    (allBasisCellRefs chainComplex)+    (boundaryEdgeMap chainComplex)++acyclicMatchingLocalized ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  LocalizedAcyclicMatching RationalAcyclicPair+acyclicMatchingLocalized chainComplex cellScore =+  acyclicMatchingWith rationalMorsePivotOps (rationalizeFiniteChainComplex chainComplex) cellScore++refinedAcyclicMatching ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  Either HomologyFailure (LocalizedAcyclicMatching RationalAcyclicPair)+{-# DEPRECATED refinedAcyclicMatching "Use refinedAcyclicMatchingTranscript for canonical stage-aware reductions; use fmap flattenRefinedAcyclicMatching only as a compatibility projection." #-}+refinedAcyclicMatching chainComplex cellScore =+  flattenRefinedAcyclicMatching <$> refinedAcyclicMatchingTranscript chainComplex cellScore++refinedAcyclicMatchingTranscript ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  Either HomologyFailure (RefinedAcyclicMatching Rational)+refinedAcyclicMatchingTranscript chainComplex cellScore =+  case runRefinedMorseDescent chainComplex cellScore of+    RefinedMorseDescentComplete refinedComplex -> Right (rmcTranscript refinedComplex)+    RefinedMorseDescentBlocked _ failureValue -> Left failureValue++refinedMorseComplex ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  Either HomologyFailure (RefinedMorseComplex Rational)+refinedMorseComplex chainComplex cellScore =+  case runRefinedMorseDescent chainComplex cellScore of+    RefinedMorseDescentComplete refinedComplex -> Right refinedComplex+    RefinedMorseDescentBlocked _ failureValue -> Left failureValue++filteredRefinedMorseComplex ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Int) ->+  (BasisCellRef -> Double) ->+  Either HomologyFailure (FilteredRefinedMorseComplex Rational)+filteredRefinedMorseComplex chainComplex originalFiltration cellScore =+  case runFilteredRefinedMorseDescent chainComplex originalFiltration cellScore of+    RefinedMorseDescentBlocked _ failureValue -> Left failureValue+    RefinedMorseDescentComplete refinedComplex -> do+      reducedFiltrationValue <-+        reducedFiltrationByCriticalBasis+          (rmcReducedComplex refinedComplex)+          (rmcCriticalBasis refinedComplex)+          originalFiltration+      compatibilityValue <- filteredMorseCompatibility originalFiltration (rmcTranscript refinedComplex)+      Right+        FilteredRefinedMorseComplex+          { frmcRefinedMorseComplex = refinedComplex,+            frmcReducedFiltrationByBasis = reducedFiltrationValue,+            frmcCompatibility = compatibilityValue+          }++runRefinedMorseDescent ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  RefinedMorseDescent Rational+runRefinedMorseDescent chainComplex cellScore =+  runRefinedMorseDescentWith (\_ currentComplex currentScore -> acyclicMatchingRational currentComplex currentScore) chainComplex cellScore++runFilteredRefinedMorseDescent ::+  Integral r =>+  FiniteChainComplex r ->+  (BasisCellRef -> Int) ->+  (BasisCellRef -> Double) ->+  RefinedMorseDescent Rational+runFilteredRefinedMorseDescent chainComplex originalFiltration cellScore =+  runRefinedMorseDescentWith+    ( \currentBasis currentComplex currentScore ->+        acyclicMatchingRationalWith+          (filteredPairCompatible originalFiltration currentBasis)+          currentComplex+          currentScore+    )+    chainComplex+    cellScore++runRefinedMorseDescentWith ::+  Integral r =>+  ( Map BasisCellRef BasisCellRef ->+    FiniteChainComplex Rational ->+    (BasisCellRef -> Double) ->+    LocalizedAcyclicMatching RationalAcyclicPair+  ) ->+  FiniteChainComplex r ->+  (BasisCellRef -> Double) ->+  RefinedMorseDescent Rational+runRefinedMorseDescentWith matchingAt chainComplex cellScore =+  -- The first stage runs the fully gated 'morseComplexRational' (the user's+  -- complex and the initial matching are unproven input); every later stage+  -- operates on a theorem-guaranteed reduction with an engine-built matching+  -- and descends through the trusted entry — the invariant is established+  -- once at the boundary, not re-proved per stage.+  refineMatching morseComplexRational [] initialBasis initialComplex+  where+    initialComplex = rationalizeFiniteChainComplex chainComplex+    initialBasis = Map.fromList [(cell, cell) | cell <- allBasisCellRefs initialComplex]+    buildTranscript :: [RefinedMatchingStage Rational] -> [BasisCellRef] -> RefinedAcyclicMatching Rational+    buildTranscript accumulatedStages criticalCells =+      RefinedAcyclicMatching+        { ramStages = reverse accumulatedStages,+          ramCriticalCells = criticalCells+        }+    refineMatching ::+      ( FiniteChainComplex Rational ->+        LocalizedAcyclicMatching RationalAcyclicPair ->+        Either HomologyFailure (LocalizedMorseComplex Rational)+      ) ->+      [RefinedMatchingStage Rational] ->+      Map BasisCellRef BasisCellRef ->+      FiniteChainComplex Rational ->+      RefinedMorseDescent Rational+    refineMatching reduceStage accumulatedStages currentBasis currentComplex =+      let currentMatching = matchingAt currentBasis currentComplex (cellScore . rebaseCell currentBasis)+          currentPairs = lamPairs currentMatching+          translatedMatching = rebaseLocalizedMatching currentBasis currentMatching+          translatedCriticalCells = lamCriticalCells translatedMatching+       in case currentPairs of+            [] ->+              let transcriptValue = buildTranscript accumulatedStages translatedCriticalCells+               in RefinedMorseDescentComplete+                    RefinedMorseComplex+                      { rmcTranscript = transcriptValue,+                        rmcReducedComplex = currentComplex,+                        rmcCriticalBasis = currentBasis+                      }+            _ ->+              case reduceStage currentComplex currentMatching of+                Left failureValue ->+                  RefinedMorseDescentBlocked+                    ( buildTranscript+                        ( RefinedMatchingStage+                            { rmsMatching = translatedMatching,+                              rmsReducedComplex = Nothing,+                              rmsCriticalBasis = Nothing+                            } :+                          accumulatedStages+                        )+                        translatedCriticalCells+                    )+                    failureValue+                Right reducedComplexData ->+                  let nextReducedComplex = lmcReducedComplex reducedComplexData+                      nextCriticalBasis = composeCriticalBasis currentBasis (lmcCriticalBasis reducedComplexData)+                      stageValue =+                        RefinedMatchingStage+                          { rmsMatching = translatedMatching,+                            rmsReducedComplex = Just nextReducedComplex,+                            rmsCriticalBasis = Just nextCriticalBasis+                          }+                   in refineMatching+                        morseComplexRationalTrusted+                        (stageValue : accumulatedStages)+                        nextCriticalBasis+                        nextReducedComplex++filteredPairCompatible ::+  (BasisCellRef -> Int) ->+  Map BasisCellRef BasisCellRef ->+  RationalAcyclicPair ->+  Bool+filteredPairCompatible originalFiltration currentBasis candidatePair =+  let lowerOriginal = rebaseCell currentBasis (localizedLowerCell candidatePair)+      upperOriginal = rebaseCell currentBasis (localizedUpperCell candidatePair)+   in originalFiltration lowerOriginal == originalFiltration upperOriginal++reducedFiltrationByCriticalBasis ::+  FiniteChainComplex r ->+  Map BasisCellRef BasisCellRef ->+  (BasisCellRef -> Int) ->+  Either HomologyFailure (Map BasisCellRef Int)+reducedFiltrationByCriticalBasis reducedComplex criticalBasis originalFiltration =+  Map.fromList+    <$> traverse+      ( \basisRef ->+          fmap+            (\originalBasisRef -> (basisRef, originalFiltration originalBasisRef))+            (criticalOriginalBasis criticalBasis basisRef)+      )+      (allBasisCellRefs reducedComplex)++-- | Filtration value of a reduced basis cell. Cells outside the reduced+-- critical basis answer 0 by convention — callers that need to distinguish+-- "filtration 0" from "not a critical cell" should consult+-- 'frmcReducedFiltrationByBasis' directly.+filteredReducedFiltration ::+  FilteredRefinedMorseComplex r ->+  BasisCellRef ->+  Int+filteredReducedFiltration filteredComplex basisRef =+  Map.findWithDefault 0 basisRef (frmcReducedFiltrationByBasis filteredComplex)++criticalOriginalBasis ::+  Map BasisCellRef BasisCellRef ->+  BasisCellRef ->+  Either HomologyFailure BasisCellRef+criticalOriginalBasis criticalBasis basisRef =+  case Map.lookup basisRef criticalBasis of+    Just originalBasisRef -> Right originalBasisRef+    Nothing -> Left (MissingCriticalBasisProvenance basisRef)++filteredMorseCompatibility ::+  (BasisCellRef -> Int) ->+  RefinedAcyclicMatching Rational ->+  Either HomologyFailure FilteredMorseCompatibility+filteredMorseCompatibility originalFiltration transcriptValue =+  fmap+    (FilteredMorseCompatibility . foldMap id)+    (traverse (stageFilteredPairWitnesses originalFiltration) (ramStages transcriptValue))++stageFilteredPairWitnesses ::+  (BasisCellRef -> Int) ->+  RefinedMatchingStage Rational ->+  Either HomologyFailure [FilteredMorsePairWitness]+stageFilteredPairWitnesses originalFiltration stageValue =+  traverse+    (filteredPairWitness originalFiltration)+    (lamPairs (rmsMatching stageValue))++filteredPairWitness ::+  (BasisCellRef -> Int) ->+  RationalAcyclicPair ->+  Either HomologyFailure FilteredMorsePairWitness+filteredPairWitness originalFiltration candidatePair =+  let lowerCell = localizedLowerCell candidatePair+      upperCell = localizedUpperCell candidatePair+      lowerLevel = originalFiltration lowerCell+      upperLevel = originalFiltration upperCell+   in if lowerLevel == upperLevel+        then+          Right+            FilteredMorsePairWitness+              { fmpwLowerCell = lowerCell,+                fmpwUpperCell = upperCell,+                fmpwFiltrationLevel = lowerLevel+              }+        else+          Left (FiltrationIncompatibleMorsePair lowerCell upperCell lowerLevel upperLevel)++foldRefinedAcyclicMatching ::+  (RefinedMatchingStage r -> a -> a) ->+  ([BasisCellRef] -> a) ->+  RefinedAcyclicMatching r ->+  a+foldRefinedAcyclicMatching step finish refinedMatching =+  foldr step (finish (ramCriticalCells refinedMatching)) (ramStages refinedMatching)++traverseRefinedStages ::+  Applicative f =>+  (RefinedMatchingStage r -> f a) ->+  RefinedAcyclicMatching r ->+  f [a]+traverseRefinedStages summarizeStage =+  foldRefinedAcyclicMatching+    (\stageValue accumulatedSummaries -> (:) <$> summarizeStage stageValue <*> accumulatedSummaries)+    (const (pure []))++mapRefinedStages ::+  (RefinedMatchingStage r -> a) ->+  RefinedAcyclicMatching r ->+  [a]+mapRefinedStages summarizeStage =+  foldRefinedAcyclicMatching+    (\stageValue accumulatedSummaries -> summarizeStage stageValue : accumulatedSummaries)+    (const [])++summarizeRefinedMatching ::+  Monoid a =>+  (RefinedMatchingStage r -> a) ->+  RefinedAcyclicMatching r ->+  (a, [BasisCellRef])+summarizeRefinedMatching summarizeStage =+  foldRefinedAcyclicMatching+    (\stageValue (stageSummary, criticalCells) -> (summarizeStage stageValue <> stageSummary, criticalCells))+    (\criticalCells -> (mempty, criticalCells))++refinedMatchingSummary :: RefinedAcyclicMatching r -> RefinedMatchingSummary+refinedMatchingSummary refinedMatching =+  RefinedMatchingSummary+    { rmsStageCount = refinedStageCount refinedMatching,+      rmsHasStages = hasRefinedStages refinedMatching,+      rmsIsTerminal = isTerminalRefinedMatching refinedMatching,+      rmsFinalCriticalCellCount = finalRefinedCriticalCellCount refinedMatching,+      rmsFinalCriticalDegreeHistogram = finalRefinedCriticalDegreeHistogram refinedMatching,+      rmsFinalHomologicalSupport = finalRefinedHomologicalSupport refinedMatching,+      rmsFinalMaxCriticalDegree = finalRefinedMaxCriticalDegree refinedMatching+    }++refinedStageCount :: RefinedAcyclicMatching r -> Int+refinedStageCount =+  foldRefinedAcyclicMatching (\_ countValue -> countValue + 1) (const 0)++hasRefinedStages :: RefinedAcyclicMatching r -> Bool+hasRefinedStages =+  foldRefinedAcyclicMatching (\_ _ -> True) (const False)++isTerminalRefinedMatching :: RefinedAcyclicMatching r -> Bool+isTerminalRefinedMatching =+  all (== HomologicalDegree 0) . finalRefinedCriticalDegrees++finalRefinedCriticalDegrees :: RefinedAcyclicMatching r -> [HomologicalDegree]+finalRefinedCriticalDegrees =+  fmap cellDegree . refinedMatchingCriticalCells++finalRefinedCriticalCellCount :: RefinedAcyclicMatching r -> Int+finalRefinedCriticalCellCount =+  length . refinedMatchingCriticalCells++finalRefinedCriticalDegreeHistogram :: RefinedAcyclicMatching r -> Map HomologicalDegree Int+finalRefinedCriticalDegreeHistogram =+  Map.fromListWith (+)+    . fmap (\degreeValue -> (degreeValue, 1))+    . finalRefinedCriticalDegrees++finalRefinedHomologicalSupport :: RefinedAcyclicMatching r -> Set.Set HomologicalDegree+finalRefinedHomologicalSupport =+  Set.fromList . finalRefinedCriticalDegrees++finalRefinedMaxCriticalDegree :: RefinedAcyclicMatching r -> Maybe HomologicalDegree+finalRefinedMaxCriticalDegree =+  Set.lookupMax . finalRefinedHomologicalSupport++refinedMatchingCriticalCells :: RefinedAcyclicMatching r -> [BasisCellRef]+refinedMatchingCriticalCells =+  foldRefinedAcyclicMatching (\_ criticalCells -> criticalCells) id++refinedStageMatching ::+  RefinedMatchingStage r ->+  LocalizedAcyclicMatching (LocalizedAcyclicPair r)+refinedStageMatching RefinedMatchingStage {rmsMatching = matching} = matching++refinedStageReducedComplex ::+  RefinedMatchingStage r ->+  Maybe (FiniteChainComplex r)+refinedStageReducedComplex RefinedMatchingStage {rmsReducedComplex = reducedComplex} = reducedComplex++refinedStageCriticalBasis ::+  RefinedMatchingStage r ->+  Maybe (Map BasisCellRef BasisCellRef)+refinedStageCriticalBasis RefinedMatchingStage {rmsCriticalBasis = criticalBasis} = criticalBasis++flattenRefinedAcyclicMatching ::+  RefinedAcyclicMatching r ->+  LocalizedAcyclicMatching (LocalizedAcyclicPair r)+flattenRefinedAcyclicMatching refinedMatching =+  foldRefinedAcyclicMatching+    (\stage accumulatedMatching ->+       LocalizedAcyclicMatching+         { lamPairs = lamPairs (rmsMatching stage) <> lamPairs accumulatedMatching,+           lamCriticalCells = lamCriticalCells accumulatedMatching,+           lamObstructions = lamObstructions (rmsMatching stage) <> lamObstructions accumulatedMatching+         }+    )+    (\criticalCells ->+       LocalizedAcyclicMatching+         { lamPairs = [],+           lamCriticalCells = criticalCells,+           lamObstructions = []+         }+    )+    refinedMatching++morseComplex ::+  (Integral r, Semiring r) =>+  FiniteChainComplex r ->+  AcyclicMatching ->+  Either HomologyFailure (MorseComplex r)+morseComplex chainComplex matching =+  case morseComplexWith unitMorsePivotOps chainComplex (integralMatchingToAlgebraic matching) of+    Left failureValue -> Left failureValue+    Right morseValue ->+      Right+        MorseComplex+          { mcMatching = matching,+            mcReducedComplex = lmcReducedComplex morseValue,+            mcCriticalBasis = lmcCriticalBasis morseValue,+            mcProjection = lmcProjection morseValue,+            mcInclusion = lmcInclusion morseValue,+            mcHomotopy = lmcHomotopy morseValue+          }++morseComplexWith ::+  (Eq r, Num r, Semiring r) =>+  MorsePivotOps r ->+  FiniteChainComplex r ->+  AlgebraicMorseMatching r ->+  Either HomologyFailure (AlgebraicMorseComplex r)+morseComplexWith pivotOps chainComplex matching+  | not (isAcyclicMatchingAgainstEdgeMapWith pivotOps allCells initialEdgeMap matching) =+      Left (InvalidTopologyInput "Invalid algebraic acyclic matching")+  | otherwise =+      case reductionData of+        Left failureValue -> Left failureValue+        Right reducedData ->+          Right+            LocalizedMorseComplex+              { lmcMatching = matching,+                lmcReducedComplex = mrdReducedComplex reducedData,+                lmcCriticalBasis = mrdCriticalBasis reducedData,+                lmcProjection = mrdProjection reducedData,+                lmcInclusion = mrdInclusion reducedData,+                lmcHomotopy = mrdHomotopy reducedData+              }+  where+    allCells = allBasisCellRefs chainComplex+    initialEdgeMap = boundaryEdgeMap chainComplex+    reducedMatchingPairs = lamPairs matching+    criticalCells = expectedCriticalCells localizedLowerCell localizedUpperCell allCells reducedMatchingPairs+    finalEdgeMap = foldl' (flip (reverseCandidateEdgeWith pivotOps)) initialEdgeMap reducedMatchingPairs+    reductionData =+      buildReducedComplexData chainComplex criticalCells reducedMatchingPairs initialEdgeMap finalEdgeMap++morseComplexLocalized ::+  Integral r =>+  FiniteChainComplex r ->+  LocalizedAcyclicMatching RationalAcyclicPair ->+  Either HomologyFailure (LocalizedMorseComplex Rational)+morseComplexLocalized chainComplex matching =+  morseComplexWith rationalMorsePivotOps (rationalizeFiniteChainComplex chainComplex) matching++isAcyclicMatching ::+  Integral r =>+  FiniteChainComplex r ->+  AcyclicMatching ->+  Bool+isAcyclicMatching chainComplex =+  isAcyclicMatchingWith unitMorsePivotOps chainComplex . integralMatchingToAlgebraic++isAcyclicMatchingWith ::+  (Eq r, Num r) =>+  MorsePivotOps r ->+  FiniteChainComplex r ->+  AlgebraicMorseMatching r ->+  Bool+isAcyclicMatchingWith pivotOps chainComplex matching =+  isAcyclicMatchingAgainstEdgeMapWith pivotOps (allBasisCellRefs chainComplex) (boundaryEdgeMap chainComplex) matching++isAcyclicMatchingAgainstEdgeMapWith ::+  (Eq r, Num r) =>+  MorsePivotOps r ->+  [BasisCellRef] ->+  DirectedEdgeMap r ->+  AlgebraicMorseMatching r ->+  Bool+isAcyclicMatchingAgainstEdgeMapWith pivotOps allCells initialEdgeMap matching =+  uniquePairEndpoints localizedLowerCell localizedUpperCell matchingPairs+    && all pairIsValid matchingPairs+    && Set.fromList (lamCriticalCells matching) == Set.fromList expectedCritical+    && graphIsAcyclic finalEdgeMap+  where+    matchingPairs = lamPairs matching+    expectedCritical = expectedCriticalCells localizedLowerCell localizedUpperCell allCells matchingPairs+    finalEdgeMap = foldl' (flip (reverseCandidateEdgeWith pivotOps)) initialEdgeMap matchingPairs+    pairIsValid candidatePair =+      let lowerCell = localizedLowerCell candidatePair+          upperCell = localizedUpperCell candidatePair+          coefficientValue = localizedIncidenceCoefficient candidatePair+       in isCodimensionOne lowerCell upperCell+            && maybe False (const True) (mpoUnitInverse pivotOps coefficientValue)+            && Map.lookup (upperCell, lowerCell) initialEdgeMap == Just coefficientValue++isAcyclicMatchingLocalized ::+  Integral r =>+  FiniteChainComplex r ->+  LocalizedAcyclicMatching RationalAcyclicPair ->+  Bool+isAcyclicMatchingLocalized chainComplex matching =+  isAcyclicMatchingWith rationalMorsePivotOps (rationalizeFiniteChainComplex chainComplex) matching++extractCandidatePairsWith :: MorsePivotOps r -> DirectedEdgeMap r -> [AlgebraicMorsePair r]+extractCandidatePairsWith pivotOps edgeMap =+  edgeMap+    & Map.toAscList+    & mapMaybe+      ( \((upperCell, lowerCell), coefficientValue) ->+          if maybe False (const True) (mpoUnitInverse pivotOps coefficientValue)+            then+              Just+                LocalizedAcyclicPair+                  { lapLowerCell = lowerCell,+                    lapUpperCell = upperCell,+                    lapIncidenceCoefficient = coefficientValue+                  }+            else Nothing+      )++extractCandidatePairsLocalized :: DirectedEdgeMap Rational -> [RationalAcyclicPair]+extractCandidatePairsLocalized =+  extractCandidatePairsWith rationalMorsePivotOps++reverseCandidateEdgeWith ::+  Num r =>+  MorsePivotOps r ->+  AlgebraicMorsePair r ->+  DirectedEdgeMap r ->+  DirectedEdgeMap r+reverseCandidateEdgeWith pivotOps candidatePair =+  case mpoUnitInverse pivotOps (localizedIncidenceCoefficient candidatePair) of+    Nothing -> id+    Just inverseCoefficient ->+      Map.delete (localizedUpperCell candidatePair, localizedLowerCell candidatePair)+        . Map.insert+          (localizedLowerCell candidatePair, localizedUpperCell candidatePair)+          (negate inverseCoefficient)++reverseCandidateEdgeLocalized ::+  RationalAcyclicPair ->+  DirectedEdgeMap Rational ->+  DirectedEdgeMap Rational+reverseCandidateEdgeLocalized =+  reverseCandidateEdgeWith rationalMorsePivotOps++acyclicMatchingRational ::+  FiniteChainComplex Rational ->+  (BasisCellRef -> Double) ->+  LocalizedAcyclicMatching RationalAcyclicPair+acyclicMatchingRational chainComplex cellScore =+  acyclicMatchingWith rationalMorsePivotOps chainComplex cellScore++acyclicMatchingRationalWith ::+  (RationalAcyclicPair -> Bool) ->+  FiniteChainComplex Rational ->+  (BasisCellRef -> Double) ->+  LocalizedAcyclicMatching RationalAcyclicPair+acyclicMatchingRationalWith pairAllowed chainComplex cellScore =+  acyclicMatchingFromEdgeMapWith+    rationalMorsePivotOps+    pairAllowed+    (allBasisCellRefs chainComplex)+    (boundaryEdgeMap chainComplex)+    cellScore++acyclicMatchingFromEdgeMapWith ::+  Num r =>+  MorsePivotOps r ->+  (AlgebraicMorsePair r -> Bool) ->+  [BasisCellRef] ->+  DirectedEdgeMap r ->+  (BasisCellRef -> Double) ->+  AlgebraicMorseMatching r+acyclicMatchingFromEdgeMapWith pivotOps pairAllowed allCells edgeMap cellScore =+  buildMatchingBy+    allCells+    cellScore+    edgeMap+    (filter pairAllowed (extractCandidatePairsWith pivotOps edgeMap))+    localizedLowerCell+    localizedUpperCell+    (reverseCandidateEdgeWith pivotOps)+    (\candidate witness -> LocalizedCollapseObstruction {lcoCandidate = candidate, lcoCycleWitness = witness})+    (\pairs criticalCells obstructions ->+       LocalizedAcyclicMatching+         { lamPairs = pairs,+           lamCriticalCells = criticalCells,+           lamObstructions = obstructions+         }+    )++morseComplexRational ::+  FiniteChainComplex Rational ->+  LocalizedAcyclicMatching RationalAcyclicPair ->+  Either HomologyFailure (LocalizedMorseComplex Rational)+morseComplexRational =+  morseComplexWith rationalMorsePivotOps++-- | Gate-free variant of 'morseComplexRational' for the refined descent's+-- interior stages: the stage complex is a Morse reduction of a complex the+-- first (gated) stage already validated, and the stage matching comes from+-- the internal greedy engine, which certifies acyclicity incrementally as it+-- accepts each pair. Re-running 'isAcyclicMatchingAgainstEdgeMapWith' and the+-- shape/nilpotence sweep per stage would re-prove established invariants.+morseComplexRationalTrusted ::+  FiniteChainComplex Rational ->+  LocalizedAcyclicMatching RationalAcyclicPair ->+  Either HomologyFailure (LocalizedMorseComplex Rational)+morseComplexRationalTrusted chainComplex matching =+  case buildReducedComplexDataTrusted chainComplex criticalCells reducedMatchingPairs finalEdgeMap of+    Left failureValue -> Left failureValue+    Right reducedData ->+      Right+        LocalizedMorseComplex+          { lmcMatching = matching,+            lmcReducedComplex = mrdReducedComplex reducedData,+            lmcCriticalBasis = mrdCriticalBasis reducedData,+            lmcProjection = mrdProjection reducedData,+            lmcInclusion = mrdInclusion reducedData,+            lmcHomotopy = mrdHomotopy reducedData+          }+  where+    allCells = allBasisCellRefs chainComplex+    initialEdgeMap = boundaryEdgeMap chainComplex+    reducedMatchingPairs = lamPairs matching+    criticalCells = expectedCriticalCells localizedLowerCell localizedUpperCell allCells reducedMatchingPairs+    finalEdgeMap = foldl' (flip (reverseCandidateEdgeWith rationalMorsePivotOps)) initialEdgeMap reducedMatchingPairs++buildMatchingBy ::+  [BasisCellRef] ->+  (BasisCellRef -> Double) ->+  DirectedEdgeMap edgeWeight ->+  [pair] ->+  (pair -> BasisCellRef) ->+  (pair -> BasisCellRef) ->+  (pair -> DirectedEdgeMap edgeWeight -> DirectedEdgeMap edgeWeight) ->+  (pair -> [BasisCellRef] -> obstruction) ->+  ([pair] -> [BasisCellRef] -> [obstruction] -> matching) ->+  matching+buildMatchingBy allCells cellScore initialEdgeMap initialCandidates lowerCell upperCell reverseEdge makeObstruction makeMatching =+  go initialGradientState Set.empty [] [] orderedCandidates+  where+    initialGradientState = gradientAcyclicState initialEdgeMap+    orderedCandidates = sortCandidates lowerCell upperCell cellScore initialCandidates+    go currentGradientState matchedCells acceptedPairs acceptedObstructions remainingCandidates =+      case remainingCandidates of+        [] ->+          let finalizedPairs = reverse acceptedPairs+           in makeMatching+                finalizedPairs+                (expectedCriticalCells lowerCell upperCell allCells finalizedPairs)+                (reverse acceptedObstructions)+        candidatePair : restCandidates+          | Set.member lower matchedCells || Set.member upper matchedCells ->+              go currentGradientState matchedCells acceptedPairs acceptedObstructions restCandidates+          | otherwise ->+              case reverseAcyclicState (reverseEdge candidatePair) upper lower currentGradientState of+                AcyclicRewriteRejected witnessPath ->+                  go+                    currentGradientState+                    matchedCells+                    acceptedPairs+                    (makeObstruction candidatePair (lower : witnessPath) : acceptedObstructions)+                    restCandidates+                AcyclicRewriteAccepted nextGradientState ->+                  go+                    nextGradientState+                    (Set.insert lower (Set.insert upper matchedCells))+                    (candidatePair : acceptedPairs)+                    acceptedObstructions+                    restCandidates+          where+            lower = lowerCell candidatePair+            upper = upperCell candidatePair++type MorseReductionData :: Type -> Type+data MorseReductionData r = MorseReductionData+  { mrdReducedComplex :: !(FiniteChainComplex r),+    mrdCriticalBasis :: !(Map BasisCellRef BasisCellRef),+    mrdProjection :: !(ChainMap BasisCellRef BasisCellRef r),+    mrdInclusion :: !(ChainMap BasisCellRef BasisCellRef r),+    mrdHomotopy :: !(ChainHomotopy BasisCellRef r)+  }++type BoundaryLookup :: Type -> Type+newtype BoundaryLookup r = BoundaryLookup+  (Map BasisCellRef [(r, BasisCellRef)])++buildReducedComplexData ::+  (Eq r, Num r, Semiring r) =>+  FiniteChainComplex r ->+  [BasisCellRef] ->+  [AlgebraicMorsePair r] ->+  DirectedEdgeMap r ->+  DirectedEdgeMap r ->+  Either HomologyFailure (MorseReductionData r)+buildReducedComplexData chainComplex criticalCells matchingPairs originalEdgeMap edgeMap = do+  validateMorseReductionInput chainComplex originalEdgeMap+  buildReducedComplexDataTrusted chainComplex criticalCells matchingPairs edgeMap++-- | The reduction body without the input gate. Interior callers (the refined+-- descent, stages ≥ 2) operate on complexes that are Morse reductions of an+-- already-validated complex — chain complexes by the reduction theorem — so+-- re-running shape and nilpotence validation there would re-prove a theorem+-- per stage. Exterior entry points go through 'buildReducedComplexData'.+buildReducedComplexDataTrusted ::+  (Eq r, Num r, Semiring r) =>+  FiniteChainComplex r ->+  [BasisCellRef] ->+  [AlgebraicMorsePair r] ->+  DirectedEdgeMap r ->+  Either HomologyFailure (MorseReductionData r)+buildReducedComplexDataTrusted chainComplex criticalCells matchingPairs edgeMap = do+  let originalCells = allBasisCellRefs chainComplex+      complexMaxDegree = maxHomologicalDegree chainComplex+      HomologicalDegree complexMaxDimension = complexMaxDegree+      adjacency = adjacencyMap edgeMap+      topologicalVertexOrder = topologicalOrderWithVertices originalCells adjacency+      sortedCriticalCells = sortOn basisCellKey criticalCells+      criticalCellsByDegree =+        Map.fromListWith (<>)+          [(basisCellDimension cell, [cell]) | cell <- sortedCriticalCells]+      criticalCellsAt degreeValue = Map.findWithDefault [] degreeValue criticalCellsByDegree+      pathWeightsBySource =+        pathWeightOracle edgeMap topologicalVertexOrder+      criticalBasis =+        Map.fromList+          [ ( BasisCellRef+                { cellDegree = HomologicalDegree degreeValue,+                  cellIndex = reducedIndex+                },+              originalCell+            )+          | degreeValue <- [0 .. complexMaxDimension],+            (reducedIndex, originalCell) <- zip [0 ..] (criticalCellsAt degreeValue)+          ]+      criticalOriginalToReduced =+        Map.fromList [(originalCell, reducedCell) | (reducedCell, originalCell) <- Map.toAscList criticalBasis]+      (projectionMap, inclusionMap, homotopyMap) =+        morseReductionMaps+          pathWeightsBySource+          criticalBasis+          criticalOriginalToReduced+          matchingPairs+  incidencesByDegree <-+    traverse+      ( \degreeValue ->+          (\incidence -> (degreeValue, incidence))+            <$> materializeIncidenceBoundary+              (reducedBoundaryOf pathWeightsBySource (criticalCellsAt (degreeValue - 1)))+              (criticalCellsAt degreeValue)+              (criticalCellsAt (degreeValue - 1))+      )+      [0 .. complexMaxDimension]+  let incidenceByDegree = Map.fromList incidencesByDegree+  let reducedComplex =+        mkFiniteChainComplex+          complexMaxDegree+          (\(HomologicalDegree degreeValue) -> Map.findWithDefault emptyBoundaryIncidence degreeValue incidenceByDegree)+  pure+    MorseReductionData+      { mrdReducedComplex = reducedComplex,+        mrdCriticalBasis = criticalBasis,+        mrdProjection = projectionMap,+        mrdInclusion = inclusionMap,+        mrdHomotopy = homotopyMap+      }++validateMorseReductionInput ::+  (Eq r, Num r) =>+  FiniteChainComplex r ->+  DirectedEdgeMap r ->+  Either HomologyFailure ()+validateMorseReductionInput chainComplex originalEdgeMap = do+  validateFiniteChainComplexShape chainComplex+  validateBoundaryNilpotenceAsMorseObstruction (boundaryLookupFromEdgeMap originalEdgeMap) (allBasisCellRefs chainComplex)++validateBoundaryNilpotenceAsMorseObstruction ::+  (Eq r, Num r) =>+  BoundaryLookup r ->+  [BasisCellRef] ->+  Either HomologyFailure ()+validateBoundaryNilpotenceAsMorseObstruction boundaryLookupValue cells =+  -- The condition checked here is d ∘ d = 0 on the input complex; report it+  -- as the nilpotence law (as every other detection path does), not as a+  -- reduction chain-map violation.+  LC.checkLawWith+    LC.numArithmetic+    ChainNilpotenceLaw+    cells+    (const [])+    (LC.composeWith LC.numArithmetic (morseBoundaryOfLookup boundaryLookupValue) . morseBoundaryOfLookup boundaryLookupValue)++reducedBoundaryOf :: (Eq r, Num r) => PathWeightOracle r -> [BasisCellRef] -> BasisCellRef -> [(r, BasisCellRef)]+reducedBoundaryOf pathWeightSums targetCells upperCell =+  -- One O(V+E) path-weight propagation per upper cell, shared by every+  -- lower cell — floated out of the lambda so the sharing does not depend+  -- on the optimizer's full-laziness pass.+  let weightsFromUpper = pathWeightsFromOracle pathWeightSums upperCell+   in targetCells+        & mapMaybe+          ( \lowerCell ->+              case Map.lookup lowerCell weightsFromUpper of+                Just coefficientValue+                  | coefficientValue /= 0 -> Just (coefficientValue, lowerCell)+                _ -> Nothing+          )++morseReductionMaps ::+  (Eq r, Num r) =>+  PathWeightOracle r ->+  Map BasisCellRef BasisCellRef ->+  Map BasisCellRef BasisCellRef ->+  [AlgebraicMorsePair r] ->+  (ChainMap BasisCellRef BasisCellRef r, ChainMap BasisCellRef BasisCellRef r, ChainHomotopy BasisCellRef r)+morseReductionMaps pathWeightSums criticalBasis criticalOriginalToReduced matchingPairs =+  (projectionMap, inclusionMap, homotopyMap)+  where+    pathWeightsFrom =+      pathWeightsFromOracle pathWeightSums++    matchedUpperCells =+      Set.fromList (fmap localizedUpperCell matchingPairs)++    projectionMap =+      ChainMap $+        \originalCell ->+          LC.normalizeWith LC.numArithmetic+            [ (coefficientValue, reducedCell)+            | (targetCell, coefficientValue) <- Map.toAscList (pathWeightsFrom originalCell),+              coefficientValue /= 0,+              cellDegree targetCell == cellDegree originalCell,+              Just reducedCell <- [Map.lookup targetCell criticalOriginalToReduced]+            ]++    inclusionMap =+      ChainMap $+        \reducedCell ->+          case Map.lookup reducedCell criticalBasis of+            Nothing -> []+            Just criticalOriginal ->+              LC.normalizeWith LC.numArithmetic+                [ (coefficientValue, targetCell)+                | (targetCell, coefficientValue) <- Map.toAscList (pathWeightsFrom criticalOriginal),+                  coefficientValue /= 0,+                  cellDegree targetCell == cellDegree criticalOriginal+                ]++    homotopyMap =+      ChainHomotopy $+        \originalCell ->+          LC.normalizeWith LC.numArithmetic+            [ (negate coefficientValue, targetCell)+            | (targetCell, coefficientValue) <- Map.toAscList (pathWeightsFrom originalCell),+              coefficientValue /= 0,+              Set.member targetCell matchedUpperCells,+              basisCellDimension targetCell == basisCellDimension originalCell + 1+            ]++morseBoundaryOfLookup ::+  BoundaryLookup r ->+  BasisCellRef ->+  [(r, BasisCellRef)]+morseBoundaryOfLookup (BoundaryLookup boundaryBySource) cell =+  Map.findWithDefault [] cell boundaryBySource++boundaryLookupFromEdgeMap :: (Eq r, Num r) => DirectedEdgeMap r -> BoundaryLookup r+boundaryLookupFromEdgeMap edgeMap =+  BoundaryLookup+    (Map.map (LC.normalizeWith LC.numArithmetic) boundaryBySource)+  where+    indexedBoundaryEntries =+      [ (sourceCell, targetCell, coefficientValue)+      | ((sourceCell, targetCell), coefficientValue) <- Map.toAscList edgeMap,+        coefficientValue /= 0+      ]+    boundaryBySource =+      Map.fromListWith+        (<>)+        [ (sourceCell, [(coefficientValue, targetCell)])+        | (sourceCell, targetCell, coefficientValue) <- indexedBoundaryEntries+        ]++integralMatchingFromAlgebraic :: AlgebraicMorseMatching Integer -> AcyclicMatching+integralMatchingFromAlgebraic matching =+  AcyclicMatching+    { amPairs = fmap integralPairFromAlgebraic (lamPairs matching),+      amCriticalCells = lamCriticalCells matching,+      amObstructions = fmap integralObstructionFromAlgebraic (lamObstructions matching)+    }++integralPairFromAlgebraic :: AlgebraicMorsePair Integer -> AcyclicPair+integralPairFromAlgebraic candidatePair =+  AcyclicPair+    { apLowerCell = localizedLowerCell candidatePair,+      apUpperCell = localizedUpperCell candidatePair,+      apIncidenceCoefficient = fromIntegral (localizedIncidenceCoefficient candidatePair)+    }++integralObstructionFromAlgebraic ::+  LocalizedCollapseObstruction (AlgebraicMorsePair Integer) ->+  CollapseObstruction+integralObstructionFromAlgebraic obstruction =+  CollapseObstruction+    { coCandidate = integralPairFromAlgebraic (lcoCandidate obstruction),+      coCycleWitness = lcoCycleWitness obstruction+    }++integralMatchingToAlgebraic :: Num r => AcyclicMatching -> AlgebraicMorseMatching r+integralMatchingToAlgebraic matching =+  LocalizedAcyclicMatching+    { lamPairs = fmap integralPairToAlgebraic (amPairs matching),+      lamCriticalCells = amCriticalCells matching,+      lamObstructions = fmap integralObstructionToAlgebraic (amObstructions matching)+    }++integralPairToAlgebraic :: Num r => AcyclicPair -> AlgebraicMorsePair r+integralPairToAlgebraic candidatePair =+  LocalizedAcyclicPair+    { lapLowerCell = apLowerCell candidatePair,+      lapUpperCell = apUpperCell candidatePair,+      lapIncidenceCoefficient = fromIntegral (apIncidenceCoefficient candidatePair)+    }++integralObstructionToAlgebraic ::+  Num r =>+  CollapseObstruction ->+  LocalizedCollapseObstruction (AlgebraicMorsePair r)+integralObstructionToAlgebraic obstruction =+  LocalizedCollapseObstruction+    { lcoCandidate = integralPairToAlgebraic (coCandidate obstruction),+      lcoCycleWitness = coCycleWitness obstruction+    }++boundaryEdgeMap :: (Eq r, Num r) => FiniteChainComplex r -> DirectedEdgeMap r+boundaryEdgeMap chainComplex =+  Map.filter (/= 0) $+    Map.fromListWith (+)+      [ (edgeKey, coefficientValue)+      | degreeValue <- [1 .. maxDegreeValue],+        let boundaryIncidence = incidenceMatrixAt chainComplex (HomologicalDegree degreeValue),+        boundaryEntry <- boundaryEntries boundaryIncidence,+        let coefficientValue = boundaryCoefficient boundaryEntry,+        let edgeKey =+              ( BasisCellRef+                  { cellDegree = HomologicalDegree degreeValue,+                    cellIndex = sourceIndex boundaryEntry+                  },+                BasisCellRef+                  { cellDegree = HomologicalDegree (degreeValue - 1),+                    cellIndex = targetIndex boundaryEntry+                  }+              )+      ]+  where+    HomologicalDegree maxDegreeValue = maxHomologicalDegree chainComplex++integralBoundaryEdgeMap :: Integral r => FiniteChainComplex r -> DirectedEdgeMap Integer+integralBoundaryEdgeMap = Map.map toInteger . boundaryEdgeMap++rationalizeFiniteChainComplex :: Integral r => FiniteChainComplex r -> FiniteChainComplex Rational+rationalizeFiniteChainComplex chainComplex =+  mkFiniteChainComplex+    (maxHomologicalDegree chainComplex)+    (mapBoundaryCoefficients fromIntegral . incidenceMatrixAt chainComplex)++expectedCriticalCells ::+  (pair -> BasisCellRef) ->+  (pair -> BasisCellRef) ->+  [BasisCellRef] ->+  [pair] ->+  [BasisCellRef]+expectedCriticalCells lowerCell upperCell allCells matchingPairs =+  filter (`Set.notMember` matchedCells) allCells+  where+    matchedCells =+      Set.fromList+        [ cell+        | candidatePair <- matchingPairs,+          cell <- [lowerCell candidatePair, upperCell candidatePair]+        ]++uniquePairEndpoints ::+  (pair -> BasisCellRef) ->+  (pair -> BasisCellRef) ->+  [pair] ->+  Bool+uniquePairEndpoints lowerCell upperCell matchingPairs =+  length endpointCells == Set.size (Set.fromList endpointCells)+  where+    endpointCells =+      [ cell+      | candidatePair <- matchingPairs,+        cell <- [lowerCell candidatePair, upperCell candidatePair]+      ]++sortCandidates ::+  (pair -> BasisCellRef) ->+  (pair -> BasisCellRef) ->+  (BasisCellRef -> Double) ->+  [pair] ->+  [pair]+sortCandidates lowerCell upperCell cellScore =+  sortOn+    (\candidatePair ->+       ( cellScore (upperCell candidatePair),+         cellScore (lowerCell candidatePair),+         basisCellKey (upperCell candidatePair),+         basisCellKey (lowerCell candidatePair)+       )+    )++gradientAcyclicState ::+  DirectedEdgeMap edgeWeight ->+  GradientAcyclicState edgeWeight+gradientAcyclicState edgeMap =+  GradientAcyclicState+    { gasEdgeMap = edgeMap,+      gasAdjacency = adjacencyMap edgeMap,+      gasMatchedUpperByLower = Map.empty,+      gasGradientAdjacency = Map.empty+    }++reverseAcyclicState ::+  (DirectedEdgeMap edgeWeight -> DirectedEdgeMap edgeWeight) ->+  BasisCellRef ->+  BasisCellRef ->+  GradientAcyclicState edgeWeight ->+  AcyclicRewrite edgeWeight+reverseAcyclicState reverseEdge upperCell lowerCell state =+  let lowerTargets =+        gasAdjacency state+          & Map.findWithDefault [] upperCell+          & filter (/= lowerCell)+   in case gradientCycleWitness upperCell lowerCell lowerTargets state of+        Just witnessPath ->+          AcyclicRewriteRejected witnessPath+        Nothing ->+          AcyclicRewriteAccepted+            GradientAcyclicState+              { gasEdgeMap = reverseEdge (gasEdgeMap state),+                gasAdjacency = insertAdjacencyEdge lowerCell upperCell (deleteAdjacencyEdge upperCell lowerCell (gasAdjacency state)),+                gasMatchedUpperByLower = Map.insert lowerCell upperCell (gasMatchedUpperByLower state),+                gasGradientAdjacency =+                  if null lowerTargets+                    then gasGradientAdjacency state+                    else Map.insert lowerCell lowerTargets (gasGradientAdjacency state)+              }++gradientCycleWitness ::+  BasisCellRef ->+  BasisCellRef ->+  [BasisCellRef] ->+  GradientAcyclicState edgeWeight ->+  Maybe [BasisCellRef]+gradientCycleWitness upperCell lowerCell lowerTargets state =+  firstJust+    ( \targetCell ->+        gradientPathInAdjacency (gasGradientAdjacency state) targetCell lowerCell+          >>= directedPathFromGradientPath upperCell (gasMatchedUpperByLower state)+    )+    lowerTargets++gradientPathInAdjacency ::+  DirectedAdjacencyMap ->+  BasisCellRef ->+  BasisCellRef ->+  Maybe [BasisCellRef]+gradientPathInAdjacency adjacency startCell goalCell =+  snd (findFrom Set.empty startCell)+  where+    findFrom visited currentCell+      | currentCell == goalCell = (visited, Just [goalCell])+      | Set.member currentCell visited = (visited, Nothing)+      | otherwise =+          foldl'+            (findThroughSuccessor currentCell)+            (Set.insert currentCell visited, Nothing)+            (Map.findWithDefault [] currentCell adjacency)+    findThroughSuccessor currentCell (visited, discoveredPath) successorCell =+      case discoveredPath of+        Just pathValue -> (visited, Just pathValue)+        Nothing ->+          case findFrom visited successorCell of+            (visitedAfterSuccessor, Just suffixPath) ->+              (visitedAfterSuccessor, Just (currentCell : suffixPath))+            (visitedAfterSuccessor, Nothing) ->+              (visitedAfterSuccessor, Nothing)++directedPathFromGradientPath ::+  BasisCellRef ->+  Map BasisCellRef BasisCellRef ->+  [BasisCellRef] ->+  Maybe [BasisCellRef]+directedPathFromGradientPath upperCell matchedUpperByLower gradientPath =+  fmap (upperCell :) (expandGradientPath gradientPath)+  where+    expandGradientPath pathValue =+      case pathValue of+        [] -> Just []+        [terminalLower] -> Just [terminalLower]+        lowerValue : remainingPath@(_ : _) ->+          case Map.lookup lowerValue matchedUpperByLower of+            Nothing -> Nothing+            Just matchedUpper ->+              fmap ((lowerValue :) . (matchedUpper :)) (expandGradientPath remainingPath)++firstJust :: (a -> Maybe b) -> [a] -> Maybe b+firstJust selectValue =+  foldr+    ( \value restValue ->+        case selectValue value of+          Just selectedValue -> Just selectedValue+          Nothing -> restValue+    )+    Nothing++rebaseCell :: Map BasisCellRef BasisCellRef -> BasisCellRef -> BasisCellRef+rebaseCell basis cell = Map.findWithDefault cell cell basis++rebaseLocalizedPair ::+  Map BasisCellRef BasisCellRef ->+  LocalizedAcyclicPair r ->+  LocalizedAcyclicPair r+rebaseLocalizedPair basis candidatePair =+  LocalizedAcyclicPair+    { lapLowerCell = rebaseCell basis (localizedLowerCell candidatePair),+      lapUpperCell = rebaseCell basis (localizedUpperCell candidatePair),+      lapIncidenceCoefficient = localizedIncidenceCoefficient candidatePair+    }++rebaseLocalizedMatching ::+  Map BasisCellRef BasisCellRef ->+  LocalizedAcyclicMatching RationalAcyclicPair ->+  LocalizedAcyclicMatching RationalAcyclicPair+rebaseLocalizedMatching basis matching =+  LocalizedAcyclicMatching+    { lamPairs = fmap (rebaseLocalizedPair basis) (lamPairs matching),+      lamCriticalCells = fmap (rebaseCell basis) (lamCriticalCells matching),+      lamObstructions = fmap (rebaseLocalizedObstruction basis) (lamObstructions matching)+    }++rebaseLocalizedObstruction ::+  Map BasisCellRef BasisCellRef ->+  LocalizedCollapseObstruction RationalAcyclicPair ->+  LocalizedCollapseObstruction RationalAcyclicPair+rebaseLocalizedObstruction basis obstruction =+  LocalizedCollapseObstruction+    { lcoCandidate = rebaseLocalizedPair basis (lcoCandidate obstruction),+      lcoCycleWitness = fmap (rebaseCell basis) (lcoCycleWitness obstruction)+    }++composeCriticalBasis ::+  Map BasisCellRef BasisCellRef ->+  Map BasisCellRef BasisCellRef ->+  Map BasisCellRef BasisCellRef+composeCriticalBasis priorBasis = fmap (rebaseCell priorBasis)++localizedLowerCell :: LocalizedAcyclicPair r -> BasisCellRef+localizedLowerCell LocalizedAcyclicPair {lapLowerCell = lowerCell} = lowerCell++localizedUpperCell :: LocalizedAcyclicPair r -> BasisCellRef+localizedUpperCell LocalizedAcyclicPair {lapUpperCell = upperCell} = upperCell++localizedIncidenceCoefficient :: LocalizedAcyclicPair r -> r+localizedIncidenceCoefficient LocalizedAcyclicPair {lapIncidenceCoefficient = coefficientValue} = coefficientValue++isCodimensionOne :: BasisCellRef -> BasisCellRef -> Bool+isCodimensionOne lowerCell upperCell =+  basisCellDimension upperCell == basisCellDimension lowerCell + 1
+ src-topology/Moonlight/Homology/Pure/Topology/Morse/Digraph.hs view
@@ -0,0 +1,234 @@+-- | Directed-graph machinery for algebraic discrete Morse theory: edge maps+-- over basis cells, adjacency projections, DFS topological order, three-color+-- acyclicity certification, and gradient path-weight propagation.+--+-- This layer is deliberately theory-free: it knows nothing about matchings,+-- reductions, or chain complexes — only 'BasisCellRef' vertices, weighted+-- directed edges, and the DAG algorithms 'Moonlight.Homology.Pure.Topology.Morse'+-- runs on top of them.+module Moonlight.Homology.Pure.Topology.Morse.Digraph+  ( DirectedEdgeMap,+    DirectedAdjacencyMap,+    WeightedAdjacencyMap,+    PathWeightOracle (..),+    adjacencyMap,+    deleteAdjacencyEdge,+    insertAdjacencyEdge,+    topologicalOrderWithVertices,+    pathWeightOracle,+    pathWeightsFromOracle,+    graphIsAcyclic,+    basisCellDimension,+    basisCellKey,+  )+where++import Data.Kind (Type)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Homology.Pure.Carrier (BasisCellRef (..))+import Moonlight.Homology.Pure.Degree (HomologicalDegree (..))++type DirectedEdgeMap :: Type -> Type+type DirectedEdgeMap r = Map (BasisCellRef, BasisCellRef) r++type DirectedAdjacencyMap :: Type+type DirectedAdjacencyMap = Map BasisCellRef [BasisCellRef]++type WeightedAdjacencyMap :: Type -> Type+type WeightedAdjacencyMap r = Map BasisCellRef [(r, BasisCellRef)]++type PathWeightOracle :: Type -> Type+newtype PathWeightOracle r = PathWeightOracle+  { pwoPathWeightsFrom :: BasisCellRef -> Map BasisCellRef r+  }++rankOf :: Map BasisCellRef Int -> BasisCellRef -> Int+rankOf rankValue cell =+  Map.findWithDefault maxBound cell rankValue++topologicalRank :: [BasisCellRef] -> Map BasisCellRef Int+topologicalRank orderValue =+  Map.fromList (zip orderValue [0 :: Int ..])++adjacencyMap :: DirectedEdgeMap r -> DirectedAdjacencyMap+adjacencyMap edgeMap =+  Map.map+    (sortOn basisCellKey)+    ( Map.fromListWith+        (<>)+        [ (fromCell, [toCell])+        | ((fromCell, toCell), _) <- Map.toAscList edgeMap+        ]+    )++deleteAdjacencyEdge ::+  BasisCellRef ->+  BasisCellRef ->+  DirectedAdjacencyMap ->+  DirectedAdjacencyMap+deleteAdjacencyEdge fromCell toCell =+  Map.update prunedSuccessors fromCell+  where+    prunedSuccessors successorCells =+      case filter (/= toCell) successorCells of+        [] -> Nothing+        remainingSuccessors -> Just remainingSuccessors++insertAdjacencyEdge ::+  BasisCellRef ->+  BasisCellRef ->+  DirectedAdjacencyMap ->+  DirectedAdjacencyMap+insertAdjacencyEdge fromCell toCell =+  Map.insertWith mergeSuccessors fromCell [toCell]+  where+    mergeSuccessors insertedSuccessors existingSuccessors =+      sortOn basisCellKey (insertedSuccessors <> filter (/= toCell) existingSuccessors)++topologicalOrderWithVertices :: [BasisCellRef] -> DirectedAdjacencyMap -> [BasisCellRef]+topologicalOrderWithVertices vertices adjacency =+  snd (foldl' visitVertex (Set.empty, []) graphVertices)+  where+    graphVertices =+      Set.toAscList+        (Set.fromList vertices <> Map.keysSet adjacency <> foldMap Set.fromList (Map.elems adjacency))+    visitVertex (visited, orderedCells) vertex+      | Set.member vertex visited = (visited, orderedCells)+      | otherwise = visitFrom visited orderedCells vertex+    visitFrom visited orderedCells vertex+      | Set.member vertex visited = (visited, orderedCells)+      | otherwise =+          let (visitedAfterSuccessors, orderedAfterSuccessors) =+                foldl'+                  ( \(visitedState, orderedState) successorCell ->+                      visitFrom visitedState orderedState successorCell+                  )+                  (Set.insert vertex visited, orderedCells)+                  (Map.findWithDefault [] vertex adjacency)+           in (visitedAfterSuccessors, vertex : orderedAfterSuccessors)++pathWeightOracle ::+  (Eq r, Num r) =>+  DirectedEdgeMap r ->+  [BasisCellRef] ->+  PathWeightOracle r+pathWeightOracle edgeMap topologicalVertexOrder =+  PathWeightOracle+    { pwoPathWeightsFrom =+        pathWeightsFromSource weightedAdjacency topologicalVertexOrder (topologicalRank topologicalVertexOrder)+    }+  where+    weightedAdjacency = weightedAdjacencyMap edgeMap++weightedAdjacencyMap :: DirectedEdgeMap r -> WeightedAdjacencyMap r+weightedAdjacencyMap edgeMap =+  Map.map+    (sortOn (basisCellKey . snd))+    ( Map.fromListWith+        (<>)+        [ (fromCell, [(coefficientValue, toCell)])+        | ((fromCell, toCell), coefficientValue) <- Map.toAscList edgeMap+        ]+    )++pathWeightsFromOracle :: PathWeightOracle r -> BasisCellRef -> Map BasisCellRef r+pathWeightsFromOracle pathWeightSums =+  pwoPathWeightsFrom pathWeightSums++pathWeightsFromSource ::+  (Eq r, Num r) =>+  WeightedAdjacencyMap r ->+  [BasisCellRef] ->+  Map BasisCellRef Int ->+  BasisCellRef ->+  Map BasisCellRef r+pathWeightsFromSource weightedAdjacency topologicalVertexOrder rankValue startCell =+  Map.filter (/= 0) $+    foldl'+      propagatePathWeights+      (Map.singleton startCell 1)+      (topologicalSuffix rankValue startCell topologicalVertexOrder)+  where+    propagatePathWeights pathWeights currentCell =+      case Map.lookup currentCell pathWeights of+        Nothing -> pathWeights+        Just currentWeight ->+          foldl'+            (accumulateWeightedSuccessor currentWeight)+            pathWeights+            (Map.findWithDefault [] currentCell weightedAdjacency)++accumulateWeightedSuccessor ::+  (Eq r, Num r) =>+  r ->+  Map BasisCellRef r ->+  (r, BasisCellRef) ->+  Map BasisCellRef r+accumulateWeightedSuccessor currentWeight pathWeights (edgeWeight, successorCell) =+  let contribution = currentWeight * edgeWeight+   in if contribution == 0+        then pathWeights+        else Map.alter (addPathContribution contribution) successorCell pathWeights++addPathContribution :: (Eq r, Num r) => r -> Maybe r -> Maybe r+addPathContribution contribution existingValue =+  let nextValue = maybe contribution (+ contribution) existingValue+   in if nextValue == 0+        then Nothing+        else Just nextValue++topologicalSuffix ::+  Map BasisCellRef Int ->+  BasisCellRef ->+  [BasisCellRef] ->+  [BasisCellRef]+topologicalSuffix rankValue startCell =+  filter (\cell -> rankOf rankValue cell >= rankOf rankValue startCell)++graphIsAcyclic :: DirectedEdgeMap r -> Bool+graphIsAcyclic edgeMap =+  visitAll Set.empty graphVertices+  where+    adjacency = adjacencyMap edgeMap+    graphVertices =+      Set.toAscList+        ( Set.fromList+            [ cell+            | ((fromCell, toCell), _) <- Map.toList edgeMap,+              cell <- [fromCell, toCell]+            ]+        )+    visitAll permanentlyVisited remainingVertices =+      case remainingVertices of+        [] -> True+        vertex : restVertices+          | Set.member vertex permanentlyVisited -> visitAll permanentlyVisited restVertices+          | otherwise ->+              case visit permanentlyVisited Set.empty vertex of+                Nothing -> False+                Just permanentlyVisited' -> visitAll permanentlyVisited' restVertices+    visit permanentlyVisited temporarilyVisited vertex+      | Set.member vertex temporarilyVisited = Nothing+      | Set.member vertex permanentlyVisited = Just permanentlyVisited+      | otherwise =+          let temporarilyVisited' = Set.insert vertex temporarilyVisited+           in case visitSuccessors permanentlyVisited temporarilyVisited' (Map.findWithDefault [] vertex adjacency) of+                Nothing -> Nothing+                Just permanentlyVisited' -> Just (Set.insert vertex permanentlyVisited')+    visitSuccessors permanentlyVisited temporarilyVisited successorCells =+      case successorCells of+        [] -> Just permanentlyVisited+        successorCell : restCells ->+          case visit permanentlyVisited temporarilyVisited successorCell of+            Nothing -> Nothing+            Just permanentlyVisited' -> visitSuccessors permanentlyVisited' temporarilyVisited restCells++basisCellDimension :: BasisCellRef -> Int+basisCellDimension BasisCellRef {cellDegree = HomologicalDegree degreeValue} = degreeValue++basisCellKey :: BasisCellRef -> (Int, Int)+basisCellKey BasisCellRef {cellDegree = HomologicalDegree degreeValue, cellIndex = indexValue} =+  (degreeValue, indexValue)
+ src-topology/Moonlight/Homology/Pure/Topology/Observation.hs view
@@ -0,0 +1,24 @@+module Moonlight.Homology.Pure.Topology.Observation+  ( TopologyObservationConfig (..),+    defaultTopologyObservationConfig,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Topology.Core (FilteredFiniteChainComplex)+import Moonlight.Homology.Pure.Topology.MacroScaffold (ScalarPotentialField)++type TopologyObservationConfig :: Type -> Type+data TopologyObservationConfig r = TopologyObservationConfig+  { observationFiltration :: Maybe (FilteredFiniteChainComplex r),+    observationPotential :: Maybe ScalarPotentialField,+    observationLowModeCount :: Int+  }++defaultTopologyObservationConfig :: TopologyObservationConfig r+defaultTopologyObservationConfig =+  TopologyObservationConfig+    { observationFiltration = Nothing,+      observationPotential = Nothing,+      observationLowModeCount = 0+    }
+ src-topology/Moonlight/Homology/Pure/Topology/Persistence.hs view
@@ -0,0 +1,373 @@+module Moonlight.Homology.Pure.Topology.Persistence+  ( mkFilteredFiniteChainComplex,+    mod2PersistentPairs,+    mod2PersistenceTopologyWitness,+    mod2PersistentBoundaryColumn,+    persistentPairs,+    persistenceTopologyWitness,+    persistentBoundaryColumn,+    persistenceEssentialBirths,+    reducePersistentColumn,+    reduceBoundaryColumn,+    materializeFinitePersistencePair,+    materializeEssentialPersistencePair,+    orderedFilteredCells,+    validateBirthCoverage,+    validateBirthExactness,+    validateFiltrationMonotonicity,+  )+where++import Data.Function ((&))+import Data.IntMap.Strict qualified as IntMap+import Data.Kind (Type)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Moonlight.Homology.Boundary.Finite+  ( FiniteChainComplex,+    incidenceMatrixAt,+  )+import Moonlight.Homology.Boundary.LinAlg+  ( BoundaryEntry,+    BoundaryIncidence,+    boundaryCoefficient,+    boundaryEntries,+    sourceIndex,+    targetIndex,+  )+import Moonlight.Homology.Pure.Chain+  ( HomologicalDegree (..),+    PersistencePair (..),+    TopologyWitness (..),+    decrementDegree,+    emptyTopologyWitness,+  )+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Topology.Core++type OrderedFilteredCell :: Type+data OrderedFilteredCell = OrderedFilteredCell+  { orderedCellIdentity :: BasisCellRef,+    orderedCellBirth :: FiltrationValue+  }+  deriving stock (Eq, Show)++type PersistenceState :: Type+data PersistenceState = PersistenceState+  { persistenceLowColumns :: !(Map.Map Int (Set.Set Int)),+    persistencePairsByIndex :: ![(Int, Int)],+    persistenceCreators :: !(Set.Set Int)+  }++emptyPersistenceState :: PersistenceState+emptyPersistenceState =+  PersistenceState+    { persistenceLowColumns = Map.empty,+      persistencePairsByIndex = [],+      persistenceCreators = Set.empty+    }++mkFilteredFiniteChainComplex ::+  Integral r =>+  FiniteChainComplex r ->+  [(BasisCellRef, FiltrationValue)] ->+  Either HomologyFailure (FilteredFiniteChainComplex r)+mkFilteredFiniteChainComplex finite births = do+  let birthMap = Map.fromList births+  validateBirthUniqueness births birthMap+  validateBirthCoverage finite birthMap+  validateBirthExactness finite birthMap+  validateFiltrationMonotonicity finite birthMap+  pure+    FilteredFiniteChainComplex+      { filteredBaseComplex = finite,+        filteredCellBirths = birthMap+      }++mod2PersistentPairs ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Either HomologyFailure [PersistencePair FiltrationValue]+mod2PersistentPairs filtered = do+  let orderedCells = orderedFilteredCells filtered+      orderedCellByIndex =+        orderedCells+          & zip [0 :: Int ..]+          & Map.fromList+      globalIndexByCell =+        orderedCells+          & zip [0 :: Int ..]+          & fmap (\(globalIndexValue, orderedCell) -> (orderedCellIdentity orderedCell, globalIndexValue))+          & Map.fromList+      groupedBoundaryEntries = boundaryEntriesByDegree (filteredBaseComplex filtered)+      boundaryColumns = fmap (mod2PersistentBoundaryColumnFromIndex groupedBoundaryEntries globalIndexByCell) orderedCells+      stateAfterReduction = foldl' reducePersistentColumn emptyPersistenceState (zip [0 :: Int ..] boundaryColumns)+      finitePairs =+        persistencePairsByIndex stateAfterReduction+          & reverse+          & mapMaybe (uncurry (materializeFinitePersistencePair orderedCellByIndex))+      essentialPairs =+        persistenceEssentialBirths stateAfterReduction+          & Set.toAscList+          & mapMaybe (materializeEssentialPersistencePair orderedCellByIndex)+  pure (finitePairs <> essentialPairs)++persistentPairs ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Either HomologyFailure [PersistencePair FiltrationValue]+{-# DEPRECATED persistentPairs "Use mod2PersistentPairs — this computes mod-2 persistence despite its Integral constraint" #-}+persistentPairs = mod2PersistentPairs++mod2PersistenceTopologyWitness ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Either HomologyFailure (TopologyWitness scaffold spectral FiltrationValue coefficient basis)+mod2PersistenceTopologyWitness filtered = do+  pairs <- mod2PersistentPairs filtered+  pure+    emptyTopologyWitness+      { topologyPersistencePairs = pairs+      }++persistenceTopologyWitness ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Either HomologyFailure (TopologyWitness scaffold spectral FiltrationValue coefficient basis)+{-# DEPRECATED persistenceTopologyWitness "Use mod2PersistenceTopologyWitness — this computes mod-2 persistence despite its Integral constraint" #-}+persistenceTopologyWitness = mod2PersistenceTopologyWitness++persistenceEssentialBirths :: PersistenceState -> Set.Set Int+persistenceEssentialBirths stateValue =+  let pairedBirths = persistencePairsByIndex stateValue & fmap fst & Set.fromList+   in persistenceCreators stateValue `Set.difference` pairedBirths++reducePersistentColumn :: PersistenceState -> (Int, Set.Set Int) -> PersistenceState+reducePersistentColumn stateValue (columnIndexValue, initialColumn) =+  let reducedColumn = reduceBoundaryColumn (persistenceLowColumns stateValue) initialColumn+   in case lowIndex reducedColumn of+        Nothing ->+          stateValue+            { persistenceCreators = Set.insert columnIndexValue (persistenceCreators stateValue)+            }+        Just lowValue ->+          stateValue+            { persistenceLowColumns = Map.insert lowValue reducedColumn (persistenceLowColumns stateValue),+              persistencePairsByIndex = (lowValue, columnIndexValue) : persistencePairsByIndex stateValue+            }++reduceBoundaryColumn :: Map.Map Int (Set.Set Int) -> Set.Set Int -> Set.Set Int+reduceBoundaryColumn lowColumns columnValue =+  case lowIndex columnValue >>= (`Map.lookup` lowColumns) of+    Nothing -> columnValue+    Just pivotColumn -> reduceBoundaryColumn lowColumns (symmetricDifference columnValue pivotColumn)++materializeFinitePersistencePair ::+  Map.Map Int OrderedFilteredCell ->+  Int ->+  Int ->+  Maybe (PersistencePair FiltrationValue)+materializeFinitePersistencePair orderedCellByIndex birthIndexValue deathIndexValue =+  case (Map.lookup birthIndexValue orderedCellByIndex, Map.lookup deathIndexValue orderedCellByIndex) of+    (Just birthCell, Just deathCell) ->+      Just+        PersistencePair+          { persistenceDegree = cellDegree (orderedCellIdentity birthCell),+            persistenceBirth = orderedCellBirth birthCell,+            persistenceDeath = Just (orderedCellBirth deathCell)+          }+    _ -> Nothing++materializeEssentialPersistencePair ::+  Map.Map Int OrderedFilteredCell ->+  Int ->+  Maybe (PersistencePair FiltrationValue)+materializeEssentialPersistencePair orderedCellByIndex birthIndexValue =+  Map.lookup birthIndexValue orderedCellByIndex+    & fmap+      ( \birthCell ->+          PersistencePair+            { persistenceDegree = cellDegree (orderedCellIdentity birthCell),+              persistenceBirth = orderedCellBirth birthCell,+              persistenceDeath = Nothing+            }+      )++orderedFilteredCells :: FilteredFiniteChainComplex r -> [OrderedFilteredCell]+orderedFilteredCells filtered =+  allBasisCellRefs (filteredBaseComplex filtered)+    & mapMaybe+      ( \cellRefValue ->+          fmap (OrderedFilteredCell cellRefValue)+            (Map.lookup cellRefValue (filteredCellBirths filtered))+      )+    & List.sortOn+      ( \orderedCell ->+          let degreeValue = cellDegree (orderedCellIdentity orderedCell)+           in ( orderedCellBirth orderedCell,+                unHomologicalDegree degreeValue,+                cellIndex (orderedCellIdentity orderedCell)+              )+      )++mod2PersistentBoundaryColumn ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Map.Map BasisCellRef Int ->+  OrderedFilteredCell ->+  Set.Set Int+mod2PersistentBoundaryColumn filtered globalIndexByCell orderedCell =+  let cellRefValue = orderedCellIdentity orderedCell+      degreeValue = cellDegree cellRefValue+      incidence = incidenceMatrixAt (filteredBaseComplex filtered) degreeValue+   in mod2PersistentBoundaryColumnFromEntries (entriesBySource incidence) globalIndexByCell orderedCell++mod2PersistentBoundaryColumnFromIndex ::+  Integral r =>+  Map.Map HomologicalDegree (IntMap.IntMap [BoundaryEntry r]) ->+  Map.Map BasisCellRef Int ->+  OrderedFilteredCell ->+  Set.Set Int+mod2PersistentBoundaryColumnFromIndex groupedBoundaryEntries globalIndexByCell orderedCell =+  let cellRefValue = orderedCellIdentity orderedCell+      degreeEntries = Map.findWithDefault IntMap.empty (cellDegree cellRefValue) groupedBoundaryEntries+   in mod2PersistentBoundaryColumnFromEntries degreeEntries globalIndexByCell orderedCell++mod2PersistentBoundaryColumnFromEntries ::+  Integral r =>+  IntMap.IntMap [BoundaryEntry r] ->+  Map.Map BasisCellRef Int ->+  OrderedFilteredCell ->+  Set.Set Int+mod2PersistentBoundaryColumnFromEntries groupedEntries globalIndexByCell orderedCell =+  let cellRefValue = orderedCellIdentity orderedCell+      degreeValue = cellDegree cellRefValue+   in IntMap.findWithDefault [] (cellIndex cellRefValue) groupedEntries+        & filter (\entry -> odd (abs (boundaryCoefficient entry)))+        & fmap+          ( \entry ->+              BasisCellRef+                { cellDegree = decrementDegree degreeValue,+                  cellIndex = targetIndex entry+                }+          )+        & mapMaybeWithLookup globalIndexByCell+        & Set.fromList++boundaryEntriesByDegree ::+  FiniteChainComplex r ->+  Map.Map HomologicalDegree (IntMap.IntMap [BoundaryEntry r])+boundaryEntriesByDegree finite =+  dimensionsOf finite+    & fmap (\degreeValue -> (degreeValue, entriesBySource (incidenceMatrixAt finite degreeValue)))+    & Map.fromList++entriesBySource :: BoundaryIncidence r -> IntMap.IntMap [BoundaryEntry r]+entriesBySource incidence =+  boundaryEntries incidence+    & foldr+      ( \entryValue ->+          IntMap.insertWith (<>) (sourceIndex entryValue) [entryValue]+      )+      IntMap.empty++persistentBoundaryColumn ::+  Integral r =>+  FilteredFiniteChainComplex r ->+  Map.Map BasisCellRef Int ->+  OrderedFilteredCell ->+  Set.Set Int+{-# DEPRECATED persistentBoundaryColumn "Use mod2PersistentBoundaryColumn — this computes mod-2 boundary despite its Integral constraint" #-}+persistentBoundaryColumn = mod2PersistentBoundaryColumn++validateBirthUniqueness ::+  [(BasisCellRef, FiltrationValue)] ->+  Map.Map BasisCellRef FiltrationValue ->+  Either HomologyFailure ()+validateBirthUniqueness births birthMap =+  if length births == Map.size birthMap+    then Right ()+    else Left (InvalidTopologyInput "duplicate birth assignments for the same cell")++validateBirthCoverage ::+  FiniteChainComplex r ->+  Map.Map BasisCellRef FiltrationValue ->+  Either HomologyFailure ()+validateBirthCoverage finite birthMap =+  allBasisCellRefs finite+    & List.find (\cellRefValue -> Map.notMember cellRefValue birthMap)+    & maybe (Right ()) missingCellFailure+  where+    missingCellFailure :: BasisCellRef -> Either HomologyFailure ()+    missingCellFailure cellRefValue =+      Left+        ( InvalidTopologyInput+            ( "missing filtration value for cell "+                <> show cellRefValue+            )+        )++validateBirthExactness ::+  FiniteChainComplex r ->+  Map.Map BasisCellRef FiltrationValue ->+  Either HomologyFailure ()+validateBirthExactness finite birthMap =+  let basisSet = Set.fromList (allBasisCellRefs finite)+      extraKeys = Map.keysSet birthMap `Set.difference` basisSet+   in if Set.null extraKeys+        then Right ()+        else+          Left+            ( InvalidTopologyInput+                ( "birth map contains cells absent from the chain complex: "+                    <> show (Set.toList extraKeys)+                )+            )++validateFiltrationMonotonicity ::+  Integral r =>+  FiniteChainComplex r ->+  Map.Map BasisCellRef FiltrationValue ->+  Either HomologyFailure ()+validateFiltrationMonotonicity finite birthMap =+  filtrationViolations+    & List.find (const True)+    & maybe (Right ()) (Left . InvalidTopologyInput)+  where+    filtrationViolations =+      dimensionsOf finite+        >>= ( \degreeValue@(HomologicalDegree degreeIndex) ->+                if degreeIndex <= 0+                  then []+                  else+                    let incidence = incidenceMatrixAt finite degreeValue+                     in boundaryEntries incidence+                          & filter (\entry -> boundaryCoefficient entry /= 0)+                          & mapMaybe+                            ( \entry ->+                                let sourceCell =+                                      BasisCellRef+                                        { cellDegree = degreeValue,+                                          cellIndex = sourceIndex entry+                                        }+                                    targetCell =+                                      BasisCellRef+                                        { cellDegree = decrementDegree degreeValue,+                                          cellIndex = targetIndex entry+                                        }+                                 in case (Map.lookup sourceCell birthMap, Map.lookup targetCell birthMap) of+                                      (Just sourceBirth, Just targetBirth) ->+                                        if targetBirth <= sourceBirth+                                          then Nothing+                                          else+                                            Just+                                              ( "filtration violates face monotonicity for "+                                                  <> show sourceCell+                                                  <> " -> "+                                                  <> show targetCell+                                              )+                                      _ -> Nothing+                            )+           )
+ src-topology/Moonlight/Homology/Pure/Topology/Realize.hs view
@@ -0,0 +1,459 @@+module Moonlight.Homology.Pure.Topology.Realize+  ( Orientation (..),+    RawCellData (..),+    RawCellScopes (..),+    RealizationBudget (..),+    realizeScaffoldRaw,+    realizeScaffoldRawWithScopes,+  )+where++import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.Kind (Type)+import Data.List (sortBy)+import Data.Map.Strict qualified as Map+import Data.Ord (Down (..), comparing)+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.Algebra.Pure.Orientation (Orientation (..))+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Topology.Graph.Algebra (connectedComponentsFromAdjacency)+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( BasisCellRef,+    HarmonicLoop (..),+    MacroScaffoldIR (..),+    MorseReebArc (..),+    MorseReebNode (..),+    MorseReebScaffold (..),+    PotentialValue,+    ReebArcId,+    ReebNodeId (..),+    unPotentialValue,+  )++type RawCellData :: Type+data RawCellData = RawCellData+  { rawVertices :: [Int],+    rawEdges :: [(Int, Int, Int)],+    rawFaces :: [(Int, [(Int, Orientation)])],+    rawVertexCount :: !Int,+    rawEdgeCount :: !Int,+    rawFaceCount :: !Int+  }+  deriving stock (Eq, Show)++instance Semigroup RawCellData where+  a <> b =+    RawCellData+      { rawVertices = rawVertices a <> rawVertices b,+        rawEdges = rawEdges a <> rawEdges b,+        rawFaces = rawFaces a <> rawFaces b,+        rawVertexCount = rawVertexCount a + rawVertexCount b,+        rawEdgeCount = rawEdgeCount a + rawEdgeCount b,+        rawFaceCount = rawFaceCount a + rawFaceCount b+      }++instance Monoid RawCellData where+  mempty = RawCellData [] [] [] 0 0 0++type RawCellScopes :: Type -> Type+data RawCellScopes tag = RawCellScopes+  { rawVertexScopes :: Map.Map tag (Set Int),+    rawEdgeScopes :: Map.Map tag (Set Int),+    rawFaceScopes :: Map.Map tag (Set Int)+  }+  deriving stock (Eq, Show)++instance Ord tag => Semigroup (RawCellScopes tag) where+  left <> right =+    RawCellScopes+      { rawVertexScopes = Map.unionWith Set.union (rawVertexScopes left) (rawVertexScopes right),+        rawEdgeScopes = Map.unionWith Set.union (rawEdgeScopes left) (rawEdgeScopes right),+        rawFaceScopes = Map.unionWith Set.union (rawFaceScopes left) (rawFaceScopes right)+      }++instance Ord tag => Monoid (RawCellScopes tag) where+  mempty =+    RawCellScopes+      { rawVertexScopes = Map.empty,+        rawEdgeScopes = Map.empty,+        rawFaceScopes = Map.empty+      }++type RealizationBudget :: Type+newtype RealizationBudget = RealizationBudget+  { unRealizationBudget :: Int+  }+  deriving stock (Eq, Show)++type IdState :: Type+data IdState = IdState+  { nextVertexId :: !Int,+    nextEdgeId :: !Int,+    nextFaceId :: !Int+  }++realizeScaffoldRaw :: MacroScaffoldIR -> RealizationBudget -> Either HomologyFailure RawCellData+realizeScaffoldRaw scaffold budget = do+  let reebScaffold = macroScaffoldReeb scaffold+      nodes = morseReebNodes reebScaffold+      arcs = morseReebArcs reebScaffold+      loops = macroScaffoldHarmonicLoops scaffold+      nodePotentialMap = buildNodePotentialMap nodes+  validateLoopClosure reebScaffold loops+  let (nodeData, nodeVertexMap, initialIdState) = realizeNodes reebScaffold+      arcBudgets = distributeBudget budget arcs nodePotentialMap+  arcDataList <- foldArcs nodeVertexMap arcBudgets initialIdState arcs+  Right (nodeData <> mconcat arcDataList)++realizeScaffoldRawWithScopes ::+  Ord tag =>+  (BasisCellRef -> Set tag) ->+  MacroScaffoldIR ->+  RealizationBudget ->+  Either HomologyFailure (RawCellData, RawCellScopes tag)+realizeScaffoldRawWithScopes labelsAt scaffold budget = do+  let reebScaffold = macroScaffoldReeb scaffold+      nodes = morseReebNodes reebScaffold+      arcs = morseReebArcs reebScaffold+      loops = macroScaffoldHarmonicLoops scaffold+      nodePotentialMap = buildNodePotentialMap nodes+  validateLoopClosure reebScaffold loops+  let (nodeData, nodeVertexMap, initialIdState, nodeScopes) =+        realizeNodesWithScopes labelsAt reebScaffold+      arcBudgets = distributeBudget budget arcs nodePotentialMap+  (arcData, arcScopes) <-+    foldArcsWithScopes labelsAt nodeVertexMap arcBudgets initialIdState arcs+  pure (nodeData <> arcData, nodeScopes <> arcScopes)++buildNodePotentialMap :: [MorseReebNode] -> Map.Map ReebNodeId PotentialValue+buildNodePotentialMap =+  Map.fromList+    . fmap (\node -> (morseReebNodeId node, morseReebNodePotential node))++realizeNodes :: MorseReebScaffold -> (RawCellData, Map.Map ReebNodeId Int, IdState)+realizeNodes reebScaffold =+  let nodes = morseReebNodes reebScaffold+      nodeCount = length nodes+      nodeVertexMap =+        Map.fromList+          ( zip+              (fmap morseReebNodeId nodes)+              [0 .. nodeCount - 1]+          )+      nodeData =+        RawCellData+          { rawVertices = [0 .. nodeCount - 1],+            rawEdges = [],+            rawFaces = [],+            rawVertexCount = nodeCount,+            rawEdgeCount = 0,+            rawFaceCount = 0+          }+      initialIdState =+        IdState+          { nextVertexId = nodeCount,+            nextEdgeId = 0,+            nextFaceId = 0+          }+   in (nodeData, nodeVertexMap, initialIdState)++realizeNodesWithScopes ::+  Ord tag =>+  (BasisCellRef -> Set tag) ->+  MorseReebScaffold ->+  (RawCellData, Map.Map ReebNodeId Int, IdState, RawCellScopes tag)+realizeNodesWithScopes labelsAt reebScaffold =+  let (nodeData, nodeVertexMap, initialIdState) = realizeNodes reebScaffold+      nodeScopes =+        morseReebNodes reebScaffold+          & zip [0 ..]+          & foldr+            ( \(vertexId, nodeValue) ->+                (<>)+                  (scopeForVertices (labelsAt (morseReebNodeAnchor nodeValue)) [vertexId])+            )+            mempty+   in (nodeData, nodeVertexMap, initialIdState, nodeScopes)++distributeBudget ::+  RealizationBudget ->+  [MorseReebArc] ->+  Map.Map ReebNodeId PotentialValue ->+  Map.Map ReebArcId Int+-- | Distribute a face budget across arcs proportionally to potential delta,+-- with a floor of one face per arc. The floor dominates the budget: when+-- @totalBudget < length arcs@ the distribution totals @length arcs@, i.e.+-- the budget is treated as a target, not a hard cap.+distributeBudget (RealizationBudget totalBudget) arcs nodePotentialMap =+  let arcDeltas =+        fmap (arcPotentialDelta nodePotentialMap) arcs+      totalDelta = sum arcDeltas+      arcIdsWithDeltas = zip (fmap morseReebArcId arcs) arcDeltas+      rawAllocations =+        fmap+          ( \(arcId, delta) ->+              let proportion =+                    if totalDelta > 0+                      then delta / totalDelta+                      else 1.0 / fromIntegral (max 1 (length arcs))+                  rawAlloc = fromIntegral totalBudget * proportion :: Double+                  floorAlloc = max 1 (floor rawAlloc :: Int)+                  fractionalRemainder = rawAlloc - fromIntegral floorAlloc+               in (arcId, floorAlloc, fractionalRemainder)+          )+          arcIdsWithDeltas+      floorTotal = sum (fmap (\(_, alloc, _) -> alloc) rawAllocations)+      deficit = totalBudget - floorTotal+      sortedByRemainder =+        sortBy (comparing (\(_, _, remainder) -> Down remainder)) rawAllocations+      distributed = distributeRemainder deficit sortedByRemainder+   in Map.fromList distributed++distributeRemainder :: Int -> [(ReebArcId, Int, Double)] -> [(ReebArcId, Int)]+distributeRemainder remaining allocations =+  case allocations of+    [] -> []+    (arcId, alloc, _remainder) : rest+      | remaining > 0 ->+          (arcId, alloc + 1) : distributeRemainder (remaining - 1) rest+      | otherwise ->+          (arcId, alloc) : fmap (\(aid, a, _) -> (aid, a)) rest++arcPotentialDelta :: Map.Map ReebNodeId PotentialValue -> MorseReebArc -> Double+arcPotentialDelta nodePotentialMap arc =+  let sourcePotential =+        maybe 0.0 unPotentialValue+          (Map.lookup (morseReebArcSource arc) nodePotentialMap)+      targetPotential =+        maybe 0.0 unPotentialValue+          (Map.lookup (morseReebArcTarget arc) nodePotentialMap)+   in abs (targetPotential - sourcePotential)++foldArcs ::+  Map.Map ReebNodeId Int ->+  Map.Map ReebArcId Int ->+  IdState ->+  [MorseReebArc] ->+  Either HomologyFailure [RawCellData]+foldArcs nodeVertexMap arcBudgets initialState arcs =+  let step (currentState, revAccumulated) arc = do+        (nextState, cellData) <- realizeArcWithState nodeVertexMap arcBudgets currentState arc+        Right (nextState, cellData : revAccumulated)+   in fmap (reverse . snd) (foldl' (\acc arc -> acc >>= \s -> step s arc) (Right (initialState, [])) arcs)++foldArcsWithScopes ::+  Ord tag =>+  (BasisCellRef -> Set tag) ->+  Map.Map ReebNodeId Int ->+  Map.Map ReebArcId Int ->+  IdState ->+  [MorseReebArc] ->+  Either HomologyFailure (RawCellData, RawCellScopes tag)+foldArcsWithScopes labelsAt nodeVertexMap arcBudgets initialState arcs =+  let step (currentState, revDataList, revScopesList) arc = do+        (nextState, cellData, cellScopes) <-+          realizeArcWithStateAndScopes labelsAt nodeVertexMap arcBudgets currentState arc+        Right (nextState, cellData : revDataList, cellScopes : revScopesList)+   in fmap+        (\(_, revDataList, revScopesList) -> (mconcat (reverse revDataList), mconcat (reverse revScopesList)))+        (foldl' (\acc arc -> acc >>= \stateValue -> step stateValue arc) (Right (initialState, [], [])) arcs)++realizeArcWithState ::+  Map.Map ReebNodeId Int ->+  Map.Map ReebArcId Int ->+  IdState ->+  MorseReebArc ->+  Either HomologyFailure (IdState, RawCellData)+realizeArcWithState nodeVertexMap arcBudgets idState arc = do+  let arcId = morseReebArcId arc+  faceBudget <-+    maybe+      (Left (InvalidTopologyInput "arc budget not found during realization"))+      Right+      (Map.lookup arcId arcBudgets)+  sourceVertex <-+    maybe+      (Left (InvalidTopologyInput "arc source node not found in vertex map"))+      Right+      (Map.lookup (morseReebArcSource arc) nodeVertexMap)+  targetVertex <-+    maybe+      (Left (InvalidTopologyInput "arc target node not found in vertex map"))+      Right+      (Map.lookup (morseReebArcTarget arc) nodeVertexMap)+  Right (realizeArc idState faceBudget sourceVertex targetVertex)++realizeArcWithStateAndScopes ::+  Ord tag =>+  (BasisCellRef -> Set tag) ->+  Map.Map ReebNodeId Int ->+  Map.Map ReebArcId Int ->+  IdState ->+  MorseReebArc ->+  Either HomologyFailure (IdState, RawCellData, RawCellScopes tag)+realizeArcWithStateAndScopes labelsAt nodeVertexMap arcBudgets idState arc = do+  (nextState, cellData) <- realizeArcWithState nodeVertexMap arcBudgets idState arc+  let arcLabels =+        morseReebArcSupport arc+          & fmap labelsAt+          & foldr Set.union Set.empty+  pure+    ( nextState,+      cellData,+      scopeForRawCellData arcLabels cellData+    )++realizeArc :: IdState -> Int -> Int -> Int -> (IdState, RawCellData)+realizeArc idState faceBudget sourceVertex targetVertex =+  let intermediateCount = faceBudget - 1+      intermediateVertexIds = [nextVertexId idState .. nextVertexId idState + intermediateCount - 1]+      lateralVertexId = nextVertexId idState + intermediateCount+      newVertexIds = intermediateVertexIds <> [lateralVertexId]+      newVertexCount = intermediateCount + 1+      spineVertices = [sourceVertex] <> intermediateVertexIds <> [targetVertex]+      spineEdges =+        zipWith+          (\i (src, tgt) -> (nextEdgeId idState + i, src, tgt))+          [0 ..]+          (zip (take faceBudget spineVertices) (drop 1 spineVertices))+      lateralEdgeStart = nextEdgeId idState + faceBudget+      lateralEdgeCount = faceBudget + 1+      lateralEdges =+        zipWith+          (\i sv -> (lateralEdgeStart + i, sv, lateralVertexId))+          [0 ..]+          spineVertices+      totalNewEdges = faceBudget + lateralEdgeCount+      faceStart = nextFaceId idState+      faces =+        zipWith+          ( \i faceIdx ->+              let spineEdgeId = nextEdgeId idState + i+                  lateralEdgeIdNext = lateralEdgeStart + i + 1+                  lateralEdgeIdCur = lateralEdgeStart + i+               in ( faceIdx,+                    [ (spineEdgeId, Positive),+                      (lateralEdgeIdNext, Positive),+                      (lateralEdgeIdCur, Negative)+                    ]+                  )+          )+          [0 .. faceBudget - 1]+          [faceStart .. faceStart + faceBudget - 1]+      nextState =+        IdState+          { nextVertexId = nextVertexId idState + newVertexCount,+            nextEdgeId = nextEdgeId idState + totalNewEdges,+            nextFaceId = nextFaceId idState + faceBudget+          }+      cellData =+        RawCellData+          { rawVertices = newVertexIds,+            rawEdges = spineEdges <> lateralEdges,+            rawFaces = faces,+            rawVertexCount = newVertexCount,+            rawEdgeCount = totalNewEdges,+            rawFaceCount = faceBudget+         }+   in (nextState, cellData)++scopeForRawCellData :: Ord tag => Set tag -> RawCellData -> RawCellScopes tag+scopeForRawCellData labelsValue rawCellData =+  scopeForVertices labelsValue (rawVertices rawCellData)+    <> scopeForEdges labelsValue (fmap (\(edgeId, _, _) -> edgeId) (rawEdges rawCellData))+    <> scopeForFaces labelsValue (fmap fst (rawFaces rawCellData))++scopeForVertices :: Ord tag => Set tag -> [Int] -> RawCellScopes tag+scopeForVertices labelsValue vertexIds =+  mempty+    { rawVertexScopes = labelsToCells labelsValue vertexIds+    }++scopeForEdges :: Ord tag => Set tag -> [Int] -> RawCellScopes tag+scopeForEdges labelsValue edgeIds =+  mempty+    { rawEdgeScopes = labelsToCells labelsValue edgeIds+    }++scopeForFaces :: Ord tag => Set tag -> [Int] -> RawCellScopes tag+scopeForFaces labelsValue faceIds =+  mempty+    { rawFaceScopes = labelsToCells labelsValue faceIds+    }++labelsToCells :: Ord tag => Set tag -> [Int] -> Map.Map tag (Set Int)+labelsToCells labelsValue cellIds =+  labelsValue+    & Set.toList+    & fmap (\labelValue -> (labelValue, Set.fromList cellIds))+    & Map.fromListWith Set.union++validateLoopClosure :: MorseReebScaffold -> [HarmonicLoop] -> Either HomologyFailure ()+validateLoopClosure reebScaffold loops =+  let arcs = morseReebArcs reebScaffold+      arcEndpointMap =+        Map.fromList+          ( fmap+              (\arc -> (morseReebArcId arc, (morseReebArcSource arc, morseReebArcTarget arc)))+              arcs+          )+   in traverse_ (validateSingleLoop arcEndpointMap) loops++validateSingleLoop ::+  Map.Map ReebArcId (ReebNodeId, ReebNodeId) ->+  HarmonicLoop ->+  Either HomologyFailure ()+validateSingleLoop arcEndpointMap loop =+  let supportArcs = harmonicLoopSupport loop+   in case supportArcs of+        [] -> Right ()+        _ ->+          let endpoints =+                fmap+                  (\arcId -> Map.lookup arcId arcEndpointMap)+                  supportArcs+           in case sequence endpoints of+                Nothing ->+                  Left+                    ( InvalidTopologyInput+                        "harmonic loop references arc not present in scaffold"+                    )+                Just pairs ->+                  validateArcChainClosure pairs++validateArcChainClosure :: [(ReebNodeId, ReebNodeId)] -> Either HomologyFailure ()+validateArcChainClosure pairs =+  let allEndpoints = concatMap (\(src, tgt) -> [src, tgt]) pairs+      occurrences =+        foldl'+          (\acc nodeId -> Map.insertWith (+) nodeId (1 :: Int) acc)+          Map.empty+          allEndpoints+      oddDegreeNodes =+        Map.filter odd occurrences+   in if not (Map.null oddDegreeNodes)+        then+          Left+            ( InvalidTopologyInput+                "harmonic loop arc support has nodes with odd degree"+            )+        else case Map.keys occurrences of+          [] -> Right ()+          (_ : _) ->+            let adjacency =+                  foldl'+                    ( \acc (src, tgt) ->+                        Map.insertWith Set.union src (Set.singleton tgt) (Map.insertWith Set.union tgt (Set.singleton src) acc)+                    )+                    Map.empty+                    pairs+                componentCount = connectedComponentsFromAdjacency adjacency+             in if componentCount == 1+                  then Right ()+                  else+                    Left+                      ( InvalidTopologyInput+                          "harmonic loop arc support is not connected"+                      )
+ src-topology/Moonlight/Homology/Pure/Topology/ScaffoldSummary.hs view
@@ -0,0 +1,60 @@+module Moonlight.Homology.Pure.Topology.ScaffoldSummary+  ( SkeletonSignature (..),+    macroScaffoldSignature,+    macroScaffoldSummaryAlgebra,+    skeletonSignatureWithinTolerance,+    mkMacroScaffoldTopologyView,+    mkMacroScaffoldWitnessInterpreter,+  )+where++import Data.Function ((&))+import Data.Map.Strict qualified as Map+import Moonlight.Homology.Pure.Chain (TopologyWitness)+import Moonlight.Homology.Pure.Skeleton (SkeletonSignature (..), skeletonSignatureWithinTolerance)+import Moonlight.Homology.Pure.Topology.MacroScaffold+  ( MacroScaffoldIR (..),+    MorseReebScaffold (..),+    Singularity (..),+  )+import Moonlight.Homology.Pure.TopologyObserver+  ( TopologyObserver,+    WitnessInterpreter,+    mkWitnessInterpreter,+  )+import Moonlight.Homology.Pure.TopologyView+  ( ScaffoldSummaryAlgebra,+    TopologyView,+    mkScaffoldSummaryAlgebra,+    mkTopologyView,+  )+++macroScaffoldSignature :: MacroScaffoldIR -> SkeletonSignature+macroScaffoldSignature scaffoldValue =+  let criticalCounts =+        macroScaffoldSingularities scaffoldValue+          & fmap singularityKind+          & fmap (\criticalKindValue -> (criticalKindValue, 1))+          & Map.fromListWith (+)+   in SkeletonSignature+        { signatureCriticalCounts = criticalCounts,+          signatureArcCount = length (morseReebArcs (macroScaffoldReeb scaffoldValue))+        }++macroScaffoldSummaryAlgebra :: ScaffoldSummaryAlgebra MacroScaffoldIR SkeletonSignature+macroScaffoldSummaryAlgebra =+  mkScaffoldSummaryAlgebra macroScaffoldSignature+++mkMacroScaffoldTopologyView ::+  TopologyWitness MacroScaffoldIR spectral persistence coefficient basis ->+  TopologyView SkeletonSignature MacroScaffoldIR spectral persistence coefficient basis+mkMacroScaffoldTopologyView =+  mkTopologyView macroScaffoldSummaryAlgebra++mkMacroScaffoldWitnessInterpreter ::+  TopologyObserver SkeletonSignature MacroScaffoldIR spectral persistence coefficient basis observed ->+  WitnessInterpreter SkeletonSignature MacroScaffoldIR spectral persistence coefficient basis observed+mkMacroScaffoldWitnessInterpreter =+  mkWitnessInterpreter macroScaffoldSummaryAlgebra
+ src-topology/Moonlight/Homology/Pure/Topology/SparseAlgebra.hs view
@@ -0,0 +1,141 @@+module Moonlight.Homology.Pure.Topology.SparseAlgebra+  ( sparseHomologyBasisAt,+    sparseCohomologyBasisAt,+    sparseFreeBettiVector,+    sparseQuotientRepresentatives,+  )+where++import Data.Function ((&))+import Data.IntMap.Strict qualified as IntMap+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Moonlight.Homology.Boundary.Finite (FiniteChainComplex, incidenceMatrixAt)+import Moonlight.Homology.Pure.Chain+  ( HomologicalDegree (..),+    RepresentativeChain (..),+    RepresentativeCocycle,+    RepresentativeCycle,+  )+import Moonlight.Homology.Pure.Matrix.Shape+  ( cellCountAtDegree,+    dimensionsOf,+  )+import Moonlight.Homology.Pure.Topology.Graph+  ( GraphOneComplex (..),+    graphOneComplexFromComplex,+  )+import Moonlight.Homology.Pure.Matrix.SparseLinAlg+  ( SparseMatrix (..),+    SparseRow,+    sparseBoundaryMatrix,+    sparseIndependentModulo,+    sparseKernelBasisOf,+    sparseTransposeMatrix,+  )++sparseHomologyBasisAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  [RepresentativeCycle Rational Int]+sparseHomologyBasisAt finite degreeValue@(HomologicalDegree degreeIndex) =+  case degreeValue of+    HomologicalDegree 0 ->+      maybe+        (genericSparseHomologyBasisAt finite degreeValue degreeIndex)+        graphHomologyZeroRepresentatives+        (graphOneComplexFromComplex finite)+    _ ->+      genericSparseHomologyBasisAt finite degreeValue degreeIndex++sparseCohomologyBasisAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  [RepresentativeCocycle Rational Int]+sparseCohomologyBasisAt finite degreeValue@(HomologicalDegree degreeIndex) =+  case degreeValue of+    HomologicalDegree 0 ->+      maybe+        (genericSparseCohomologyBasisAt finite degreeValue degreeIndex)+        graphCohomologyZeroRepresentatives+        (graphOneComplexFromComplex finite)+    _ ->+      genericSparseCohomologyBasisAt finite degreeValue degreeIndex++genericSparseHomologyBasisAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Int ->+  [RepresentativeCycle Rational Int]+genericSparseHomologyBasisAt finite degreeValue degreeIndex =+  sparseQuotientRepresentatives+    degreeValue+    (cellCountAtDegree finite degreeValue)+    (sparseBoundaryMatrix (incidenceMatrixAt finite degreeValue))+    (sparseBoundaryMatrix (incidenceMatrixAt finite (HomologicalDegree (degreeIndex + 1))))++genericSparseCohomologyBasisAt ::+  Integral r =>+  FiniteChainComplex r ->+  HomologicalDegree ->+  Int ->+  [RepresentativeCocycle Rational Int]+genericSparseCohomologyBasisAt finite degreeValue degreeIndex =+  sparseQuotientRepresentatives+    degreeValue+    (cellCountAtDegree finite degreeValue)+    (sparseTransposeMatrix (sparseBoundaryMatrix (incidenceMatrixAt finite (HomologicalDegree (degreeIndex + 1)))))+    (sparseTransposeMatrix (sparseBoundaryMatrix (incidenceMatrixAt finite degreeValue)))++graphHomologyZeroRepresentatives :: GraphOneComplex -> [RepresentativeCycle Rational Int]+graphHomologyZeroRepresentatives graph =+  graphOneComponents graph+    & mapMaybe Set.lookupMin+    & fmap+      ( \vertexIndex ->+          RepresentativeChain+            { representativeDegree = HomologicalDegree 0,+              representativeTerms = [(1, vertexIndex)]+            }+      )++graphCohomologyZeroRepresentatives :: GraphOneComplex -> [RepresentativeCocycle Rational Int]+graphCohomologyZeroRepresentatives graph =+  graphOneComponents graph+    & fmap+      ( \component ->+          RepresentativeChain+            { representativeDegree = HomologicalDegree 0,+              representativeTerms = fmap (\vertexIndex -> (1, vertexIndex)) (Set.toAscList component)+            }+      )++sparseFreeBettiVector :: Integral r => FiniteChainComplex r -> [Int]+sparseFreeBettiVector finite =+  dimensionsOf finite+    & fmap (length . sparseHomologyBasisAt finite)++sparseQuotientRepresentatives ::+  HomologicalDegree ->+  Int ->+  SparseMatrix ->+  SparseMatrix ->+  [RepresentativeChain Rational Int]+sparseQuotientRepresentatives degreeValue ambientDimension currentMatrix incomingMatrix =+  let kernelBasis = sparseKernelBasisOf ambientDimension currentMatrix+      imageGenerators = smRows (sparseTransposeMatrix incomingMatrix)+      quotientBasis = sparseIndependentModulo ambientDimension imageGenerators kernelBasis+   in fmap (sparseVectorToRepresentative degreeValue) quotientBasis++sparseVectorToRepresentative :: HomologicalDegree -> SparseRow -> RepresentativeChain Rational Int+sparseVectorToRepresentative degreeValue rowValue =+  RepresentativeChain+    { representativeDegree = degreeValue,+      representativeTerms =+        IntMap.toAscList rowValue+          & filter (\(_, coefficientValue) -> coefficientValue /= 0)+          & fmap (\(basisIndexValue, coefficientValue) -> (coefficientValue, basisIndexValue))+    }
+ src-topology/Moonlight/Homology/Pure/Topology/Spectral.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Homology.Pure.Topology.Spectral+  ( graphLaplacian,+    laplacianEntry,+    weightedGraphLaplacian,+    weightedGraphSparseLaplacian,+    SparseSpectralConfig (..),+    defaultSparseSpectralConfig,+    weightedGraphSpectralModes,+    weightedGraphSparseSpectralModes,+    weightedGraphSpectralGap,+    gapFromModes,+    leadingModeTransport,+    smallestEigenpairs,+    largestEigenpairs,+    powerIteration,+    traceMatrix,+    subtractFromDiagonal,+    basisVector,+  )+where++import Data.Function ((&))+import Data.Bifunctor (first)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Ord (Down (..))+import qualified Data.Set as Set+import qualified Data.Vector.Unboxed as U+import Moonlight.Core (spectralGap)+import Moonlight.Homology.Pure.Failure (HomologyFailure (..))+import Moonlight.Homology.Pure.Topology.Core+import Moonlight.LinAlg.Internal.Primitives (dotProduct, matrixVectorProduct, scaleVector, subVector, vectorNorm)+import Moonlight.LinAlg.Pure.Dense.Decomposition (symmetricEigenPairs)+import Moonlight.LinAlg.Pure.Krylov.Config (mkPositiveCount)+import Moonlight.LinAlg.Pure.Krylov.Selection (SpectrumEnd (SmallestEigenvalues))+import Moonlight.LinAlg.Pure.Operator (graphLaplacianLinearOperator)+import Moonlight.LinAlg.Pure.Sparse.Structured qualified as LinAlgSparse+import Moonlight.LinAlg.Pure.Sparse.Types (SparseCSR)+import Moonlight.LinAlg.Pure.Spectral.Request (EigenRequest (..))+import Moonlight.LinAlg.Pure.Spectral.Result (Eigenpairs, eigenpairValues, eigenpairVectorAt)+import Moonlight.LinAlg.Pure.Spectral.Solve+  ( EigenSolveConfig,+    defaultEigenSolveConfig,+    solveEigenRequest,+    withEigenFallbackInitialVector,+  )++data SparseSpectralConfig = SparseSpectralConfig+  { sscEigenSolveConfig :: !EigenSolveConfig+  }+  deriving stock (Eq, Show)++defaultSparseSpectralConfig :: SparseSpectralConfig+defaultSparseSpectralConfig =+  SparseSpectralConfig+    { sscEigenSolveConfig = defaultEigenSolveConfig+    }++graphLaplacian :: Graph1Skeleton -> [[Double]]+graphLaplacian skeleton =+  let vertexCount = graphVertexCount skeleton+      adjacency = graphAdjacency skeleton+   in enumerateFromZero vertexCount+        & fmap+          ( \rowIndexValue ->+              enumerateFromZero vertexCount+                & fmap+                  ( \columnIndexValue ->+                      laplacianEntry adjacency rowIndexValue columnIndexValue+                  )+          )++laplacianEntry :: Map.Map Int (Set.Set Int) -> Int -> Int -> Double+laplacianEntry adjacency rowIndexValue columnIndexValue =+  let degreeValue =+        adjacency+          & Map.findWithDefault Set.empty rowIndexValue+          & Set.size+          & fromIntegral+   in if rowIndexValue == columnIndexValue+        then degreeValue+        else+          if Set.member columnIndexValue (Map.findWithDefault Set.empty rowIndexValue adjacency)+            then -1.0+            else 0.0++weightedGraphLaplacian :: Int -> [(Int, Int, Double)] -> [[Double]]+weightedGraphLaplacian vertexCount weightedEdges =+  let adjacencyWeights = symmetricAdjacencyWeights vertexCount weightedEdges+      degreeWeights =+        Map.toList adjacencyWeights+          & foldr+            (\((sourceVertex, _), edgeWeight) -> Map.insertWith (+) sourceVertex edgeWeight)+            Map.empty+   in enumerateFromZero vertexCount+        & fmap+          (\rowIndexValue ->+             enumerateFromZero vertexCount+               & fmap (weightedLaplacianEntry adjacencyWeights degreeWeights rowIndexValue)+          )++weightedGraphSparseLaplacian :: Int -> [(Int, Int, Double)] -> Either HomologyFailure (SparseCSR Double)+weightedGraphSparseLaplacian vertexCount weightedEdges =+  if vertexCount < 0+    then Left (BackendFailure "weighted graph sparse Laplacian requires a non-negative vertex count")+    else+      LinAlgSparse.graphLaplacianCSR+        (enumerateFromZero vertexCount)+        (cleanedSparseGraphEdges vertexCount weightedEdges)+        & first (BackendFailure . show)++weightedGraphSpectralModes ::+  Int ->+  Int ->+  [(Int, Int, Double)] ->+  Either HomologyFailure [GraphSpectralMode]+weightedGraphSpectralModes requestedModeCount vertexCount weightedEdges+  | requestedModeCount <= 0 = Right []+  | vertexCount <= 0 = Right []+  | otherwise =+      let laplacian = weightedGraphLaplacian vertexCount weightedEdges+       in fmap (fmap toSpectralMode) (smallestEigenpairs requestedModeCount laplacian)++weightedGraphSparseSpectralModes ::+  SparseSpectralConfig ->+  Int ->+  Int ->+  [(Int, Int, Double)] ->+  Either HomologyFailure [GraphSpectralMode]+weightedGraphSparseSpectralModes config requestedModeCount vertexCount weightedEdges+  | requestedModeCount <= 0 = Right []+  | vertexCount <= 0 = Right []+  | otherwise = do+      let modeCount = min requestedModeCount vertexCount+          solveConfig =+            withEigenFallbackInitialVector+              (sparseSpectralSeed vertexCount)+              (sscEigenSolveConfig config)+      countValue <- first (BackendFailure . show) (mkPositiveCount modeCount)+      operatorValue <-+        first+          (BackendFailure . show)+          ( graphLaplacianLinearOperator+              (enumerateFromZero vertexCount)+              (cleanedSparseGraphEdges vertexCount weightedEdges)+          )+      eigenpairs <-+        solveEigenRequest+          solveConfig+          operatorValue+          (EigenpairsRequest SmallestEigenvalues countValue)+          & first (BackendFailure . show)+      eigenpairSpectralPairs eigenpairs+        & fmap (fmap toSpectralMode)++weightedGraphSpectralGap ::+  Int ->+  Int ->+  [(Int, Int, Double)] ->+  Either HomologyFailure (Maybe Double)+weightedGraphSpectralGap requestedModeCount vertexCount weightedEdges =+  fmap+    (spectralGap . fmap spectralEigenvalue)+    (weightedGraphSparseSpectralModes defaultSparseSpectralConfig requestedModeCount vertexCount weightedEdges)++leadingModeTransport :: [GraphSpectralMode] -> [GraphSpectralMode] -> Maybe Double+leadingModeTransport leftModes rightModes = do+  leftMode <- preferredMode leftModes+  rightMode <- preferredMode rightModes+  modeCosineSimilarity leftMode rightMode++smallestEigenpairs :: Int -> [[Double]] -> Either HomologyFailure [(Double, [Double])]+smallestEigenpairs requestedModeCount matrixRows =+  sortedSymmetricEigenpairs requestedModeCount matrixRows+    & fmap (List.sortOn fst)++largestEigenpairs :: Int -> [[Double]] -> Either HomologyFailure [(Double, [Double])]+largestEigenpairs requestedModeCount matrixRows =+  sortedSymmetricEigenpairs requestedModeCount matrixRows+    & fmap (List.sortOn (Down . fst))++sortedSymmetricEigenpairs :: Int -> [[Double]] -> Either HomologyFailure [(Double, [Double])]+sortedSymmetricEigenpairs requestedModeCount matrixRows =+  let matrixSize = length matrixRows+      modeCount = min requestedModeCount matrixSize+   in first+        (BackendFailure . show)+        (symmetricEigenPairs matrixSize matrixRows)+        & fmap (take modeCount)++powerIteration :: Int -> Double -> [[Double]] -> [Double] -> Either HomologyFailure (Double, [Double])+powerIteration iterationLimit tolerance matrixRows initialVector = do+  seedNorm <- liftLinAlg (vectorNorm initialVector)+  let seedVector =+        if seedNorm <= tolerance+          then basisVector (length initialVector) 0+          else scaleVector (1.0 / seedNorm) initialVector+  iterateStep 0 seedVector+  where+    liftLinAlg :: Show error => Either error value -> Either HomologyFailure value+    liftLinAlg = first (BackendFailure . show)+    iterateStep iterationIndex vectorValue+      | iterationIndex >= iterationLimit = Left (NonConvergent iterationLimit)+      | otherwise = do+          projectedVector <- liftLinAlg (matrixVectorProduct matrixRows vectorValue)+          projectedNorm <- liftLinAlg (vectorNorm projectedVector)+          if projectedNorm <= tolerance+            then Right (0.0, vectorValue)+            else do+              let nextVector = scaleVector (1.0 / projectedNorm) projectedVector+              imageVector <- liftLinAlg (matrixVectorProduct matrixRows nextVector)+              eigenvalueValue <- liftLinAlg (dotProduct nextVector imageVector)+              residualVector <- liftLinAlg (subVector imageVector (scaleVector eigenvalueValue nextVector))+              residualNorm <- liftLinAlg (vectorNorm residualVector)+              if residualNorm <= tolerance+                then Right (eigenvalueValue, nextVector)+                else iterateStep (iterationIndex + 1) nextVector++toSpectralMode :: (Double, [Double]) -> GraphSpectralMode+toSpectralMode (eigenvalueValue, eigenVectorValue) =+  let supportedCoefficients =+        eigenVectorValue+          & zip [0 :: Int ..]+          & filter (\(_, coefficientValue) -> abs coefficientValue > 1.0e-10)+      positiveSupport =+        supportedCoefficients+          & filter (\(_, coefficientValue) -> coefficientValue > 1.0e-10)+          & fmap fst+      negativeSupport =+        supportedCoefficients+          & filter (\(_, coefficientValue) -> coefficientValue < -1.0e-10)+          & fmap fst+      posSize = length positiveSupport+      negSize = length negativeSupport+      criticality = 1.0 / (1.0 + log (fromIntegral (1 + min posSize negSize)))+   in GraphSpectralMode+        { spectralEigenvalue = eigenvalueValue,+          spectralCoefficients = supportedCoefficients,+          spectralPositiveSupport = positiveSupport,+          spectralNegativeSupport = negativeSupport,+          spectralSupportCriticality = criticality+        }++traceMatrix :: [[Double]] -> Double+traceMatrix matrixRows =+  matrixRows+    & zip [0 :: Int ..]+    & foldl'+      ( \accumulator (rowIndexValue, rowValue) ->+          accumulator+            + case drop rowIndexValue rowValue of+              entryValue : _ -> entryValue+              [] -> 0.0+      )+      0.0++-- | @subtractFromDiagonal d m@ computes @d·I − m@ (note the orientation:+-- the matrix is subtracted FROM the scaled identity, not the reverse).+subtractFromDiagonal :: Double -> [[Double]] -> [[Double]]+subtractFromDiagonal diagonalValue matrixRows =+  matrixRows+    & zip [0 :: Int ..]+    & fmap+      ( \(rowIndexValue, rowValue) ->+          rowValue+            & zip [0 :: Int ..]+            & fmap+              ( \(columnIndexValue, entryValue) ->+                  if rowIndexValue == columnIndexValue+                    then diagonalValue - entryValue+                    else negate entryValue+              )+      )++basisVector :: Int -> Int -> [Double]+basisVector vectorSize selectedIndex =+  enumerateFromZero vectorSize+    & fmap (\indexValue -> if indexValue == selectedIndex then 1.0 else 0.0)++-- | Symmetrized edge weights with a documented cleaning contract: entries+-- with non-positive weight, out-of-range endpoints, or equal endpoints+-- (self-loops) are silently dropped rather than rejected — the Laplacian+-- consumers treat such input as absent edges. Callers needing validation+-- must check before lowering.+symmetricAdjacencyWeights :: Int -> [(Int, Int, Double)] -> Map.Map (Int, Int) Double+symmetricAdjacencyWeights vertexCount =+  foldr insertWeight Map.empty+  where+    insertWeight (sourceVertex, targetVertex, edgeWeight) accumulatedWeights+      | edgeWeight <= 0.0 = accumulatedWeights+      | sourceVertex < 0 || targetVertex < 0 = accumulatedWeights+      | sourceVertex >= vertexCount || targetVertex >= vertexCount = accumulatedWeights+      | sourceVertex == targetVertex = accumulatedWeights+      | otherwise =+          Map.insertWith (+) (sourceVertex, targetVertex) edgeWeight+            . Map.insertWith (+) (targetVertex, sourceVertex) edgeWeight+            $ accumulatedWeights++weightedLaplacianEntry ::+  Map.Map (Int, Int) Double ->+  Map.Map Int Double ->+  Int ->+  Int ->+  Double+weightedLaplacianEntry adjacencyWeights degreeWeights rowIndexValue columnIndexValue =+  if rowIndexValue == columnIndexValue+    then Map.findWithDefault 0.0 rowIndexValue degreeWeights+    else negate (Map.findWithDefault 0.0 (rowIndexValue, columnIndexValue) adjacencyWeights)++cleanedSparseGraphEdges ::+  Int ->+  [(Int, Int, Double)] ->+  [LinAlgSparse.GraphEdge Int]+cleanedSparseGraphEdges vertexCount =+  mapMaybe+    ( \(sourceVertex, targetVertex, edgeWeight) ->+        if edgeWeight <= 0.0+          || sourceVertex < 0+          || targetVertex < 0+          || sourceVertex >= vertexCount+          || targetVertex >= vertexCount+          || sourceVertex == targetVertex+          then Nothing+          else+            Just+              ( LinAlgSparse.GraphEdge+                  sourceVertex+                  targetVertex+                  edgeWeight+              )+    )++sparseSpectralSeed :: Int -> U.Vector Double+sparseSpectralSeed vertexCount =+  if vertexCount <= 0+    then U.empty+    else+      U.generate+        vertexCount+        (\indexValue -> 1.0 / fromIntegral (indexValue + 1))++eigenpairSpectralPairs :: Eigenpairs -> Either HomologyFailure [(Double, [Double])]+eigenpairSpectralPairs pairs =+  traverse eigenpairSpectralPair (U.toList (U.indexed (eigenpairValues pairs)))+  where+    eigenpairSpectralPair (columnIndex, eigenvalue) =+      eigenpairVectorAt columnIndex pairs+        & first (BackendFailure . show)+        & fmap (\eigenvector -> (eigenvalue, U.toList eigenvector))++preferredMode :: [GraphSpectralMode] -> Maybe GraphSpectralMode+preferredMode spectralModes =+  case filter ((> 1.0e-10) . spectralEigenvalue) spectralModes of+    preferredValue : _ -> Just preferredValue+    [] ->+      case spectralModes of+        firstMode : _ -> Just firstMode+        [] -> Nothing++modeCosineSimilarity :: GraphSpectralMode -> GraphSpectralMode -> Maybe Double+modeCosineSimilarity leftMode rightMode =+  let leftCoefficients = coefficientMap leftMode+      rightCoefficients = coefficientMap rightMode+      supportKeys = Set.union (Map.keysSet leftCoefficients) (Map.keysSet rightCoefficients)+      dotValue =+        supportKeys+          & foldr+            (\cellIndexValue ->+               (+)+                 ( Map.findWithDefault 0.0 cellIndexValue leftCoefficients+                     * Map.findWithDefault 0.0 cellIndexValue rightCoefficients+                 )+            )+            0.0+      leftNorm = normOf leftCoefficients+      rightNorm = normOf rightCoefficients+   in if leftNorm <= 1.0e-10 || rightNorm <= 1.0e-10+        then Nothing+        else Just (abs dotValue / (leftNorm * rightNorm))++coefficientMap :: GraphSpectralMode -> Map.Map Int Double+coefficientMap =+  Map.fromList . spectralCoefficients++normOf :: Map.Map Int Double -> Double+normOf coefficientValues =+  coefficientValues+    & Map.elems+    & fmap (\coefficientValue -> coefficientValue * coefficientValue)+    & sum+    & sqrt++gapFromModes :: [GraphSpectralMode] -> Maybe Double+gapFromModes = spectralGap . fmap spectralEigenvalue
+ src-topology/Moonlight/Homology/Pure/Topology/Target.hs view
@@ -0,0 +1,100 @@+module Moonlight.Homology.Pure.Topology.Target+  ( TopologyTarget (..),+    TargetViolation (..),+    topologyTargetConstraints,+    validateTarget,+    validateTargets,+    validateTopologyTarget,+    validateTopologyTargets,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Chain (TopologyWitness)+import Moonlight.Homology.Pure.Constraint.Algebra (evaluateTopologicalConstraints)+import Moonlight.Homology.Pure.Constraint.Core+  ( EulerBound,+    HarmonicLoopBudget,+    PersistenceBudget,+    SingularityBudget,+    SkeletonAdherence,+    TargetBetti,+    TopologicalConstraint+      ( EulerBoundConstraint,+        HarmonicLoopBudgetConstraint,+        PersistenceBudgetConstraint,+        SingularityBudgetConstraint,+        SkeletonAdherenceConstraint,+        TargetBettiConstraint+      ),+    TopologicalViolation,+  )+import Moonlight.Homology.Pure.Filtration (FiltrationValue)+import Moonlight.Homology.Pure.Topology.MacroScaffold (MacroScaffoldIR)++type TopologyTarget :: Type+data TopologyTarget+  = EulerTarget EulerBound+  | BettiTarget TargetBetti+  | PersistenceTarget PersistenceBudget+  | SingularityTarget SingularityBudget+  | HarmonicLoopTarget HarmonicLoopBudget+  | SkeletonTarget SkeletonAdherence+  deriving stock (Eq, Show)++type TargetViolation :: Type+data TargetViolation = TargetViolation+  { violatedTarget :: TopologyTarget,+    targetViolationCause :: TopologicalViolation+  }+  deriving stock (Eq, Show)++topologyTargetConstraints :: TopologyTarget -> [TopologicalConstraint]+topologyTargetConstraints targetValue =+  case targetValue of+    EulerTarget boundValue -> [EulerBoundConstraint boundValue]+    BettiTarget bettiValue -> [TargetBettiConstraint bettiValue]+    PersistenceTarget budgetValue -> [PersistenceBudgetConstraint budgetValue]+    SingularityTarget budgetValue -> [SingularityBudgetConstraint budgetValue]+    HarmonicLoopTarget budgetValue -> [HarmonicLoopBudgetConstraint budgetValue]+    SkeletonTarget adherenceValue -> [SkeletonAdherenceConstraint adherenceValue]++validateTarget ::+  TopologyTarget ->+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  Either TargetViolation ()+validateTarget targetValue witnessValue =+  validateTopologyTarget witnessValue targetValue++validateTargets ::+  [TopologyTarget] ->+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  Either [TargetViolation] ()+validateTargets targetValues witnessValue =+  validateTopologyTargets witnessValue targetValues++validateTopologyTarget ::+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  TopologyTarget ->+  Either TargetViolation ()+validateTopologyTarget witnessValue targetValue =+  case violationsForTarget witnessValue targetValue of+    [] -> Right ()+    violationValue : _ -> Left violationValue++validateTopologyTargets ::+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  [TopologyTarget] ->+  Either [TargetViolation] ()+validateTopologyTargets witnessValue targetValues =+  case targetValues >>= violationsForTarget witnessValue of+    [] -> Right ()+    violationValues -> Left violationValues++violationsForTarget ::+  TopologyWitness MacroScaffoldIR spectral FiltrationValue coefficient basis ->+  TopologyTarget ->+  [TargetViolation]+violationsForTarget witnessValue targetValue =+  evaluateTopologicalConstraints witnessValue (topologyTargetConstraints targetValue)+    >>= (\violationValue -> [TargetViolation targetValue violationValue])
+ src-topology/Moonlight/Homology/Pure/TopologyObserver.hs view
@@ -0,0 +1,195 @@+module Moonlight.Homology.Pure.TopologyObserver+  ( TopologyObserver,+    runTopologyObserver,+    WitnessInterpreter,+    mkWitnessInterpreter,+    runWitnessInterpreter,+    observeEulerCharacteristic,+    observeBettiVector,+    observeIntegralHomology,+    observeIntegralHomologyAt,+    observeTorsionFamily,+    observeExactRepresentativeClasses,+    observeExactRepresentativeClassCount,+    observePersistencePairs,+    observePersistenceCount,+    observeCoefficientRepresentativeCycles,+    observeCoefficientRepresentativeCycleCount,+    observeCoefficientRepresentativeCocycles,+    observeCoefficientRepresentativeCocycleCount,+    observeHarmonicBasis,+    observeHarmonicCount,+    observeMacroScaffold,+    observeScaffoldSummary,+    observeLowSpectralModes,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Chain+  ( EulerCharacteristic,+    ExactRepresentativeClass,+    HarmonicBasisElement,+    HomologicalDegree,+    PersistencePair,+    RepresentativeChain,+    TopologyWitness,+  )+import Moonlight.Homology.Pure.Graded.Query (DegreeSelection)+import Moonlight.Homology.Pure.GradedTorsion (GradedTorsionFamily)+import Moonlight.Homology.Pure.Group (HomologyGroup)+import Moonlight.Homology.Pure.TopologyView+  ( ScaffoldSummaryAlgebra,+    TopologyView,+    WitnessSlice,+    mkTopologyView,+    runWitnessSlice,+    topologyViewTorsionFamily,+    sliceBettiVector,+    sliceCoefficientRepresentativeCocycles,+    sliceCoefficientRepresentativeCycles,+    sliceEulerCharacteristic,+    sliceExactRepresentativeClasses,+    sliceHarmonicBasis,+    sliceIntegralHomology,+    sliceIntegralHomologyAt,+    sliceLowSpectralModes,+    sliceMacroScaffold,+    slicePersistencePairs,+    sliceScaffoldSummary,+  )++type TopologyObserver :: Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type+newtype TopologyObserver summary scaffold spectral persistence coefficient basis observed = TopologyObserver+  { runTopologyObserver :: TopologyView summary scaffold spectral persistence coefficient basis -> observed+  }++instance Functor (TopologyObserver summary scaffold spectral persistence coefficient basis) where+  fmap mapper (TopologyObserver observeValue) =+    TopologyObserver (mapper . observeValue)++instance Applicative (TopologyObserver summary scaffold spectral persistence coefficient basis) where+  pure value =+    TopologyObserver (const value)+  TopologyObserver observeFunction <*> TopologyObserver observeValue =+    TopologyObserver (\topologyViewValue -> observeFunction topologyViewValue (observeValue topologyViewValue))++type WitnessInterpreter :: Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type+newtype WitnessInterpreter summary scaffold spectral persistence coefficient basis observed = WitnessInterpreter+  { runWitnessInterpreter :: TopologyWitness scaffold spectral persistence coefficient basis -> observed+  }++mkWitnessInterpreter ::+  ScaffoldSummaryAlgebra scaffold summary ->+  TopologyObserver summary scaffold spectral persistence coefficient basis observed ->+  WitnessInterpreter summary scaffold spectral persistence coefficient basis observed+mkWitnessInterpreter summaryAlgebra (TopologyObserver observeValue) =+  WitnessInterpreter (observeValue . mkTopologyView summaryAlgebra)++observeWithSlice ::+  WitnessSlice summary scaffold spectral persistence coefficient basis observed ->+  TopologyObserver summary scaffold spectral persistence coefficient basis observed+observeWithSlice sliceValue =+  TopologyObserver (runWitnessSlice sliceValue)++observeEulerCharacteristic ::+  TopologyObserver summary scaffold spectral persistence coefficient basis (Maybe EulerCharacteristic)+observeEulerCharacteristic =+  observeWithSlice sliceEulerCharacteristic++observeBettiVector ::+  TopologyObserver summary scaffold spectral persistence coefficient basis [Int]+observeBettiVector =+  observeWithSlice sliceBettiVector++observeIntegralHomology ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [HomologyGroup Integer]+observeIntegralHomology selectionValue =+  observeWithSlice (sliceIntegralHomology selectionValue)++observeIntegralHomologyAt ::+  HomologicalDegree ->+  TopologyObserver summary scaffold spectral persistence coefficient basis (Maybe (HomologyGroup Integer))+observeIntegralHomologyAt degreeValue =+  observeWithSlice (sliceIntegralHomologyAt degreeValue)++observeTorsionFamily ::+  TopologyObserver summary scaffold spectral persistence coefficient basis GradedTorsionFamily+observeTorsionFamily =+  TopologyObserver topologyViewTorsionFamily++observeExactRepresentativeClasses ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [ExactRepresentativeClass basis]+observeExactRepresentativeClasses selectionValue =+  observeWithSlice (sliceExactRepresentativeClasses selectionValue)++observeExactRepresentativeClassCount ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis Int+observeExactRepresentativeClassCount selectionValue =+  length <$> observeExactRepresentativeClasses selectionValue++observePersistencePairs ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [PersistencePair persistence]+observePersistencePairs selectionValue =+  observeWithSlice (slicePersistencePairs selectionValue)++observePersistenceCount ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis Int+observePersistenceCount selectionValue =+  length <$> observePersistencePairs selectionValue++observeCoefficientRepresentativeCycles ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [RepresentativeChain coefficient basis]+observeCoefficientRepresentativeCycles selectionValue =+  observeWithSlice (sliceCoefficientRepresentativeCycles selectionValue)++observeCoefficientRepresentativeCycleCount ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis Int+observeCoefficientRepresentativeCycleCount selectionValue =+  length <$> observeCoefficientRepresentativeCycles selectionValue++observeCoefficientRepresentativeCocycles ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [RepresentativeChain coefficient basis]+observeCoefficientRepresentativeCocycles selectionValue =+  observeWithSlice (sliceCoefficientRepresentativeCocycles selectionValue)++observeCoefficientRepresentativeCocycleCount ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis Int+observeCoefficientRepresentativeCocycleCount selectionValue =+  length <$> observeCoefficientRepresentativeCocycles selectionValue++observeHarmonicBasis ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis [HarmonicBasisElement coefficient basis]+observeHarmonicBasis selectionValue =+  observeWithSlice (sliceHarmonicBasis selectionValue)++observeHarmonicCount ::+  DegreeSelection ->+  TopologyObserver summary scaffold spectral persistence coefficient basis Int+observeHarmonicCount selectionValue =+  length <$> observeHarmonicBasis selectionValue++observeMacroScaffold ::+  TopologyObserver summary scaffold spectral persistence coefficient basis (Maybe scaffold)+observeMacroScaffold =+  observeWithSlice sliceMacroScaffold++observeScaffoldSummary ::+  TopologyObserver summary scaffold spectral persistence coefficient basis (Maybe summary)+observeScaffoldSummary =+  observeWithSlice sliceScaffoldSummary++observeLowSpectralModes ::+  TopologyObserver summary scaffold spectral persistence coefficient basis [spectral]+observeLowSpectralModes =+  observeWithSlice sliceLowSpectralModes
+ src-topology/Moonlight/Homology/Pure/TopologyView.hs view
@@ -0,0 +1,164 @@+module Moonlight.Homology.Pure.TopologyView+  ( ScaffoldSummaryAlgebra,+    mkScaffoldSummaryAlgebra,+    runScaffoldSummaryAlgebra,+    TopologyView,+    WitnessSlice,+    mkTopologyView,+    runWitnessSlice,+    topologyViewTorsionFamily,+    sliceEulerCharacteristic,+    sliceBettiVector,+    sliceIntegralHomology,+    sliceIntegralHomologyAt,+    sliceExactRepresentativeClasses,+    slicePersistencePairs,+    sliceCoefficientRepresentativeCycles,+    sliceCoefficientRepresentativeCocycles,+    sliceHarmonicBasis,+    sliceMacroScaffold,+    sliceScaffoldSummary,+    sliceLowSpectralModes,+  )+where++import Data.Kind (Type)+import Moonlight.Homology.Pure.Chain+  ( EulerCharacteristic,+    ExactRepresentativeClass (..),+    HarmonicBasisElement (..),+    HomologicalDegree,+    PersistencePair (..),+    RepresentativeChain (..),+    TopologyWitness (..),+  )+import Moonlight.Homology.Pure.Graded.Query+  ( DegreeSelection,+    enumerateDegreeIndexed,+    lookupDegreeIndexed,+    selectDegreeIndexed,+    selectGradedMembers,+  )+import Moonlight.Homology.Pure.GradedTorsion+  ( GradedTorsionFamily,+    mkGradedTorsionFamily,+  )+import Moonlight.Homology.Pure.Group (HomologyGroup)++type ScaffoldSummaryAlgebra :: Type -> Type -> Type+newtype ScaffoldSummaryAlgebra scaffold summary = ScaffoldSummaryAlgebra+  { runScaffoldSummaryAlgebra :: scaffold -> summary+  }++mkScaffoldSummaryAlgebra :: (scaffold -> summary) -> ScaffoldSummaryAlgebra scaffold summary+mkScaffoldSummaryAlgebra = ScaffoldSummaryAlgebra++type TopologyView :: Type -> Type -> Type -> Type -> Type -> Type -> Type+data TopologyView summary scaffold spectral persistence coefficient basis = TopologyView+  { topologyViewEulerCharacteristic :: Maybe EulerCharacteristic,+    topologyViewBettiVector :: [Int],+    topologyViewIntegralHomology :: [(HomologicalDegree, HomologyGroup Integer)],+    topologyViewTorsionFamily :: GradedTorsionFamily,+    topologyViewExactRepresentativeClasses :: [ExactRepresentativeClass basis],+    topologyViewPersistencePairs :: [PersistencePair persistence],+    topologyViewCoefficientRepresentativeCycles :: [RepresentativeChain coefficient basis],+    topologyViewCoefficientRepresentativeCocycles :: [RepresentativeChain coefficient basis],+    topologyViewHarmonicBasis :: [HarmonicBasisElement coefficient basis],+    topologyViewMacroScaffold :: Maybe scaffold,+    topologyViewScaffoldSummary :: Maybe summary,+    topologyViewLowSpectralModes :: [spectral]+  }+  deriving stock (Eq, Show)++type WitnessSlice :: Type -> Type -> Type -> Type -> Type -> Type -> Type -> Type+newtype WitnessSlice summary scaffold spectral persistence coefficient basis observed = WitnessSlice+  { runWitnessSlice :: TopologyView summary scaffold spectral persistence coefficient basis -> observed+  }++mkTopologyView ::+  ScaffoldSummaryAlgebra scaffold summary ->+  TopologyWitness scaffold spectral persistence coefficient basis ->+  TopologyView summary scaffold spectral persistence coefficient basis+mkTopologyView summaryAlgebra witnessValue =+  let integralHomology = enumerateDegreeIndexed (topologyIntegralHomologyGroups witnessValue)+   in TopologyView+        { topologyViewEulerCharacteristic = topologyEulerCharacteristic witnessValue,+          topologyViewBettiVector = topologyBettiVector witnessValue,+          topologyViewIntegralHomology = integralHomology,+          topologyViewTorsionFamily = mkGradedTorsionFamily (topologyIntegralHomologyGroups witnessValue),+          topologyViewExactRepresentativeClasses = topologyExactRepresentativeClasses witnessValue,+          topologyViewPersistencePairs = topologyPersistencePairs witnessValue,+          topologyViewCoefficientRepresentativeCycles = topologyCoefficientRepresentativeCycles witnessValue,+          topologyViewCoefficientRepresentativeCocycles = topologyCoefficientRepresentativeCocycles witnessValue,+          topologyViewHarmonicBasis = topologyHarmonicBasis witnessValue,+          topologyViewMacroScaffold = topologyMacroScaffold witnessValue,+          topologyViewScaffoldSummary = runScaffoldSummaryAlgebra summaryAlgebra <$> topologyMacroScaffold witnessValue,+          topologyViewLowSpectralModes = topologyLowSpectralModes witnessValue+        }++sliceEulerCharacteristic ::+  WitnessSlice summary scaffold spectral persistence coefficient basis (Maybe EulerCharacteristic)+sliceEulerCharacteristic =+  WitnessSlice topologyViewEulerCharacteristic++sliceBettiVector ::+  WitnessSlice summary scaffold spectral persistence coefficient basis [Int]+sliceBettiVector =+  WitnessSlice topologyViewBettiVector++sliceIntegralHomology ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [HomologyGroup Integer]+sliceIntegralHomology selectionValue =+  WitnessSlice (\viewValue -> selectDegreeIndexed selectionValue (topologyViewIntegralHomology viewValue))++sliceIntegralHomologyAt ::+  HomologicalDegree ->+  WitnessSlice summary scaffold spectral persistence coefficient basis (Maybe (HomologyGroup Integer))+sliceIntegralHomologyAt degreeValue =+  WitnessSlice (\viewValue -> lookupDegreeIndexed degreeValue (topologyViewIntegralHomology viewValue))++sliceExactRepresentativeClasses ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [ExactRepresentativeClass basis]+sliceExactRepresentativeClasses selectionValue =+  WitnessSlice (\viewValue -> selectGradedMembers exactClassDegree selectionValue (topologyViewExactRepresentativeClasses viewValue))++slicePersistencePairs ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [PersistencePair persistence]+slicePersistencePairs selectionValue =+  WitnessSlice (\viewValue -> selectGradedMembers persistenceDegree selectionValue (topologyViewPersistencePairs viewValue))++sliceCoefficientRepresentativeCycles ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [RepresentativeChain coefficient basis]+sliceCoefficientRepresentativeCycles selectionValue =+  WitnessSlice (\viewValue -> selectGradedMembers representativeDegree selectionValue (topologyViewCoefficientRepresentativeCycles viewValue))++sliceCoefficientRepresentativeCocycles ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [RepresentativeChain coefficient basis]+sliceCoefficientRepresentativeCocycles selectionValue =+  WitnessSlice (\viewValue -> selectGradedMembers representativeDegree selectionValue (topologyViewCoefficientRepresentativeCocycles viewValue))++sliceHarmonicBasis ::+  DegreeSelection ->+  WitnessSlice summary scaffold spectral persistence coefficient basis [HarmonicBasisElement coefficient basis]+sliceHarmonicBasis selectionValue =+  WitnessSlice (\viewValue -> selectGradedMembers harmonicDegree selectionValue (topologyViewHarmonicBasis viewValue))++sliceMacroScaffold ::+  WitnessSlice summary scaffold spectral persistence coefficient basis (Maybe scaffold)+sliceMacroScaffold =+  WitnessSlice topologyViewMacroScaffold++sliceScaffoldSummary ::+  WitnessSlice summary scaffold spectral persistence coefficient basis (Maybe summary)+sliceScaffoldSummary =+  WitnessSlice topologyViewScaffoldSummary++sliceLowSpectralModes ::+  WitnessSlice summary scaffold spectral persistence coefficient basis [spectral]+sliceLowSpectralModes =+  WitnessSlice topologyViewLowSpectralModes
+ test-cell-category/Main.hs view
@@ -0,0 +1,131 @@+module Main (main) where++import Moonlight.Homology.Pure.Topology.CellCategory+  ( ComplexCat,+    ComplexMor (..),+    complexCategory,+  )+import Moonlight.Algebra.Pure.Orientation (Orientation (..))+import Moonlight.Category.Pure.FiniteComposable (FiniteComposableCategory (..))+import Moonlight.Category.Simplicial+  ( generatedSimplicesAtDimension,+    normalizedNerve,+    simplicesAtDimension,+    unnormalizedNerve,+  )+import Moonlight.Homology.Pure.Topology.CellComplex+  ( CellComplex2D (..),+    CellTypes (..),+    OrientedEdge (..),+  )+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), Assertion, assertBool, testCase)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "finite incidence category"+    [ testCase "enumerates every cell object and incidence morphism" enumerateTriangleCategory,+      testCase "generates one normalized 2-simplex per face-edge-vertex flag" generateTriangleFlagNerve,+      testCase "retains identity-saturated chains only in the unnormalized nerve" compareTriangleNerves+    ]++enumerateTriangleCategory :: Assertion+enumerateTriangleCategory = do+  length (enumerateObjects triangleCategory) @?= 7+  length morphisms @?= 22+  length (filter isIdentityMorphism morphisms) @?= 7+  length (filter isFaceEdgeMorphism morphisms) @?= 3+  length (filter isEdgeVertexMorphism morphisms) @?= 6+  length (filter isFaceVertexMorphism morphisms) @?= 6+  where+    morphisms = enumerateMorphisms triangleCategory++generateTriangleFlagNerve :: Assertion+generateTriangleFlagNerve =+  length (simplicesAtDimension (normalizedNerve triangleCategory 2) 2) @?= 6++compareTriangleNerves :: Assertion+compareTriangleNerves =+  let normalizedCount = length (simplicesAtDimension (normalizedNerve triangleCategory 2) 2)+      unnormalizedCount = length (generatedSimplicesAtDimension (unnormalizedNerve triangleCategory 2) 2)+   in assertBool+        "the unnormalized nerve retains identity-inserted two-simplices"+        (unnormalizedCount > normalizedCount)++isIdentityMorphism :: ComplexMor TriangleComplex -> Bool+isIdentityMorphism morphism =+  case morphism of+    IdentityMor _ -> True+    _ -> False++isFaceEdgeMorphism :: ComplexMor TriangleComplex -> Bool+isFaceEdgeMorphism morphism =+  case morphism of+    FaceToEdge _ _ _ -> True+    _ -> False++isEdgeVertexMorphism :: ComplexMor TriangleComplex -> Bool+isEdgeVertexMorphism morphism =+  case morphism of+    EdgeToVertex _ _ -> True+    _ -> False++isFaceVertexMorphism :: ComplexMor TriangleComplex -> Bool+isFaceVertexMorphism morphism =+  case morphism of+    FaceToVertex _ _ _ -> True+    _ -> False++data TriangleComplex = TriangleComplex++data TriangleVertex+  = VertexZero+  | VertexOne+  | VertexTwo+  deriving stock (Eq, Ord, Show)++data TriangleEdge+  = EdgeZeroOne+  | EdgeOneTwo+  | EdgeTwoZero+  deriving stock (Eq, Ord, Show)++data TriangleFace = TriangleFace+  deriving stock (Eq, Ord, Show)++instance CellTypes TriangleComplex where+  type Vertex TriangleComplex = TriangleVertex+  type Edge TriangleComplex = TriangleEdge+  type Face TriangleComplex = TriangleFace++instance CellComplex2D TriangleComplex where+  vertices _ = [VertexZero, VertexOne, VertexTwo]+  edges _ = [EdgeZeroOne, EdgeOneTwo, EdgeTwoZero]+  faces _ = [TriangleFace]++  edgeBoundary _ edgeValue =+    case edgeValue of+      EdgeZeroOne -> (VertexZero, VertexOne)+      EdgeOneTwo -> (VertexOne, VertexTwo)+      EdgeTwoZero -> (VertexTwo, VertexZero)++  faceBoundary _ TriangleFace =+    [ OrientedEdge EdgeZeroOne Positive,+      OrientedEdge EdgeOneTwo Positive,+      OrientedEdge EdgeTwoZero Positive+    ]++  edgesAtVertex _ vertexValue =+    case vertexValue of+      VertexZero -> [EdgeZeroOne, EdgeTwoZero]+      VertexOne -> [EdgeZeroOne, EdgeOneTwo]+      VertexTwo -> [EdgeOneTwo, EdgeTwoZero]++  facesAtEdge _ _ = (Just TriangleFace, Nothing)++triangleCategory :: ComplexCat TriangleComplex+triangleCategory = complexCategory TriangleComplex
+ test/Main.hs view
@@ -0,0 +1,385 @@++module Main (main) where++import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.Kind (Type)+import Data.List.NonEmpty (toList)+import qualified Data.Map.Strict as Map+import Moonlight.Core (mkCapability)+import Moonlight.Homology+import Moonlight.Homology.Boundary.Finite (mkFiniteChainComplex)+import Moonlight.Homology.Effect.Laws+import Moonlight.Homology.Effect.Determinism+import BlockSchurSpec qualified+import CompileFailSpec qualified+import FieldBettiSpec qualified+import GF2GraphSpec qualified+import MorseSpec qualified+import PresentationSpec qualified+import SpectralSpec qualified+import TestFixtures+  ( GenuineGoldenCase (..),+    genuineGoldenCorpus,+    triangleCycleComplex,+  )+import TopologySpec qualified+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)+import qualified Test.Tasty.QuickCheck as QC++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "moonlight-homology"+    [ materializeBoundaryTest,+      orderedBoundaryIncidenceConstructorTests,+      FieldBettiSpec.tests,+      GF2GraphSpec.tests,+      BlockSchurSpec.tests,+      materializeBoundaryRejectsMissingTargetTest,+      incidenceScopeGuardrailTest,+      bettiPhase2CapabilityTest,+      spectralPhase4CapabilityTest,+      SpectralSpec.tests,+      CompileFailSpec.tests,+      lawSuiteTests,+      reductionWitnessValidationTests,+      effectiveHomologyConstructionTest,+      goldenCorpusTests,+      determinismHarnessTests,+      MorseSpec.tests,+      PresentationSpec.tests,+      TopologySpec.tests+    ]++emptyIntFiniteComplex :: FiniteChainComplex Int+emptyIntFiniteComplex =+  mkFiniteChainComplex (HomologicalDegree 0) (const emptyBoundaryIncidence)++identityIntReduction :: Reduction large small Int Int Int+identityIntReduction =+  Reduction+    { projection = ChainMap (\basisValue -> [(1 :: Int, basisValue)]),+      inclusion = ChainMap (\basisValue -> [(1 :: Int, basisValue)]),+      homotopy = ChainHomotopy (const [])+    }++emptyIntBoundary :: Int -> [(Int, Int)]+emptyIntBoundary = const []++failingIntBoundary :: Int -> [(Int, Int)]+failingIntBoundary basisValue = [(1 :: Int, basisValue)]++emptyReductionLawContext :: ReductionLawContext Int Int Int+emptyReductionLawContext =+  ReductionLawContext+    { sampledLargeBasis = [0 :: Int, 1],+      sampledSmallBasis = [0 :: Int, 1],+      largeBoundary = emptyIntBoundary,+      smallBoundary = emptyIntBoundary+    }++failingReductionLawContext :: ReductionLawContext Int Int Int+failingReductionLawContext =+  ReductionLawContext+    { sampledLargeBasis = [0 :: Int, 1],+      sampledSmallBasis = [0 :: Int, 1],+      largeBoundary = failingIntBoundary,+      smallBoundary = emptyIntBoundary+    }++materializeBoundaryTest :: TestTree+materializeBoundaryTest =+  testCase "materializeBoundary builds deterministic incidence entries" $ do+    let boundaryOf simplex =+          case simplex of+            (2 :: Int) -> [(1 :: Int, 10 :: Int), (1, 11)]+            _ -> []+        incidenceResult = materializeIncidenceBoundary boundaryOf [2] [10, 11]+        expectedEntries =+          [ mkBoundaryEntry 0 0 (1 :: Int),+            mkBoundaryEntry 0 1 (1 :: Int)+          ]+    case incidenceResult of+      Left failureValue -> assertFailure ("unexpected failure: " <> show failureValue)+      Right incidence -> assertEqual "incidence entries" expectedEntries (boundaryEntries incidence)++orderedBoundaryIncidenceConstructorTests :: TestTree+orderedBoundaryIncidenceConstructorTests =+  testGroup+    "ordered boundary incidence constructor"+    [ testCase "combines adjacent duplicate coordinates without map canonicalization" $ do+        let entries =+              [ mkBoundaryEntry 0 0 (1 :: Int),+                mkBoundaryEntry 0 0 (-1 :: Int),+                mkBoundaryEntry 0 1 (2 :: Int)+              ]+        assertEqual+          "ordered constructor preserves canonical semantics"+          (mkBoundaryIncidence 2 2 entries)+          (mkBoundaryIncidenceFromOrderedEntries 2 2 entries),+      testCase "falls back to canonical construction for unordered entries" $ do+        let entries =+              [ mkBoundaryEntry 1 0 (3 :: Int),+                mkBoundaryEntry 0 1 (5 :: Int)+              ]+        assertEqual+          "unordered entries still use canonical semantics"+          (mkBoundaryIncidence 2 2 entries)+          (mkBoundaryIncidenceFromOrderedEntries 2 2 entries),+      testCase "rejects out-of-bounds entries before fast construction" $+        assertEqual+          "out-of-bounds entry"+          (Left (BoundaryIncidenceEntryOutOfBounds 2 0 2 2))+          ( mkBoundaryIncidenceFromOrderedEntries+              2+              2+              [mkBoundaryEntry 2 0 (1 :: Int)]+          )+    ]++materializeBoundaryRejectsMissingTargetTest :: TestTree+materializeBoundaryRejectsMissingTargetTest =+  testCase "materializeBoundary rejects targets missing from the basis instead of dropping them" $ do+    let boundaryOf (_ :: Int) = [(1 :: Int, 12 :: Int)]+    assertEqual+      "missing target is rejected"+      (Left (InvalidBoundaryIncidence "boundary target is absent from the target basis"))+      (materializeIncidenceBoundary boundaryOf [2 :: Int] [10 :: Int, 11 :: Int])++incidenceScopeGuardrailTest :: TestTree+incidenceScopeGuardrailTest =+  testCase "portal edges are rejected by incidence materialization" $ do+    let boundaryOf (_ :: Int) =+          [(1 :: Int, ScopedBoundary PortalScope (10 :: Int))]+        result = materializeBoundary boundaryOf [2 :: Int] [10 :: Int]+    assertEqual "portal scope violation" (Left (LawViolation IncidenceScopeLaw)) result++bettiPhase2CapabilityTest :: TestTree+bettiPhase2CapabilityTest =+  testCase "phase 2 betti capability executes reducer" $ do+    assertEqual+      "betti output"+      (Right [HomologyGroup {freeRank = 1, torsionInvariants = [] :: [Int]}])+      ( computeBettiNumbers+          ( mkCapability+              @RequirePhase2+              @'Phase2+              (BettiReducer (\_ -> Right [HomologyGroup {freeRank = 1, torsionInvariants = [] :: [Int]}]))+          )+          emptyIntFiniteComplex+      )++spectralPhase4CapabilityTest :: TestTree+spectralPhase4CapabilityTest =+  testCase "phase 4 spectral capability advances page index" $ do+    let page0 =+          SpectralPage+            { pageIndex = 0,+              groupAt = \_ _ -> HomologyGroup {freeRank = 0, torsionInvariants = [] :: [Int]},+              diffMap = \_ _ -> FormalMap {formalMatrix = [], formalDomainBasis = [], formalCodomainBasis = []},+              pageEntryMap = Map.empty,+              pageDifferentialMap = Map.empty,+              pageAdvanceSource = Nothing,+              pageAdvanceState = Nothing+            }+    assertEqual+      "advanced index"+      (Right 1)+      ( pageIndex+          <$> nextPage+            (mkCapability @RequirePhase4 @'Phase4 (SpectralAdvance (\page -> Right (page {pageIndex = pageIndex page + 1}))))+            page0+      )++lawSuiteTests :: TestTree+lawSuiteTests =+  testGroup+    "laws"+    [ testCase "boundary nilpotence holds on oriented interval complex" $ do+        assertEqual "nilpotence" (Right ()) (checkBoundaryNilpotence orientedIntervalBoundary [V0, V1, E01]),+      testCase "reduction laws hold for identity reduction" $ do+        assertEqual "left inverse" (Right ()) (checkReductionLeftInverse identityIntReduction [0 :: Int, 1, 2])+        assertEqual "homotopy" (Right ()) (checkReductionHomotopy emptyIntBoundary identityIntReduction [0 :: Int, 1, 2]),+      testCase "reduction law harness accepts a real Morse reduction on the triangle cycle" realMorseReductionLawHarnessTest,+      QC.testProperty "normalization is idempotent" $+        \(terms :: [(Int, Int)]) ->+          normalizeCombination (normalizeCombination terms) == normalizeCombination terms+    ]++reductionWitnessValidationTests :: TestTree+reductionWitnessValidationTests =+  testCase "effective homology validation accumulates sampled law violations" $ do+    case mkEffectiveHomology "large" "small" identityIntReduction (mkReductionChecksFromSamples failingReductionLawContext) emptyIntFiniteComplex of+      Invalid violations ->+        let expectedViolations =+              [ ProjectionChainMapViolation (LawViolation ReductionProjectionChainMapLaw)+              , InclusionChainMapViolation (LawViolation ReductionInclusionChainMapLaw)+              ]+         in assertBool+              "expected both chain-map violations"+              (expectedViolations & all (`elem` toList violations))+      Valid _ -> assertFailure "expected sampled reduction validation failure"++effectiveHomologyConstructionTest :: TestTree+effectiveHomologyConstructionTest =+  testCase "effective homology constructor requires validated reduction" $ do+    case mkEffectiveHomology "large" "small" identityIntReduction (mkReductionChecksFromSamples emptyReductionLawContext) emptyIntFiniteComplex of+      Invalid violations ->+        assertFailure ("unexpected effective homology construction failure: " <> show (toList violations))+      Valid effective ->+        assertEqual "source retained" "large" (sourceComplex effective)++type IntervalCell :: Type+data IntervalCell+  = V0+  | V1+  | E01+  deriving stock (Eq, Ord, Show)++orientedIntervalBoundary :: IntervalCell -> [(Int, IntervalCell)]+orientedIntervalBoundary basis =+  case basis of+    V0 -> []+    V1 -> []+    E01 -> [(1 :: Int, V1), (-1, V0)]++goldenCorpusTests :: TestTree+goldenCorpusTests =+  testGroup+    "golden-corpus"+    [ testCase "genuine golden corpus includes interval, triangle cycle, and tetrahedron boundary" $+        assertEqual+          "space names"+          ["interval", "triangle cycle", "tetrahedron boundary"]+          (fmap genuineGoldenName genuineGoldenCorpus),+      testCase "genuine golden corpus Betti vectors are computed by the Smith backend" $+        traverse_ assertGenuineGoldenBetti genuineGoldenCorpus,+      testCase "Euler characteristic compares cell counts against pipeline Betti numbers" $+        traverse_ assertGenuineGoldenEuler genuineGoldenCorpus,+      testCase "genuine golden fixtures are not all-zero boundary theater" $+        assertEqual+          "nonzero boundary support"+          [True, True, True]+          (fmap (hasNonzeroBoundary . genuineGoldenComplex) genuineGoldenCorpus)+    ]++determinismHarnessTests :: TestTree+determinismHarnessTests =+  testGroup+    "determinism"+    [ testCase "boundary fingerprints are permutation invariant" $ do+        let basisFingerprintA = fingerprintBasis ([3 :: Int, 1, 2])+            basisFingerprintB = fingerprintBasis ([2 :: Int, 3, 1])+            reductionFingerprintA = fingerprintReductionImage [(2 :: Int, "alpha"), (3, "beta")]+            reductionFingerprintB = fingerprintReductionImage [(3 :: Int, "beta"), (2, "alpha")]+        assertEqual "basis fingerprint invariant" basisFingerprintA basisFingerprintB+        assertEqual "reduction fingerprint invariant" reductionFingerprintA reductionFingerprintB,+      testCase "genuine golden complex fingerprints are deterministic" $ do+        let stablePairs =+              genuineGoldenCorpus+                & fmap (\goldenCase -> let fingerprintValue = fingerprintFiniteChainComplex (genuineGoldenComplex goldenCase) in [fingerprintValue, fingerprintValue])+            pairResults =+              stablePairs+                & fmap verifyDeterministicFingerprints+                & all (either (const False) (const True))+        assertBool "pairwise deterministic verification" pairResults+    ]++realMorseReductionLawHarnessTest :: IO ()+realMorseReductionLawHarnessTest =+  case morseComplex triangleCycleComplex (acyclicMatching triangleCycleComplex (const 0)) of+    Left failureValue ->+      assertFailure ("unexpected Morse construction failure: " <> show failureValue)+    Right morseValue -> do+      let reduction =+            Reduction+              { projection = mcProjection morseValue,+                inclusion = mcInclusion morseValue,+                homotopy = mcHomotopy morseValue+              }+          reducedComplex = mcReducedComplex morseValue+          lawContext =+            ReductionLawContext+              { sampledLargeBasis = basisRefsOf triangleCycleComplex,+                sampledSmallBasis = basisRefsOf reducedComplex,+                largeBoundary = boundaryOfBasisRef triangleCycleComplex,+                smallBoundary = boundaryOfBasisRef reducedComplex+              }+      assertBool+        "Morse reduction must actually collapse cells"+        (length (sampledSmallBasis lawContext) < length (sampledLargeBasis lawContext))+      case mkReductionWitness reduction (mkReductionChecksFromSamples lawContext) of+        Invalid violations ->+          assertFailure ("unexpected Morse reduction law violations: " <> show (toList violations))+        Valid _ ->+          pure ()++assertGenuineGoldenBetti :: GenuineGoldenCase -> IO ()+assertGenuineGoldenBetti goldenCase = do+  groups <- expectHomologyGroups goldenCase+  assertEqual+    (genuineGoldenName goldenCase <> " Betti vector")+    (genuineGoldenBetti goldenCase)+    (fmap freeRank groups)++assertGenuineGoldenEuler :: GenuineGoldenCase -> IO ()+assertGenuineGoldenEuler goldenCase = do+  groups <- expectHomologyGroups goldenCase+  assertEqual+    (genuineGoldenName goldenCase <> " Euler characteristic")+    (alternatingSum (genuineGoldenCellCounts goldenCase))+    (alternatingSum (fmap freeRank groups))++expectHomologyGroups :: GenuineGoldenCase -> IO [HomologyGroup Integer]+expectHomologyGroups goldenCase =+  case runHomologyBackend (IntegralSmithBackend :: HomologyBackend Integer Integer) (genuineGoldenComplex goldenCase) of+    Left failureValue ->+      assertFailure ("unexpected homology failure for " <> genuineGoldenName goldenCase <> ": " <> show failureValue)+    Right groups ->+      pure groups++alternatingSum :: [Int] -> Int+alternatingSum values =+  sum (zipWith signedTerm [0 :: Int ..] values)++signedTerm :: Int -> Int -> Int+signedTerm indexValue value =+  if even indexValue+    then value+    else negate value++basisRefsOf :: FiniteChainComplex r -> [BasisCellRef]+basisRefsOf finite =+  case maxHomologicalDegree finite of+    HomologicalDegree maxDegreeValue ->+      [0 .. maxDegreeValue]+        >>= finiteChainBasisRefsAtDegree finite . HomologicalDegree++boundaryOfBasisRef :: FiniteChainComplex r -> BasisCellRef -> [(r, BasisCellRef)]+boundaryOfBasisRef finite basisCellRef =+  case cellDegree basisCellRef of+    HomologicalDegree degreeValue+      | degreeValue <= 0 -> []+      | otherwise ->+          incidenceMatrixAt finite (HomologicalDegree degreeValue)+            & boundaryEntries+            & filter ((== cellIndex basisCellRef) . sourceIndex)+            & fmap+              ( \entry ->+                  ( boundaryCoefficient entry,+                    BasisCellRef+                      { cellDegree = HomologicalDegree (degreeValue - 1),+                        cellIndex = targetIndex entry+                      }+                  )+              )++hasNonzeroBoundary :: FiniteChainComplex r -> Bool+hasNonzeroBoundary finite =+  basisRefsOf finite+    & any (not . null . boundaryOfBasisRef finite)
+ test/facade/CompileFailSpec.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}++module CompileFailSpec (tests) where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Pale.TestSupport.CompileDiagnostics+  ( CompileDiagnosticsSession,+    DiagnosticSnapshot (..),+    GhcPackageSpec (..),+    SnapshotExit (..),+    compileFixtures,+    normalizeSnapshot,+    openCompileDiagnosticsSession,+    readSnapshot,+    renderFixtureFailure,+    renderResourcePathError,+    renderSnapshotFileFailure,+    resolveCompilerRoot,+    snapshotRefreshEnabled,+    writeSnapshot,+  )+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup, withResource)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++type FixtureCase :: Type+data FixtureCase = FixtureCase+  { fixtureCaseLabel :: !String,+    fixtureRelativePath :: !FilePath,+    fixtureSnapshotFile :: !FilePath,+    fixtureExpectedExit :: !SnapshotExit+  }+  deriving stock (Eq, Show)++tests :: TestTree+tests =+  withResource acquireCompileContext (const (pure ())) $ \getCompileContext ->+    testGroup "compile-fixtures" (map (buildFixtureCase getCompileContext) fixtureCases)++fixtureCases :: [FixtureCase]+fixtureCases =+  [ FixtureCase+      { fixtureCaseLabel = "phase 2 capability compiles in dedicated fixture runner",+        fixtureRelativePath = "CompilePass" </> "Phase2Betti.hs",+        fixtureSnapshotFile = "CompilePass.Phase2Betti.snapshot.json",+        fixtureExpectedExit = SnapshotSuccess+      },+    FixtureCase+      { fixtureCaseLabel = "public API cleanup exposes safe names",+        fixtureRelativePath = "CompilePass" </> "PublicApiCleanup.hs",+        fixtureSnapshotFile = "CompilePass.PublicApiCleanup.snapshot.json",+        fixtureExpectedExit = SnapshotSuccess+      },+    FixtureCase+      { fixtureCaseLabel = "phase 1 betti capability fails at compile-time",+        fixtureRelativePath = "CompileFail" </> "Phase1BettiLeak.hs",+        fixtureSnapshotFile = "CompileFail.Phase1BettiLeak.snapshot.json",+        fixtureExpectedExit = SnapshotFailure+      },+    FixtureCase+      { fixtureCaseLabel = "phase 2 spectral capability fails at compile-time",+        fixtureRelativePath = "CompileFail" </> "Phase2SpectralLeak.hs",+        fixtureSnapshotFile = "CompileFail.Phase2SpectralLeak.snapshot.json",+        fixtureExpectedExit = SnapshotFailure+      }+  ]++buildFixtureCase ::+  IO (FilePath, CompileDiagnosticsSession) ->+  FixtureCase ->+  TestTree+buildFixtureCase getCompileContext fixtureCase =+  testCase (fixtureCaseLabel fixtureCase) $+    assertFixtureSnapshot getCompileContext fixtureCase++assertFixtureSnapshot ::+  IO (FilePath, CompileDiagnosticsSession) ->+  FixtureCase ->+  IO ()+assertFixtureSnapshot getCompileContext fixtureCase = do+  (compilerRoot, session) <- getCompileContext+  let fixturesRelativeRoot =+        "foundation"+          </> "moonlight-homology"+          </> "test"+          </> "fixtures"+      fixturesRoot = compilerRoot </> fixturesRelativeRoot+      compilerRelativeFixturePath = fixturesRelativeRoot </> fixtureRelativePath fixtureCase+      fixturePath = compilerRoot </> compilerRelativeFixturePath+      snapshotPath = fixturesRoot </> "Snapshots" </> fixtureSnapshotFile fixtureCase++  refreshSnapshots <-+    either (assertFailure . renderSnapshotFileFailure) pure+      =<< snapshotRefreshEnabled+  result <-+    expectRight+      =<< compileFixtures session fixturePackageIds (fixturePath :| [])++  let actualSnapshot =+        normalizeSnapshot compilerRoot compilerRelativeFixturePath result++  assertEqual+    "fixture exit mode mismatch"+    (fixtureExpectedExit fixtureCase)+    (snapshotExit actualSnapshot)++  case snapshotExit actualSnapshot of+    SnapshotSuccess ->+      assertBool+        "compile-pass fixture must emit zero structured error diagnostics"+        (null (snapshotDiagnostics actualSnapshot))+    SnapshotFailure ->+      assertBool+        "compile-fail fixture must emit at least one structured error diagnostic"+        (not (null (snapshotDiagnostics actualSnapshot)))++  if refreshSnapshots+    then+      writeSnapshot snapshotPath actualSnapshot+        >>= either (assertFailure . renderSnapshotFileFailure) pure+    else do+      expectedSnapshotResult <- readSnapshot snapshotPath+      expectedSnapshot <-+        case expectedSnapshotResult of+          Left snapshotFailure ->+            assertFailure (renderSnapshotFileFailure snapshotFailure)+          Right snapshotValue -> pure snapshotValue++      assertEqual+        ( "snapshot mismatch for fixture: "+            <> fixtureRelativePath fixtureCase+            <> "\n"+            <> renderFixtureFailure result+        )+        expectedSnapshot+        actualSnapshot++acquireCompileContext :: IO (FilePath, CompileDiagnosticsSession)+acquireCompileContext = do+  compilerRootResult <-+    resolveCompilerRoot+      ( "foundation"+          </> "moonlight-homology"+          </> "moonlight-homology.cabal"+      )+  case compilerRootResult of+    Left errorMessage -> assertFailure (renderResourcePathError errorMessage)+    Right compilerRoot -> do+      session <- expectRight =<< openCompileDiagnosticsSession compilerRoot+      pure (compilerRoot, session)++-- Unit ids, not names: a bare name leaves every other exposed version of the+-- same package visible, which reports as an ambiguous module rather than as a+-- fixture verdict.+fixturePackageIds :: [GhcPackageSpec]+fixturePackageIds =+  [GhcPackageId "moonlight-homology-0.1.0.0-inplace"]++expectRight ::+  Show left =>+  Either left right ->+  IO right+expectRight result =+  case result of+    Left failureValue ->+      assertFailure (show failureValue)+    Right value ->+      pure value
+ test/facade/PresentationSpec.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DataKinds #-}++module PresentationSpec+  ( tests,+  )+where++import Moonlight.Homology+import Moonlight.Homology.Presentation+  ( ChainBuildError (..),+    ChainSpec (..),+    compileChain,+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+  ( Assertion,+    assertEqual,+    assertFailure,+    testCase,+  )++tests :: TestTree+tests =+  testGroup+    "equational chain presentation"+    [ testCase "simplicial circle has Betti (1,1) over the rationals" testCircleAnchor,+      testCase "boundary of the tetrahedron has Betti (1,0,1) over the rationals" testSphereAnchor,+      testCase "CW torus has Betti (1,2,1) over the rationals" testTorusAnchor,+      testCase "CW projective plane separates rational and GF2 Betti" testProjectivePlaneAnchor,+      testCase "compile refuses ragged, out-of-bounds, and non-nilpotent specs" testCompileRefusals+    ]++testCircleAnchor :: Assertion+testCircleAnchor = do+  circleComplex <- expectCompiled (compileChain simplicialCircle)+  circleGroups <- rationalBetti circleComplex+  assertEqual "circle Betti" [1, 1] (fmap freeRank circleGroups)++testSphereAnchor :: Assertion+testSphereAnchor = do+  sphereComplex <- expectCompiled (compileChain tetrahedronBoundary)+  sphereGroups <- rationalBetti sphereComplex+  assertEqual "sphere Betti" [1, 0, 1] (fmap freeRank sphereGroups)++testTorusAnchor :: Assertion+testTorusAnchor = do+  torusComplex <- expectCompiled (compileChain cwTorus)+  torusGroups <- rationalBetti torusComplex+  assertEqual "torus Betti" [1, 2, 1] (fmap freeRank torusGroups)++testProjectivePlaneAnchor :: Assertion+testProjectivePlaneAnchor = do+  rationalComplex <- expectCompiled (compileChain (cwProjectivePlane :: ChainSpec Rational))+  rationalGroups <- rationalBetti rationalComplex+  assertEqual "rational projective plane Betti" [1, 0, 0] (fmap freeRank rationalGroups)+  parityComplex <- expectCompiled (compileChain (cwProjectivePlane :: ChainSpec GF2))+  parityGroups <- gf2Betti parityComplex+  assertEqual "GF2 projective plane Betti" [1, 1, 1] (fmap freeRank parityGroups)++testCompileRefusals :: Assertion+testCompileRefusals = do+  expectRefusal+    (ChainBuildBoundaryCountMismatch 1 0)+    (compileChain (ChainSpec {chainCellCounts = [2, 2], chainBoundaries = []} :: ChainSpec Rational))+  case compileChain (ChainSpec {chainCellCounts = [1, 1], chainBoundaries = [[(0, 5, 1)]]} :: ChainSpec Rational) of+    Left (ChainBuildIncidenceFault 1 _) ->+      pure ()+    otherResult ->+      assertFailure ("expected incidence refusal, got " <> show (() <$ otherResult))+  expectRefusal+    (ChainBuildComplexFault (ChainComplexNilpotenceViolation 1))+    ( compileChain+        ( ChainSpec+            { chainCellCounts = [1, 1, 1],+              chainBoundaries = [[(0, 0, 1)], [(0, 0, 1)]]+            } ::+            ChainSpec Rational+        )+    )+  where+    expectRefusal :: ChainBuildError -> Either ChainBuildError (FiniteChainComplex Rational) -> Assertion+    expectRefusal expectedFault result =+      case result of+        Left observedFault ->+          assertEqual "refusal fault" expectedFault observedFault+        Right _ ->+          assertFailure "expected refusal, got acceptance"++simplicialCircle :: ChainSpec Rational+simplicialCircle =+  ChainSpec+    { chainCellCounts = [3, 3],+      chainBoundaries =+        [ [ (0, 1, 1),+            (0, 0, -1),+            (1, 2, 1),+            (1, 0, -1),+            (2, 2, 1),+            (2, 1, -1)+          ]+        ]+    }++tetrahedronBoundary :: ChainSpec Rational+tetrahedronBoundary =+  ChainSpec+    { chainCellCounts = [4, 6, 4],+      chainBoundaries =+        [ [ (0, 1, 1),+            (0, 0, -1),+            (1, 2, 1),+            (1, 0, -1),+            (2, 3, 1),+            (2, 0, -1),+            (3, 2, 1),+            (3, 1, -1),+            (4, 3, 1),+            (4, 1, -1),+            (5, 3, 1),+            (5, 2, -1)+          ],+          [ (0, 3, 1),+            (0, 1, -1),+            (0, 0, 1),+            (1, 4, 1),+            (1, 2, -1),+            (1, 0, 1),+            (2, 5, 1),+            (2, 2, -1),+            (2, 1, 1),+            (3, 5, 1),+            (3, 4, -1),+            (3, 3, 1)+          ]+        ]+    }++cwTorus :: ChainSpec Rational+cwTorus =+  ChainSpec+    { chainCellCounts = [1, 2, 1],+      chainBoundaries = [[], []]+    }++cwProjectivePlane :: Num r => ChainSpec r+cwProjectivePlane =+  ChainSpec+    { chainCellCounts = [1, 1, 1],+      chainBoundaries = [[], [(0, 0, 2)]]+    }++rationalBetti :: FiniteChainComplex Rational -> IO [HomologyGroup Rational]+rationalBetti =+  expectRight+    . computeBettiNumbers (fieldBettiCapability RationalFieldRankBackend :: BettiCapability 'Phase2 Rational)++gf2Betti :: FiniteChainComplex GF2 -> IO [HomologyGroup GF2]+gf2Betti =+  expectRight+    . computeBettiNumbers (fieldBettiCapability GF2FieldRankBackend :: BettiCapability 'Phase2 GF2)++expectCompiled :: Either ChainBuildError (FiniteChainComplex r) -> IO (FiniteChainComplex r)+expectCompiled =+  either (assertFailure . ("compileChain refused a lawful spec: " <>) . show) pure++expectRight :: Show left => Either left right -> IO right+expectRight =+  either (assertFailure . show) pure
+ test/fixtures/CompileFail/Phase1BettiLeak.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}++module CompileFail.Phase1BettiLeak (forbiddenPhase1Capability) where++import Moonlight.Homology++forbiddenPhase1Capability :: BettiCapability 'Phase1 Rational+forbiddenPhase1Capability =+  fieldBettiCapability RationalFieldRankBackend
+ test/fixtures/CompileFail/Phase2SpectralLeak.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module CompileFail.Phase2SpectralLeak (forbiddenPhase2Spectral) where++import Moonlight.Homology++forbiddenPhase2Spectral :: ()+forbiddenPhase2Spectral =+  requirePhase4Witness @'Phase2
+ test/fixtures/CompilePass/Phase2Betti.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds #-}++module CompilePass.Phase2Betti (phase2Result) where++import Moonlight.Homology++phase2Result :: Either HomologyFailure [HomologyGroup Rational]+phase2Result = do+  finite <- mkFiniteChainComplexChecked (HomologicalDegree 0) (const emptyBoundaryIncidence)+  computeBettiNumbers+    (fieldBettiCapability RationalFieldRankBackend :: BettiCapability 'Phase2 Rational)+    finite
+ test/fixtures/CompilePass/PublicApiCleanup.hs view
@@ -0,0 +1,36 @@+module CompilePass.PublicApiCleanup+  ( publicAggregateApi,+    publicCuratedModulesApi,+  )+where++import Data.Bifunctor (first)+import qualified Moonlight.Homology as H+import qualified Moonlight.Homology.Boundary as Boundary+import qualified Moonlight.Homology.Persistence as Persistence++publicAggregateApi :: Either H.HomologyFailure (H.BoundaryIncidence Int, [H.PersistencePair H.FiltrationValue], H.TopologyWitness () () H.FiltrationValue () ())+publicAggregateApi = do+  incidence <- first (H.InvalidBoundaryIncidence . show) (H.mkBoundaryIncidence 1 1 [H.mkBoundaryEntry 0 0 (1 :: Int)])+  finite <- pointComplex+  filtered <- H.mkFilteredFiniteChainComplex finite pointBirths+  pairs <- H.mod2PersistentPairs filtered+  witness <- H.mod2PersistenceTopologyWitness filtered+  pure (incidence, pairs, witness)++publicCuratedModulesApi :: Either H.HomologyFailure (H.BoundaryIncidence Int, [H.PersistencePair H.FiltrationValue], H.TopologyWitness () () H.FiltrationValue () ())+publicCuratedModulesApi = do+  incidence <- first (H.InvalidBoundaryIncidence . show) (Boundary.mkBoundaryIncidence 1 1 [Boundary.mkBoundaryEntry 0 0 (1 :: Int)])+  finite <- pointComplex+  filtered <- Persistence.mkFilteredFiniteChainComplex finite pointBirths+  pairs <- Persistence.mod2PersistentPairs filtered+  witness <- Persistence.mod2PersistenceTopologyWitness filtered+  pure (incidence, pairs, witness)++pointComplex :: Either H.HomologyFailure (H.FiniteChainComplex Int)+pointComplex =+  H.mkFiniteChainComplexChecked (H.HomologicalDegree 0) (const (H.emptyBoundaryIncidenceOf 1 0))++pointBirths :: [(H.BasisCellRef, H.FiltrationValue)]+pointBirths =+  [(H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0}, H.FiltrationValue 0)]
+ test/fixtures/Snapshots/CompileFail.Phase1BettiLeak.snapshot.json view
@@ -0,0 +1,1 @@+{"diagnostics":[{"code":"GHC-64725","endCol":23,"endLine":9,"file":"foundation/moonlight-homology/test/fixtures/CompileFail/Phase1BettiLeak.hs","startCol":3,"startLine":9}],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"failure","fixture":"foundation/moonlight-homology/test/fixtures/CompileFail/Phase1BettiLeak.hs"}
+ test/fixtures/Snapshots/CompileFail.Phase2SpectralLeak.snapshot.json view
@@ -0,0 +1,1 @@+{"diagnostics":[{"code":"GHC-64725","endCol":23,"endLine":10,"file":"foundation/moonlight-homology/test/fixtures/CompileFail/Phase2SpectralLeak.hs","startCol":3,"startLine":10}],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"failure","fixture":"foundation/moonlight-homology/test/fixtures/CompileFail/Phase2SpectralLeak.hs"}
+ test/fixtures/Snapshots/CompilePass.Phase2Betti.snapshot.json view
@@ -0,0 +1,1 @@+{"diagnostics":[],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"success","fixture":"foundation/moonlight-homology/test/fixtures/CompilePass/Phase2Betti.hs"}
+ test/fixtures/Snapshots/CompilePass.PublicApiCleanup.snapshot.json view
@@ -0,0 +1,1 @@+{"diagnostics":[],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"success","fixture":"foundation/moonlight-homology/test/fixtures/CompilePass/PublicApiCleanup.hs"}
+ test/matrix/FieldBettiSpec.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DataKinds #-}++module FieldBettiSpec+  ( tests,+  )+where++import Moonlight.Homology+import Moonlight.Homology.Boundary.Finite (mkFiniteChainComplex)+import TestFixtures+  ( mooreComplex,+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2)+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+  ( Assertion,+    assertEqual,+    assertFailure,+    testCase,+  )++tests :: TestTree+tests =+  testGroup+    "homology backend substrate"+    [ testCase "GF2 Betti uses linalg rank for zero and identity matrices" testGF2ZeroAndIdentityBetti,+      testCase "GF2 Betti handles duplicate rows and duplicate-entry cancellation" testGF2DuplicateRowsAndEntryCancellation,+      testCase "GF2 coefficient mapping uses parity for signed integral boundaries" testGF2ParityConversion,+      testCase "typed homology backend dispatches Smith, Rational, and GF2 ranks" testHomologyBackendDispatch,+      testCase "field Betti computes isolated points and an interval through Phase 2" testFieldBettiBasicComplexes,+      testCase "field Betti rejects malformed and non-nilpotent chains through Phase 2" testFieldBettiRejectsInvalidChains,+      testCase "checked constructor refuses shape and nilpotence violations at the seal" testCheckedConstructorSeal+    ]++testGF2ZeroAndIdentityBetti :: Assertion+testGF2ZeroAndIdentityBetti = do+  zeroComplex <- expectRight (gf2OneBoundaryComplex 3 2 [])+  zeroGroups <- gf2Betti zeroComplex+  assertEqual "zero differential H0" [2, 3] (fmap freeRank zeroGroups)+  identityComplex <-+    expectRight $+      gf2OneBoundaryComplex+        3+        3+        [ mkBoundaryEntry 0 0 1,+          mkBoundaryEntry 1 1 1,+          mkBoundaryEntry 2 2 1+        ]+  identityGroups <- gf2Betti identityComplex+  assertEqual "identity differential is acyclic" [0, 0] (fmap freeRank identityGroups)++testGF2DuplicateRowsAndEntryCancellation :: Assertion+testGF2DuplicateRowsAndEntryCancellation = do+  duplicateRowComplex <-+    expectRight $+      gf2OneBoundaryComplex+        1+        2+        [ mkBoundaryEntry 0 0 1,+          mkBoundaryEntry 0 1 1+        ]+  duplicateRowGroups <- gf2Betti duplicateRowComplex+  assertEqual "duplicate row rank contributes once" [1, 0] (fmap freeRank duplicateRowGroups)+  cancelledComplex <-+    expectRight $+      gf2OneBoundaryComplex+        1+        1+        [ mkBoundaryEntry 0 0 1,+          mkBoundaryEntry 0 0 1+        ]+  cancelledGroups <- gf2Betti cancelledComplex+  assertEqual "duplicate GF2 entries cancel" [1, 1] (fmap freeRank cancelledGroups)++testGF2ParityConversion :: Assertion+testGF2ParityConversion = do+  integralBoundary <-+    expectRight $+      mkBoundaryIncidence+        4+        1+        [ mkBoundaryEntry 0 0 (2 :: Int),+          mkBoundaryEntry 1 0 (-2 :: Int),+          mkBoundaryEntry 2 0 (1 :: Int),+          mkBoundaryEntry 3 0 (-1 :: Int)+        ]+  let parityBoundary =+        mapBoundaryCoefficients fromIntegral integralBoundary+      parityComplex =+        mkFiniteChainComplex (HomologicalDegree 1) $ \degreeValue ->+          case degreeValue of+            HomologicalDegree 1 ->+              parityBoundary+            HomologicalDegree 0 ->+              emptyBoundaryIncidenceOf 1 0+            _ ->+              emptyBoundaryIncidence+  parityGroups <- gf2Betti parityComplex+  assertEqual "even entries vanish and odd signs survive" [0, 3] (fmap freeRank parityGroups)++testHomologyBackendDispatch :: Assertion+testHomologyBackendDispatch = do+  integralGroups <-+    expectRight+      (runHomologyBackend (IntegralSmithBackend :: HomologyBackend Integer Integer) mooreComplex)+  assertEqual "Smith backend preserves Moore torsion" [[], [2], []] (fmap torsionInvariants integralGroups)+  assertEqual "Smith backend tag" IntegralSmithBackendTag (homologyBackendTag (IntegralSmithBackend :: HomologyBackend Integer Integer))+  rationalComplex <- expectRight rationalIntervalComplex+  rationalGroups <- expectRight (runHomologyBackend RationalRankBackend rationalComplex)+  assertEqual "Rational backend interval Betti" [1, 0] (fmap freeRank rationalGroups)+  assertEqual "Rational backend tag" RationalRankBackendTag (homologyBackendTag RationalRankBackend)+  gf2Complex <- expectRight (gf2OneBoundaryComplex 1 1 [mkBoundaryEntry 0 0 1])+  gf2Groups <- expectRight (runHomologyBackend GF2RankBackend gf2Complex)+  assertEqual "GF2 backend acyclic interval" [0, 0] (fmap freeRank gf2Groups)+  assertEqual "GF2 backend tag" GF2RankBackendTag (homologyBackendTag GF2RankBackend)++testFieldBettiBasicComplexes :: Assertion+testFieldBettiBasicComplexes = do+  let isolatedPoints =+        mkFiniteChainComplex+          (HomologicalDegree 0)+          (const (emptyBoundaryIncidenceOf 4 0 :: BoundaryIncidence Rational))+  isolatedGroups <- rationalBetti isolatedPoints+  assertEqual "four isolated points H0" [4] (fmap freeRank isolatedGroups)+  assertEqual "degree cardinality comes from d0 source dimension" 4 (degreeCardinality isolatedPoints (HomologicalDegree 0))+  intervalComplex <- expectRight rationalIntervalComplex+  intervalGroups <- rationalBetti intervalComplex+  assertEqual "interval Betti" [1, 0] (fmap freeRank intervalGroups)++testFieldBettiRejectsInvalidChains :: Assertion+testFieldBettiRejectsInvalidChains = do+  malformedComplex <- expectRight malformedShapeComplex+  nonNilpotentValue <- expectRight nonNilpotentComplex+  case rationalBettiResult malformedComplex of+    Left (ChainComplexShapeMismatch 1 2 3) ->+      pure ()+    otherResult ->+      assertFailure ("expected malformed shape rejection, got " <> show otherResult)+  case rationalBettiResult nonNilpotentValue of+    Left (ChainComplexNilpotenceViolation 1) ->+      pure ()+    otherResult ->+      assertFailure ("expected non-nilpotent rejection, got " <> show otherResult)++testCheckedConstructorSeal :: Assertion+testCheckedConstructorSeal = do+  malformedComplex <- expectRight malformedShapeComplex+  nonNilpotentValue <- expectRight nonNilpotentComplex+  intervalComplex <- expectRight rationalIntervalComplex+  case resealComplex malformedComplex of+    Left (ChainComplexShapeMismatch 1 2 3) ->+      pure ()+    otherResult ->+      assertFailure ("expected shape refusal at the seal, got " <> show (() <$ otherResult))+  case resealComplex nonNilpotentValue of+    Left (ChainComplexNilpotenceViolation 1) ->+      pure ()+    otherResult ->+      assertFailure ("expected nilpotence refusal at the seal, got " <> show (() <$ otherResult))+  resealedInterval <- expectRight (resealComplex intervalComplex)+  intervalGroups <- rationalBetti resealedInterval+  assertEqual "sealed interval Betti" [1, 0] (fmap freeRank intervalGroups)++resealComplex :: FiniteChainComplex Rational -> Either HomologyFailure (FiniteChainComplex Rational)+resealComplex finite =+  mkFiniteChainComplexChecked (maxHomologicalDegree finite) (incidenceMatrixAt finite)++gf2Betti :: FiniteChainComplex GF2 -> IO [HomologyGroup GF2]+gf2Betti =+  expectRight . computeBettiNumbers (fieldBettiCapability GF2FieldRankBackend :: BettiCapability 'Phase2 GF2)++gf2OneBoundaryComplex ::+  Natural ->+  Natural ->+  [BoundaryEntry GF2] ->+  Either BoundaryIncidenceShapeError (FiniteChainComplex GF2)+gf2OneBoundaryComplex sourceDimension targetDimension entries = do+  boundaryIncidence <- mkBoundaryIncidence sourceDimension targetDimension entries+  pure $+    mkFiniteChainComplex (HomologicalDegree 1) $ \degreeValue ->+      case degreeValue of+        HomologicalDegree 1 ->+          boundaryIncidence+        HomologicalDegree 0 ->+          emptyBoundaryIncidenceOf targetDimension 0+        _ ->+          emptyBoundaryIncidence++rationalBetti :: FiniteChainComplex Rational -> IO [HomologyGroup Rational]+rationalBetti =+  expectRight . rationalBettiResult++rationalBettiResult :: FiniteChainComplex Rational -> Either HomologyFailure [HomologyGroup Rational]+rationalBettiResult =+  computeBettiNumbers (fieldBettiCapability RationalFieldRankBackend :: BettiCapability 'Phase2 Rational)++rationalIntervalComplex :: Either BoundaryIncidenceShapeError (FiniteChainComplex Rational)+rationalIntervalComplex = do+  intervalBoundary <-+    mkBoundaryIncidence+      1+      2+      [ mkBoundaryEntry 0 0 (-1),+        mkBoundaryEntry 0 1 1+      ]+  pure $+    mkFiniteChainComplex (HomologicalDegree 1) $ \degreeValue ->+      case degreeValue of+        HomologicalDegree 1 ->+          intervalBoundary+        HomologicalDegree 0 ->+          emptyBoundaryIncidenceOf 2 0+        _ ->+          emptyBoundaryIncidence++malformedShapeComplex :: Either BoundaryIncidenceShapeError (FiniteChainComplex Rational)+malformedShapeComplex = do+  malformedBoundary <- mkBoundaryIncidence 1 3 []+  pure $+    mkFiniteChainComplex (HomologicalDegree 1) $ \degreeValue ->+      case degreeValue of+        HomologicalDegree 1 ->+          malformedBoundary+        HomologicalDegree 0 ->+          emptyBoundaryIncidenceOf 2 0+        _ ->+          emptyBoundaryIncidence++nonNilpotentComplex :: Either BoundaryIncidenceShapeError (FiniteChainComplex Rational)+nonNilpotentComplex = do+  upperBoundary <- mkBoundaryIncidence 1 1 [mkBoundaryEntry 0 0 1]+  lowerBoundary <- mkBoundaryIncidence 1 1 [mkBoundaryEntry 0 0 1]+  pure $+    mkFiniteChainComplex (HomologicalDegree 2) $ \degreeValue ->+      case degreeValue of+        HomologicalDegree 2 ->+          upperBoundary+        HomologicalDegree 1 ->+          lowerBoundary+        HomologicalDegree 0 ->+          emptyBoundaryIncidenceOf 1 0+        _ ->+          emptyBoundaryIncidence++expectRight ::+  Show left =>+  Either left right ->+  IO right+expectRight result =+  case result of+    Left failureValue ->+      assertFailure (show failureValue)+    Right value ->+      pure value
+ test/matrix/GF2GraphSpec.hs view
@@ -0,0 +1,66 @@+module GF2GraphSpec+  ( tests,+  )+where++import Data.Set qualified as Set+import Moonlight.Homology+  ( GraphBoundaryGF2Failure (..),+    graphBoundaryRankDefectGF2,+    prepareGraphBoundaryGF2,+  )+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( Assertion,+    assertEqual,+    assertFailure,+    testCase,+  )++tests :: TestTree+tests =+  testGroup+    "GF2 graph boundary"+    [ testCase "rejects missing endpoints" testRejectsMissingEndpoint,+      testCase "tree rank defect is zero" testTreeRankDefect,+      testCase "simple cycle rank defect is one" testSimpleCycleRankDefect,+      testCase "self-loop rank defect is one" testSelfLoopRankDefect,+      testCase "parallel edges rank defect is one" testParallelEdgeRankDefect+    ]++testRejectsMissingEndpoint :: Assertion+testRejectsMissingEndpoint =+  case prepareGraphBoundaryGF2 (Set.singleton (1 :: Int)) [(1, 2)] of+    Left (GraphBoundaryGF2EndpointMissing edgeIndex missingCell edgeValue) ->+      assertEqual "missing endpoint" (0, 2, (1, 2)) (edgeIndex, missingCell, edgeValue)+    Left failureValue ->+      assertFailure ("unexpected graph boundary failure: " <> show failureValue)+    Right _ ->+      assertFailure "expected graph boundary construction to reject missing endpoint"++testTreeRankDefect :: Assertion+testTreeRankDefect =+  assertGraphDefect "tree defect" 0 (Set.fromList [1 :: Int, 2]) [(1, 2)]++testSimpleCycleRankDefect :: Assertion+testSimpleCycleRankDefect =+  assertGraphDefect "triangle defect" 1 (Set.fromList [1 :: Int, 2, 3]) [(1, 2), (2, 3), (3, 1)]++testSelfLoopRankDefect :: Assertion+testSelfLoopRankDefect =+  assertGraphDefect "self-loop defect" 1 (Set.singleton (1 :: Int)) [(1, 1)]++testParallelEdgeRankDefect :: Assertion+testParallelEdgeRankDefect =+  assertGraphDefect "parallel-edge defect" 1 (Set.fromList [1 :: Int, 2]) [(1, 2), (1, 2)]++assertGraphDefect :: String -> Int -> Set.Set Int -> [(Int, Int)] -> Assertion+assertGraphDefect label expectedDefect vertices edges =+  case prepareGraphBoundaryGF2 vertices edges of+    Left failureValue ->+      assertFailure ("graph boundary construction failed: " <> show failureValue)+    Right boundaryValue ->+      assertEqual label expectedDefect (graphBoundaryRankDefectGF2 boundaryValue)
+ test/sequence/SpectralSpec.hs view
@@ -0,0 +1,950 @@+module SpectralSpec+  ( tests,+  )+where++import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.Kind (Type)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Moonlight.Homology as H+import qualified Moonlight.Homology.Boundary.Finite as H (mkFiniteChainComplex)+import Moonlight.Homology.Pure.Matrix.SparseLinAlg (sparseRowFromDense, sparseSpanRank)+import qualified Moonlight.Homology.Pure.Sequence.Spectral.Build as SpectralBuild+import qualified Moonlight.Homology.Sequence as TopologySpectral+import qualified Moonlight.Homology.Matrix as Matrix+import TestFixtures (intervalComplex, triangleCycleComplex, widePathComplex)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "spectral sequence"+    [ weightedGraphShadowGapContractsTest,+      weightedGraphLeadingTransportStaysNormalizedTest,+      weightedGraphGapIgnoresInvalidEdgesTest,+      weightedGraphSparseModesAgreeWithDenseModesTest,+      trivialFiltrationConvergesToCohomologyTest,+      rationalSpectralPagesMatchManualRationalizationTest,+      filteredRefinedMorseSpectralPagesMatchUnreducedBaselineTest,+      filteredTriangleBuildsExpectedE0StrataTest,+      pathIndexFiltrationSpectralFamilyAnchorTest,+      delayedIntervalSpectralDifferentialAnchorTest,+      triangleCycleIndexFiltrationStabilizationTest,+      filteredSpectralLimitMatchesUnfilteredBettiTest,+      spectralPageDifferentialLawsTest,+      malformedBoundaryIsRejectedTest,+      validatedMatrixRejectsRaggedColumnsTest,+      spectralQuotientRejectsNonSubspaceDenominatorTest,+      filteredAnnulusStressTest,+      invertedFiltrationIsRejectedTest,+      monotoneFiltrationSucceedsTest,+      incompatibleTriangleFiltrationIsRejectedTest,+      boundaryMonotoneFiltrationOnPathGraphTest+    ]++weightedGraphShadowGapContractsTest :: TestTree+weightedGraphShadowGapContractsTest =+  testCase "weighted graph gap contracts when the structural edge weight is reduced" $+    case+        ( TopologySpectral.weightedGraphSpectralGap 2 2 [(0, 1, 1.0)],+          TopologySpectral.weightedGraphSpectralGap 2 2 [(0, 1, 0.25)]+        ) of+      (Right (Just fullGap), Right (Just contractedGap)) ->+        assertBool "expected lighter edge weighting to contract the spectral gap" (fullGap > contractedGap)+      (Left failureValue, _) ->+        assertFailure ("unexpected full-weight spectral failure: " <> show failureValue)+      (_, Left failureValue) ->+        assertFailure ("unexpected contracted-weight spectral failure: " <> show failureValue)+      unexpectedValue ->+        assertFailure ("expected concrete weighted spectral gaps, got: " <> show unexpectedValue)++weightedGraphLeadingTransportStaysNormalizedTest :: TestTree+weightedGraphLeadingTransportStaysNormalizedTest =+  testCase "leading mode transport stays normalized across equivalent weighted shadows" $+    case+        ( TopologySpectral.weightedGraphSpectralModes 2 2 [(0, 1, 1.0)],+          TopologySpectral.weightedGraphSpectralModes 2 2 [(0, 1, 0.25)]+        ) of+      (Right fullModes, Right contractedModes) ->+        case TopologySpectral.leadingModeTransport fullModes contractedModes of+          Just transportValue -> do+            assertBool "expected normalized transport" (transportValue >= 0.0 && transportValue <= 1.0)+            assertBool "expected the same one-edge carrier to preserve the leading eigenvector direction" (abs (transportValue - 1.0) < 1.0e-6)+          Nothing ->+            assertFailure "expected a transport value for nonempty weighted graph shadows"+      (Left failureValue, _) ->+        assertFailure ("unexpected full-weight spectral failure: " <> show failureValue)+      (_, Left failureValue) ->+        assertFailure ("unexpected contracted-weight spectral failure: " <> show failureValue)++weightedGraphGapIgnoresInvalidEdgesTest :: TestTree+weightedGraphGapIgnoresInvalidEdgesTest =+  testCase "weighted graph gap ignores invalid, self-loop, and nonpositive edges" $+    let cleanEdges = [(0, 1, 1.0)]+        noisyEdges =+          cleanEdges+            <> [(0, 0, 7.0), (1, 1, 5.0), (-1, 1, 3.0), (0, 2, 3.0), (0, 1, 0.0), (1, 0, -2.0)]+     in case+          ( TopologySpectral.weightedGraphSpectralGap 2 2 cleanEdges,+            TopologySpectral.weightedGraphSpectralGap 2 2 noisyEdges+          ) of+          (Right cleanGap, Right noisyGap) ->+            assertEqual "expected invalid edges to be ignored by weighted spectral gap construction" cleanGap noisyGap+          (Left failureValue, _) ->+            assertFailure ("unexpected clean-edge spectral failure: " <> show failureValue)+          (_, Left failureValue) ->+            assertFailure ("unexpected noisy-edge spectral failure: " <> show failureValue)++weightedGraphSparseModesAgreeWithDenseModesTest :: TestTree+weightedGraphSparseModesAgreeWithDenseModesTest =+  testCase "sparse Lanczos weighted graph modes agree with dense modes on a small carrier" $+    let weightedEdges =+          [ (0, 1, 1.0),+            (1, 2, 2.0),+            (2, 3, 1.5)+          ]+     in case+          ( TopologySpectral.weightedGraphSpectralModes 3 4 weightedEdges,+            TopologySpectral.weightedGraphSparseSpectralModes TopologySpectral.defaultSparseSpectralConfig 3 4 weightedEdges+          )+          of+          (Right denseModes, Right sparseModes) ->+            assertApproxList+              "expected sparse eigenvalues to track dense eigenvalues"+              (modeEigenvalues denseModes)+              (modeEigenvalues sparseModes)+          (Left failureValue, _) ->+            assertFailure ("unexpected dense spectral failure: " <> show failureValue)+          (_, Left failureValue) ->+            assertFailure ("unexpected sparse spectral failure: " <> show failureValue)++modeEigenvalues :: [H.GraphSpectralMode] -> [Double]+modeEigenvalues =+  List.sort . fmap H.spectralEigenvalue++assertApproxList :: String -> [Double] -> [Double] -> IO ()+assertApproxList label expectedValues actualValues = do+  assertEqual (label <> " length") (length expectedValues) (length actualValues)+  traverse_+    ( \(expectedValue, actualValue) ->+        assertBool+          (label <> ": expected " <> show expectedValue <> ", got " <> show actualValue)+          (abs (expectedValue - actualValue) < 1.0e-5)+    )+    (zip expectedValues actualValues)++trivialFiltrationConvergesToCohomologyTest :: TestTree+trivialFiltrationConvergesToCohomologyTest =+  testCase "trivial filtration converges at E1 to triangle cohomology" $ do+    case computeRationalizedSpectralPages triangleCycleComplex (const 0) of+      Left failureValue ->+        assertFailure ("unexpected spectral failure: " <> show failureValue)+      Right pages ->+        case lookupPage 1 pages of+          Nothing ->+            assertFailure "expected an E1 page for the trivial filtration"+          Just page1 -> do+            assertEqual "convergence depth" 1 (H.convergenceDepth pages)+            assertBool "one-pass parseable" (H.isKPassParseable 1 pages)+            assertBool "zero-pass not parseable" (not (H.isKPassParseable 0 pages))+            assertEqual "H^0 free rank" 1 (H.freeRank (H.groupAt page1 0 0))+            assertEqual "H^1 free rank" 1 (H.freeRank (H.groupAt page1 0 1))++rationalSpectralPagesMatchManualRationalizationTest :: TestTree+rationalSpectralPagesMatchManualRationalizationTest =+  testCase "rational spectral entrypoint matches manual rationalization" $ do+    let canonicalRationalTriangleComplex = H.rationalizeFiniteChainComplex triangleCycleComplex+        manualRationalTriangleComplex =+          H.mkFiniteChainComplex+            (H.maxHomologicalDegree triangleCycleComplex)+            (H.mapBoundaryCoefficients fromIntegral . H.incidenceMatrixAt triangleCycleComplex)+    case+        ( H.computeRationalSpectralPages canonicalRationalTriangleComplex triangleStepFiltration,+          H.computeRationalSpectralPages manualRationalTriangleComplex triangleStepFiltration+        )+      of+        (Right canonicalPages, Right manualPages) -> do+          assertEqual "page indices" (fmap H.pageIndex canonicalPages) (fmap H.pageIndex manualPages)+          assertEqual "page entries" (fmap H.pageEntryMap canonicalPages) (fmap H.pageEntryMap manualPages)+          assertEqual "page differentials" (fmap H.pageDifferentialMap canonicalPages) (fmap H.pageDifferentialMap manualPages)+        (Left failureValue, _) ->+          assertFailure ("unexpected canonical rational spectral failure: " <> show failureValue)+        (_, Left failureValue) ->+          assertFailure ("unexpected manual rational spectral failure: " <> show failureValue)++filteredRefinedMorseSpectralPagesMatchUnreducedBaselineTest :: TestTree+filteredRefinedMorseSpectralPagesMatchUnreducedBaselineTest =+  testCase "filtered refined Morse spectral pages match the unreduced rational baseline" $+    let complex = widePathComplex 4+     in case+          ( computeRationalizedSpectralPages complex pathGraphFiltration,+            H.filteredRefinedMorseComplex complex pathGraphFiltration (const 0)+          )+          of+          (Right unreducedPages, Right filteredComplex) -> do+            let refinedComplex = H.frmcRefinedMorseComplex filteredComplex+                reducedComplex = H.rmcReducedComplex refinedComplex+            case H.computeRationalSpectralPages reducedComplex (H.filteredReducedFiltration filteredComplex) of+              Left failureValue ->+                assertFailure ("unexpected filtered reduced spectral failure: " <> show failureValue)+              Right reducedPages -> do+                assertBool+                  "filtered refined Morse should actually collapse this path fixture"+                  (basisCellCount reducedComplex < basisCellCount (H.rationalizeFiniteChainComplex complex))+                assertBool+                  "filtered refined Morse should carry at least one compatibility witness"+                  (not (null (H.fmcPairWitnesses (H.frmcCompatibility filteredComplex))))+                case (lookupPage 1 unreducedPages, lookupPage 1 reducedPages) of+                  (Just unreducedPage1, Just reducedPage1) ->+                    assertEqual+                      "filtered reduced E1 nonzero groups must match the unreduced rational E1 nonzero groups"+                      (nonZeroPageGroupSummary unreducedPage1)+                      (nonZeroPageGroupSummary reducedPage1)+                  missingPage ->+                    let (unreducedPage, reducedPage) = missingPage+                     in assertFailure+                          ( "expected E1 pages in both spectral computations, received "+                              <> show (fmap H.pageIndex unreducedPage, fmap H.pageIndex reducedPage)+                          )+                case (expectStablePage unreducedPages, expectStablePage reducedPages) of+                  (Right unreducedStablePage, Right reducedStablePage) ->+                    assertEqual+                      "filtered reduced stable nonzero groups must match the unreduced rational stable nonzero groups"+                      (nonZeroPageGroupSummary unreducedStablePage)+                      (nonZeroPageGroupSummary reducedStablePage)+                  (Left failureMessage, _) ->+                    assertFailure failureMessage+                  (_, Left failureMessage) ->+                    assertFailure failureMessage+          (Left failureValue, _) ->+            assertFailure ("unexpected unreduced spectral failure: " <> show failureValue)+          (_, Left failureValue) ->+            assertFailure ("unexpected filtered refined Morse failure: " <> show failureValue)++filteredTriangleBuildsExpectedE0StrataTest :: TestTree+filteredTriangleBuildsExpectedE0StrataTest =+  testCase "triangle filtration yields graded E0 strata before convergence" $ do+    case computeRationalizedSpectralPages triangleCycleComplex triangleStepFiltration of+      Left failureValue ->+        assertFailure ("unexpected spectral failure: " <> show failureValue)+      Right pages ->+        case lookupPage 0 pages of+          Nothing ->+            assertFailure "expected an E0 page for the filtered triangle"+          Just page0 -> do+            assertEqual "page indices follow filtration width" [0, 1, 2, 3] (fmap H.pageIndex pages)+            assertEqual "vertex stratum rank" 3 (H.freeRank (H.groupAt page0 0 0))+            assertEqual "first edge stratum rank" 2 (H.freeRank (H.groupAt page0 1 0))+            assertEqual "late edge stratum rank" 1 (H.freeRank (H.groupAt page0 2 (-1)))+            assertBool "convergence stays within filtration width" (H.convergenceDepth pages <= 3)+            assertEqual "hand-derived stabilization index" 2 (H.convergenceDepth pages)+            case expectStablePage pages of+              Left failureMessage ->+                assertFailure failureMessage+              Right stablePage ->+                assertEqual+                  "stable Betti agrees with direct triangle cohomology"+                  [1, 1]+                  (spectralBettiVector 2 stablePage)++pathIndexFiltrationSpectralFamilyAnchorTest :: TestTree+pathIndexFiltrationSpectralFamilyAnchorTest =+  testCase "path vertex and edge index filtration converges to the path Betti vector within its width" $+    let complex = widePathComplex 7+        pathFiltrationWidth = filtrationWidthOf complex pathGraphFiltration+     in case computeRationalizedSpectralFamily complex pathGraphFiltration of+          Left failureValue ->+            assertFailure ("unexpected path spectral family failure: " <> show failureValue)+          Right family -> do+            assertEqual "path filtration width" 6 pathFiltrationWidth+            traverse_ assertSpectralDifferentialSquaresToZero (H.spectralFamilyPages family)+            assertBool+              "path spectral family stabilizes no later than filtration width plus one"+              (H.spectralFamilyStableFrom family <= pathFiltrationWidth + 1)+            assertEqual+              "path limit-page total-degree ranks"+              [1, 0]+              (spectralBettiVector 2 (H.spectralFamilyLimitPage family))++delayedIntervalSpectralDifferentialAnchorTest :: TestTree+delayedIntervalSpectralDifferentialAnchorTest =+  testCase "interval delayed-edge filtration has a nonzero d1 that kills the edge class" $+    case computeRationalizedSpectralFamily intervalComplex delayedIntervalFiltration of+      Left failureValue ->+        assertFailure ("unexpected delayed interval spectral family failure: " <> show failureValue)+      Right family ->+        case+            ( lookupPage 0 (H.spectralFamilyPages family),+              lookupPage 1 (H.spectralFamilyPages family),+              lookupPage 2 (H.spectralFamilyPages family)+            )+          of+          (Just page0, Just page1, Just page2) -> do+            assertEqual+              "delayed interval E0 ranks"+              (Map.fromList [((0, 0), 2), ((1, 0), 1)])+              (pageEntryRanks page0)+            assertEqual+              "delayed interval E1 ranks"+              (Map.fromList [((0, 0), 2), ((1, 0), 1)])+              (pageEntryRanks page1)+            assertEqual+              "delayed interval nonzero E1 differential source rank"+              (Map.fromList [((0, 0), 1)])+              (nonZeroDifferentialRanks page1)+            case Map.lookup (H.mkBidegree 0 0) (H.pageDifferentialMap page1) of+              Nothing ->+                assertFailure "expected delayed interval d1 at bidegree (0,0)"+              Just differentialValue -> do+                assertEqual "delayed interval d1 domain rank" 2 (length (H.formalDomainBasis differentialValue))+                assertEqual "delayed interval d1 codomain rank" 1 (length (H.formalCodomainBasis differentialValue))+                assertEqual "delayed interval d1 matrix rank" 1 (matrixRank (H.formalMatrix differentialValue))+            assertEqual+              "delayed interval d1 target bidegree"+              (1, 0)+              (H.bidegreeCoordinates (H.targetBidegreeAfterDifferential 1 (H.mkBidegree 0 0)))+            assertEqual+              "delayed interval E2 ranks"+              (Map.fromList [((0, 0), 1), ((1, 0), 0)])+              (pageEntryRanks page2)+            assertEqual "delayed interval stabilization index" 2 (H.spectralFamilyStableFrom family)+            assertEqual+              "delayed interval limit-page total-degree ranks"+              [1, 0]+              (spectralBettiVector 2 (H.spectralFamilyLimitPage family))+          missingPages ->+            let (page0, page1, page2) = missingPages+             in assertFailure+                  ( "expected E0, E1, and E2 pages for delayed interval, received "+                      <> show (fmap H.pageIndex page0, fmap H.pageIndex page1, fmap H.pageIndex page2)+                  )++triangleCycleIndexFiltrationStabilizationTest :: TestTree+triangleCycleIndexFiltrationStabilizationTest =+  testCase "triangle cycle index filtration stabilizes at the hand-derived page" $+    case computeRationalizedSpectralFamily triangleCycleComplex triangleCycleIndexFiltration of+      Left failureValue ->+        assertFailure ("unexpected triangle spectral family failure: " <> show failureValue)+      Right family -> do+        assertEqual "triangle index-filtration stabilization index" 1 (H.spectralFamilyStableFrom family)+        assertEqual+          "triangle limit-page total-degree ranks"+          [1, 1]+          (spectralBettiVector 2 (H.spectralFamilyLimitPage family))++filteredSpectralLimitMatchesUnfilteredBettiTest :: TestTree+filteredSpectralLimitMatchesUnfilteredBettiTest =+  testCase "filtered spectral limit ranks match unfiltered rational Betti numbers" $+    traverse_ assertFilteredSpectralAnchorConverges filteredSpectralAnchors++malformedBoundaryIsRejectedTest :: TestTree+malformedBoundaryIsRejectedTest =+  testCase "validated boundary constructors reject malformed incidence instead of padding or truncating" $+    case H.mkBoundaryIncidence 1 1 [H.mkBoundaryEntry 0 2 (1 :: Int)] of+      Left (H.BoundaryIncidenceEntryOutOfBounds 0 2 1 1) ->+        pure ()+      Left shapeError ->+        assertFailure ("expected explicit out-of-bounds rejection, got: " <> show shapeError)+      Right _ ->+        assertFailure "expected malformed incidence rejection"++validatedMatrixRejectsRaggedColumnsTest :: TestTree+validatedMatrixRejectsRaggedColumnsTest =+  testCase "validated matrices reject ragged columns instead of zero padding them into fake linear maps" $+    case Matrix.validatedMatrixFromColumns 3 [[1 :: Rational, 0, 0], [0, 1]] of+      Left (H.InvalidMatrixShape _) ->+        pure ()+      Left failureValue ->+        assertFailure ("expected a matrix-shape rejection, got: " <> show failureValue)+      Right _ ->+        assertFailure "expected ragged column rejection"++spectralQuotientRejectsNonSubspaceDenominatorTest :: TestTree+spectralQuotientRejectsNonSubspaceDenominatorTest =+  testCase "spectral quotient rejects denominator vectors outside the numerator subspace" $+    case SpectralBuild.buildEntryFromBases (H.mkBidegree 0 0) 2 (fmap sparseRowFromDense [[1, 0]]) (fmap sparseRowFromDense [[0, 1]]) of+      Left (H.SpectralQuotientDenominatorNotSubspace (0, 0) 2 [0, 1]) ->+        pure ()+      Left failureValue ->+        assertFailure ("expected denominator-subset obstruction, got: " <> show failureValue)+      Right _ ->+        assertFailure "expected unlawful quotient rejection"++filteredAnnulusStressTest :: TestTree+filteredAnnulusStressTest =+  testCase "filtered annulus stress test converges to the correct Betti vector on a realistic complex" $ do+    case buildAnnulusScenario 5 1 3 of+      Left failureValue ->+        assertFailure ("failed to build annulus scenario: " <> show failureValue)+      Right scenario -> do+        let expectedBetti = H.freeBettiVector (asComplex scenario)+        assertEqual "annulus Betti vector" [1, 1, 0] expectedBetti+        case computeRationalizedSpectralPages (asComplex scenario) (asFiltration scenario) of+          Left failureValue ->+            assertFailure ("unexpected spectral failure on annulus stress case: " <> show failureValue)+          Right pages -> do+            traverse_ assertSpectralPageWellShaped pages+            case expectStablePage pages of+              Left failureMessage ->+                assertFailure failureMessage+              Right stablePage -> do+                let stableBetti = spectralBettiVector (length expectedBetti) stablePage+                assertEqual "stable spectral Betti must equal direct cohomology" expectedBetti stableBetti++type AnnulusScenario :: Type+data AnnulusScenario = AnnulusScenario+  { asComplex :: H.FiniteChainComplex Integer,+    asFiltration :: H.FiltrationFunction,+    asVertexCount :: Int,+    asEdgeCount :: Int,+    asFaceCount :: Int+  }++buildAnnulusScenario :: Int -> Int -> Int -> Either H.HomologyFailure AnnulusScenario+buildAnnulusScenario outerSize holeLower holeUpper = do+  let faceBasis = annulusFaceBasis outerSize holeLower holeUpper+      edgeBasis = annulusEdgeBasis faceBasis+      vertexBasis = annulusVertexBasis edgeBasis+  faceBoundaryIncidence <- H.materializeIncidenceBoundary faceBoundary faceBasis edgeBasis+  edgeBoundaryIncidence <- H.materializeIncidenceBoundary edgeBoundary edgeBasis vertexBasis+  pure+    AnnulusScenario+      { asComplex =+          H.mkFiniteChainComplex (H.HomologicalDegree 2) $ \degreeValue ->+            case degreeValue of+              H.HomologicalDegree 2 -> faceBoundaryIncidence+              H.HomologicalDegree 1 -> edgeBoundaryIncidence+              H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf (fromIntegral (length vertexBasis)) 0+              _ -> H.emptyBoundaryIncidence,+        asFiltration = annulusFiltration vertexBasis edgeBasis faceBasis,+        asVertexCount = length vertexBasis,+        asEdgeCount = length edgeBasis,+        asFaceCount = length faceBasis+      }++annulusFaceBasis :: Int -> Int -> Int -> [AnnulusFace]+annulusFaceBasis outerSize holeLower holeUpper =+  coordinateRange outerSize+    & concatMap+      (\xValue -> fmap (AnnulusFace xValue) (coordinateRange outerSize))+    & filter (not . faceInsideHole holeLower holeUpper)++annulusEdgeBasis :: [AnnulusFace] -> [AnnulusEdge]+annulusEdgeBasis =+  Set.toAscList+    . Set.fromList+    . concatMap faceBoundaryEdges++annulusVertexBasis :: [AnnulusEdge] -> [AnnulusVertex]+annulusVertexBasis =+  Set.toAscList+    . Set.fromList+    . concatMap edgeVertices++coordinateRange :: Int -> [Int]+coordinateRange outerSize = [0 .. outerSize - 1]++faceInsideHole :: Int -> Int -> AnnulusFace -> Bool+faceInsideHole holeLower holeUpper (AnnulusFace xValue yValue) =+  xValue >= holeLower+    && xValue < holeUpper+    && yValue >= holeLower+    && yValue < holeUpper++annulusFiltration :: [AnnulusVertex] -> [AnnulusEdge] -> [AnnulusFace] -> H.FiltrationFunction+annulusFiltration vertexBasis edgeBasis faceBasis basisCellRef =+  case H.cellDegree basisCellRef of+    H.HomologicalDegree 0 ->+      maybe 0 vertexFiltration (basisAt (H.cellIndex basisCellRef) vertexBasis)+    H.HomologicalDegree 1 ->+      maybe 0 edgeFiltration (basisAt (H.cellIndex basisCellRef) edgeBasis)+    H.HomologicalDegree 2 ->+      maybe 0 faceFiltration (basisAt (H.cellIndex basisCellRef) faceBasis)+    _ -> 0++basisAt :: Int -> [a] -> Maybe a+basisAt indexValue values+  | indexValue < 0 = Nothing+  | otherwise =+      case drop indexValue values of+        value : _ -> Just value+        [] -> Nothing++lookupPage :: Int -> [H.SpectralPage Rational] -> Maybe (H.SpectralPage Rational)+lookupPage targetIndex =+  List.find (\page -> H.pageIndex page == targetIndex)++computeRationalizedSpectralPages ::+  Integral r =>+  H.FiniteChainComplex r ->+  H.FiltrationFunction ->+  Either H.HomologyFailure [H.RationalSpectralPage]+computeRationalizedSpectralPages finiteComplex =+  H.computeRationalSpectralPages (H.rationalizeFiniteChainComplex finiteComplex)++computeRationalizedSpectralFamily ::+  Integral r =>+  H.FiniteChainComplex r ->+  H.FiltrationFunction ->+  Either H.HomologyFailure H.RationalSpectralFamily+computeRationalizedSpectralFamily finiteComplex =+  H.computeRationalSpectralFamily (H.rationalizeFiniteChainComplex finiteComplex)++expectStablePage :: [H.SpectralPage Rational] -> Either String (H.SpectralPage Rational)+expectStablePage pages =+  case H.stableSpectralPage pages of+    Just stablePage -> Right stablePage+    Nothing -> Left "spectral construction produced no stable page"++assertSpectralPageWellShaped :: H.SpectralPage Rational -> IO ()+assertSpectralPageWellShaped page =+  traverse_+    assertFormalMapWellShaped+    (Map.elems (H.pageDifferentialMap page))++assertFormalMapWellShaped :: H.FormalMap Rational -> IO ()+assertFormalMapWellShaped formalMapValue = do+  let matrixValue = H.formalMatrix formalMapValue+      expectedRowCount = length (H.formalCodomainBasis formalMapValue)+      expectedColumnCount = length (H.formalDomainBasis formalMapValue)+  assertEqual "formal map row count matches codomain basis size" expectedRowCount (length matrixValue)+  assertBool+    "formal map columns match domain basis size"+    (all ((== expectedColumnCount) . length) matrixValue)++spectralPageDifferentialLawsTest :: TestTree+spectralPageDifferentialLawsTest =+  testCase "filtered triangle pages satisfy d² = 0 and advance by homology of the previous page" $+    case computeRationalizedSpectralPages triangleCycleComplex triangleStepFiltration of+      Left failureValue ->+        assertFailure ("unexpected spectral failure: " <> show failureValue)+      Right pages -> do+        traverse_ assertSpectralDifferentialSquaresToZero pages+        traverse_ (uncurry assertNextPageIsDifferentialHomology) (zip pages (drop 1 pages))++assertSpectralDifferentialSquaresToZero :: H.SpectralPage Rational -> IO ()+assertSpectralDifferentialSquaresToZero page =+  traverse_+    (assertDifferentialSquareAt page)+    (Map.toAscList (H.pageDifferentialMap page))++assertDifferentialSquareAt :: H.SpectralPage Rational -> (H.Bidegree, H.FormalMap Rational) -> IO ()+assertDifferentialSquareAt page (sourceBidegree, firstMap) =+  let targetBidegree = H.targetBidegreeAfterDifferential (H.pageIndex page) sourceBidegree+      secondMap =+        Map.findWithDefault+          (zeroFormalMapOn (H.formalCodomainBasis firstMap))+          targetBidegree+          (H.pageDifferentialMap page)+   in case composeFormalMaps secondMap firstMap of+        Left failureMessage ->+          assertFailure failureMessage+        Right compositeMatrix ->+          assertBool+            ("expected d² = 0 at " <> show (H.bidegreeCoordinates sourceBidegree) <> " on page " <> show (H.pageIndex page))+            (zeroMatrixValue compositeMatrix)++assertNextPageIsDifferentialHomology :: H.SpectralPage Rational -> H.SpectralPage Rational -> IO ()+assertNextPageIsDifferentialHomology previousPage nextPage = do+  assertEqual+    ("page support at E" <> show (H.pageIndex nextPage))+    (Map.keysSet (H.pageEntryMap previousPage))+    (Map.keysSet (H.pageEntryMap nextPage))+  traverse_+    (assertNextEntryIsDifferentialHomology previousPage nextPage)+    (Map.toAscList (H.pageEntryMap nextPage))++assertNextEntryIsDifferentialHomology ::+  H.SpectralPage Rational ->+  H.SpectralPage Rational ->+  (H.Bidegree, H.SpectralEntry Rational) ->+  IO ()+assertNextEntryIsDifferentialHomology previousPage nextPage (bidegreeValue, nextEntry) =+  case Map.lookup bidegreeValue (H.pageDifferentialMap previousPage) of+    Nothing ->+      assertFailure+        ("previous page lacks outgoing differential at " <> show (H.bidegreeCoordinates bidegreeValue))+    Just outgoingMap -> do+      let incomingRank =+            Map.lookup (incomingSourceBidegree (H.pageIndex previousPage) bidegreeValue) (H.pageDifferentialMap previousPage)+              & maybe 0 (matrixRank . H.formalMatrix)+          outgoingRank = matrixRank (H.formalMatrix outgoingMap)+          domainDimension = length (H.formalDomainBasis outgoingMap)+          expectedRank = domainDimension - outgoingRank - incomingRank+          nextGroup = H.entryGroupValue nextEntry+      assertBool+        ("expected nonnegative page homology rank at " <> show (H.bidegreeCoordinates bidegreeValue))+        (expectedRank >= 0)+      assertEqual+        ( "E"+            <> show (H.pageIndex nextPage)+            <> " rank at "+            <> show (H.bidegreeCoordinates bidegreeValue)+        )+        expectedRank+        (H.freeRank nextGroup)+      assertEqual+        ("rational spectral entry has no torsion at " <> show (H.bidegreeCoordinates bidegreeValue))+        []+        (H.torsionInvariants nextGroup)++incomingSourceBidegree :: Int -> H.Bidegree -> H.Bidegree+incomingSourceBidegree pageNumber bidegreeValue =+  H.mkBidegree+    (H.bidegreeFiltrationDegree bidegreeValue - pageNumber)+    (H.bidegreeComplementaryDegree bidegreeValue + pageNumber - 1)++zeroFormalMapOn :: [H.RepresentativeCocycle Rational Int] -> H.FormalMap Rational+zeroFormalMapOn domainBasis =+  H.FormalMap+    { H.formalMatrix = [],+      H.formalDomainBasis = domainBasis,+      H.formalCodomainBasis = []+    }++composeFormalMaps :: H.FormalMap Rational -> H.FormalMap Rational -> Either String [[Rational]]+composeFormalMaps secondMap firstMap =+  let sharedDimension = length (H.formalCodomainBasis firstMap)+      sourceDimension = length (H.formalDomainBasis firstMap)+      targetDimension = length (H.formalCodomainBasis secondMap)+      firstMatrix = H.formalMatrix firstMap+      secondMatrix = H.formalMatrix secondMap+   in if H.formalDomainBasis secondMap /= H.formalCodomainBasis firstMap+        then Left "spectral formal map composition encountered incompatible bases"+        else+          if not (matrixHasShape sharedDimension sourceDimension firstMatrix)+            || not (matrixHasShape targetDimension sharedDimension secondMatrix)+            then Left "spectral formal map composition encountered malformed matrices"+            else Right (matrixProduct sourceDimension secondMatrix firstMatrix)++matrixProduct :: Int -> [[Rational]] -> [[Rational]] -> [[Rational]]+matrixProduct rightColumnCount leftRows rightRows =+  let rightColumns =+        case rightRows of+          [] -> replicate rightColumnCount []+          _ -> List.transpose rightRows+   in fmap+        ( \leftRow ->+            fmap (sum . zipWith (*) leftRow) rightColumns+        )+        leftRows++matrixHasShape :: Int -> Int -> [[Rational]] -> Bool+matrixHasShape expectedRowCount expectedColumnCount matrixValue =+  length matrixValue == expectedRowCount+    && all ((== expectedColumnCount) . length) matrixValue++matrixRank :: [[Rational]] -> Int+matrixRank matrixValue =+  case matrixValue of+    [] -> 0+    firstRow : _ ->+      sparseSpanRank (length firstRow) (fmap sparseRowFromDense matrixValue)++zeroMatrixValue :: [[Rational]] -> Bool+zeroMatrixValue =+  all (all (== 0))++pageEntryRanks :: H.SpectralPage Rational -> Map.Map (Int, Int) Int+pageEntryRanks page =+  H.pageEntryMap page+    & Map.toAscList+    & fmap+      ( \(bidegreeValue, entryValue) ->+          (H.bidegreeCoordinates bidegreeValue, H.freeRank (H.entryGroupValue entryValue))+      )+    & Map.fromList++nonZeroDifferentialRanks :: H.SpectralPage Rational -> Map.Map (Int, Int) Int+nonZeroDifferentialRanks page =+  H.pageDifferentialMap page+    & Map.toAscList+    & fmap+      ( \(bidegreeValue, formalMapValue) ->+          (H.bidegreeCoordinates bidegreeValue, matrixRank (H.formalMatrix formalMapValue))+      )+    & filter ((/= 0) . snd)+    & Map.fromList++spectralBettiVector :: Int -> H.SpectralPage Rational -> [Int]+spectralBettiVector degreeCount page =+  let ranksByTotalDegree =+        H.pageEntryMap page+          & Map.keys+          & fmap+            (\bidegreeValue ->+                ( totalDegreeIndex (H.bidegreeTotalDegree bidegreeValue),+                  H.freeRank+                    (H.groupAt page (H.bidegreeFiltrationDegree bidegreeValue) (H.bidegreeComplementaryDegree bidegreeValue))+                )+            )+          & Map.fromListWith (+)+   in fmap (\degreeValue -> Map.findWithDefault 0 degreeValue ranksByTotalDegree) [0 .. degreeCount - 1]++totalDegreeIndex :: H.HomologicalDegree -> Int+totalDegreeIndex (H.HomologicalDegree degreeValue) = degreeValue++nonZeroPageGroupSummary :: H.SpectralPage Rational -> Map.Map H.Bidegree (H.HomologyGroup Rational)+nonZeroPageGroupSummary =+  Map.filter nonZeroHomologyGroup . fmap H.entryGroupValue . H.pageEntryMap++nonZeroHomologyGroup :: H.HomologyGroup Rational -> Bool+nonZeroHomologyGroup groupValue =+  H.freeRank groupValue /= 0 || not (null (H.torsionInvariants groupValue))++basisCellCount :: H.FiniteChainComplex r -> Int+basisCellCount =+  length . basisRefsOfComplex++filtrationWidthOf :: H.FiniteChainComplex r -> H.FiltrationFunction -> Int+filtrationWidthOf finiteComplex filtration =+  case fmap filtration (basisRefsOfComplex finiteComplex) of+    [] -> 0+    firstLevel : remainingLevels ->+      List.foldl' max firstLevel remainingLevels - List.foldl' min firstLevel remainingLevels++basisRefsOfComplex :: H.FiniteChainComplex r -> [H.BasisCellRef]+basisRefsOfComplex finiteComplex =+  [0 .. totalDegreeIndex (H.maxHomologicalDegree finiteComplex)]+    >>= ( \degreeValue ->+            let homologicalDegreeValue = H.HomologicalDegree degreeValue+             in fmap+                  (H.BasisCellRef homologicalDegreeValue)+                  [0 .. H.sourceCardinality (H.incidenceMatrixAt finiteComplex homologicalDegreeValue) - 1]+       )++triangleStepFiltration :: H.FiltrationFunction+triangleStepFiltration basisCellRef =+  case (H.cellDegree basisCellRef, H.cellIndex basisCellRef) of+    (H.HomologicalDegree 0, _) -> 0+    (H.HomologicalDegree 1, 0) -> 1+    (H.HomologicalDegree 1, 1) -> 1+    (H.HomologicalDegree 1, 2) -> 2+    _ -> 0++triangleCycleIndexFiltration :: H.FiltrationFunction+triangleCycleIndexFiltration basisCellRef =+  case H.cellDegree basisCellRef of+    H.HomologicalDegree 0 -> H.cellIndex basisCellRef+    H.HomologicalDegree 1 -> H.cellIndex basisCellRef + 1+    _ -> 0++type AnnulusVertex :: Type+data AnnulusVertex = AnnulusVertex Int Int+  deriving stock (Eq, Ord, Show)++type AnnulusEdge :: Type+data AnnulusEdge+  = HorizontalEdge Int Int+  | VerticalEdge Int Int+  deriving stock (Eq, Ord, Show)++type AnnulusFace :: Type+data AnnulusFace = AnnulusFace Int Int+  deriving stock (Eq, Ord, Show)++vertexFiltration :: AnnulusVertex -> Int+vertexFiltration (AnnulusVertex xValue yValue) = xValue + yValue++edgeFiltration :: AnnulusEdge -> Int+edgeFiltration edgeValue =+  case edgeValue of+    HorizontalEdge xValue yValue -> xValue + yValue + 1+    VerticalEdge xValue yValue -> xValue + yValue + 1++faceFiltration :: AnnulusFace -> Int+faceFiltration (AnnulusFace xValue yValue) = xValue + yValue + 2++edgeVertices :: AnnulusEdge -> [AnnulusVertex]+edgeVertices edgeValue =+  case edgeValue of+    HorizontalEdge xValue yValue ->+      [ AnnulusVertex xValue yValue,+        AnnulusVertex (xValue + 1) yValue+      ]+    VerticalEdge xValue yValue ->+      [ AnnulusVertex xValue yValue,+        AnnulusVertex xValue (yValue + 1)+      ]++edgeBoundary :: AnnulusEdge -> [(Integer, AnnulusVertex)]+edgeBoundary edgeValue =+  case edgeValue of+    HorizontalEdge xValue yValue ->+      [ (-1, AnnulusVertex xValue yValue),+        (1, AnnulusVertex (xValue + 1) yValue)+      ]+    VerticalEdge xValue yValue ->+      [ (-1, AnnulusVertex xValue yValue),+        (1, AnnulusVertex xValue (yValue + 1))+      ]++faceBoundaryEdges :: AnnulusFace -> [AnnulusEdge]+faceBoundaryEdges (AnnulusFace xValue yValue) =+  [ HorizontalEdge xValue yValue,+    VerticalEdge (xValue + 1) yValue,+    HorizontalEdge xValue (yValue + 1),+    VerticalEdge xValue yValue+  ]++faceBoundary :: AnnulusFace -> [(Integer, AnnulusEdge)]+faceBoundary (AnnulusFace xValue yValue) =+  [ (1, HorizontalEdge xValue yValue),+    (1, VerticalEdge (xValue + 1) yValue),+    (-1, HorizontalEdge xValue (yValue + 1)),+    (-1, VerticalEdge xValue yValue)+  ]++invertedFiltrationIsRejectedTest :: TestTree+invertedFiltrationIsRejectedTest =+  testCase "filtration that inverts cochain filtration preservation is rejected at source construction" $+    let wideComplex = widePathComplex 5+     in case computeRationalizedSpectralPages wideComplex (invertedWideFiltration 5) of+          Left (H.FiltrationNotPreserved lowerCell upperCell lowerLevel upperLevel) -> do+            assertEqual "lower cell" (H.BasisCellRef (H.HomologicalDegree 0) 0) lowerCell+            assertEqual "upper cell" (H.BasisCellRef (H.HomologicalDegree 1) 0) upperCell+            assertEqual "lower level" 4 lowerLevel+            assertEqual "upper level" 0 upperLevel+          Left failureValue ->+            assertFailure ("expected filtration preservation failure, got: " <> show failureValue)+          Right _ ->+            assertFailure "expected inverted filtration rejection"++monotoneFiltrationSucceedsTest :: TestTree+monotoneFiltrationSucceedsTest =+  testCase "cochain-preserving filtration succeeds on the same complex" $+    case computeRationalizedSpectralPages triangleCycleComplex monotoneFiltration of+      Left failureValue ->+        assertFailure ("unexpected spectral failure with monotone filtration: " <> show failureValue)+      Right pages ->+        case expectStablePage pages of+          Left failureMessage -> assertFailure failureMessage+          Right stablePage ->+            assertEqual+              "stable spectral Betti must equal direct cohomology"+              (H.freeBettiVector triangleCycleComplex)+              (spectralBettiVector 2 stablePage)++invertedWideFiltration :: Int -> H.FiltrationFunction+invertedWideFiltration nodeCount basisCellRef =+  case H.cellDegree basisCellRef of+    H.HomologicalDegree 0 ->+      nodeCount - 1 - H.cellIndex basisCellRef+    H.HomologicalDegree 1 ->+      0+    _ -> 0++monotoneFiltration :: H.FiltrationFunction+monotoneFiltration basisCellRef =+  case (H.cellDegree basisCellRef, H.cellIndex basisCellRef) of+    (H.HomologicalDegree 0, 0) -> 0+    (H.HomologicalDegree 0, 1) -> 0+    (H.HomologicalDegree 0, 2) -> 0+    (H.HomologicalDegree 1, 0) -> 1+    (H.HomologicalDegree 1, 1) -> 1+    (H.HomologicalDegree 1, 2) -> 2+    _ -> 0++pathGraphFiltration :: H.FiltrationFunction+pathGraphFiltration basisCellRef =+  case H.cellDegree basisCellRef of+    H.HomologicalDegree 0 -> H.cellIndex basisCellRef+    H.HomologicalDegree 1 -> H.cellIndex basisCellRef + 1+    _ -> 0++delayedIntervalFiltration :: H.FiltrationFunction+delayedIntervalFiltration basisCellRef =+  case H.cellDegree basisCellRef of+    H.HomologicalDegree 0 -> 0+    H.HomologicalDegree 1 -> 1+    _ -> 0++type FilteredSpectralAnchor :: Type+data FilteredSpectralAnchor = FilteredSpectralAnchor+  { fsaName :: String,+    fsaComplex :: H.FiniteChainComplex Integer,+    fsaFiltration :: H.FiltrationFunction,+    fsaExpectedBetti :: [Int]+  }++filteredSpectralAnchors :: [FilteredSpectralAnchor]+filteredSpectralAnchors =+  [ FilteredSpectralAnchor+      { fsaName = "seven-vertex path",+        fsaComplex = widePathComplex 7,+        fsaFiltration = pathGraphFiltration,+        fsaExpectedBetti = [1, 0]+      },+    FilteredSpectralAnchor+      { fsaName = "delayed interval",+        fsaComplex = intervalComplex,+        fsaFiltration = delayedIntervalFiltration,+        fsaExpectedBetti = [1, 0]+      },+    FilteredSpectralAnchor+      { fsaName = "triangle cycle index filtration",+        fsaComplex = triangleCycleComplex,+        fsaFiltration = triangleCycleIndexFiltration,+        fsaExpectedBetti = [1, 1]+      }+  ]++assertFilteredSpectralAnchorConverges :: FilteredSpectralAnchor -> IO ()+assertFilteredSpectralAnchorConverges anchor =+  case computeRationalizedSpectralFamily (fsaComplex anchor) (fsaFiltration anchor) of+    Left failureValue ->+      assertFailure (fsaName anchor <> " spectral family failed: " <> show failureValue)+    Right family -> do+      let unfilteredBetti = H.freeBettiVector (fsaComplex anchor)+          limitBetti =+            spectralBettiVector+              (length (fsaExpectedBetti anchor))+              (H.spectralFamilyLimitPage family)+      assertEqual (fsaName anchor <> " hand Betti vector") (fsaExpectedBetti anchor) unfilteredBetti+      assertEqual (fsaName anchor <> " limit-page Betti vector") unfilteredBetti limitBetti++incompatibleTriangleFiltrationIsRejectedTest :: TestTree+incompatibleTriangleFiltrationIsRejectedTest =+  testCase "triangle filtration that violates cochain preservation is rejected before page construction" $ do+    case computeRationalizedSpectralPages triangleCycleComplex incompatibleTriangleFiltration of+      Left (H.FiltrationNotPreserved lowerCell upperCell lowerLevel upperLevel) -> do+        assertEqual "lower cell" (H.BasisCellRef (H.HomologicalDegree 0) 2) lowerCell+        assertEqual "upper cell" (H.BasisCellRef (H.HomologicalDegree 1) 2) upperCell+        assertEqual "lower level" 1 lowerLevel+        assertEqual "upper level" 0 upperLevel+      Left failureValue ->+        assertFailure ("expected filtration preservation failure, got: " <> show failureValue)+      Right _ ->+        assertFailure "expected incompatible triangle filtration rejection"++incompatibleTriangleFiltration :: H.FiltrationFunction+incompatibleTriangleFiltration basisCellRef =+  case (H.cellDegree basisCellRef, H.cellIndex basisCellRef) of+    (H.HomologicalDegree 0, 0) -> 0+    (H.HomologicalDegree 0, 1) -> 1+    (H.HomologicalDegree 0, 2) -> 1+    (H.HomologicalDegree 1, 0) -> 1+    (H.HomologicalDegree 1, 1) -> 1+    (H.HomologicalDegree 1, 2) -> 0+    _ -> 0++boundaryMonotoneFiltrationOnPathGraphTest :: TestTree+boundaryMonotoneFiltrationOnPathGraphTest =+  testCase "cochain-preserving filtration on path graph converges to correct Betti" $+    let complex = widePathComplex 4+     in case computeRationalizedSpectralPages complex pathGraphFiltration of+          Left failureValue ->+            assertFailure ("path filtration failed: " <> show failureValue)+          Right pages ->+            case expectStablePage pages of+              Left failureMessage -> assertFailure failureMessage+              Right stablePage -> do+                assertEqual "page indices use filtration-width cap" [0, 1, 2, 3, 4] (fmap H.pageIndex pages)+                assertEqual+                  "stable spectral Betti must equal direct cohomology"+                  (H.freeBettiVector complex)+                  (spectralBettiVector 2 stablePage)
+ test/support/TestFixtures.hs view
@@ -0,0 +1,203 @@+module TestFixtures+  ( GenuineGoldenCase (..),+    genuineGoldenCorpus,+    intervalComplex,+    mooreComplex,+    projectivePlaneComplex,+    tetrahedronBoundaryComplex,+    tetrahedronBoundaryMissingFaceComplex,+    triangleCycleComplex,+    widePathComplex,+  )+where++import Moonlight.Core (Semiring)+import qualified Moonlight.Homology as H+import qualified Moonlight.Homology.Boundary.Finite as H (mkFiniteChainComplex)+import Numeric.Natural (Natural)++data GenuineGoldenCase = GenuineGoldenCase+  { genuineGoldenName :: String,+    genuineGoldenCellCounts :: [Int],+    genuineGoldenBetti :: [Int],+    genuineGoldenComplex :: H.FiniteChainComplex Integer+  }++genuineGoldenCorpus :: [GenuineGoldenCase]+genuineGoldenCorpus =+  [ GenuineGoldenCase+      { genuineGoldenName = "interval",+        genuineGoldenCellCounts = [2, 1],+        genuineGoldenBetti = [1, 0],+        genuineGoldenComplex = intervalComplex+      },+    GenuineGoldenCase+      { genuineGoldenName = "triangle cycle",+        genuineGoldenCellCounts = [3, 3],+        genuineGoldenBetti = [1, 1],+        genuineGoldenComplex = triangleCycleComplex+      },+    GenuineGoldenCase+      { genuineGoldenName = "tetrahedron boundary",+        genuineGoldenCellCounts = [4, 6, 4],+        genuineGoldenBetti = [1, 0, 1],+        genuineGoldenComplex = tetrahedronBoundaryComplex+      }+  ]++triangleCycleComplex :: H.FiniteChainComplex Integer+triangleCycleComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \dimensionValue ->+    case dimensionValue of+      H.HomologicalDegree 1 ->+        boundaryIncidence+          3+          3+          [ boundaryEntry 0 0 (-1),+            boundaryEntry 0 1 1,+            boundaryEntry 1 1 (-1),+            boundaryEntry 1 2 1,+            boundaryEntry 2 2 (-1),+            boundaryEntry 2 0 1+          ]+      H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 3 0+      _ -> H.emptyBoundaryIncidence++projectivePlaneComplex :: H.FiniteChainComplex Integer+projectivePlaneComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 2) $ \dimensionValue ->+    case dimensionValue of+      H.HomologicalDegree 2 ->+        boundaryIncidence 1 1 [boundaryEntry 0 0 2]+      H.HomologicalDegree 1 -> H.emptyBoundaryIncidenceOf 1 1+      H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 1 0+      _ -> H.emptyBoundaryIncidence++mooreComplex :: H.FiniteChainComplex Integer+mooreComplex = projectivePlaneComplex++tetrahedronBoundaryComplex :: H.FiniteChainComplex Integer+tetrahedronBoundaryComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 2) $ \dimensionValue ->+    case dimensionValue of+      H.HomologicalDegree 2 ->+        boundaryIncidence+          4+          6+          [ boundaryEntry 0 3 1,+            boundaryEntry 0 1 (-1),+            boundaryEntry 0 0 1,+            boundaryEntry 1 4 1,+            boundaryEntry 1 2 (-1),+            boundaryEntry 1 0 1,+            boundaryEntry 2 5 1,+            boundaryEntry 2 2 (-1),+            boundaryEntry 2 1 1,+            boundaryEntry 3 5 1,+            boundaryEntry 3 4 (-1),+            boundaryEntry 3 3 1+          ]+      H.HomologicalDegree 1 ->+        boundaryIncidence+          6+          4+          [ boundaryEntry 0 0 (-1),+            boundaryEntry 0 1 1,+            boundaryEntry 1 0 (-1),+            boundaryEntry 1 2 1,+            boundaryEntry 2 0 (-1),+            boundaryEntry 2 3 1,+            boundaryEntry 3 1 (-1),+            boundaryEntry 3 2 1,+            boundaryEntry 4 1 (-1),+            boundaryEntry 4 3 1,+            boundaryEntry 5 2 (-1),+            boundaryEntry 5 3 1+          ]+      H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 4 0+      _ -> H.emptyBoundaryIncidence++intervalComplex :: H.FiniteChainComplex Integer+intervalComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \dimensionValue ->+    case dimensionValue of+      H.HomologicalDegree 1 ->+        boundaryIncidence+          1+          2+          [ boundaryEntry 0 0 (-1),+            boundaryEntry 0 1 1+          ]+      H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 2 0+      _ -> H.emptyBoundaryIncidence++tetrahedronBoundaryMissingFaceComplex :: H.FiniteChainComplex Integer+tetrahedronBoundaryMissingFaceComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 2) $ \dimensionValue ->+    case dimensionValue of+      H.HomologicalDegree 2 ->+        boundaryIncidence+          3+          6+          [ boundaryEntry 0 1 (-1),+            boundaryEntry 0 2 1,+            boundaryEntry 0 4 1,+            boundaryEntry 1 0 1,+            boundaryEntry 1 2 1,+            boundaryEntry 1 3 (-1),+            boundaryEntry 2 1 1,+            boundaryEntry 2 3 (-1),+            boundaryEntry 2 5 1+          ]+      H.HomologicalDegree 1 ->+        boundaryIncidence+          6+          4+          [ boundaryEntry 0 1 (-1),+            boundaryEntry 0 3 1,+            boundaryEntry 1 0 (-1),+            boundaryEntry 1 2 1,+            boundaryEntry 2 0 (-1),+            boundaryEntry 2 1 1,+            boundaryEntry 3 0 (-1),+            boundaryEntry 3 3 1,+            boundaryEntry 4 1 (-1),+            boundaryEntry 4 2 1,+            boundaryEntry 5 2 (-1),+            boundaryEntry 5 3 1+          ]+      H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 4 0+      _ -> H.emptyBoundaryIncidence++boundaryEntry :: Natural -> Natural -> coefficient -> H.BoundaryEntry coefficient+boundaryEntry = H.mkBoundaryEntry++boundaryIncidence :: (Eq coefficient, Semiring coefficient) => Natural -> Natural -> [H.BoundaryEntry coefficient] -> H.BoundaryIncidence coefficient+boundaryIncidence sourceDimension targetDimension entries =+  case H.mkBoundaryIncidence sourceDimension targetDimension entries of+    Left shapeError ->+      error ("invalid homology test fixture boundary: " <> show shapeError)+    Right incidence ->+      incidence++widePathComplex :: Natural -> H.FiniteChainComplex Integer+widePathComplex nodeCount =+  let edgeCount = nodeCount - 1+   in H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \dimensionValue ->+        case dimensionValue of+          H.HomologicalDegree 1 ->+            boundaryIncidence+              (fromIntegral edgeCount)+              (fromIntegral nodeCount)+              ( concatMap+                  ( \edgeIndex ->+                      [ H.mkBoundaryEntry edgeIndex edgeIndex (-1),+                        H.mkBoundaryEntry edgeIndex (edgeIndex + 1) 1+                      ]+                  )+                  [0 .. edgeCount - 1]+              )+          H.HomologicalDegree 0 ->+            boundaryIncidence (fromIntegral nodeCount) 0 []+          _ ->+            boundaryIncidence 0 0 []
+ test/topology/BlockSchurSpec.hs view
@@ -0,0 +1,161 @@+module BlockSchurSpec+  ( tests,+  )+where++import Data.Ratio ((%))+import Moonlight.Core (Semiring)+import Moonlight.Homology+  ( BasisBlock (..),+    BlockSchurFailure (..),+    BlockSchurPivot (..),+    BlockSchurReduction (..),+    BlockSchurTranscript (..),+    BoundaryEntry,+    BoundaryIncidence,+    FiniteChainComplex,+    HomologicalDegree (..),+    HomologyBackend (..),+    blockSchurReduceWith,+    boundaryCoefficient,+    boundaryEntries,+    emptyBoundaryIncidenceOf,+    freeRank,+    gf2BlockPivotOps,+    integerUnimodularBlockPivotOps,+    incidenceMatrixAt,+    mkBoundaryEntry,+    mkBoundaryIncidenceFromOrderedEntries,+    rationalBlockPivotOps,+    sourceCardinality,+    sourceIndex,+    targetIndex,+  )+import Moonlight.Homology.Boundary.Finite (mkFiniteChainComplex)+import Moonlight.Homology.Effect.Laws+  ( BlockSchurHomologyAgreement (..),+    checkBlockSchurHomologyAgreement,+  )+import Moonlight.LinAlg.Pure.Dense.Block+  ( BlockMatrixFailure (..),+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2 (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "block Schur reduction"+    [ testCase "rank-2 block interval cancels in one pivot" testRankTwoBlockInterval,+      testCase "Schur residual uses C - B P^-1 A" testSchurResidual,+      testCase "integer non-unimodular pivot is rejected" testIntegerNonUnimodularRejected,+      testGroup+        "laws"+        [ testCase "rank-2 block interval preserves integral homology" testIntegralAgreementLaw,+          testCase "GF2 block pivot preserves field Betti" testGF2AgreementLaw+        ]+    ]++testRankTwoBlockInterval :: Assertion+testRankTwoBlockInterval = do+  reduction <- rankTwoBlockIntervalReduction+  assertEqual "one block pivot matrix" [[1, 0], [0, 1]] (bstPivotMatrix (bsrTranscript reduction))+  assertEqual "all degree-one sources are removed" 0 (sourceCardinality (incidenceMatrixAt (bsrReducedComplex reduction) (HomologicalDegree 1)))+  assertEqual "all degree-zero targets are removed" 0 (sourceCardinality (incidenceMatrixAt (bsrReducedComplex reduction) (HomologicalDegree 0)))++testSchurResidual :: Assertion+testSchurResidual = do+  boundary <- boundaryMatrix 2 2 [(0, 0, 1 :: Rational), (1, 0, 2), (0, 1, 3), (1, 1, 5)]+  reduction <-+    expectRight $+      blockSchurReduceWith+        rationalBlockPivotOps+        (oneBoundaryComplex 2 boundary)+        (pivotAt 1 [0] [0])+  assertEqual+    "residual boundary entry"+    [((0, 0), (-1) :: Rational)]+    (entrySummary <$> boundaryEntries (bstResidualBoundary (bsrTranscript reduction)))++testIntegerNonUnimodularRejected :: Assertion+testIntegerNonUnimodularRejected = do+  boundary <- boundaryMatrix 1 1 [(0, 0, 2 :: Integer)]+  case blockSchurReduceWith+    integerUnimodularBlockPivotOps+    (oneBoundaryComplex 1 boundary)+    (pivotAt 1 [0] [0]) of+    Left failure ->+      assertEqual+        "non-unimodular integer pivot rejected"+        (BlockSchurPivotMatrixFailed (BlockMatrixNonUnimodular [[1 % 2]]))+        failure+    Right _ -> assertFailure "non-unimodular block unexpectedly reduced"++testIntegralAgreementLaw :: Assertion+testIntegralAgreementLaw = do+  reduction <- rankTwoBlockIntervalReduction+  agreement <- expectRight $ checkBlockSchurHomologyAgreement IntegralSmithBackend reduction+  assertEqual "integral homology agreement is empty-rank" [0, 0] (fmap (freeRank . snd) (bshaGroupsByDegree agreement))++testGF2AgreementLaw :: Assertion+testGF2AgreementLaw = do+  reduction <- gf2SingleIntervalReduction+  agreement <- expectRight $ checkBlockSchurHomologyAgreement GF2RankBackend reduction+  assertEqual "GF2 homology agreement" [0, 0] (fmap (freeRank . snd) (bshaGroupsByDegree agreement))++rankTwoBlockIntervalReduction :: IO (BlockSchurReduction Integer)+rankTwoBlockIntervalReduction = do+  boundary <- boundaryMatrix 2 2 [(0, 0, 1 :: Integer), (1, 1, 1)]+  expectRight $+    blockSchurReduceWith+      integerUnimodularBlockPivotOps+      (oneBoundaryComplex 2 boundary)+      (pivotAt 1 [0, 1] [0, 1])++gf2SingleIntervalReduction :: IO (BlockSchurReduction GF2)+gf2SingleIntervalReduction = do+  boundary <- boundaryMatrix 1 1 [(0, 0, GF2One)]+  expectRight $+    blockSchurReduceWith+      gf2BlockPivotOps+      (oneBoundaryComplex 1 boundary)+      (pivotAt 1 [0] [0])++oneBoundaryComplex :: Int -> BoundaryIncidence coefficient -> FiniteChainComplex coefficient+oneBoundaryComplex degreeZeroDimension boundary =+  mkFiniteChainComplex+    (HomologicalDegree 1)+    ( \degreeValue ->+        case degreeValue of+          HomologicalDegree 0 -> emptyBoundaryIncidenceOf (fromIntegral degreeZeroDimension) 0+          HomologicalDegree 1 -> boundary+          _ -> emptyBoundaryIncidenceOf 0 0+    )++pivotAt :: Int -> [Int] -> [Int] -> BlockSchurPivot+pivotAt upperDegree upperIndices lowerIndices =+  BlockSchurPivot+    { bspUpperBlock = BasisBlock (HomologicalDegree upperDegree) upperIndices,+      bspLowerBlock = BasisBlock (HomologicalDegree (upperDegree - 1)) lowerIndices+    }++boundaryMatrix :: (Eq coefficient, Semiring coefficient) => Int -> Int -> [(Int, Int, coefficient)] -> IO (BoundaryIncidence coefficient)+boundaryMatrix sourceCount targetCount entries =+  expectRight $+    mkBoundaryIncidenceFromOrderedEntries+      (fromIntegral sourceCount)+      (fromIntegral targetCount)+      [ mkBoundaryEntry (fromIntegral sourceIndexValue) (fromIntegral targetIndexValue) coefficientValue+        | (sourceIndexValue, targetIndexValue, coefficientValue) <- entries+      ]++entrySummary :: BoundaryEntry coefficient -> ((Int, Int), coefficient)+entrySummary entry =+  ((sourceIndex entry, targetIndex entry), boundaryCoefficient entry)++expectRight :: Show failure => Either failure value -> IO value+expectRight result =+  case result of+    Right value -> pure value+    Left failureValue -> assertFailure ("unexpected failure: " <> show failureValue)
+ test/topology/MorseSpec.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE DataKinds #-}++module MorseSpec+  ( tests,+  )+where++import Data.Function ((&))+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Ratio ((%))+import qualified Data.Set as Set+import Moonlight.Core (Semiring)+import qualified Moonlight.Homology as H+import qualified Moonlight.Homology.Boundary.Finite as H (mkFiniteChainComplex)+import TestFixtures+  ( GenuineGoldenCase (..),+    genuineGoldenCorpus,+    intervalComplex,+    mooreComplex,+    tetrahedronBoundaryMissingFaceComplex,+    triangleCycleComplex,+  )+import Moonlight.LinAlg.Pure.Dense.GF2 (GF2 (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "morse"+    [ testCase "unit incidences collapse while non-units remain critical" testUnitIncidenceFiltering,+      testCase "localized matching collapses non-unit incidences over Q" testLocalizedMatching,+      testCase "localized edge reversal uses reciprocal weights" testLocalizedEdgeReversal,+      testCase "generic algebraic Morse accepts rational nonunit pivots through compact reduction" testGenericRationalMorse,+      testCase "generic algebraic Morse accepts GF2 pivots and preserves field Betti" testGF2MorsePreservesFieldBetti,+      testCase "refined transcript preserves the simple localized collapse" testRefinedLocalizedMatching,+      testCase "refined transcript captures a second-pass collapse" testRefinedMatchingCapturesSecondPassCollapse,+      testCase "refined Morse complex exposes final rational reduction" testRefinedMorseComplexExposesFinalReduction,+      testCase "filtered refined Morse only collapses filtration-compatible pairs" testFilteredRefinedMorseCompatibility,+      testCase "critical-basis filtration transfer reports missing provenance as a typed obstruction" testMissingCriticalBasisProvenance,+      testCase "refined transcript reports terminality from final critical degrees" testRefinedMatchingTerminality,+      testCase "refined transcript propagates reduction failure as a typed obstruction" testRefinedTranscriptFailurePropagation,+      testCase "cyclic modified Hasse matchings are rejected with witnesses" testAcyclicityRejection,+      testCase "Morse differential remains nilpotent on triangle cycle" (assertMorseNilpotence "triangle cycle" triangleCycleComplex),+      testCase "Morse differential remains nilpotent on interval" (assertMorseNilpotence "interval" intervalComplex),+      testCase "Morse exposes projection and inclusion chain maps on interval" testIntervalMorseMaps,+      testCase "Morse differential differs from boundary restriction on triangle cycle" testBoundaryRestrictionDifference,+      goldenBettiPreservationTests+    ]++testUnitIncidenceFiltering :: Assertion+testUnitIncidenceFiltering =+  let triangleMatching = H.acyclicMatching triangleCycleComplex (const 0)+      mooreMatching = H.acyclicMatching mooreComplex (const 0)+   in do+        assertBool+          "triangle complex should admit unit-incidence matches"+          (not (null (H.amPairs triangleMatching)))+        H.amPairs mooreMatching @?= []+        length (H.amCriticalCells mooreMatching) @?= 3++testLocalizedMatching :: Assertion+testLocalizedMatching =+  let matchingValue = H.acyclicMatchingLocalized mooreComplex (const 0)+      expectedPair =+        H.LocalizedAcyclicPair+          { H.lapLowerCell = basisCellAt 1 0,+            H.lapUpperCell = basisCellAt 2 0,+            H.lapIncidenceCoefficient = 2 % 1+          }+   in do+        H.lamPairs matchingValue @?= [expectedPair]+        assertBool+          "localized matcher should accept non-unit incidences"+          (H.isAcyclicMatchingLocalized mooreComplex matchingValue)+        case H.morseComplexLocalized mooreComplex matchingValue of+          Left failureValue ->+            assertFailure ("unexpected localized Morse construction failure: " <> show failureValue)+          Right morseValue -> do+            let reducedComplexValue = H.lmcReducedComplex morseValue+            H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 2)) @?= 0+            H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 1)) @?= 0+            H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 0)) @?= 1+            H.lmcCriticalBasis morseValue+              @?= Map.fromList [(basisCellAt 0 0, basisCellAt 0 0)]++testLocalizedEdgeReversal :: Assertion+testLocalizedEdgeReversal =+  let lowerCell = basisCellAt 1 0+      upperCell = basisCellAt 2 0+      candidatePair =+        H.LocalizedAcyclicPair+          { H.lapLowerCell = lowerCell,+            H.lapUpperCell = upperCell,+            H.lapIncidenceCoefficient = 2 % 1+          }+      edgeMap = Map.fromList [((upperCell, lowerCell), 2 % 1)]+   in H.reverseCandidateEdgeLocalized candidatePair edgeMap+        @?= Map.fromList [((lowerCell, upperCell), (-1) % 2)]++testGenericRationalMorse :: Assertion+testGenericRationalMorse =+  let rationalComplex = H.rationalizeFiniteChainComplex mooreComplex+      matchingValue = H.acyclicMatchingWith H.rationalMorsePivotOps rationalComplex (const 0)+      expectedPair =+        H.LocalizedAcyclicPair+          { H.lapLowerCell = basisCellAt 1 0,+            H.lapUpperCell = basisCellAt 2 0,+            H.lapIncidenceCoefficient = 2 % 1+          }+   in do+        H.lamPairs matchingValue @?= [expectedPair]+        case H.morseComplexWith H.rationalMorsePivotOps rationalComplex matchingValue of+          Left failureValue ->+            assertFailure ("unexpected generic rational Morse construction failure: " <> show failureValue)+          Right morseValue -> do+            H.lmcCriticalBasis morseValue+              @?= Map.fromList [(basisCellAt 0 0, basisCellAt 0 0)]++testGF2MorsePreservesFieldBetti :: Assertion+testGF2MorsePreservesFieldBetti = do+  let matchingValue = H.acyclicMatchingWith H.gf2MorsePivotOps gf2IdentityComplex (const 0)+      expectedPair =+        H.LocalizedAcyclicPair+          { H.lapLowerCell = basisCellAt 0 0,+            H.lapUpperCell = basisCellAt 1 0,+            H.lapIncidenceCoefficient = GF2One+          }+  H.lamPairs matchingValue @?= [expectedPair]+  case H.morseComplexWith H.gf2MorsePivotOps gf2IdentityComplex matchingValue of+    Left failureValue ->+      assertFailure ("unexpected GF2 Morse construction failure: " <> show failureValue)+    Right morseValue -> do+      originalRanks <- gf2BettiRanks gf2IdentityComplex+      reducedRanks <- gf2BettiRanks (H.lmcReducedComplex morseValue)+      reducedRanks @?= originalRanks+      H.lmcCriticalBasis morseValue @?= Map.empty++testRefinedLocalizedMatching :: Assertion+testRefinedLocalizedMatching = do+  refinedTranscript <- expectRight (H.refinedAcyclicMatchingTranscript mooreComplex (const 0))+  let localizedMatching = H.acyclicMatchingLocalized mooreComplex (const 0)+      refinedMatching = H.flattenRefinedAcyclicMatching refinedTranscript+      refinedStagePairs = H.mapRefinedStages (H.lamPairs . H.refinedStageMatching) refinedTranscript+      refinedCriticalCells = H.refinedMatchingCriticalCells refinedTranscript+  H.lamPairs refinedMatching @?= H.lamPairs localizedMatching+  H.lamCriticalCells refinedMatching @?= H.lamCriticalCells localizedMatching+  H.lamObstructions refinedMatching @?= H.lamObstructions localizedMatching+  H.hasRefinedStages refinedTranscript @?= True+  H.refinedStageCount refinedTranscript @?= 1+  H.isTerminalRefinedMatching refinedTranscript @?= True+  H.finalRefinedCriticalDegrees refinedTranscript @?= [H.HomologicalDegree 0]+  H.finalRefinedCriticalCellCount refinedTranscript @?= 1+  H.finalRefinedCriticalDegreeHistogram refinedTranscript+    @?= Map.fromList [(H.HomologicalDegree 0, 1)]+  H.finalRefinedHomologicalSupport refinedTranscript+    @?= Set.fromList [H.HomologicalDegree 0]+  H.finalRefinedMaxCriticalDegree refinedTranscript+    @?= Just (H.HomologicalDegree 0)+  H.refinedMatchingSummary refinedTranscript+    @?= H.RefinedMatchingSummary+      { H.rmsStageCount = 1,+        H.rmsHasStages = True,+        H.rmsIsTerminal = True,+        H.rmsFinalCriticalCellCount = 1,+        H.rmsFinalCriticalDegreeHistogram = Map.fromList [(H.HomologicalDegree 0, 1)],+        H.rmsFinalHomologicalSupport = Set.fromList [H.HomologicalDegree 0],+        H.rmsFinalMaxCriticalDegree = Just (H.HomologicalDegree 0)+      }+  refinedCriticalCells @?= H.lamCriticalCells localizedMatching+  refinedStagePairs @?= [H.lamPairs localizedMatching]++testRefinedMatchingCapturesSecondPassCollapse :: Assertion+testRefinedMatchingCapturesSecondPassCollapse = do+  refinedTranscript <- expectRight (H.refinedAcyclicMatchingTranscript tetrahedronBoundaryMissingFaceComplex (const 0))+  let refinedMatching = H.flattenRefinedAcyclicMatching refinedTranscript+      (refinedStageSummaries, refinedCriticalCells) =+        H.summarizeRefinedMatching+          ( \stageValue ->+              [ ( length (H.lamPairs (H.refinedStageMatching stageValue)),+                  fmap H.cellDegree (H.lamCriticalCells (H.refinedStageMatching stageValue)),+                  maybe False (const True) (H.refinedStageReducedComplex stageValue)+                )+              ]+          )+          refinedTranscript+  H.hasRefinedStages refinedTranscript @?= True+  H.refinedStageCount refinedTranscript @?= 2+  H.isTerminalRefinedMatching refinedTranscript @?= True+  H.finalRefinedCriticalDegrees refinedTranscript @?= [H.HomologicalDegree 0]+  H.finalRefinedCriticalCellCount refinedTranscript @?= 1+  H.finalRefinedCriticalDegreeHistogram refinedTranscript+    @?= Map.fromList [(H.HomologicalDegree 0, 1)]+  H.finalRefinedHomologicalSupport refinedTranscript+    @?= Set.fromList [H.HomologicalDegree 0]+  H.finalRefinedMaxCriticalDegree refinedTranscript+    @?= Just (H.HomologicalDegree 0)+  refinedStageSummaries+    @?= [ (5, fmap H.HomologicalDegree [0, 1, 2], True),+          (1, [H.HomologicalDegree 0], True)+        ]+  length (H.lamPairs refinedMatching) @?= 6+  fmap H.cellDegree refinedCriticalCells+    @?= [H.HomologicalDegree 0]+  fmap H.cellDegree (H.lamCriticalCells refinedMatching)+    @?= [H.HomologicalDegree 0]++testRefinedMorseComplexExposesFinalReduction :: Assertion+testRefinedMorseComplexExposesFinalReduction =+  case H.refinedMorseComplex tetrahedronBoundaryMissingFaceComplex (const 0) of+    Left failureValue ->+      assertFailure ("unexpected refined Morse construction failure: " <> show failureValue)+    Right refinedComplex -> do+      let transcriptValue = H.rmcTranscript refinedComplex+          reducedComplexValue = H.rmcReducedComplex refinedComplex+          criticalBasisValue = H.rmcCriticalBasis refinedComplex+      H.refinedStageCount transcriptValue @?= 2+      H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 0)) @?= 1+      H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 1)) @?= 0+      H.sourceCardinality (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 2)) @?= 0+      Map.keys criticalBasisValue @?= [basisCellAt 0 0]+      fmap H.cellDegree (Map.elems criticalBasisValue) @?= [H.HomologicalDegree 0]++testFilteredRefinedMorseCompatibility :: Assertion+testFilteredRefinedMorseCompatibility =+  case H.filteredRefinedMorseComplex intervalComplex intervalFiltration (const 0) of+    Left failureValue ->+      assertFailure ("unexpected filtered refined Morse construction failure: " <> show failureValue)+    Right filteredComplex -> do+      let refinedComplex = H.frmcRefinedMorseComplex filteredComplex+          pairWitnesses = H.fmcPairWitnesses (H.frmcCompatibility filteredComplex)+          reducedFiltration = H.frmcReducedFiltrationByBasis filteredComplex+      pairWitnesses+        @?= [ H.FilteredMorsePairWitness+                { H.fmpwLowerCell = basisCellAt 0 1,+                  H.fmpwUpperCell = basisCellAt 1 0,+                  H.fmpwFiltrationLevel = 1+                }+            ]+      H.sourceCardinality (H.incidenceMatrixAt (H.rmcReducedComplex refinedComplex) (H.HomologicalDegree 0)) @?= 1+      reducedFiltration @?= Map.fromList [(basisCellAt 0 0, 0)]++testMissingCriticalBasisProvenance :: Assertion+testMissingCriticalBasisProvenance =+  case H.reducedFiltrationByCriticalBasis (H.rationalizeFiniteChainComplex intervalComplex) Map.empty intervalFiltration of+    Left (H.MissingCriticalBasisProvenance missingBasisRef) ->+      missingBasisRef @?= basisCellAt 0 0+    Left failureValue ->+      assertFailure ("expected missing-provenance obstruction, received " <> show failureValue)+    Right filtrationValue ->+      assertFailure ("expected missing-provenance obstruction, received filtration " <> show filtrationValue)++intervalFiltration :: H.BasisCellRef -> Int+intervalFiltration basisCellRef =+  case (H.cellDegree basisCellRef, H.cellIndex basisCellRef) of+    (H.HomologicalDegree 0, 0) -> 0+    (H.HomologicalDegree 0, 1) -> 1+    (H.HomologicalDegree 1, 0) -> 1+    _ -> 0++testRefinedMatchingTerminality :: Assertion+testRefinedMatchingTerminality = do+  refinedTranscript <- expectRight (H.refinedAcyclicMatchingTranscript triangleCycleComplex (const 0))+  H.hasRefinedStages refinedTranscript @?= True+  H.isTerminalRefinedMatching refinedTranscript @?= False+  H.finalRefinedCriticalCellCount refinedTranscript @?= 2+  List.sort (H.finalRefinedCriticalDegrees refinedTranscript)+    @?= [H.HomologicalDegree 0, H.HomologicalDegree 1]+  H.finalRefinedCriticalDegreeHistogram refinedTranscript+    @?= Map.fromList [(H.HomologicalDegree 0, 1), (H.HomologicalDegree 1, 1)]+  H.finalRefinedHomologicalSupport refinedTranscript+    @?= Set.fromList [H.HomologicalDegree 0, H.HomologicalDegree 1]+  H.finalRefinedMaxCriticalDegree refinedTranscript+    @?= Just (H.HomologicalDegree 1)+  H.refinedMatchingSummary refinedTranscript+    @?= H.RefinedMatchingSummary+      { H.rmsStageCount = 1,+        H.rmsHasStages = True,+        H.rmsIsTerminal = False,+        H.rmsFinalCriticalCellCount = 2,+        H.rmsFinalCriticalDegreeHistogram =+          Map.fromList [(H.HomologicalDegree 0, 1), (H.HomologicalDegree 1, 1)],+        H.rmsFinalHomologicalSupport = Set.fromList [H.HomologicalDegree 0, H.HomologicalDegree 1],+        H.rmsFinalMaxCriticalDegree = Just (H.HomologicalDegree 1)+      }++testRefinedTranscriptFailurePropagation :: Assertion+testRefinedTranscriptFailurePropagation =+  case H.refinedAcyclicMatchingTranscript nonNilpotentTwoStepComplex (const 0) of+    Left (H.LawViolation H.ChainNilpotenceLaw) -> pure ()+    Left otherFailure -> assertFailure ("unexpected failure: " <> show otherFailure)+    Right _ -> assertFailure "expected propagated law violation for non-nilpotent complex"++testAcyclicityRejection :: Assertion+testAcyclicityRejection =+  let cyclicMatching =+        H.AcyclicMatching+          { H.amPairs =+              [ pairAt 0 0 (-1),+                pairAt 1 1 (-1),+                pairAt 2 2 (-1)+              ],+            H.amCriticalCells = [],+            H.amObstructions = []+          }+      greedyMatching = H.acyclicMatching triangleCycleComplex (const 0)+   in do+        assertBool+          "manually cyclic matching must be rejected"+          (not (H.isAcyclicMatching triangleCycleComplex cyclicMatching))+        case H.amObstructions greedyMatching of+          obstructionValue : _ ->+            assertBool+              "cycle witness should expose a directed cycle"+              (length (H.coCycleWitness obstructionValue) >= 4)+          [] ->+            assertFailure "expected the greedy matcher to record a cycle obstruction"++assertMorseNilpotence :: String -> H.FiniteChainComplex Integer -> Assertion+assertMorseNilpotence label finite =+  withMorseComplex finite $ \morseValue ->+    let reducedComplexValue = H.mcReducedComplex morseValue+        H.HomologicalDegree maxDegreeValue = H.maxHomologicalDegree reducedComplexValue+     in mapM_+          ( \degreeValue ->+              case+                H.composeBoundaryIncidence+                  (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree (degreeValue - 1)))+                  (H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree degreeValue))+              of+                Left shapeError ->+                  assertFailure+                    ("unexpected boundary shape failure for " <> label <> " at degree " <> show degreeValue <> ": " <> show shapeError)+                Right composedBoundary ->+                  assertBool+                    ("expected ∂∘∂ = 0 for " <> label <> " at degree " <> show degreeValue)+                    (all ((== 0) . H.boundaryCoefficient) (H.boundaryEntries composedBoundary))+          )+          [1 .. maxDegreeValue]++testBoundaryRestrictionDifference :: Assertion+testBoundaryRestrictionDifference =+  withMorseComplex triangleCycleComplex $ \morseValue -> do+    let reducedComplexValue = H.mcReducedComplex morseValue+        morseBoundary = H.incidenceMatrixAt reducedComplexValue (H.HomologicalDegree 1)+        restrictedBoundary = restrictedBoundaryIncidence triangleCycleComplex (H.mcCriticalBasis morseValue) 1+    assertBool+      "triangle Morse differential should not collapse to naive boundary restriction"+      (morseBoundary /= restrictedBoundary)++testIntervalMorseMaps :: Assertion+testIntervalMorseMaps =+  withMorseComplex intervalComplex $ \morseValue -> do+    let criticalVertex = basisCellAt 0 0+        collapsedVertex = basisCellAt 0 0+        retainedVertex = basisCellAt 0 1+        intervalEdge = basisCellAt 1 0+    H.runChainMap (H.mcProjection morseValue) collapsedVertex @?= [(1, criticalVertex)]+    H.runChainMap (H.mcProjection morseValue) retainedVertex @?= [(1, criticalVertex)]+    H.runChainMap (H.mcProjection morseValue) intervalEdge @?= []+    H.runChainMap (H.mcInclusion morseValue) criticalVertex @?= [(1, retainedVertex)]+    H.runChainHomotopy (H.mcHomotopy morseValue) collapsedVertex @?= [(-1, intervalEdge)]+    H.runChainHomotopy (H.mcHomotopy morseValue) retainedVertex @?= []+    H.runChainHomotopy (H.mcHomotopy morseValue) intervalEdge @?= []++goldenBettiPreservationTests :: TestTree+goldenBettiPreservationTests =+  testGroup+    "golden betti preservation"+    ( genuineGoldenCorpus+        & fmap+          ( \goldenCase ->+              testCase (genuineGoldenName goldenCase) $+                withMorseComplex (genuineGoldenComplex goldenCase) $ \morseValue -> do+                  H.freeBettiVector (genuineGoldenComplex goldenCase)+                    @?= genuineGoldenBetti goldenCase+                  H.freeBettiVector (H.mcReducedComplex morseValue)+                    @?= genuineGoldenBetti goldenCase+          )+    )++withMorseComplex :: H.FiniteChainComplex Integer -> (H.MorseComplex Integer -> Assertion) -> Assertion+withMorseComplex finite assertion =+  let matchingValue = H.acyclicMatching finite (const 0)+   in case H.morseComplex finite matchingValue of+        Left failureValue ->+          assertFailure ("unexpected Morse construction failure: " <> show failureValue)+        Right morseValue ->+          assertion morseValue++gf2IdentityComplex :: H.FiniteChainComplex GF2+gf2IdentityComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \degreeValue ->+    case degreeValue of+      H.HomologicalDegree 1 ->+        validatedBoundaryIncidence 1 1 [H.mkBoundaryEntry 0 0 GF2One]+      H.HomologicalDegree 0 ->+        H.emptyBoundaryIncidenceOf 1 0+      _ ->+        H.emptyBoundaryIncidence++nonNilpotentTwoStepComplex :: H.FiniteChainComplex Integer+nonNilpotentTwoStepComplex =+  H.mkFiniteChainComplex (H.HomologicalDegree 2) $ \degreeValue ->+    case degreeValue of+      H.HomologicalDegree 2 ->+        validatedBoundaryIncidence 1 1 [H.mkBoundaryEntry 0 0 1]+      H.HomologicalDegree 1 ->+        validatedBoundaryIncidence 1 1 [H.mkBoundaryEntry 0 0 1]+      H.HomologicalDegree 0 ->+        H.emptyBoundaryIncidenceOf 1 0+      _ ->+        H.emptyBoundaryIncidence++gf2BettiRanks :: H.FiniteChainComplex GF2 -> IO [Int]+gf2BettiRanks finite =+  fmap (fmap H.freeRank) $+    expectRight+      ( H.computeBettiNumbers+          (H.fieldBettiCapability H.GF2FieldRankBackend :: H.BettiCapability 'H.Phase2 GF2)+          finite+      )++expectRight ::+  Show left =>+  Either left right ->+  IO right+expectRight result =+  case result of+    Left failureValue ->+      assertFailure (show failureValue)+    Right value ->+      pure value++pairAt :: Int -> Int -> Int -> H.AcyclicPair+pairAt lowerIndexValue upperIndexValue coefficientValue =+  H.AcyclicPair+    { H.apLowerCell = basisCellAt 0 lowerIndexValue,+      H.apUpperCell = basisCellAt 1 upperIndexValue,+      H.apIncidenceCoefficient = coefficientValue+    }++basisCellAt :: Int -> Int -> H.BasisCellRef+basisCellAt degreeValue indexValue =+  H.BasisCellRef+    { H.cellDegree = H.HomologicalDegree degreeValue,+      H.cellIndex = indexValue+    }++restrictedBoundaryIncidence ::+  H.FiniteChainComplex Integer ->+  Map.Map H.BasisCellRef H.BasisCellRef ->+  Int ->+  H.BoundaryIncidence Integer+restrictedBoundaryIncidence finite reducedBasis degreeValue =+  let sourceReducedPairs = reducedPairsAt degreeValue reducedBasis+      targetReducedPairs =+        if degreeValue <= 0+          then []+          else reducedPairsAt (degreeValue - 1) reducedBasis+      incidenceEntries =+        incidenceEntryMap (H.incidenceMatrixAt finite (H.HomologicalDegree degreeValue))+          & Map.toList+          & List.sortOn fst+          & foldr+            ( \((sourceIndexValue, targetIndexValue), coefficientValue) accumulator ->+                let sourceOriginal = basisCellAt degreeValue sourceIndexValue+                    targetOriginal = basisCellAt (degreeValue - 1) targetIndexValue+                 in case (lookupReducedRef sourceOriginal sourceReducedPairs, lookupReducedRef targetOriginal targetReducedPairs) of+                      (Just sourceReducedRef, Just targetReducedRef) ->+                        H.mkBoundaryEntry+                          (fromIntegral (H.cellIndex sourceReducedRef))+                          (fromIntegral (H.cellIndex targetReducedRef))+                          coefficientValue :+                          accumulator+                      _ ->+                        accumulator+            )+            []+   in validatedBoundaryIncidence+        (length sourceReducedPairs)+        (length targetReducedPairs)+        incidenceEntries++reducedPairsAt ::+  Int ->+  Map.Map H.BasisCellRef H.BasisCellRef ->+  [(H.BasisCellRef, H.BasisCellRef)]+reducedPairsAt degreeValue reducedBasis =+  reducedBasis+    & Map.toList+    & filter ((== H.HomologicalDegree degreeValue) . H.cellDegree . fst)+    & List.sortOn (H.cellIndex . fst)++lookupReducedRef ::+  H.BasisCellRef ->+  [(H.BasisCellRef, H.BasisCellRef)] ->+  Maybe H.BasisCellRef+lookupReducedRef originalCellValue =+  fmap fst+    . List.find ((== originalCellValue) . snd)++validatedBoundaryIncidence :: (Eq coefficient, Semiring coefficient) => Int -> Int -> [H.BoundaryEntry coefficient] -> H.BoundaryIncidence coefficient+validatedBoundaryIncidence sourceDimension targetDimension entries =+  case H.mkBoundaryIncidence (fromIntegral sourceDimension) (fromIntegral targetDimension) entries of+    Left shapeError ->+      error ("invalid Morse test boundary: " <> show shapeError)+    Right incidence ->+      incidence++incidenceEntryMap :: Num r => H.BoundaryIncidence r -> Map.Map (Int, Int) r+incidenceEntryMap incidence =+  H.boundaryEntries incidence+    & fmap+      ( \boundaryEntry ->+          ( (H.sourceIndex boundaryEntry, H.targetIndex boundaryEntry),+            H.boundaryCoefficient boundaryEntry+          )+      )+    & Map.fromListWith (+)
+ test/topology/TopologySpec.hs view
@@ -0,0 +1,1159 @@+module TopologySpec+  ( tests,+  )+where++import Data.Bifunctor (first)+import Data.Function ((&))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Maybe (isNothing)+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Moonlight.Homology as H+import qualified Moonlight.Homology.Boundary.Finite as H (mkFiniteChainComplex)+import Moonlight.Homology.Pure.Topology.Algebra (mkQuotientPresentation)+import Moonlight.Homology.Pure.Topology.Harmonic (harmonicBasisAt)+import TestFixtures+  ( intervalComplex,+    mooreComplex,+    projectivePlaneComplex,+    tetrahedronBoundaryComplex,+    triangleCycleComplex,+  )+import Moonlight.Pale.Test.Assertions (assertApproxEqual, expectRight, expectSome)+import Moonlight.Pale.Test.Core (mkTolerance)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertEqual, assertFailure, testCase)+++tests :: TestTree+tests =+  testGroup+    "topology"+    [ testCase "exact witness recovers Betti and Euler for triangle cycle" testExactWitnessTriangle,+      testCase "tetrahedron boundary computes the 2-sphere H2 anchor" testTetrahedronBoundarySphereAnchor,+      testCase "graph adjacency algebra inserts absent keys and counts connected components" testGraphAdjacencyAlgebra,+      testCase "sparse H0 graph representatives choose one vertex per component" testSparseGraphHomologyRepresentatives,+      testCase "sparse H0 cohomology representatives are component-constant" testSparseGraphCohomologyRepresentatives,+      testCase "malformed graph-shaped boundaries use generic sparse fallback" testSparseGraphFallbackOnMalformedBoundaries,+      testCase "graph skeleton preserves parallel one-cell multiplicity" testGraphSkeletonParallelMultiplicity,+      testCase "exact witness recovers torsion and exact classes for Moore complex" testExactWitnessMoore,+      testCase "projective plane cellular attaching map exposes Z/2 torsion" testProjectivePlaneTorsionAnchor,+      testCase "persistent witness tracks the essential loop birth" testPersistentTriangleLoop,+      testCase "graph witness extracts scaffold and low modes on interval" testGraphWitnessInterval,+      testCase "graph witness remains convergent on branched five-vertex skeletons" testGraphWitnessBranchedFiveVertexSkeleton,+      testCase "graph witness seed enriches graph scaffolds with exact loop data" testGraphWitnessSeedTriangle,+      testCase "harmonic loop discovery enriches scaffold from exact cycle data" testHarmonicLoopDiscovery,+      scaffoldCompositionTests,+      testCase "topology targets validate witness constraints through the target algebra" testTopologyTargets,+      testCase "direction field constructor rejects coverage mismatch" testDirectionFieldConstructorRejectsCoverageMismatch,+      testCase "direction angle constructor normalizes phase modulo symmetry" testDirectionAngleConstructorNormalizesPhase,+      testCase "direction phase constructor rejects non-finite values" testDirectionPhaseConstructorRejectsNonFiniteValues,+      testCase "direction coefficient constructor rejects non-finite values" testDirectionCoefficientConstructorRejectsNonFiniteValues,+      testCase "potential value constructor rejects non-finite values" testPotentialValueConstructorRejectsNonFiniteValues,+      testCase "scalar potential raw constructor rejects non-finite samples" testScalarPotentialFieldRawConstructorRejectsNonFiniteSamples,+      testCase "graded torsion family reuses canonical degree aggregation laws" testGradedTorsionFamily,+      testCase "graded query kernel reuses selection across homology, persistence, and harmonics" testGradedQueryKernel,+      testCase "topology observers interpret witness data without raw record spelunking" testTopologyObserver,+      testCase "cohomologyBasisAt degree 1 is non-empty for triangle cycle" testCohomologyBasisTriangle,+      testCase "cohomologyBasisAt degree 1 is empty for contractible interval" testCohomologyBasisInterval,+      testCase "cohomologyBasisAt degree 1 is empty for degenerate zero-boundary complex" testCohomologyBasisDegenerate,+      presentationCoordinateTests+    ]++scaffoldCompositionTests :: TestTree+scaffoldCompositionTests =+  testGroup+    "macro scaffold composition"+    [ testCase "is identity on singleton inputs" testMacroScaffoldCompositionSingletonIdentity,+      testCase "preserves basis reindex stability" testMacroScaffoldCompositionBasisReindexing,+      testCase "keeps Reeb, singularity, and loop ids disjoint" testMacroScaffoldCompositionIdDisjointness,+      testCase "stitches routed regions with a seam arc" testMacroScaffoldRouteStitching,+      testCase "keeps route-kind seams distinct" testMacroScaffoldRouteKindsRemainDistinct,+      testCase "widens weighted corridor seams" testMacroScaffoldWeightedCorridorSeams,+      testCase "preserves scalar and direction compatibility checks" testMacroScaffoldCompositionCompatibilityChecks,+      testCase "adds scaffold cardinalities across disjoint union" testMacroScaffoldCompositionCardinalityAdditivity,+      testCase "rejects incompatible inputs symmetrically" testMacroScaffoldCompositionCompatibilitySymmetry,+      testCase "adds Reeb cycle rank across disjoint union" testMacroScaffoldCompositionCycleRank+    ]++withExactWitness ::+  H.FiniteChainComplex Integer ->+  (H.TopologyWitness H.MacroScaffoldIR H.GraphSpectralMode H.FiltrationValue Rational Int -> Assertion) ->+  Assertion+withExactWitness finite assertion = do+  witnessValue <- expectRight (H.exactTopologyWitness finite)+  assertion witnessValue++testExactWitnessTriangle :: Assertion+testExactWitnessTriangle =+  withExactWitness triangleCycleComplex $ \witnessValue ->+    let degreeOneCycles =+          H.topologyCoefficientRepresentativeCycles witnessValue+            & filter ((== H.HomologicalDegree 1) . H.representativeDegree)+        degreeOneCocycles =+          H.topologyCoefficientRepresentativeCocycles witnessValue+            & filter ((== H.HomologicalDegree 1) . H.representativeDegree)+     in do+          fmap H.unEulerCharacteristic (H.topologyEulerCharacteristic witnessValue) @?= Just 0+          H.topologyBettiVector witnessValue @?= [1, 1]+          fmap H.freeRank (H.topologyIntegralHomologyGroups witnessValue) @?= [1, 1]+          fmap H.torsionInvariants (H.topologyIntegralHomologyGroups witnessValue) @?= [[], []]+          length degreeOneCycles @?= 1+          length degreeOneCocycles @?= 1++testTetrahedronBoundarySphereAnchor :: Assertion+testTetrahedronBoundarySphereAnchor = do+  integralGroups <-+    expectRight+      ( H.runHomologyBackend+          (H.IntegralSmithBackend :: H.HomologyBackend Integer Integer)+          tetrahedronBoundaryComplex+      )+  rationalGroups <-+    expectRight+      ( H.runHomologyBackend+          H.RationalRankBackend+          (H.rationalizeFiniteChainComplex tetrahedronBoundaryComplex)+      )+  witnessValue <- expectRight (H.exactTopologyWitness tetrahedronBoundaryComplex)+  fmap (H.degreeCardinality tetrahedronBoundaryComplex . H.HomologicalDegree) [0, 1, 2] @?= [4, 6, 4]+  length (H.boundaryEntries (H.incidenceMatrixAt tetrahedronBoundaryComplex (H.HomologicalDegree 2))) @?= 12+  let tetrahedronBoundaryComposite =+        H.composeBoundaryIncidence+          (H.incidenceMatrixAt tetrahedronBoundaryComplex (H.HomologicalDegree 1))+          (H.incidenceMatrixAt tetrahedronBoundaryComplex (H.HomologicalDegree 2))+  case tetrahedronBoundaryComposite of+    Left shapeError ->+      assertFailure ("unexpected tetrahedron boundary composition shape failure: " <> show shapeError)+    Right compositeBoundary ->+      assertBool+        "tetrahedron boundary satisfies d1 . d2 = 0"+        (all ((== 0) . H.boundaryCoefficient) (H.boundaryEntries compositeBoundary))+  fmap H.freeRank integralGroups @?= [1, 0, 1]+  fmap H.torsionInvariants integralGroups @?= [[], [], []]+  fmap H.freeRank rationalGroups @?= [1, 0, 1]+  H.topologyBettiVector witnessValue @?= [1, 0, 1]+  fmap H.unEulerCharacteristic (H.topologyEulerCharacteristic witnessValue) @?= Just 2+  length (harmonicBasisAt tetrahedronBoundaryComplex (H.HomologicalDegree 2)) @?= 1++testGraphAdjacencyAlgebra :: Assertion+testGraphAdjacencyAlgebra =+  let adjacency =+        ( H.addUndirectedAdjacency 0 1+            . H.addUndirectedAdjacency 0 1+            . H.addUndirectedAdjacency 2 3+            $ Map.empty+        ) ::+          Map.Map Integer [Integer]+   in do+        adjacency+          @?= Map.fromList+            [ (0, [1, 1]),+              (1, [0, 0]),+              (2, [3]),+              (3, [2])+            ]+        H.connectedComponentsFromAdjacency adjacency @?= 2++testSparseGraphHomologyRepresentatives :: Assertion+testSparseGraphHomologyRepresentatives = do+  disconnectedGraph <- expectRight (graphChainComplex 4 [(0, 1), (2, 3)])+  fmap H.representativeTerms (H.sparseHomologyBasisAt intervalComplex (H.HomologicalDegree 0))+    @?= [[(1, 0)]]+  fmap H.representativeTerms (H.sparseHomologyBasisAt disconnectedGraph (H.HomologicalDegree 0))+    @?= [[(1, 0)], [(1, 2)]]++testSparseGraphCohomologyRepresentatives :: Assertion+testSparseGraphCohomologyRepresentatives = do+  disconnectedGraph <- expectRight (graphChainComplex 4 [(0, 1), (2, 3)])+  fmap H.representativeTerms (H.sparseCohomologyBasisAt intervalComplex (H.HomologicalDegree 0))+    @?= [[(1, 0), (1, 1)]]+  fmap H.representativeTerms (H.sparseCohomologyBasisAt disconnectedGraph (H.HomologicalDegree 0))+    @?= [[(1, 0), (1, 1)], [(1, 2), (1, 3)]]++testSparseGraphFallbackOnMalformedBoundaries :: Assertion+testSparseGraphFallbackOnMalformedBoundaries = do+  nonUnitGraph <- expectRight (boundaryOneComplex 2 1 [boundaryEntry 0 0 (-2), boundaryEntry 0 1 2])+  singleEndpointGraph <- expectRight (boundaryOneComplex 2 1 [boundaryEntry 0 0 1])+  H.graph1SkeletonFromComplex nonUnitGraph @?= Left (H.InvalidOrientedUnitGraphEdgeBoundary 0)+  H.graph1SkeletonFromComplex singleEndpointGraph @?= Left (H.InvalidOrientedUnitGraphEdgeBoundary 0)+  assertBool+    "non-unit graph-shaped boundary still falls back to generic sparse H0 representatives"+    (not (null (H.sparseHomologyBasisAt nonUnitGraph (H.HomologicalDegree 0))))+  fmap H.representativeTerms (H.sparseHomologyBasisAt singleEndpointGraph (H.HomologicalDegree 0))+    @?= [[(1, 1)]]++testGraphSkeletonParallelMultiplicity :: Assertion+testGraphSkeletonParallelMultiplicity = do+  parallelPath <- expectRight (graphChainComplex 3 [(0, 1), (0, 1), (1, 2)])+  skeleton <- expectRight (H.graph1SkeletonFromComplex parallelPath)+  potentialField <- expectRight parallelPathPotentialField+  scaffoldValue <- expectRight (H.graphMacroScaffold potentialField skeleton)+  let potentials = Map.fromList [(0, 0.0), (1, 1.0), (2, 2.0)]+      edgeIndicesAt vertexValue =+        fmap H.graphEdgeIndex (Map.findWithDefault [] vertexValue (H.graphEdgeAdjacency skeleton))+      reebValue = H.macroScaffoldReeb scaffoldValue+  H.graphEdges skeleton+    @?= [ H.GraphEdge 0 0 1,+          H.GraphEdge 1 0 1,+          H.GraphEdge 2 1 2+        ]+  edgeIndicesAt 0 @?= [0, 1]+  edgeIndicesAt 1 @?= [0, 1, 2]+  H.higherNeighbors potentials skeleton 0 @?= [1, 1]+  H.lowerNeighbors potentials skeleton 1 @?= [0, 0]+  H.higherNeighbors potentials skeleton 1 @?= [2]+  H.criticalKindAt potentials skeleton 1 @?= Just H.Merge+  fmap H.morseReebNodeKind (H.morseReebNodes reebValue) @?= [H.Basin, H.Merge, H.Peak]+  fmap H.morseReebArcSupport (H.morseReebArcs reebValue)+    @?= [ [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 0},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}+          ],+          [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 1},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}+          ],+          [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 2},+            H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2}+          ]+        ]+  spectralModes <- expectRight (H.graphSpectralModes 3 skeleton)+  length spectralModes @?= 3++testExactWitnessMoore :: Assertion+testExactWitnessMoore =+  withExactWitness mooreComplex $ \witnessValue ->+    let degreeOneClasses =+          H.topologyExactRepresentativeClasses witnessValue+            & filter ((== H.HomologicalDegree 1) . H.exactClassDegree)+     in do+          fmap H.unEulerCharacteristic (H.topologyEulerCharacteristic witnessValue) @?= Just 1+          H.topologyBettiVector witnessValue @?= [1, 0, 0]+          fmap H.freeRank (H.topologyIntegralHomologyGroups witnessValue) @?= [1, 0, 0]+          fmap H.torsionInvariants (H.topologyIntegralHomologyGroups witnessValue) @?= [[], [2], []]+          fmap H.exactClassOrder degreeOneClasses @?= [Just 2]+          fmap (H.representativeTerms . H.exactClassRepresentative) degreeOneClasses @?= [[(1, 0)]]++testProjectivePlaneTorsionAnchor :: Assertion+testProjectivePlaneTorsionAnchor = do+  integralGroups <-+    expectRight+      ( H.runHomologyBackend+          (H.IntegralSmithBackend :: H.HomologyBackend Integer Integer)+          projectivePlaneComplex+      )+  fmap (H.degreeCardinality projectivePlaneComplex . H.HomologicalDegree) [0, 1, 2] @?= [1, 1, 1]+  fmap H.boundaryCoefficient (H.boundaryEntries (H.incidenceMatrixAt projectivePlaneComplex (H.HomologicalDegree 2))) @?= [2]+  fmap H.freeRank integralGroups @?= [1, 0, 0]+  fmap H.torsionInvariants integralGroups @?= [[], [2], []]++testPersistentTriangleLoop :: Assertion+testPersistentTriangleLoop = do+  filteredComplex <- expectRight (H.mkFilteredFiniteChainComplex triangleCycleComplex triangleFiltration)+  witnessValue <- expectRight (H.observeTopologyWitness defaultTopologyConfig {H.observationFiltration = Just filteredComplex} triangleCycleComplex)+  let essentialLoops =+        H.topologyPersistencePairs witnessValue+          & filter (\pairValue -> H.persistenceDegree pairValue == H.HomologicalDegree 1)+          & filter (isNothing . H.persistenceDeath)+  length essentialLoops @?= 1+  fmap H.persistenceBirth essentialLoops @?= [H.FiltrationValue 2.0]++testGraphWitnessInterval :: Assertion+testGraphWitnessInterval =+  withIntervalObservation $ \intervalObservationValue -> do+    _ <- expectRight (H.graph1SkeletonFromComplex intervalComplex)+    witnessValue <- expectRight (H.observeTopologyWitness intervalObservationValue intervalComplex)+    H.topologyBettiVector witnessValue @?= [1, 0]+    scaffoldValue <- expectSome "expected macro scaffold" (H.topologyMacroScaffold witnessValue)+    length (H.carrierCells (H.scalarPotentialCarrier (H.macroScaffoldScalarPotential scaffoldValue))) @?= 2+    H.unDirectionSymmetryOrder (H.directionFieldSymmetryOrder (H.macroScaffoldDirectionField scaffoldValue)) @?= 1+    length (H.morseReebNodes (H.macroScaffoldReeb scaffoldValue)) @?= 2+    fmap H.morseReebNodeKind (H.morseReebNodes (H.macroScaffoldReeb scaffoldValue)) @?= [H.Basin, H.Peak]+    length (H.morseReebArcs (H.macroScaffoldReeb scaffoldValue)) @?= 1+    fmap H.singularityKind (H.macroScaffoldSingularities scaffoldValue) @?= [H.Basin, H.Peak]+    let spectralModes = H.topologyLowSpectralModes witnessValue+    length spectralModes @?= 2+    assertBool+      "contains zero mode"+      (spectralModes & any (\modeValue -> abs (H.spectralEigenvalue modeValue) < 1.0e-6))++testGraphWitnessBranchedFiveVertexSkeleton :: Assertion+testGraphWitnessBranchedFiveVertexSkeleton =+  let branchedSkeleton =+        H.graphFromEdgeSupports+          5+          [ (0, 1),+            (1, 2),+            (2, 3),+            (3, 4),+            (0, 2),+            (1, 3)+          ]+   in do+        witnessValue <- expectRight (H.graphTopologyWitness 2 Nothing branchedSkeleton)+        length (H.topologyLowSpectralModes witnessValue) @?= 2+        assertBool+          "contains zero mode for connected branched skeleton"+          (H.topologyLowSpectralModes witnessValue & any (\modeValue -> abs (H.spectralEigenvalue modeValue) < 1.0e-6))++testGraphWitnessSeedTriangle :: Assertion+testGraphWitnessSeedTriangle =+  withTriangleObservation $ \triangleObservationValue -> do+    triangleSkeleton <- expectRight (H.graph1SkeletonFromComplex triangleCycleComplex)+    witnessValue <-+      expectRight+        ( H.observeTopologyWitnessSeed+            ( ( H.GraphTopologySeed+                  triangleSkeleton+                  Nothing+                  (H.observationPotential triangleObservationValue)+                  (H.observationLowModeCount triangleObservationValue)+              ) ::+                H.TopologyWitnessSeed Integer+            )+        )+    H.topologyBettiVector witnessValue @?= [1, 1]+    scaffoldValue <- expectSome "expected graph seed scaffold" (H.topologyMacroScaffold witnessValue)+    length (H.macroScaffoldHarmonicLoops scaffoldValue) @?= 1++testHarmonicLoopDiscovery :: Assertion+testHarmonicLoopDiscovery =+  withTriangleObservation $ \triangleObservationValue -> do+    witnessValue <- expectRight (H.observeTopologyWitness triangleObservationValue triangleCycleComplex)+    scaffoldValue <- expectSome "expected macro scaffold with harmonic loop enrichment" (H.topologyMacroScaffold witnessValue)+    case H.macroScaffoldHarmonicLoops scaffoldValue of+      [H.HarmonicLoop {H.harmonicLoopDegree = degreeValue, H.harmonicLoopSupport = supportValue, H.harmonicLoopCycle = cycleValue}] -> do+        degreeValue @?= H.HomologicalDegree 1+        assertEqual "harmonic loop support count" 2 (length supportValue)+        assertEqual "harmonic loop cycle term count" 3 (length (H.representativeTerms cycleValue))+      observedLoops ->+        assertFailure ("expected one harmonic loop, observed " <> show observedLoops)++testMacroScaffoldCompositionSingletonIdentity :: Assertion+testMacroScaffoldCompositionSingletonIdentity = do+  _ <- expectRight intervalMacroScaffold+  _ <- expectRight triangleMacroScaffold+  assertSingletonIdentity intervalCompositionFixture+  assertSingletonIdentity triangleCompositionFixture++testMacroScaffoldCompositionBasisReindexing :: Assertion+testMacroScaffoldCompositionBasisReindexing =+  withSelfComposition intervalCompositionFixture $ \_ composedScaffold -> do+          H.carrierCells (H.scalarPotentialCarrier (H.macroScaffoldScalarPotential composedScaffold))+            @?= basisRefs (H.HomologicalDegree 0) [0, 1, 2, 3]+          Map.keys (H.scalarPotentialSamples (H.macroScaffoldScalarPotential composedScaffold))+            @?= basisRefs (H.HomologicalDegree 0) [0, 1, 2, 3]+          H.carrierCells (H.directionFieldCarrier (H.macroScaffoldDirectionField composedScaffold))+            @?= basisRefs (H.HomologicalDegree 1) [0, 1]+          fmap H.morseReebNodeAnchor (H.morseReebNodes (H.macroScaffoldReeb composedScaffold))+            @?= basisRefs (H.HomologicalDegree 0) [0, 1, 2, 3]+          (H.morseReebArcs (H.macroScaffoldReeb composedScaffold) >>= H.morseReebArcSupport)+            @?= [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0},+                  H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 0},+                  H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1},+                  H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2},+                  H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 1},+                  H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 3}+                ]++testMacroScaffoldCompositionIdDisjointness :: Assertion+testMacroScaffoldCompositionIdDisjointness =+  withSelfComposition triangleCompositionFixture $ \_ composedScaffold -> do+          assertDistinct "Reeb node ids remain disjoint" (fmap H.morseReebNodeId (H.morseReebNodes (H.macroScaffoldReeb composedScaffold)))+          assertDistinct "Reeb arc ids remain disjoint" (fmap H.morseReebArcId (H.morseReebArcs (H.macroScaffoldReeb composedScaffold)))+          assertDistinct "singularity ids remain disjoint" (fmap H.singularityId (H.macroScaffoldSingularities composedScaffold))+          assertDistinct "harmonic loop ids remain disjoint" (fmap H.harmonicLoopId (H.macroScaffoldHarmonicLoops composedScaffold))+          fmap H.harmonicLoopId (H.macroScaffoldHarmonicLoops composedScaffold)+            @?= [H.HarmonicLoopId 0, H.HarmonicLoopId 1]++testMacroScaffoldRouteStitching :: Assertion+testMacroScaffoldRouteStitching =+  withFixture intervalCompositionFixture $ \leftScaffold ->+    withFixture intervalCompositionFixture $ \rightScaffold -> do+      (composedScaffold, regionScopes) <-+        expectRight (H.composeMacroScaffoldsWithScopes ((Text.pack "left", leftScaffold) :| [(Text.pack "right", rightScaffold)]))+      (stitchedScaffold, stitchScopes) <-+        expectRight+          ( H.stitchMacroScaffoldRoutes+              stitchSemantics+              regionScopes+              [H.StitchRoute (Text.pack "trail") (Text.pack "left" :| [Text.pack "right"])]+              composedScaffold+          )+      length (H.morseReebArcs (H.macroScaffoldReeb stitchedScaffold))+        @?= length (H.morseReebArcs (H.macroScaffoldReeb composedScaffold)) + 1+      let trailKey = H.StitchRouteKey (Text.pack "trail") (Text.pack "left") (Text.pack "right")+          trailScope = Map.findWithDefault Set.empty trailKey stitchScopes+          leftRegionRefs = Map.findWithDefault Set.empty (Text.pack "left") regionScopes+          rightRegionRefs = Map.findWithDefault Set.empty (Text.pack "right") regionScopes+      assertBool "trail stitch scope is non-empty" (not (Set.null trailScope))+      assertBool "trail scope contains refs from left region"+        (not (Set.null (Set.intersection trailScope leftRegionRefs)))+      assertBool "trail scope contains refs from right region"+        (not (Set.null (Set.intersection trailScope rightRegionRefs)))+      assertEqual "trail stitch basis scope size" 6 (Set.size trailScope)+  where+    stitchSemantics routeKind =+      if routeKind == Text.pack "trail"+        then+          H.StitchSemantics+            { H.ssSourceBoundary = H.UpperBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.BoundarySupport,+              H.ssSupportRefinement = H.BoundaryEnvelopeRefinement+            }+        else+          H.StitchSemantics+            { H.ssSourceBoundary = H.LowerBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.AnchorSupport,+              H.ssSupportRefinement = H.KernelSupportRefinement+            }++testMacroScaffoldRouteKindsRemainDistinct :: Assertion+testMacroScaffoldRouteKindsRemainDistinct =+  withFixture intervalCompositionFixture $ \leftScaffold ->+    withFixture intervalCompositionFixture $ \rightScaffold -> do+      (composedScaffold, regionScopes) <-+        expectRight (H.composeMacroScaffoldsWithScopes ((Text.pack "left", leftScaffold) :| [(Text.pack "right", rightScaffold)]))+      (stitchedScaffold, stitchScopes) <-+        expectRight+          ( H.stitchMacroScaffoldRoutes+              stitchSemantics+              regionScopes+              [ H.StitchRoute (Text.pack "trail") (Text.pack "left" :| [Text.pack "right"]),+                H.StitchRoute (Text.pack "waterway") (Text.pack "left" :| [Text.pack "right"])+              ]+              composedScaffold+          )+      let trailKey = H.StitchRouteKey (Text.pack "trail") (Text.pack "left") (Text.pack "right")+          waterwayKey = H.StitchRouteKey (Text.pack "waterway") (Text.pack "left") (Text.pack "right")+          trailScope = Map.findWithDefault Set.empty trailKey stitchScopes+          waterwayScope = Map.findWithDefault Set.empty waterwayKey stitchScopes+          leftRegionRefs = Map.findWithDefault Set.empty (Text.pack "left") regionScopes+          rightRegionRefs = Map.findWithDefault Set.empty (Text.pack "right") regionScopes+      length (H.morseReebArcs (H.macroScaffoldReeb stitchedScaffold))+        @?= length (H.morseReebArcs (H.macroScaffoldReeb composedScaffold)) + 2+      assertBool "trail scope contains refs from left region"+        (not (Set.null (Set.intersection trailScope leftRegionRefs)))+      assertBool "trail scope contains refs from right region"+        (not (Set.null (Set.intersection trailScope rightRegionRefs)))+      assertEqual "trail stitch basis scope size" 6 (Set.size trailScope)+      assertEqual "waterway stitch basis scope size" 2 (Set.size waterwayScope)+      assertBool "expected route kinds to retain distinct stitch supports" (trailScope /= waterwayScope)+      assertBool "waterway scope is a subset of trail scope" (Set.isSubsetOf waterwayScope trailScope)+      assertBool "expected anchor waterway support to be no larger than trail support" (Set.size waterwayScope <= Set.size trailScope)+  where+    stitchSemantics routeKind =+      if routeKind == Text.pack "trail"+        then+          H.StitchSemantics+            { H.ssSourceBoundary = H.UpperBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.BoundarySupport,+              H.ssSupportRefinement = H.BoundaryEnvelopeRefinement+            }+        else+          H.StitchSemantics+            { H.ssSourceBoundary = H.LowerBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.AnchorSupport,+              H.ssSupportRefinement = H.KernelSupportRefinement+            }++testMacroScaffoldWeightedCorridorSeams :: Assertion+testMacroScaffoldWeightedCorridorSeams =+  withFixture intervalCompositionFixture $ \leftScaffold ->+    withFixture intervalCompositionFixture $ \rightScaffold -> do+      (composedScaffold, regionScopes) <-+        expectRight (H.composeMacroScaffoldsWithScopes ((Text.pack "left", leftScaffold) :| [(Text.pack "right", rightScaffold)]))+      (_, stitchScopes) <-+        expectRight+          ( H.stitchMacroScaffoldRoutes+              stitchSemantics+              regionScopes+              [ H.StitchRoute (Text.pack "waterway-light") (Text.pack "left" :| [Text.pack "right"]),+                H.StitchRoute (Text.pack "waterway-heavy") (Text.pack "left" :| [Text.pack "right"])+              ]+              composedScaffold+          )+      let lightKey = H.StitchRouteKey (Text.pack "waterway-light") (Text.pack "left") (Text.pack "right")+          heavyKey = H.StitchRouteKey (Text.pack "waterway-heavy") (Text.pack "left") (Text.pack "right")+          lightScope = Map.findWithDefault Set.empty lightKey stitchScopes+          heavyScope = Map.findWithDefault Set.empty heavyKey stitchScopes+          leftRegionRefs = Map.findWithDefault Set.empty (Text.pack "left") regionScopes+          rightRegionRefs = Map.findWithDefault Set.empty (Text.pack "right") regionScopes+      assertBool "light seam scope is non-empty" (not (Set.null lightScope))+      assertEqual "light seam scope size" 2 (Set.size lightScope)+      assertBool "heavy scope contains refs from left region"+        (not (Set.null (Set.intersection heavyScope leftRegionRefs)))+      assertBool "heavy scope contains refs from right region"+        (not (Set.null (Set.intersection heavyScope rightRegionRefs)))+      assertEqual "heavy seam scope size" 6 (Set.size heavyScope)+      assertBool "light scope is a subset of heavy scope" (Set.isSubsetOf lightScope heavyScope)+      assertBool "expected heavy corridor to widen support" (Set.size heavyScope >= Set.size lightScope)+      assertBool "expected weighted seams to remain distinct" (lightScope /= heavyScope)+  where+    stitchSemantics routeKind =+      if routeKind == Text.pack "waterway-light"+        then+          H.StitchSemantics+            { H.ssSourceBoundary = H.LowerBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.AnchorSupport,+              H.ssSupportRefinement = H.KernelSupportRefinement+            }+        else+          H.StitchSemantics+            { H.ssSourceBoundary = H.LowerBoundary,+              H.ssTargetBoundary = H.LowerBoundary,+              H.ssSupportSelection = H.AnchorSupport,+              H.ssSupportRefinement = H.RegionalEnvelopeRefinement+            }++testMacroScaffoldCompositionCompatibilityChecks :: Assertion+testMacroScaffoldCompositionCompatibilityChecks =+  withFixture intervalCompositionFixture $ \scaffoldValue -> do+    angleDirectionField <- expectRight (rebuildAngleDirectionField (H.macroScaffoldDirectionField scaffoldValue))+    let normalizationMismatch =+          scaffoldValue+            { H.macroScaffoldScalarPotential =+                (H.macroScaffoldScalarPotential scaffoldValue)+                  { H.scalarPotentialNormalization = H.UnitIntervalPotentialScale+                  }+            }+        encodingMismatch =+          scaffoldValue+            { H.macroScaffoldDirectionField = angleDirectionField+            }+    H.composeMacroScaffolds (scaffoldValue :| [normalizationMismatch])+      @?= Left H.MismatchedScalarPotentialNormalizations+    H.composeMacroScaffolds (scaffoldValue :| [encodingMismatch])+      @?= Left H.MismatchedDirectionEncodingFamilies++testMacroScaffoldCompositionCardinalityAdditivity :: Assertion+testMacroScaffoldCompositionCardinalityAdditivity =+  withComposedScaffolds intervalCompositionFixture triangleCompositionFixture $ \intervalScaffold triangleScaffold composedScaffold ->+          scaffoldCardinalities composedScaffold+            @?= addScaffoldCardinalities+              (scaffoldCardinalities intervalScaffold)+              (scaffoldCardinalities triangleScaffold)++testMacroScaffoldCompositionCompatibilitySymmetry :: Assertion+testMacroScaffoldCompositionCompatibilitySymmetry =+  withFixture intervalCompositionFixture $ \scaffoldValue -> do+    angleDirectionField <- expectRight (rebuildAngleDirectionField (H.macroScaffoldDirectionField scaffoldValue))+    let normalizationMismatch =+          scaffoldValue+            { H.macroScaffoldScalarPotential =+                (H.macroScaffoldScalarPotential scaffoldValue)+                  { H.scalarPotentialNormalization = H.UnitIntervalPotentialScale+                  }+            }+        encodingMismatch =+          scaffoldValue+            { H.macroScaffoldDirectionField = angleDirectionField+            }+    assertSymmetricCompositionFailure+      H.MismatchedScalarPotentialNormalizations+      scaffoldValue+      normalizationMismatch+    assertSymmetricCompositionFailure+      H.MismatchedDirectionEncodingFamilies+      scaffoldValue+      encodingMismatch++testMacroScaffoldCompositionCycleRank :: Assertion+testMacroScaffoldCompositionCycleRank =+  withSelfComposition triangleCompositionFixture $ \scaffoldValue composedScaffold ->+          reebCycleRank (H.macroScaffoldReeb composedScaffold)+            @?= 2 * reebCycleRank (H.macroScaffoldReeb scaffoldValue)++testTopologyTargets :: Assertion+testTopologyTargets =+  withIntervalObservation $ \intervalObservationValue -> do+    witnessValue <- expectRight (H.observeTopologyWitness intervalObservationValue intervalComplex)+    let targetValues =+          [ H.EulerTarget (H.EulerBound (H.Exactly 1)),+            H.BettiTarget (H.TargetBetti [1, 0]),+            H.SkeletonTarget+              H.SkeletonAdherence+                { H.skeletonTargetSignature =+                    H.SkeletonSignature+                      { H.signatureCriticalCounts = Map.fromList [(H.Basin, 1), (H.Peak, 1)],+                        H.signatureArcCount = 1+                      },+                  H.skeletonTolerance = 0+                }+          ]+    H.validateTopologyTargets witnessValue targetValues @?= Right ()+    case H.validateTopologyTarget witnessValue (H.BettiTarget (H.TargetBetti [0, 1])) of+      Left (H.TargetViolation {H.violatedTarget = H.BettiTarget _, H.targetViolationCause = H.BettiViolation _ observedBetti}) ->+        observedBetti @?= [1, 0]+      validationResult ->+        assertFailure ("expected target violation for incorrect Betti target, observed " <> show validationResult)++testDirectionFieldConstructorRejectsCoverageMismatch :: Assertion+testDirectionFieldConstructorRejectsCoverageMismatch =+  let supportedCell =+        H.BasisCellRef+          { H.cellDegree = H.HomologicalDegree 1,+            H.cellIndex = 0+          }+      missingCell =+        H.BasisCellRef+          { H.cellDegree = H.HomologicalDegree 1,+            H.cellIndex = 1+          }+      extraneousCell =+        H.BasisCellRef+          { H.cellDegree = H.HomologicalDegree 1,+            H.cellIndex = 2+          }+   in do+        carrierValue <- expectRight (H.mkCellCarrier (H.HomologicalDegree 1) [supportedCell, missingCell])+        symmetryOrderValue <- expectRight (H.mkDirectionSymmetryOrder 2)+        supportedCoefficient <- expectRight (first show (H.mkDirectionCoefficient 1.0))+        extraneousCoefficient <- expectRight (first show (H.mkDirectionCoefficient (-1.0)))+        H.mkDirectionCochainField+          carrierValue+          symmetryOrderValue+          ( Map.fromList+              [ (supportedCell, supportedCoefficient),+                (extraneousCell, extraneousCoefficient)+              ]+          )+          @?= Left+            H.DirectionFieldCoverageMismatch+              { H.directionFieldMissingCells = [missingCell],+                H.directionFieldExtraneousCells = [extraneousCell]+              }++testDirectionAngleConstructorNormalizesPhase :: Assertion+testDirectionAngleConstructorNormalizesPhase =+  let supportedCell =+        H.BasisCellRef+          { H.cellDegree = H.HomologicalDegree 1,+            H.cellIndex = 0+          }+      expectedPhase = pi / 2+   in do+        carrierValue <- expectRight (H.mkCellCarrier (H.HomologicalDegree 1) [supportedCell])+        symmetryOrderValue <- expectRight (H.mkDirectionSymmetryOrder 2)+        phaseValue <- expectRight (first show (H.mkDirectionPhase ((-3) * pi / 2)))+        directionFieldValue <-+          expectRight+            ( H.mkDirectionAngleField+                carrierValue+                symmetryOrderValue+                (Map.fromList [(supportedCell, phaseValue)])+            )+        case H.directionFieldEncoding directionFieldValue of+          H.DirectionAngleEncoding phaseMap -> do+            normalizedPhaseValue <-+              expectSome "normalized direction phase missing from angle encoding" (Map.lookup supportedCell phaseMap)+            assertApproxEqual+              "angle phase normalized modulo symmetry order"+              (mkTolerance 1.0e-9 0)+              expectedPhase+              (H.unDirectionPhase normalizedPhaseValue)+          H.DirectionCochainEncoding _ ->+            assertFailure "expected angle encoding after angle field construction"++testDirectionPhaseConstructorRejectsNonFiniteValues :: Assertion+testDirectionPhaseConstructorRejectsNonFiniteValues =+  case (H.mkDirectionPhase (0 / 0), H.mkDirectionPhase (1 / 0)) of+    (Left (H.NonFiniteDirectionPhase notANumberValue), Left (H.NonFiniteDirectionPhase infiniteValue)) -> do+      assertBool "direction phase rejects NaN" (isNaN notANumberValue)+      assertBool "direction phase rejects infinity" (isInfinite infiniteValue)+    (nanResult, infinityResult) ->+      assertFailure+        ( "expected non-finite direction phase failures, observed "+            <> show (nanResult, infinityResult)+        )++testDirectionCoefficientConstructorRejectsNonFiniteValues :: Assertion+testDirectionCoefficientConstructorRejectsNonFiniteValues =+  case (H.mkDirectionCoefficient (0 / 0), H.mkDirectionCoefficient ((-1) / 0)) of+    (Left (H.NonFiniteDirectionCoefficient notANumberValue), Left (H.NonFiniteDirectionCoefficient infiniteValue)) -> do+      assertBool "direction coefficient rejects NaN" (isNaN notANumberValue)+      assertBool "direction coefficient rejects infinity" (isInfinite infiniteValue)+    (nanResult, infinityResult) ->+      assertFailure+        ( "expected non-finite direction coefficient failures, observed "+            <> show (nanResult, infinityResult)+        )++testPotentialValueConstructorRejectsNonFiniteValues :: Assertion+testPotentialValueConstructorRejectsNonFiniteValues =+  case (H.mkPotentialValue (0 / 0), H.mkPotentialValue (1 / 0)) of+    (Left (H.NonFinitePotentialValue notANumberValue), Left (H.NonFinitePotentialValue infiniteValue)) -> do+      assertBool "potential value rejects NaN" (isNaN notANumberValue)+      assertBool "potential value rejects infinity" (isInfinite infiniteValue)+    (nanResult, infinityResult) ->+      assertFailure+        ( "expected non-finite potential value failures, observed "+            <> show (nanResult, infinityResult)+        )++testScalarPotentialFieldRawConstructorRejectsNonFiniteSamples :: Assertion+testScalarPotentialFieldRawConstructorRejectsNonFiniteSamples =+  let supportedCell =+        H.BasisCellRef+          { H.cellDegree = H.HomologicalDegree 0,+            H.cellIndex = 0+          }+   in do+        carrierValue <- expectRight (H.mkCellCarrier (H.HomologicalDegree 0) [supportedCell])+        case+          H.mkScalarPotentialFieldFromSamples+            carrierValue+            H.NativePotentialScale+            (Map.fromList [(supportedCell, 0 / 0)])+          of+          Left (H.ScalarPotentialFieldInvalidSamples [(invalidCell, H.NonFinitePotentialValue invalidValue)]) -> do+            invalidCell @?= supportedCell+            assertBool "scalar potential raw constructor rejects NaN sample" (isNaN invalidValue)+          otherResult ->+            assertFailure+              ( "expected scalar potential invalid-sample failure, observed "+                  <> show otherResult+              )++testGradedTorsionFamily :: Assertion+testGradedTorsionFamily =+  let torsionFamily =+        H.mkGradedTorsionFamily+          [ H.HomologyGroup {H.freeRank = 1, H.torsionInvariants = [] :: [Integer]},+            H.HomologyGroup {H.freeRank = 0, H.torsionInvariants = [4 :: Integer]},+            H.HomologyGroup {H.freeRank = 0, H.torsionInvariants = [3 :: Integer]}+          ]+      combinedTorsion = H.gradedTorsionCombined H.selectAllDegrees torsionFamily+      supportQuery = H.degreewiseUnionQuery H.selectAllDegrees+      productQuery = H.directProductQuery H.selectAllDegrees+   in do+        fmap H.finiteAbelianInvariants (H.gradedTorsionAtDegree (H.HomologicalDegree 1) torsionFamily) @?= Just [4]+        H.gradedTorsionOrderSupport supportQuery torsionFamily @?= [2, 3, 4]+        H.gradedTorsionOrderSupport productQuery torsionFamily @?= [2, 3, 4, 6, 12]+        H.gradedTorsionPrimaryOrderSupport 2 supportQuery torsionFamily @?= Just [2, 4]+        H.finiteAbelianInvariants combinedTorsion @?= [3, 4]+        H.finiteAbelianExactOrderElementCount 12 combinedTorsion @?= 4++testGradedQueryKernel :: Assertion+testGradedQueryKernel =+  let degreeOneSelection = H.selectDegree (H.HomologicalDegree 1)+      degreeIndexedGroups =+        H.enumerateDegreeIndexed+          [ H.HomologyGroup {H.freeRank = 1, H.torsionInvariants = [] :: [Integer]},+            H.HomologyGroup {H.freeRank = 0, H.torsionInvariants = [4 :: Integer]},+            H.HomologyGroup {H.freeRank = 0, H.torsionInvariants = [3 :: Integer]}+          ]+      persistencePairs =+        [ H.PersistencePair+            { H.persistenceDegree = H.HomologicalDegree 0,+              H.persistenceBirth = H.FiltrationValue 0.0,+              H.persistenceDeath = Nothing+            },+          H.PersistencePair+            { H.persistenceDegree = H.HomologicalDegree 1,+              H.persistenceBirth = H.FiltrationValue 2.0,+              H.persistenceDeath = Nothing+            }+        ]+      harmonicBasis =+        [ H.HarmonicBasisElement+            { H.harmonicDegree = H.HomologicalDegree 1,+              H.harmonicRepresentative =+                H.RepresentativeChain+                  { H.representativeDegree = H.HomologicalDegree 1,+                    H.representativeTerms = [(1 :: Integer, 0 :: Int)]+                  }+            },+          H.HarmonicBasisElement+            { H.harmonicDegree = H.HomologicalDegree 2,+              H.harmonicRepresentative =+                H.RepresentativeChain+                  { H.representativeDegree = H.HomologicalDegree 2,+                    H.representativeTerms = [(1 :: Integer, 1 :: Int)]+                  }+            }+        ]+   in do+        fmap H.torsionInvariants (H.selectDegreeIndexed degreeOneSelection degreeIndexedGroups) @?= [[4 :: Integer]]+        fmap H.torsionInvariants (H.lookupDegreeIndexed (H.HomologicalDegree 2) degreeIndexedGroups) @?= Just [3 :: Integer]+        H.countGradedMembers H.persistenceDegree degreeOneSelection persistencePairs @?= 1+        H.countGradedMembers H.harmonicDegree degreeOneSelection harmonicBasis @?= 1++testTopologyObserver :: Assertion+testTopologyObserver =+  withIntervalObservation $ \intervalObservationValue -> do+    _ <- expectRight (H.graph1SkeletonFromComplex intervalComplex)+    witnessValue <- expectRight (H.observeTopologyWitness intervalObservationValue intervalComplex)+    let topologyView =+          H.mkMacroScaffoldTopologyView witnessValue+    H.runTopologyObserver H.observeBettiVector topologyView @?= [1, 0]+    fmap H.freeRank (H.runTopologyObserver (H.observeIntegralHomology H.selectAllDegrees) topologyView) @?= [1, 0]+    H.runTopologyObserver (H.observePersistenceCount H.selectAllDegrees) topologyView @?= 0+    H.runTopologyObserver (H.observeHarmonicCount (H.selectDegree (H.HomologicalDegree 0))) topologyView @?= 0+    H.runWitnessInterpreter (H.mkMacroScaffoldWitnessInterpreter H.observeScaffoldSummary) witnessValue+      @?= Just+        H.SkeletonSignature+          { H.signatureCriticalCounts = Map.fromList [(H.Basin, 1), (H.Peak, 1)],+            H.signatureArcCount = 1+          }++graphChainComplex :: Int -> [(Int, Int)] -> Either String (H.FiniteChainComplex Integer)+graphChainComplex vertexCount edgeSupports =+  boundaryOneComplex+    vertexCount+    (length edgeSupports)+    (zipWith orientedEdgeBoundaryEntries [0 ..] edgeSupports >>= id)++boundaryOneComplex ::+  Int ->+  Int ->+  [H.BoundaryEntry Integer] ->+  Either String (H.FiniteChainComplex Integer)+boundaryOneComplex vertexCount edgeCount entries = do+  edgeBoundary <-+    first show $+      H.mkBoundaryIncidence+        (fromIntegral edgeCount)+        (fromIntegral vertexCount)+        entries+  pure+    ( H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \dimensionValue ->+        case dimensionValue of+          H.HomologicalDegree 1 ->+            edgeBoundary+          H.HomologicalDegree 0 ->+            H.emptyBoundaryIncidenceOf (fromIntegral vertexCount) 0+          _ ->+            H.emptyBoundaryIncidence+    )++orientedEdgeBoundaryEntries :: Int -> (Int, Int) -> [H.BoundaryEntry Integer]+orientedEdgeBoundaryEntries edgeIndexValue (sourceVertex, targetVertex) =+  [ boundaryEntry edgeIndexValue sourceVertex (-1),+    boundaryEntry edgeIndexValue targetVertex 1+  ]++boundaryEntry :: Int -> Int -> coefficient -> H.BoundaryEntry coefficient+boundaryEntry sourceIndexValue targetIndexValue =+  H.mkBoundaryEntry (fromIntegral sourceIndexValue) (fromIntegral targetIndexValue)++triangleFiltration :: [(H.BasisCellRef, H.FiltrationValue)]+triangleFiltration =+  [ (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0}, H.FiltrationValue 0.0),+    (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}, H.FiltrationValue 0.0),+    (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2}, H.FiltrationValue 0.0),+    (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 0}, H.FiltrationValue 1.0),+    (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 1}, H.FiltrationValue 1.0),+    (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 1, H.cellIndex = 2}, H.FiltrationValue 2.0)+  ]++withIntervalObservation :: (H.TopologyObservationConfig Integer -> Assertion) -> Assertion+withIntervalObservation assertion = do+  observationValue <- expectRight intervalObservation+  assertion observationValue++intervalObservation :: Either String (H.TopologyObservationConfig Integer)+intervalObservation = do+  potentialField <- intervalPotentialField+  pure+    defaultTopologyConfig+      { H.observationPotential = Just potentialField,+        H.observationLowModeCount = 2+      }++withTriangleObservation :: (H.TopologyObservationConfig Integer -> Assertion) -> Assertion+withTriangleObservation assertion = do+  observationValue <- expectRight triangleObservation+  assertion observationValue++triangleObservation :: Either String (H.TopologyObservationConfig Integer)+triangleObservation = do+  potentialField <- trianglePotentialField+  pure+    defaultTopologyConfig+      { H.observationPotential = Just potentialField,+        H.observationLowModeCount = 0+      }++trianglePotentialField :: Either String H.ScalarPotentialField+trianglePotentialField = do+  carrierValue <-+    first show $+      H.mkCellCarrier+        (H.HomologicalDegree 0)+        [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0},+          H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1},+          H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2}+        ]+  first show $+    H.mkScalarPotentialFieldFromSamples+      carrierValue+      H.NativePotentialScale+      ( Map.fromList+          [ (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0}, 0.0),+            (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}, 1.0),+            (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2}, 2.0)+          ]+      )++parallelPathPotentialField :: Either String H.ScalarPotentialField+parallelPathPotentialField = do+  carrierValue <-+    first show $+      H.mkCellCarrier+        (H.HomologicalDegree 0)+        (basisRefs (H.HomologicalDegree 0) [0, 1, 2])+  first show $+    H.mkScalarPotentialFieldFromSamples+      carrierValue+      H.NativePotentialScale+      ( Map.fromList+          [ (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0}, 0.0),+            (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}, 1.0),+            (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 2}, 2.0)+          ]+      )++intervalPotentialField :: Either String H.ScalarPotentialField+intervalPotentialField = do+  carrierValue <-+    first show $+      H.mkCellCarrier+        (H.HomologicalDegree 0)+        [ H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0},+          H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}+        ]+  first show $+    H.mkScalarPotentialFieldFromSamples+      carrierValue+      H.NativePotentialScale+      ( Map.fromList+          [ (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 0}, 0.0),+            (H.BasisCellRef {H.cellDegree = H.HomologicalDegree 0, H.cellIndex = 1}, 1.0)+          ]+      )++defaultTopologyConfig :: H.TopologyObservationConfig Integer+defaultTopologyConfig =+  H.TopologyObservationConfig+    { H.observationFiltration = Nothing,+      H.observationPotential = Nothing,+      H.observationLowModeCount = 0+    }++intervalMacroScaffold :: Either String H.MacroScaffoldIR+intervalMacroScaffold =+  observedMacroScaffold intervalObservation intervalComplex++intervalCompositionFixture :: CompositionFixture+intervalCompositionFixture =+  CompositionFixture+    { compositionFixtureLabel = "interval scaffold",+      compositionFixtureScaffold = intervalMacroScaffold+    }++triangleMacroScaffold :: Either String H.MacroScaffoldIR+triangleMacroScaffold =+  observedMacroScaffold triangleObservation triangleCycleComplex++triangleCompositionFixture :: CompositionFixture+triangleCompositionFixture =+  CompositionFixture+    { compositionFixtureLabel = "triangle scaffold",+      compositionFixtureScaffold = triangleMacroScaffold+    }++observedMacroScaffold ::+  Either String (H.TopologyObservationConfig Integer) ->+  H.FiniteChainComplex Integer ->+  Either String H.MacroScaffoldIR+observedMacroScaffold observationResult finiteComplex = do+  observationValue <- observationResult+  witnessValue <- first show (H.observeTopologyWitness observationValue finiteComplex)+  maybe+    (Left "expected macro scaffold")+    Right+    (H.topologyMacroScaffold witnessValue)++rebuildAngleDirectionField :: H.DirectionField -> Either String H.DirectionField+rebuildAngleDirectionField directionFieldValue = do+  phaseValue <- first show (H.mkDirectionPhase 0.0)+  first show $+    H.mkDirectionAngleField+      (H.directionFieldCarrier directionFieldValue)+      (H.directionFieldSymmetryOrder directionFieldValue)+      ( Map.fromList+          ( fmap+              (\basisCellRef -> (basisCellRef, phaseValue))+              (H.carrierCells (H.directionFieldCarrier directionFieldValue))+          )+      )++basisRefs :: H.HomologicalDegree -> [Int] -> [H.BasisCellRef]+basisRefs degreeValue =+  fmap+    (\indexValue -> H.BasisCellRef {H.cellDegree = degreeValue, H.cellIndex = indexValue})++type CompositionFixture :: Type+data CompositionFixture = CompositionFixture+  { compositionFixtureLabel :: String,+    compositionFixtureScaffold :: Either String H.MacroScaffoldIR+  }++withFixture :: CompositionFixture -> (H.MacroScaffoldIR -> Assertion) -> Assertion+withFixture fixtureValue assertion = do+  scaffoldValue <- expectRight (compositionFixtureScaffold fixtureValue)+  assertion scaffoldValue++withComposedScaffolds ::+  CompositionFixture ->+  CompositionFixture ->+  (H.MacroScaffoldIR -> H.MacroScaffoldIR -> H.MacroScaffoldIR -> Assertion) ->+  Assertion+withComposedScaffolds leftFixture rightFixture assertion =+  withFixture leftFixture $ \leftScaffold ->+    withFixture rightFixture $ \rightScaffold -> do+      composedScaffold <- expectRight (H.composeMacroScaffolds (leftScaffold :| [rightScaffold]))+      assertion leftScaffold rightScaffold composedScaffold++withSelfComposition ::+  CompositionFixture ->+  (H.MacroScaffoldIR -> H.MacroScaffoldIR -> Assertion) ->+  Assertion+withSelfComposition fixtureValue assertion =+  withComposedScaffolds fixtureValue fixtureValue (\scaffoldValue _ composedScaffold -> assertion scaffoldValue composedScaffold)++assertSingletonIdentity :: CompositionFixture -> Assertion+assertSingletonIdentity fixtureValue =+  withFixture fixtureValue $ \scaffoldValue ->+    H.composeMacroScaffolds (scaffoldValue :| []) @?= Right scaffoldValue++type ScaffoldCardinalities :: Type+data ScaffoldCardinalities = ScaffoldCardinalities+  { scaffoldScalarCarrierCount :: Int,+    scaffoldDirectionCarrierCount :: Int,+    scaffoldReebNodeCount :: Int,+    scaffoldReebArcCount :: Int,+    scaffoldSingularityCount :: Int,+    scaffoldHarmonicLoopCount :: Int+  }+  deriving stock (Eq, Show)++scaffoldCardinalities :: H.MacroScaffoldIR -> ScaffoldCardinalities+scaffoldCardinalities scaffoldValue =+  ScaffoldCardinalities+    { scaffoldScalarCarrierCount =+        length (H.carrierCells (H.scalarPotentialCarrier (H.macroScaffoldScalarPotential scaffoldValue))),+      scaffoldDirectionCarrierCount =+        length (H.carrierCells (H.directionFieldCarrier (H.macroScaffoldDirectionField scaffoldValue))),+      scaffoldReebNodeCount =+        length (H.morseReebNodes (H.macroScaffoldReeb scaffoldValue)),+      scaffoldReebArcCount =+        length (H.morseReebArcs (H.macroScaffoldReeb scaffoldValue)),+      scaffoldSingularityCount =+        length (H.macroScaffoldSingularities scaffoldValue),+      scaffoldHarmonicLoopCount =+        length (H.macroScaffoldHarmonicLoops scaffoldValue)+    }++addScaffoldCardinalities :: ScaffoldCardinalities -> ScaffoldCardinalities -> ScaffoldCardinalities+addScaffoldCardinalities leftCounts rightCounts =+  ScaffoldCardinalities+    { scaffoldScalarCarrierCount =+        scaffoldScalarCarrierCount leftCounts + scaffoldScalarCarrierCount rightCounts,+      scaffoldDirectionCarrierCount =+        scaffoldDirectionCarrierCount leftCounts + scaffoldDirectionCarrierCount rightCounts,+      scaffoldReebNodeCount =+        scaffoldReebNodeCount leftCounts + scaffoldReebNodeCount rightCounts,+      scaffoldReebArcCount =+        scaffoldReebArcCount leftCounts + scaffoldReebArcCount rightCounts,+      scaffoldSingularityCount =+        scaffoldSingularityCount leftCounts + scaffoldSingularityCount rightCounts,+      scaffoldHarmonicLoopCount =+        scaffoldHarmonicLoopCount leftCounts + scaffoldHarmonicLoopCount rightCounts+    }++assertDistinct :: Ord a => String -> [a] -> Assertion+assertDistinct message values =+  assertBool message (Set.size (Set.fromList values) == length values)++assertSymmetricCompositionFailure ::+  H.MacroScaffoldCompositionError ->+  H.MacroScaffoldIR ->+  H.MacroScaffoldIR ->+  Assertion+assertSymmetricCompositionFailure expectedFailure leftScaffold rightScaffold = do+  H.composeMacroScaffolds (leftScaffold :| [rightScaffold]) @?= Left expectedFailure+  H.composeMacroScaffolds (rightScaffold :| [leftScaffold]) @?= Left expectedFailure++reebCycleRank :: H.MorseReebScaffold -> Int+reebCycleRank reebValue =+  let nodes = H.morseReebNodes reebValue+      arcs = H.morseReebArcs reebValue+      adjacency = foldr insertArc (Map.fromList (fmap (\nodeValue -> (H.morseReebNodeId nodeValue, Set.empty)) nodes)) arcs+      componentCount = H.connectedComponentsFromAdjacency adjacency+   in max 0 (length arcs - length nodes + componentCount)+  where+    insertArc arcValue =+      connectNodes+        (H.morseReebArcSource arcValue)+        (H.morseReebArcTarget arcValue)++connectNodes ::+  H.ReebNodeId ->+  H.ReebNodeId ->+  Map.Map H.ReebNodeId (Set.Set H.ReebNodeId) ->+  Map.Map H.ReebNodeId (Set.Set H.ReebNodeId)+connectNodes sourceNode targetNode =+  Map.alter (Just . Set.insert targetNode . maybe Set.empty id) sourceNode+    . Map.alter (Just . Set.insert sourceNode . maybe Set.empty id) targetNode++testCohomologyBasisTriangle :: Assertion+testCohomologyBasisTriangle =+  let cocycles = H.cohomologyBasisAt triangleCycleComplex (H.HomologicalDegree 1)+   in assertEqual "H^1 cocycle count for triangle cycle" 1 (length cocycles)++testCohomologyBasisInterval :: Assertion+testCohomologyBasisInterval =+  let cocycles = H.cohomologyBasisAt intervalComplex (H.HomologicalDegree 1)+   in cocycles @?= []++testCohomologyBasisDegenerate :: Assertion+testCohomologyBasisDegenerate =+  let degenerateComplex :: H.FiniteChainComplex Integer+      degenerateComplex =+        H.mkFiniteChainComplex (H.HomologicalDegree 1) $ \dimensionValue ->+          case dimensionValue of+            H.HomologicalDegree 1 -> H.emptyBoundaryIncidenceOf 0 100+            H.HomologicalDegree 0 -> H.emptyBoundaryIncidenceOf 100 0+            _ -> H.emptyBoundaryIncidence+      cocycles = H.cohomologyBasisAt degenerateComplex (H.HomologicalDegree 1)+   in cocycles @?= []++presentationCoordinateTests :: TestTree+presentationCoordinateTests =+  testGroup+    "presentation coordinates (solveLinearCombination regression)"+    [ testCase "zero-dimensional quotient accepts empty target" $+        H.presentationCoordinates (mkQuotientPresentation 0 [] [] []) [] @?= Just [],+      testCase "trivial quotient in nonzero ambient space accepts zero vector" $+        H.presentationCoordinates (mkQuotientPresentation 3 [] [] []) [0, 0, 0] @?= Just [],+      testCase "trivial quotient in nonzero ambient space rejects nonzero vector" $+        H.presentationCoordinates (mkQuotientPresentation 3 [] [] []) [1, 0, 0] @?= Nothing,+      testCase "single basis vector yields correct coordinate" $+        H.presentationCoordinates (mkQuotientPresentation 2 [[1, 0]] [] []) [3, 0] @?= Just [3],+      testCase "vector outside basis span returns Nothing" $+        H.presentationCoordinates (mkQuotientPresentation 2 [[1, 0]] [] []) [0, 1] @?= Nothing,+      testCase "denominator absorbs component leaving quotient coordinates" $+        H.presentationCoordinates (mkQuotientPresentation 2 [[1, 0]] [] [[0, 1]]) [5, 7] @?= Just [5]+    ]