diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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).
diff --git a/THIRD_PARTY_NOTICES.md b/THIRD_PARTY_NOTICES.md
new file mode 100644
--- /dev/null
+++ b/THIRD_PARTY_NOTICES.md
@@ -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.
diff --git a/bench/Main.hs b/bench/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Main.hs
@@ -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
+    ]
diff --git a/bench/sequence/SparseSpectral.hs b/bench/sequence/SparseSpectral.hs
new file mode 100644
--- /dev/null
+++ b/bench/sequence/SparseSpectral.hs
@@ -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
diff --git a/bench/topology/MorseSpectral.hs b/bench/topology/MorseSpectral.hs
new file mode 100644
--- /dev/null
+++ b/bench/topology/MorseSpectral.hs
@@ -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
diff --git a/docs/BENCHMARKS-m4-pro.md b/docs/BENCHMARKS-m4-pro.md
new file mode 100644
--- /dev/null
+++ b/docs/BENCHMARKS-m4-pro.md
@@ -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 |
diff --git a/moonlight-homology.cabal b/moonlight-homology.cabal
new file mode 100644
--- /dev/null
+++ b/moonlight-homology.cabal
@@ -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
diff --git a/src-cell-category/Moonlight/Homology/Pure/Topology/CellCategory.hs b/src-cell-category/Moonlight/Homology/Pure/Topology/CellCategory.hs
new file mode 100644
--- /dev/null
+++ b/src-cell-category/Moonlight/Homology/Pure/Topology/CellCategory.hs
@@ -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
diff --git a/src-cell-complex/Moonlight/Homology/Pure/Topology/CellComplex.hs b/src-cell-complex/Moonlight/Homology/Pure/Topology/CellComplex.hs
new file mode 100644
--- /dev/null
+++ b/src-cell-complex/Moonlight/Homology/Pure/Topology/CellComplex.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/Carrier.hs b/src-chain/Moonlight/Homology/Pure/Carrier.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Carrier.hs
@@ -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)
+        }
diff --git a/src-chain/Moonlight/Homology/Pure/Chain.hs b/src-chain/Moonlight/Homology/Pure/Chain.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Chain.hs
@@ -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
+
diff --git a/src-chain/Moonlight/Homology/Pure/Constraint/Core.hs b/src-chain/Moonlight/Homology/Pure/Constraint/Core.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Constraint/Core.hs
@@ -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]
diff --git a/src-chain/Moonlight/Homology/Pure/Degree.hs b/src-chain/Moonlight/Homology/Pure/Degree.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Degree.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/Failure.hs b/src-chain/Moonlight/Homology/Pure/Failure.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Failure.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/Filtration.hs b/src-chain/Moonlight/Homology/Pure/Filtration.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Filtration.hs
@@ -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]
diff --git a/src-chain/Moonlight/Homology/Pure/FiniteAbelian.hs b/src-chain/Moonlight/Homology/Pure/FiniteAbelian.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/FiniteAbelian.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/Graded/Query.hs b/src-chain/Moonlight/Homology/Pure/Graded/Query.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Graded/Query.hs
@@ -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
diff --git a/src-chain/Moonlight/Homology/Pure/GradedTorsion.hs b/src-chain/Moonlight/Homology/Pure/GradedTorsion.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/GradedTorsion.hs
@@ -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
diff --git a/src-chain/Moonlight/Homology/Pure/Group.hs b/src-chain/Moonlight/Homology/Pure/Group.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Group.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/LinearCombination.hs b/src-chain/Moonlight/Homology/Pure/LinearCombination.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/LinearCombination.hs
@@ -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)
diff --git a/src-chain/Moonlight/Homology/Pure/Phase.hs b/src-chain/Moonlight/Homology/Pure/Phase.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Phase.hs
@@ -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 = ()
diff --git a/src-chain/Moonlight/Homology/Pure/Reductions.hs b/src-chain/Moonlight/Homology/Pure/Reductions.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Reductions.hs
@@ -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
diff --git a/src-chain/Moonlight/Homology/Pure/Reductions/Core.hs b/src-chain/Moonlight/Homology/Pure/Reductions/Core.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Reductions/Core.hs
@@ -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 ()
diff --git a/src-chain/Moonlight/Homology/Pure/Skeleton.hs b/src-chain/Moonlight/Homology/Pure/Skeleton.hs
new file mode 100644
--- /dev/null
+++ b/src-chain/Moonlight/Homology/Pure/Skeleton.hs
@@ -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
diff --git a/src-laws/Moonlight/Homology/Effect/Determinism.hs b/src-laws/Moonlight/Homology/Effect/Determinism.hs
new file mode 100644
--- /dev/null
+++ b/src-laws/Moonlight/Homology/Effect/Determinism.hs
@@ -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)
diff --git a/src-laws/Moonlight/Homology/Effect/Laws.hs b/src-laws/Moonlight/Homology/Effect/Laws.hs
new file mode 100644
--- /dev/null
+++ b/src-laws/Moonlight/Homology/Effect/Laws.hs
@@ -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 ..]
diff --git a/src-matrix/Moonlight/Homology/Boundary/Finite.hs b/src-matrix/Moonlight/Homology/Boundary/Finite.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Boundary/Finite.hs
@@ -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
diff --git a/src-matrix/Moonlight/Homology/Boundary/LinAlg.hs b/src-matrix/Moonlight/Homology/Boundary/LinAlg.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Boundary/LinAlg.hs
@@ -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)
diff --git a/src-matrix/Moonlight/Homology/Boundary/SNF.hs b/src-matrix/Moonlight/Homology/Boundary/SNF.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Boundary/SNF.hs
@@ -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)
diff --git a/src-matrix/Moonlight/Homology/Pure/Effective.hs b/src-matrix/Moonlight/Homology/Pure/Effective.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Effective.hs
@@ -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
diff --git a/src-matrix/Moonlight/Homology/Pure/Matrix/Reducer.hs b/src-matrix/Moonlight/Homology/Pure/Matrix/Reducer.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Matrix/Reducer.hs
@@ -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)
diff --git a/src-matrix/Moonlight/Homology/Pure/Matrix/Shape.hs b/src-matrix/Moonlight/Homology/Pure/Matrix/Shape.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Matrix/Shape.hs
@@ -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
diff --git a/src-matrix/Moonlight/Homology/Pure/Matrix/SparseLinAlg.hs b/src-matrix/Moonlight/Homology/Pure/Matrix/SparseLinAlg.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Matrix/SparseLinAlg.hs
@@ -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)
diff --git a/src-matrix/Moonlight/Homology/Pure/Matrix/Validated.hs b/src-matrix/Moonlight/Homology/Pure/Matrix/Validated.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Matrix/Validated.hs
@@ -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
diff --git a/src-matrix/Moonlight/Homology/Pure/Rank/Field.hs b/src-matrix/Moonlight/Homology/Pure/Rank/Field.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Rank/Field.hs
@@ -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 #-}
diff --git a/src-matrix/Moonlight/Homology/Pure/Rank/GF2.hs b/src-matrix/Moonlight/Homology/Pure/Rank/GF2.hs
new file mode 100644
--- /dev/null
+++ b/src-matrix/Moonlight/Homology/Pure/Rank/GF2.hs
@@ -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 #-}
diff --git a/src-public/Moonlight/Homology.hs b/src-public/Moonlight/Homology.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Backend.hs b/src-public/Moonlight/Homology/Backend.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Backend.hs
@@ -0,0 +1,9 @@
+module Moonlight.Homology.Backend
+  ( HomologyBackendTag (..),
+    HomologyBackend (..),
+    homologyBackendTag,
+    runHomologyBackend
+  )
+where
+
+import Moonlight.Homology.Pure.Backend as X
diff --git a/src-public/Moonlight/Homology/Boundary.hs b/src-public/Moonlight/Homology/Boundary.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Boundary.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Boundary/GraphGF2.hs b/src-public/Moonlight/Homology/Boundary/GraphGF2.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Boundary/GraphGF2.hs
@@ -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]
diff --git a/src-public/Moonlight/Homology/Chain.hs b/src-public/Moonlight/Homology/Chain.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Chain.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Matrix.hs b/src-public/Moonlight/Homology/Matrix.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Matrix.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Persistence.hs b/src-public/Moonlight/Homology/Persistence.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Persistence.hs
@@ -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)
diff --git a/src-public/Moonlight/Homology/Presentation.hs b/src-public/Moonlight/Homology/Presentation.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Presentation.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Rank.hs b/src-public/Moonlight/Homology/Rank.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Rank.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Rank/Field.hs b/src-public/Moonlight/Homology/Rank/Field.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Rank/Field.hs
@@ -0,0 +1,7 @@
+module Moonlight.Homology.Rank.Field
+  ( FieldRankBackend (..),
+    fieldBettiCapability
+  )
+where
+
+import Moonlight.Homology.Pure.Rank.Field as X
diff --git a/src-public/Moonlight/Homology/Rank/GF2.hs b/src-public/Moonlight/Homology/Rank/GF2.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Rank/GF2.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Sequence.hs b/src-public/Moonlight/Homology/Sequence.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Sequence.hs
@@ -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
diff --git a/src-public/Moonlight/Homology/Topology.hs b/src-public/Moonlight/Homology/Topology.hs
new file mode 100644
--- /dev/null
+++ b/src-public/Moonlight/Homology/Topology.hs
@@ -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,
+  )
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Exact.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Exact.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Exact.hs
@@ -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)
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral.hs
@@ -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
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Bidegree.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Bidegree.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Bidegree.hs
@@ -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)
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Build.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Build.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Build.hs
@@ -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)
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Linear.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Linear.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Linear.hs
@@ -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))
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Support.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Support.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Support.hs
@@ -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
diff --git a/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Types.hs b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Types.hs
new file mode 100644
--- /dev/null
+++ b/src-sequence/Moonlight/Homology/Pure/Sequence/Spectral/Types.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Backend.hs b/src-topology/Moonlight/Homology/Pure/Backend.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Backend.hs
@@ -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 #-}
diff --git a/src-topology/Moonlight/Homology/Pure/Constraint.hs b/src-topology/Moonlight/Homology/Pure/Constraint.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Constraint.hs
@@ -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 (..))
diff --git a/src-topology/Moonlight/Homology/Pure/Constraint/Algebra.hs b/src-topology/Moonlight/Homology/Pure/Constraint/Algebra.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Constraint/Algebra.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology.hs b/src-topology/Moonlight/Homology/Pure/Topology.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology.hs
@@ -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
+    )
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Algebra.hs b/src-topology/Moonlight/Homology/Pure/Topology/Algebra.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Algebra.hs
@@ -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))
+    }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/BlockSchur.hs b/src-topology/Moonlight/Homology/Pure/Topology/BlockSchur.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/BlockSchur.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Core.hs b/src-topology/Moonlight/Homology/Pure/Topology/Core.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Core.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph.hs
@@ -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,
+  )
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph/Algebra.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Algebra.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Algebra.hs
@@ -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))
+    )
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph/Critical.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Critical.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Critical.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph/Reeb.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Reeb.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Reeb.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph/Skeleton.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Skeleton.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Skeleton.hs
@@ -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)
+  ]
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Graph/Witness.hs b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Witness.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Graph/Witness.hs
@@ -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
+      }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Harmonic.hs b/src-topology/Moonlight/Homology/Pure/Topology/Harmonic.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Harmonic.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Integral.hs b/src-topology/Moonlight/Homology/Pure/Topology/Integral.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Integral.hs
@@ -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))
+    }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Core.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Core.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Core.hs
@@ -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
+    }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Merge.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Merge.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Merge.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Reindex.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Reindex.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Reindex.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Stitch.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Stitch.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Compose/Stitch.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Direction.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Direction.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Direction.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/HarmonicLoop.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/HarmonicLoop.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/HarmonicLoop.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Potential.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Potential.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Potential.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Reeb.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Reeb.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Reeb.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Singularity.hs b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Singularity.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/MacroScaffold/Singularity.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Morse.hs b/src-topology/Moonlight/Homology/Pure/Topology/Morse.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Morse.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Morse/Digraph.hs b/src-topology/Moonlight/Homology/Pure/Topology/Morse/Digraph.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Morse/Digraph.hs
@@ -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)
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Observation.hs b/src-topology/Moonlight/Homology/Pure/Topology/Observation.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Observation.hs
@@ -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
+    }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Persistence.hs b/src-topology/Moonlight/Homology/Pure/Topology/Persistence.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Persistence.hs
@@ -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
+                            )
+           )
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Realize.hs b/src-topology/Moonlight/Homology/Pure/Topology/Realize.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Realize.hs
@@ -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"
+                      )
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/ScaffoldSummary.hs b/src-topology/Moonlight/Homology/Pure/Topology/ScaffoldSummary.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/ScaffoldSummary.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/SparseAlgebra.hs b/src-topology/Moonlight/Homology/Pure/Topology/SparseAlgebra.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/SparseAlgebra.hs
@@ -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))
+    }
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Spectral.hs b/src-topology/Moonlight/Homology/Pure/Topology/Spectral.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Spectral.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/Topology/Target.hs b/src-topology/Moonlight/Homology/Pure/Topology/Target.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/Topology/Target.hs
@@ -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])
diff --git a/src-topology/Moonlight/Homology/Pure/TopologyObserver.hs b/src-topology/Moonlight/Homology/Pure/TopologyObserver.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/TopologyObserver.hs
@@ -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
diff --git a/src-topology/Moonlight/Homology/Pure/TopologyView.hs b/src-topology/Moonlight/Homology/Pure/TopologyView.hs
new file mode 100644
--- /dev/null
+++ b/src-topology/Moonlight/Homology/Pure/TopologyView.hs
@@ -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
diff --git a/test-cell-category/Main.hs b/test-cell-category/Main.hs
new file mode 100644
--- /dev/null
+++ b/test-cell-category/Main.hs
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -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)
diff --git a/test/facade/CompileFailSpec.hs b/test/facade/CompileFailSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/facade/CompileFailSpec.hs
@@ -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
diff --git a/test/facade/PresentationSpec.hs b/test/facade/PresentationSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/facade/PresentationSpec.hs
@@ -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
diff --git a/test/fixtures/CompileFail/Phase1BettiLeak.hs b/test/fixtures/CompileFail/Phase1BettiLeak.hs
new file mode 100644
--- /dev/null
+++ b/test/fixtures/CompileFail/Phase1BettiLeak.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds #-}
+
+module CompileFail.Phase1BettiLeak (forbiddenPhase1Capability) where
+
+import Moonlight.Homology
+
+forbiddenPhase1Capability :: BettiCapability 'Phase1 Rational
+forbiddenPhase1Capability =
+  fieldBettiCapability RationalFieldRankBackend
diff --git a/test/fixtures/CompileFail/Phase2SpectralLeak.hs b/test/fixtures/CompileFail/Phase2SpectralLeak.hs
new file mode 100644
--- /dev/null
+++ b/test/fixtures/CompileFail/Phase2SpectralLeak.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+
+module CompileFail.Phase2SpectralLeak (forbiddenPhase2Spectral) where
+
+import Moonlight.Homology
+
+forbiddenPhase2Spectral :: ()
+forbiddenPhase2Spectral =
+  requirePhase4Witness @'Phase2
diff --git a/test/fixtures/CompilePass/Phase2Betti.hs b/test/fixtures/CompilePass/Phase2Betti.hs
new file mode 100644
--- /dev/null
+++ b/test/fixtures/CompilePass/Phase2Betti.hs
@@ -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
diff --git a/test/fixtures/CompilePass/PublicApiCleanup.hs b/test/fixtures/CompilePass/PublicApiCleanup.hs
new file mode 100644
--- /dev/null
+++ b/test/fixtures/CompilePass/PublicApiCleanup.hs
@@ -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)]
diff --git a/test/fixtures/Snapshots/CompileFail.Phase1BettiLeak.snapshot.json b/test/fixtures/Snapshots/CompileFail.Phase1BettiLeak.snapshot.json
new file mode 100644
--- /dev/null
+++ b/test/fixtures/Snapshots/CompileFail.Phase1BettiLeak.snapshot.json
@@ -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"}
diff --git a/test/fixtures/Snapshots/CompileFail.Phase2SpectralLeak.snapshot.json b/test/fixtures/Snapshots/CompileFail.Phase2SpectralLeak.snapshot.json
new file mode 100644
--- /dev/null
+++ b/test/fixtures/Snapshots/CompileFail.Phase2SpectralLeak.snapshot.json
@@ -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"}
diff --git a/test/fixtures/Snapshots/CompilePass.Phase2Betti.snapshot.json b/test/fixtures/Snapshots/CompilePass.Phase2Betti.snapshot.json
new file mode 100644
--- /dev/null
+++ b/test/fixtures/Snapshots/CompilePass.Phase2Betti.snapshot.json
@@ -0,0 +1,1 @@
+{"diagnostics":[],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"success","fixture":"foundation/moonlight-homology/test/fixtures/CompilePass/Phase2Betti.hs"}
diff --git a/test/fixtures/Snapshots/CompilePass.PublicApiCleanup.snapshot.json b/test/fixtures/Snapshots/CompilePass.PublicApiCleanup.snapshot.json
new file mode 100644
--- /dev/null
+++ b/test/fixtures/Snapshots/CompilePass.PublicApiCleanup.snapshot.json
@@ -0,0 +1,1 @@
+{"diagnostics":[],"diagnosticsFlag":"-fdiagnostics-as-json","exit":"success","fixture":"foundation/moonlight-homology/test/fixtures/CompilePass/PublicApiCleanup.hs"}
diff --git a/test/matrix/FieldBettiSpec.hs b/test/matrix/FieldBettiSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/matrix/FieldBettiSpec.hs
@@ -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
diff --git a/test/matrix/GF2GraphSpec.hs b/test/matrix/GF2GraphSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/matrix/GF2GraphSpec.hs
@@ -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)
diff --git a/test/sequence/SpectralSpec.hs b/test/sequence/SpectralSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/sequence/SpectralSpec.hs
@@ -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)
diff --git a/test/support/TestFixtures.hs b/test/support/TestFixtures.hs
new file mode 100644
--- /dev/null
+++ b/test/support/TestFixtures.hs
@@ -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 []
diff --git a/test/topology/BlockSchurSpec.hs b/test/topology/BlockSchurSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/topology/BlockSchurSpec.hs
@@ -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)
diff --git a/test/topology/MorseSpec.hs b/test/topology/MorseSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/topology/MorseSpec.hs
@@ -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 (+)
diff --git a/test/topology/TopologySpec.hs b/test/topology/TopologySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/topology/TopologySpec.hs
@@ -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]
+    ]