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)