packages feed

moonlight-algebra (empty) → 0.1.0.0

raw patch · 74 files changed

+13687/−0 lines, 74 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, deepseq, hedgehog, lattices, moonlight-algebra, moonlight-core, moonlight-pale, tasty, tasty-bench, tasty-hedgehog, tasty-hunit, tasty-quickcheck, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,22 @@+# Changelog++## 0.1.0.0 - unreleased++- Initial release of the Level-1 algebraic tower over `moonlight-core`.+- Group surface: standard `Semigroup`/`Monoid`, `Group`, `AbelianGroup`, and+  operation-selecting `Additive`/`Multiplicative` wrappers, plus free structures+  (`FreeMonoid`, `FreeAbelianGroup`).+- Lattice tower: join/meet semilattices through distributive, Heyting, and+  Boolean algebras (`Lattice`, `Orientation`). Compiled finite context lattices+  now live in the public `moonlight-algebra:finite-lattice` sublibrary.+- Ring tower: operation-bearing `Semiring`/`Ring`/`CommutativeRing` classes live+  in `moonlight-core`; `moonlight-algebra` adds `IntegralDomain`, `GCDDomain`,+  `EuclideanDomain`, canonical residues, modular arithmetic (`Zn`), number+  theory, and `GCD`.+- Modules, vector spaces, bilinear spaces (`Module`, `Magnitude`), polynomials,+  power sets, products, quotients, and sparse vectors with finite support.+- All `Moonlight.Algebra.Pure.*` modules are now exposed for selective qualified+  import; `Moonlight.Algebra` re-exports the tower, grouped by family, as a+  convenience.+- Algebraic laws documented in module headers and exercised by the private+  `moonlight-algebra-laws` sublibrary.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 The Blue Rose, Rosalia Fialkova++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,209 @@+# moonlight-algebra++> Part of **Moonlight**, the sheaf-theoretic computation layer beneath+> [Melusine](https://bluerose.blue) and Pale Meridian.++The law-governed algebraic tower the rest of the cathedral stands on.++`moonlight-algebra` is Moonlight's algebraic tier. Building on+[`moonlight-core`](../moonlight-core), it supplies a tower of+pure, law-governed algebraic structures: standard semigroups/monoids with+operation-selecting additive and multiplicative wrappers, group refinements, the+lattice hierarchy up to Heyting and Boolean algebras, integral/GCD/Euclidean+domain refinements, modules and vector spaces, modular arithmetic, number+theory, free structures, and sparse vectors. Each structure is a thin type+class or newtype boundary; its laws are stated in the module header and+exercised by the private law-suite sublibrary.++## Relationship to `moonlight-core`++`moonlight-core` owns the operation-bearing numeric tower: `AdditiveMonoid`,+`AdditiveGroup`, `MultiplicativeMonoid`, `Semiring`, `Ring`, `CommutativeRing`,+and `Field`. `Moonlight.Algebra.Pure.Ring` re-exports the law-only semiring and+commutative-ring classes from core and adds only the stronger domain refinements:+`IntegralDomain`, `GCDDomain`, `EuclideanDomain`, and+`CanonicalEuclideanDomain`. There is one arithmetic vocabulary; the ring layer+reuses core's `zero`, `one`, `add`, and `mul`.++## What it provides++- **Groups, free structures and actions.** Standard `Semigroup`/`Monoid`,+  `Group`/`AbelianGroup` law refinements, `Additive` and `Multiplicative`+  wrappers for carriers with several lawful operations, free monoids and free+  abelian groups, the two-element sign/orientation group (ℤ/2), and monoid+  actions on a carrier with a group-acting refinement.+- **The lattice hierarchy.** Join/meet semilattices up to Heyting and Boolean+  algebras. Compiled finite lattices live in the public+  `moonlight-algebra:finite-lattice` sublibrary.+- **Rings and arithmetic.** Semiring → commutative ring → integral/GCD/Euclidean+  domains; modular arithmetic (`Zn`); quotient rings `R/(n)` of a Euclidean+  domain; number theory and gcd; and univariate polynomials over a coefficient+  ring (Horner evaluation, a free module on monomial degrees).+- **Modules and magnitudes.** Modules, free modules, vector spaces, bilinear+  spaces over a field, and real-valued magnitudes for obstructions.+- **Constructions.** Power-set lattices, finite *n*-fold product algebras with+  coordinatewise structure, quotients, and sparse vectors with finite support.++## Tiny usage examples++```haskell+import Moonlight.Algebra.Pure.Group++difference :: Additive Integer+difference = groupDifference (Additive 3) (Additive 5)++product :: Multiplicative Integer+product = Multiplicative 3 <> Multiplicative 5+```++Sparse kernels:++```haskell+compiled = compileSparseLinearMap 128 (\i -> [(i, 1), (i + 1, 2)])++combined = add (fromEntries [('x', 2)]) (fromEntries [('x', 3), ('y', 1)])+```++## Finite lattices++This public sublibrary owns checked finite-order compilation and the dense+runtime views inside `moonlight-algebra`: `ContextLattice`, dense join/meet/`<=`+plans, resident branded keys, Heyting implication, least/greatest fixpoints,+cover edges, presentation builders, and generator support kernels.++The main `moonlight-algebra` library remains the abstract algebra class tower.+The `finite-lattice` sublibrary is the finite, validated, queryable realization+of a lattice over a declared closed universe.++### Quick start++Declare a finite order by name binding. `latticeOf` infers the unique top and+bottom, transitively closes the order, derives join and meet, and proves+lattice-hood, returning a compiled `ContextLattice` or the first obstruction it+finds.++```haskell+import Moonlight.FiniteLattice++data Context = Bottom | West | East | Top+  deriving (Eq, Ord, Show)++diamond :: Either (LatticeBuildError Context) (ContextLattice Context)+diamond =+  latticeOf $ do+    [bottom, west, east, top] <- elements [Bottom, West, East, Top]+    below bottom west+    below bottom east+    below west top+    below east top+```++`West` and `East` are incomparable; their least upper bound and greatest lower+bound are derived from the order alone. On the compiled lattice, order, join and+meet are total, checked lookups into the dense plan:++```+>>> Right lattice = diamond+>>> joinContext lattice West East+Right Top+>>> meetContext lattice West East+Right Bottom+>>> leqContext lattice Bottom Top+Right True+```++### Heyting implication++The diamond is distributive, so it carries a Heyting structure. `compileContextHeyting`+builds the residual plan once; `impliesContext` is then the relative pseudocomplement:+the largest `x` with `antecedent ∧ x ≤ consequent`.++```+>>> Right heyting = compileContextHeyting lattice+>>> impliesContext heyting West East+Right East+>>> impliesContext heyting West West+Right Top+```++### Least and greatest fixpoints++Every monotone endomap on the lattice has a least and a greatest fixpoint+(Knaster–Tarski). `leastContextFixpoint` climbs up from the bottom, `greatestContextFixpoint`+descends from the top; a non-monotone step is rejected as a typed `ContextMonotoneMapError`.++```haskell+settle :: Context -> Context+settle Bottom = West+settle West   = West+settle East   = Top+settle Top    = Top+```++```+>>> leastContextFixpoint lattice settle+Right West+>>> greatestContextFixpoint lattice settle+Right Top+```++### The resident fast path++`joinContext`, `meetContext`, and `impliesContext` resolve each domain value through a map+on every call. When you sweep many queries, resolve once: `withResidentContext` hands you+branded keys whose order, join, and meet are pure array indexing without per-query+lookup inside the loop.++```haskell+leqRelationSize :: ContextLattice Context -> Int+leqRelationSize lattice =+  withResidentContext lattice $ \ctx ->+    let keys = residentContextKeys ctx+     in length [() | a <- keys, b <- keys, residentContextKeyLeq ctx a b]+```++```+>>> leqRelationSize lattice+9+```++The count is the size of the `≤` relation: four reflexive pairs, plus `Bottom` under+`West`, `East`, and `Top`, plus `West` and `East` each under `Top`.++## Public modules++| Module | Surface |+| --- | --- |+| `Moonlight.Algebra` | Umbrella re-export of the whole tower, plus the operation-bearing numeric classes from `moonlight-core`. |+| `Moonlight.Algebra.Pure.Group` | Standard `Semigroup`/`Monoid`, `Group`/`AbelianGroup`, and `Additive`/`Multiplicative` wrappers. |+| `Moonlight.Algebra.Pure.FreeMonoid`, `.FreeAbelianGroup` | Free monoids and free abelian groups. |+| `Moonlight.Algebra.Pure.Action` | Monoid actions (`Action`) and their group-acting refinement (`InvertibleAction`). |+| `Moonlight.Algebra.Pure.Orientation` | The two-element sign/orientation group ℤ/2 with a direct standard monoid/group instance. |+| `Moonlight.Algebra.Pure.Lattice` | Join/meet semilattices up to Heyting and Boolean algebras. |+| `Moonlight.FiniteLattice.*` | Public `finite-lattice` sublibrary: checked finite-order compilation, dense query plans, resident keys, Heyting implication, fixpoints, covers, presentation builders, and support kernels. |+| `Moonlight.Algebra.Pure.Ring` | Re-exported semiring/commutative-ring law classes plus integral/GCD/Euclidean/canonical-domain refinements. |+| `Moonlight.Algebra.Pure.Zn`, `.Quotient` | Modular arithmetic and quotient rings `R/(n)`. |+| `Moonlight.Algebra.Pure.NumberTheory`, `.GCD` | Number theory and gcd. |+| `Moonlight.Algebra.Pure.Polynomial` | Univariate polynomials over a coefficient ring; a free module on monomial degrees. |+| `Moonlight.Algebra.Pure.Module` | Modules, free modules, vector spaces, and bilinear spaces over a field. |+| `Moonlight.Algebra.Pure.Magnitude` | Real-valued magnitudes for obstructions. |+| `Moonlight.Algebra.Pure.PowerSet`, `.Product` | Power-set lattices and finite *n*-fold product algebras (coordinatewise structure). |+| `Moonlight.Algebra.Pure.SparseVec` | Sparse vectors with finite support. |++All `Moonlight.Algebra.Pure.*` leaves are exposed by the public `abstract`+sublibrary and gathered by the `Moonlight.Algebra` surface. The unsafe GCD witness+(`Moonlight.Algebra.Unsafe.GCDWitness`) lives in the private+`moonlight-algebra-internal` sublibrary, the compiled finite lattice realization+lives in the public `finite-lattice` sublibrary, and the law suite+(`Moonlight.Algebra.Effect.Laws`, `Moonlight.Algebra.Test.Generators`) lives in+the private `moonlight-algebra-laws` sublibrary.++## Performance++Compilation and the resident-key and `<=` query paths are fast; join/meet+throughput and the compiled `ContextLattice` query surface are under active+performance work.++## License++MIT; see [`LICENSE`](./LICENSE).
+ bench/abstract/AbstractBench.hs view
@@ -0,0 +1,331 @@+module AbstractBench+  ( abstractBenchmarks,+  )+where++import Control.DeepSeq (NFData (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.Algebra.Pure.Lattice qualified as Lattice+import Moonlight.Algebra.Pure.LaneVector+  ( LaneVector,+    laneCount,+    laneVectorFromLanes,+    laneVectorLanes,+  )+import Moonlight.Algebra.Pure.Polynomial (Polynomial)+import Moonlight.Algebra.Pure.Polynomial qualified as Polynomial+import Moonlight.Algebra.Pure.PowerSet qualified as PowerSet+import Moonlight.Algebra.Pure.SparseVec (SparseVec)+import Moonlight.Algebra.Pure.SparseVec qualified as SparseVec+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++type SparseBenchVector = SparseVec Int Int++type PolynomialBench = Polynomial Int++abstractBenchmarks :: Benchmark+abstractBenchmarks =+  bgroup+    "abstract"+    [ laneVectorBenchmarks,+      sparseVecWorldBenchmarks,+      polynomialWorldBenchmarks,+      powerSetWorldBenchmarks+    ]++newtype LaneVectorBenchOperands = LaneVectorBenchOperands [(LaneVector, LaneVector)]++instance NFData LaneVectorBenchOperands where+  rnf (LaneVectorBenchOperands operands) =+    foldr forceLaneVectorPair () operands++laneVectorBenchmarks :: Benchmark+laneVectorBenchmarks =+  bgroup+    "lane-vector/group-arithmetic"+    (fmap laneVectorBenchmark laneVectorEditCounts)++laneVectorBenchmark :: Int -> Benchmark+laneVectorBenchmark editCount =+  env (pure (laneVectorOperands editCount)) $ \operands ->+    bgroup+      ("edits=" <> show editCount <> " lanes-per-edit=" <> show laneCount)+      [ bench "add" (nf laneVectorAddWeight operands),+        bench "sub" (nf laneVectorSubWeight operands),+        bench "neg" (nf laneVectorNegWeight operands)+      ]++laneVectorOperands :: Int -> LaneVectorBenchOperands+laneVectorOperands editCount =+  LaneVectorBenchOperands (fmap laneVectorOperandPair (keys editCount))++laneVectorOperandPair :: Int -> (LaneVector, LaneVector)+laneVectorOperandPair editIndex =+  ( laneVectorOperand 0x243f6a8885a308d3 editIndex,+    laneVectorOperand 0x13198a2e03707344 editIndex+  )++laneVectorOperand :: Word64 -> Int -> LaneVector+laneVectorOperand seed editIndex =+  laneVectorFromLanes+    (UVector.generate laneCount (laneValue seed editIndex))++laneValue :: Word64 -> Int -> Int -> Word64+laneValue seed editIndex laneIndex =+  seed+    + 0x9e3779b97f4a7c15 * fromIntegral editIndex+    + 0xbf58476d1ce4e5b9 * fromIntegral laneIndex++laneVectorAddWeight :: LaneVectorBenchOperands -> Word64+laneVectorAddWeight (LaneVectorBenchOperands operands) =+  foldr (combineLaneVectorPair add) 0 operands++laneVectorSubWeight :: LaneVectorBenchOperands -> Word64+laneVectorSubWeight (LaneVectorBenchOperands operands) =+  foldr (combineLaneVectorPair sub) 0 operands++laneVectorNegWeight :: LaneVectorBenchOperands -> Word64+laneVectorNegWeight (LaneVectorBenchOperands operands) =+  foldr (\(left, _right) accumulated -> laneVectorWeight (neg left) + accumulated) 0 operands++combineLaneVectorPair :: (LaneVector -> LaneVector -> LaneVector) -> (LaneVector, LaneVector) -> Word64 -> Word64+combineLaneVectorPair operation (left, right) accumulated =+  laneVectorWeight (operation left right) + accumulated++laneVectorWeight :: LaneVector -> Word64+laneVectorWeight =+  UVector.foldl' (+) 0 . laneVectorLanes++forceLaneVectorPair :: (LaneVector, LaneVector) -> () -> ()+forceLaneVectorPair (left, right) forcedRest =+  rnf (laneVectorLanes left) `seq` rnf (laneVectorLanes right) `seq` forcedRest++laneVectorEditCounts :: [Int]+laneVectorEditCounts =+  [128, 512, 2048]++sparseVecWorldBenchmarks :: Benchmark+sparseVecWorldBenchmarks =+  bgroup+    "sparse-vec/us-vs-world"+    (fmap sparseVecWorldBenchmark sparseVecSizes)++sparseVecWorldBenchmark :: Int -> Benchmark+sparseVecWorldBenchmark size =+  env (pure (sparseEntryPair size)) $ \entryPair ->+    bgroup+      (caseLabel "normalize+add" size)+      [ bench "moonlight: SparseVec.fromEntries/add" (nf moonlightSparseVecAddWeight entryPair),+        bench "world: containers Map.fromListWith/unionWith" (nf containersMapAddWeight entryPair)+      ]++moonlightSparseVecAddWeight :: ([(Int, Int)], [(Int, Int)]) -> Int+moonlightSparseVecAddWeight (leftEntries, rightEntries) =+  sparseEntriesWeight+    ( SparseVec.toEntries+        ( add+            (SparseVec.fromEntries leftEntries :: SparseBenchVector)+            (SparseVec.fromEntries rightEntries :: SparseBenchVector)+        )+    )++containersMapAddWeight :: ([(Int, Int)], [(Int, Int)]) -> Int+containersMapAddWeight (leftEntries, rightEntries) =+  mapEntriesWeight+    ( normalizeMap+        (Map.unionWith (+) (containersMapFromEntries leftEntries) (containersMapFromEntries rightEntries))+    )++containersMapFromEntries :: [(Int, Int)] -> Map Int Int+containersMapFromEntries =+  normalizeMap . Map.fromListWith (+)++normalizeMap :: Map Int Int -> Map Int Int+normalizeMap =+  Map.mapMaybe nonZero++nonZero :: Int -> Maybe Int+nonZero value+  | value == 0 = Nothing+  | otherwise = Just value++polynomialWorldBenchmarks :: Benchmark+polynomialWorldBenchmarks =+  bgroup+    "polynomial/us-vs-world"+    (fmap polynomialWorldBenchmark polynomialSizes)++polynomialWorldBenchmark :: Int -> Benchmark+polynomialWorldBenchmark size =+  env (pure (polynomialCoefficientPair size)) $ \coefficientPair ->+    bgroup+      (caseLabel "multiply+evaluate" size)+      [ bench "moonlight: Polynomial.mul/evaluatePolynomial" (nf moonlightPolynomialWeight coefficientPair),+        bench "world: containers Map convolution/Horner" (nf containersPolynomialWeight coefficientPair)+      ]++moonlightPolynomialWeight :: ([Int], [Int]) -> Int+moonlightPolynomialWeight (leftCoefficients, rightCoefficients) =+  let productPolynomial =+        mul+          (Polynomial.fromCoefficients leftCoefficients :: PolynomialBench)+          (Polynomial.fromCoefficients rightCoefficients :: PolynomialBench)+   in Polynomial.evaluatePolynomial 3 productPolynomial+        + coefficientsWeight (Polynomial.toCoefficients productPolynomial)++containersPolynomialWeight :: ([Int], [Int]) -> Int+containersPolynomialWeight (leftCoefficients, rightCoefficients) =+  let productTerms =+        containersPolynomialMultiply+          (polynomialMapFromCoefficients leftCoefficients)+          (polynomialMapFromCoefficients rightCoefficients)+   in denseHornerEvaluate 3 (coefficientsFromPolynomialMap productTerms)+        + mapEntriesWeight productTerms++containersPolynomialMultiply :: Map Int Int -> Map Int Int -> Map Int Int+containersPolynomialMultiply leftTerms rightTerms =+  normalizeMap+    ( Map.fromListWith+        (+)+        [ (leftDegree + rightDegree, leftCoefficient * rightCoefficient)+        | (leftDegree, leftCoefficient) <- Map.toAscList leftTerms,+          (rightDegree, rightCoefficient) <- Map.toAscList rightTerms+        ]+    )++polynomialMapFromCoefficients :: [Int] -> Map Int Int+polynomialMapFromCoefficients =+  normalizeMap . Map.fromAscList . zip [0 ..]++coefficientsFromPolynomialMap :: Map Int Int -> [Int]+coefficientsFromPolynomialMap =+  denseCoefficientsFromTerms 0 . Map.toAscList++denseCoefficientsFromTerms :: Int -> [(Int, Int)] -> [Int]+denseCoefficientsFromTerms expectedDegree remainingTerms =+  case remainingTerms of+    [] -> []+    (degreeValue, coefficientValue) : restTerms+      | expectedDegree < degreeValue ->+          replicate (degreeValue - expectedDegree) zero+            <> denseCoefficientsFromTerms degreeValue remainingTerms+      | otherwise ->+          coefficientValue : denseCoefficientsFromTerms (expectedDegree + 1) restTerms++denseHornerEvaluate :: Int -> [Int] -> Int+denseHornerEvaluate value =+  foldr (\coefficient accumulator -> coefficient + value * accumulator) 0++powerSetWorldBenchmarks :: Benchmark+powerSetWorldBenchmarks =+  bgroup+    "power-set-lattice/us-vs-world"+    (fmap powerSetWorldBenchmark powerSetSizes)++powerSetWorldBenchmark :: Int -> Benchmark+powerSetWorldBenchmark size =+  env (pure (powerSetListPair size)) $ \setPair ->+    bgroup+      (caseLabel "join+meet" size)+      [ bench "moonlight: PowerSet join/meet" (nf moonlightPowerSetJoinMeetWeight setPair),+        bench "world: containers Set union/intersection" (nf containersSetJoinMeetWeight setPair)+      ]++moonlightPowerSetJoinMeetWeight :: ([Int], [Int]) -> Int+moonlightPowerSetJoinMeetWeight (leftValues, rightValues) =+  let leftSet = PowerSet.fromList leftValues+      rightSet = PowerSet.fromList rightValues+      joinedSet = Lattice.join leftSet rightSet+      metSet = Lattice.meet leftSet rightSet+   in listWeight (PowerSet.toPowerSetList joinedSet)+        + listWeight (PowerSet.toPowerSetList metSet)++containersSetJoinMeetWeight :: ([Int], [Int]) -> Int+containersSetJoinMeetWeight (leftValues, rightValues) =+  let leftSet = Set.fromList leftValues+      rightSet = Set.fromList rightValues+   in setWeight (Set.union leftSet rightSet)+        + setWeight (Set.intersection leftSet rightSet)++sparseEntryPair :: Int -> ([(Int, Int)], [(Int, Int)])+sparseEntryPair size =+  ( sparseEntries size,+    fmap (\(basisKey, coefficient) -> (basisKey + size `quot` 4, negate coefficient)) (sparseEntries size)+  )++sparseEntries :: Int -> [(Int, Int)]+sparseEntries size =+  [ (key `mod` max 1 (size `quot` 2), coefficientForKey key)+  | key <- keys (size * 2)+  ]++polynomialCoefficientPair :: Int -> ([Int], [Int])+polynomialCoefficientPair size =+  (fmap coefficientForKey (keys size), fmap (coefficientForKey . (+ size)) (keys size))++powerSetListPair :: Int -> ([Int], [Int])+powerSetListPair size =+  ( [key | key <- keys size, key `mod` 2 == 0],+    [key | key <- keys size, key `mod` 3 /= 0]+  )++coefficientForKey :: Int -> Int+coefficientForKey key =+  case key `mod` 7 of+    0 -> 0+    residue -> residue - 3++sparseEntriesWeight :: [(Int, Int)] -> Int+sparseEntriesWeight =+  foldr (\(basisKey, coefficient) accumulated -> accumulated + basisKey * 31 + coefficient) 0++mapEntriesWeight :: Map Int Int -> Int+mapEntriesWeight =+  Map.foldlWithKey' (\accumulated key value -> accumulated + key * 31 + value) 0++coefficientsWeight :: [Int] -> Int+coefficientsWeight =+  foldr (\coefficient accumulated -> accumulated * 33 + coefficient) 5381++listWeight :: [Int] -> Int+listWeight =+  foldr (\value accumulated -> accumulated * 16777619 + value) 146959810++setWeight :: Set.Set Int -> Int+setWeight =+  listWeight . Set.toAscList++keys :: Int -> [Int]+keys size =+  [0 .. size - 1]++sparseVecSizes :: [Int]+sparseVecSizes =+  [128, 512, 2048]++polynomialSizes :: [Int]+polynomialSizes =+  [16, 64, 128]++powerSetSizes :: [Int]+powerSetSizes =+  [128, 512, 2048]++caseLabel :: String -> Int -> String+caseLabel label size =+  label <> " n=" <> show size
+ bench/abstract/Main.hs view
@@ -0,0 +1,15 @@+module Main+  ( main,+  )+where++import AbstractBench+  ( abstractBenchmarks,+  )+import Moonlight.Pale.Bench.Runner+  ( runBenchmark,+  )++main :: IO ()+main =+  runBenchmark abstractBenchmarks
+ bench/aggregate/Main.hs view
@@ -0,0 +1,21 @@+module Main+  ( main,+  )+where++import AbstractBench+  ( abstractBenchmarks,+  )+import FiniteLatticeBench+  ( finiteLatticeBenchmarkSuite,+  )+import Moonlight.Pale.Bench.Runner+  ( runBenchmarks,+  )++main :: IO ()+main =+  runBenchmarks+    [ abstractBenchmarks,+      finiteLatticeBenchmarkSuite+    ]
+ bench/finite-lattice/Atomic.hs view
@@ -0,0 +1,190 @@+module Atomic+  ( atomicOperationComparisonBenchmarks,+  )+where++import Algebra.Lattice+  ( joinLeq,+    (/\),+    (\/),+  )+import Control.DeepSeq+  ( NFData (..),+  )+import Data.Bifunctor+  ( first,+  )+import Data.IntSet qualified as IntSet+import Fixtures+  ( Shape (BooleanCube),+    assertFiniteFixture,+    booleanCubeBits,+    caseLabel,+    compileLatticeEnv,+    hackageBooleanCubeElement,+    hackageBooleanCubeElements,+    keys,+    querySizes,+  )+import Kernels+  ( leqSweepWeight,+    residentJoinMeetKeySweepWeight,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+    joinContext,+    leqContext,+    meetContext,+  )+import Moonlight.FiniteLattice.Resident+  ( residentContextKeys,+    withResidentContext,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++data PreparedHackageAtomicComparison = PreparedHackageAtomicComparison !Int !(ContextLattice Int) ![IntSet.IntSet]++instance NFData PreparedHackageAtomicComparison where+  rnf (PreparedHackageAtomicComparison size lattice elements) =+    rnf (size, lattice, elements)++atomicOperationComparisonBenchmarks :: Benchmark+atomicOperationComparisonBenchmarks =+  bgroup+    "atomic-operation-baseline"+    [ bgroup+        "boolean-cube"+        (fmap hackageAtomicComparisonBenchmark querySizes)+    ]++hackageAtomicComparisonBenchmark :: Int -> Benchmark+hackageAtomicComparisonBenchmark size =+  env (prepareHackageAtomicComparison size) $ \prepared ->+    bgroup+      (caseLabel "hackage-compatible query sweep" size)+      [ bench "moonlight: resident key <= sweep" (nf moonlightAtomicLeqWeight prepared),+        bench "hackage lattices: IntSet joinLeq sweep" (nf hackageAtomicLeqWeight prepared),+        bench "moonlight: public join sweep" (nf moonlightAtomicJoinWeight prepared),+        bench "hackage lattices: IntSet \\/ sweep" (nf hackageAtomicJoinWeight prepared),+        bench "moonlight: public meet sweep" (nf moonlightAtomicMeetWeight prepared),+        bench "hackage lattices: IntSet /\\ sweep" (nf hackageAtomicMeetWeight prepared),+        bench "moonlight: resident key join/meet sweep" (nf moonlightAtomicJoinMeetWeight prepared),+        bench "hackage lattices: IntSet join/meet sweep" (nf hackageAtomicJoinMeetWeight prepared)+      ]++prepareHackageAtomicComparison :: Int -> IO PreparedHackageAtomicComparison+prepareHackageAtomicComparison size = do+  lattice <- compileLatticeEnv BooleanCube size+  let !elements = hackageBooleanCubeElements size+  assertFiniteFixture "hackage BooleanCube atomic baseline" (assertHackageAtomicAgrees size lattice elements)+  pure (PreparedHackageAtomicComparison size lattice elements)++assertHackageAtomicAgrees :: Int -> ContextLattice Int -> [IntSet.IntSet] -> Either String ()+assertHackageAtomicAgrees size lattice elements+  | length elements /= size =+      Left ("hackage element count " <> show (length elements) <> " /= " <> show size)+  | otherwise =+      fmap (const ()) (traverse checkPair pairs)+  where+    bits =+      booleanCubeBits size++    keyedElements =+      zip (keys size) elements++    pairs =+      [ (leftValue, leftElement, rightValue, rightElement)+      | (leftValue, leftElement) <- keyedElements,+        (rightValue, rightElement) <- keyedElements+      ]++    checkPair (leftValue, leftElement, rightValue, rightElement) = do+      actualLeq <- first show (leqContext lattice leftValue rightValue)+      joined <- first show (joinContext lattice leftValue rightValue)+      met <- first show (meetContext lattice leftValue rightValue)+      let !hackageLeq = joinLeq leftElement rightElement+          !hackageJoin = leftElement \/ rightElement+          !hackageMeet = leftElement /\ rightElement+          !moonlightJoin = hackageBooleanCubeElement bits joined+          !moonlightMeet = hackageBooleanCubeElement bits met+      if actualLeq == hackageLeq && moonlightJoin == hackageJoin && moonlightMeet == hackageMeet+        then Right ()+        else+          Left ("hackage BooleanCube mismatch for " <> show (leftValue, rightValue))++moonlightAtomicLeqWeight :: PreparedHackageAtomicComparison -> Int+moonlightAtomicLeqWeight (PreparedHackageAtomicComparison size lattice _) =+  leqSweepWeight size lattice++moonlightAtomicJoinWeight :: PreparedHackageAtomicComparison -> Either String Int+moonlightAtomicJoinWeight (PreparedHackageAtomicComparison size lattice _) =+  fmap sum+    ( traverse+        joinPairWeight+        [ (leftValue, rightValue)+        | leftValue <- keys size,+          rightValue <- keys size+        ]+    )+  where+    joinPairWeight (leftValue, rightValue) =+      first show (joinContext lattice leftValue rightValue)++moonlightAtomicMeetWeight :: PreparedHackageAtomicComparison -> Either String Int+moonlightAtomicMeetWeight (PreparedHackageAtomicComparison size lattice _) =+  fmap sum+    ( traverse+        meetPairWeight+        [ (leftValue, rightValue)+        | leftValue <- keys size,+          rightValue <- keys size+        ]+    )+  where+    meetPairWeight (leftValue, rightValue) =+      first show (meetContext lattice leftValue rightValue)++moonlightAtomicJoinMeetWeight :: PreparedHackageAtomicComparison -> Either String Int+moonlightAtomicJoinMeetWeight (PreparedHackageAtomicComparison _size lattice _) =+  withResidentContext lattice $ \contextValue ->+    residentJoinMeetKeySweepWeight contextValue (residentContextKeys contextValue)++hackageAtomicLeqWeight :: PreparedHackageAtomicComparison -> Int+hackageAtomicLeqWeight (PreparedHackageAtomicComparison _size _lattice elements) =+  length+    [ ()+    | leftElement <- elements,+      rightElement <- elements,+      joinLeq leftElement rightElement+    ]++hackageAtomicJoinWeight :: PreparedHackageAtomicComparison -> Int+hackageAtomicJoinWeight (PreparedHackageAtomicComparison _size _lattice elements) =+  sum+    [ IntSet.size (leftElement \/ rightElement)+    | leftElement <- elements,+      rightElement <- elements+    ]++hackageAtomicMeetWeight :: PreparedHackageAtomicComparison -> Int+hackageAtomicMeetWeight (PreparedHackageAtomicComparison _size _lattice elements) =+  sum+    [ IntSet.size (leftElement /\ rightElement)+    | leftElement <- elements,+      rightElement <- elements+    ]++hackageAtomicJoinMeetWeight :: PreparedHackageAtomicComparison -> Int+hackageAtomicJoinMeetWeight (PreparedHackageAtomicComparison _size _lattice elements) =+  sum+    [ IntSet.size (leftElement \/ rightElement)+        + IntSet.size (leftElement /\ rightElement)+    | leftElement <- elements,+      rightElement <- elements+    ]
+ bench/finite-lattice/Finite.hs view
@@ -0,0 +1,89 @@+module Finite+  ( finiteLatticeBenchmarks,+  )+where++import Fixtures+  ( Shape (..),+    caseLabel,+    compileBoundedPresentationWeight,+    compileLatticeEnv,+    compileLatticeWeight,+    compilePresentationWeight,+    compileSizes,+    querySizes,+    shapeLabel,+    shapes,+  )+import Kernels+  ( fixpointPairWeight,+    implicationKeySweepWeight,+    implicationSweepWeight,+    joinMeetSweepWeight,+    residentJoinMeetKeySweepWeight,+    residentLeqSweepWeight,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+  )+import Moonlight.FiniteLattice.Resident+  ( residentContextKeys,+    withResidentContext,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++finiteLatticeBenchmarks :: Benchmark+finiteLatticeBenchmarks =+  bgroup+    "finite-lattice"+    [ bgroup+        (shapeLabel shape)+        (finiteLatticeBenchmarksForShape shape)+    | shape <- shapes+    ]++finiteLatticeBenchmarksForShape :: Shape -> [Benchmark]+finiteLatticeBenchmarksForShape shape =+  compileBenchmarks shape+    <> fmap (queryBenchmarks shape) querySizes++compileBenchmarks :: Shape -> [Benchmark]+compileBenchmarks shape =+  compileSizes >>= \size ->+    [ bench (caseLabel "compile/order+operations" size) (nf (compileLatticeWeight shape) size),+      bench (caseLabel "presentation/order+operations" size) (nf (compilePresentationWeight shape) size),+      bench (caseLabel "bounded-presentation/order+operations" size) (nf (compileBoundedPresentationWeight shape) size)+    ]++queryBenchmarks :: Shape -> Int -> Benchmark+queryBenchmarks shape size =+  env (compileLatticeEnv shape size) $ \lattice ->+    bgroup+      (caseLabel "compiled query fixture" size)+      (queryBenchmarkCases shape size lattice)++queryBenchmarkCases :: Shape -> Int -> ContextLattice Int -> [Benchmark]+queryBenchmarkCases shape size lattice =+  withResidentContext lattice $ \contextValue ->+    let contextKeys = residentContextKeys contextValue+     in [ bench (caseLabel "key <= sweep" size) (nf (residentLeqSweepWeight contextValue) contextKeys),+          bench (caseLabel "key join/meet sweep" size) (nf (residentJoinMeetKeySweepWeight contextValue) contextKeys),+          bench (caseLabel "join/meet sweep" size) (nf (joinMeetSweepWeight size) lattice),+          bench (caseLabel "least/greatest fixpoint" size) (nf (fixpointPairWeight shape size) lattice)+        ]+          <> heytingQueryBenchmarkCases shape size lattice++heytingQueryBenchmarkCases :: Shape -> Int -> ContextLattice Int -> [Benchmark]+heytingQueryBenchmarkCases shape size lattice =+  case shape of+    Fan -> []+    _ ->+      [ bench (caseLabel "key heyting implication sweep" size) (nf implicationKeySweepWeight lattice),+        bench (caseLabel "heyting implication sweep" size) (nf (implicationSweepWeight size) lattice)+      ]
+ bench/finite-lattice/FiniteLatticeBench.hs view
@@ -0,0 +1,39 @@+module FiniteLatticeBench+  ( finiteLatticeBenchmarkSuite,+  )+where++import Atomic+  ( atomicOperationComparisonBenchmarks,+  )+import Finite+  ( finiteLatticeBenchmarks,+  )+import JoinMeet+  ( joinMeetComparisonBenchmarks,+  )+import Rows+  ( contextRowComparisonBenchmarks,+  )+import Support+  ( supportBenchmarks,+  )+import Tableless+  ( tablelessFallbackBenchmarks,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bgroup,+  )++finiteLatticeBenchmarkSuite :: Benchmark+finiteLatticeBenchmarkSuite =+  bgroup+    "finite-lattice"+    [ finiteLatticeBenchmarks,+      tablelessFallbackBenchmarks,+      supportBenchmarks,+      atomicOperationComparisonBenchmarks,+      joinMeetComparisonBenchmarks,+      contextRowComparisonBenchmarks+    ]
+ bench/finite-lattice/Fixtures.hs view
@@ -0,0 +1,577 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Fixtures+  ( Shape (..),+    shapes,+    compileSizes,+    querySizes,+    tablelessTallGridCompileHeights,+    tablelessTallGridQueryHeights,+    compileLatticeEnv,+    compileTablelessLatticeEnv,+    compileTablelessTallGridEnv,+    assertFiniteFixture,+    compileLatticeWeight,+    compileTablelessLatticeWeight,+    compileTablelessTallGridWeight,+    compilePresentationWeight,+    compileBoundedPresentationWeight,+    shapeJoinMeetTable,+    rawRelationRows,+    hackageBooleanCubeElements,+    hackageBooleanCubeElement,+    booleanCubeBits,+    supportSeeds,+    wideSupportSeeds,+    shiftedWideSupportSeeds,+    joinSeedStep,+    meetSeedStep,+    tallGridElementCount,+    shapeLabel,+    caseLabel,+    keys,+    topKey,+    bottomKey,+  )+where++import Control.DeepSeq+  ( NFData (..),+  )+import Data.Bifunctor+  ( first,+  )+import Data.Bits+  ( (.&.),+    (.|.),+    popCount,+  )+import Data.IntSet qualified as IntSet+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.FiniteLattice.Core+  ( ContextCompileLimits (..),+    ContextLattice,+    ContextOrderDecl,+    clBottom,+    clTop,+    compileContextLattice,+    compileContextLatticeWith,+    contextLatticeElements,+    contextOrderDecl,+    defaultContextCompileLimits,+  )+import Moonlight.FiniteLattice.Cover+  ( coverPairs,+  )+import Moonlight.FiniteLattice.Presentation qualified as Presentation++-- | Finite benchmark presentation families. Each family is a local chart over+-- the same declared carrier @[0..n-1]@; the benchmark groups are glued from+-- these fixtures rather than re-declaring lattice shape folklore inline.+data Shape+  = Chain+  | Fan+  | BooleanCube+  | DenseGrid+  deriving stock (Eq, Ord, Show)++instance NFData c => NFData (ContextLattice c) where+  rnf lattice =+    rnf+      ( clTop lattice,+        clBottom lattice,+        contextLatticeElements lattice,+        coverPairs lattice+      )++compileLatticeEnv :: Shape -> Int -> IO (ContextLattice Int)+compileLatticeEnv shape size =+  case compileLattice shape size of+    Left err -> fail ("invalid finite-lattice benchmark fixture: " <> err)+    Right lattice -> pure lattice++compileTablelessLatticeEnv :: Shape -> Int -> IO (ContextLattice Int)+compileTablelessLatticeEnv shape size =+  case first show (compileContextLatticeWith tablelessLimits (universe size) (decl shape size)) of+    Left err -> fail ("invalid tableless finite-lattice benchmark fixture: " <> err)+    Right lattice -> pure lattice++compileTablelessTallGridEnv :: Int -> IO (ContextLattice Int)+compileTablelessTallGridEnv height =+  case first show (compileContextLatticeWith tablelessLimits (tallGridUniverse height) (tallGridDecl height)) of+    Left err -> fail ("invalid tableless tall-grid benchmark fixture: " <> err)+    Right lattice -> pure lattice++assertFiniteFixture :: String -> Either String () -> IO ()+assertFiniteFixture label outcome =+  case outcome of+    Right () ->+      pure ()+    Left err ->+      fail ("invalid finite-lattice benchmark fixture " <> label <> ": " <> err)++compileLatticeWeight :: Shape -> Int -> Either String Int+compileLatticeWeight shape size =+  first show (compileContextLattice (universe size) (decl shape size)) >>= latticeCompileWeight++compileTablelessLatticeWeight :: Shape -> Int -> Either String Int+compileTablelessLatticeWeight shape size =+  first show (compileContextLatticeWith tablelessLimits (universe size) (decl shape size)) >>= latticeCompileWeight++compileTablelessTallGridWeight :: Int -> Either String Int+compileTablelessTallGridWeight height =+  first show (compileContextLatticeWith tablelessLimits (tallGridUniverse height) (tallGridDecl height)) >>= latticeCompileWeight++compilePresentationWeight :: Shape -> Int -> Either String Int+compilePresentationWeight shape size =+  first show (Presentation.latticeOf (presentation shape size)) >>= latticeCompileWeight++compileBoundedPresentationWeight :: Shape -> Int -> Either String Int+compileBoundedPresentationWeight shape size =+  first show (Presentation.boundedLatticeOf (topKey size) bottomKey (presentation shape size)) >>= latticeCompileWeight++latticeCompileWeight :: ContextLattice Int -> Either String Int+latticeCompileWeight lattice =+  Right+    ( clTop lattice+        + clBottom lattice+        + length (contextLatticeElements lattice)+        + length (coverPairs lattice)+    )++compileLattice :: Shape -> Int -> Either String (ContextLattice Int)+compileLattice shape size =+  first show (compileContextLattice (universe size) (decl shape size))++presentation :: Shape -> Int -> Presentation.LatticeBuilder Int ()+presentation shape size = do+  elementRefs <- Presentation.elements (keys size)+  declarePresentationShapeEdges shape size elementRefs++declarePresentationShapeEdges :: Shape -> Int -> [Presentation.ElemRef Int] -> Presentation.LatticeBuilder Int ()+declarePresentationShapeEdges shape size elementRefs =+  case shape of+    Chain ->+      Presentation.belowAll (zip elementRefs (drop 1 elementRefs))+    Fan ->+      declareFanPresentationEdges elementRefs+    BooleanCube ->+      declareBooleanCubePresentationEdges size elementRefs+    DenseGrid ->+      declareGridPresentationEdges size elementRefs++declareFanPresentationEdges :: [Presentation.ElemRef Int] -> Presentation.LatticeBuilder Int ()+declareFanPresentationEdges elementRefs =+  case elementRefs of+    bottomRef : restRefs ->+      case List.unsnoc restRefs of+        Just (atomRefs, topRef) ->+          Presentation.belowAll+            ( foldMap+                (\atomRef -> [(bottomRef, atomRef), (atomRef, topRef)])+                atomRefs+            )+        Nothing -> pure ()+    [] -> pure ()++declareBooleanCubePresentationEdges :: Int -> [Presentation.ElemRef Int] -> Presentation.LatticeBuilder Int ()+declareBooleanCubePresentationEdges size elementRefs =+  let elementRefByValue = Vector.fromList elementRefs+      dimensionBits = takeWhile (< size) (iterate (* 2) 1)+   in Presentation.belowAll+        [ (lowerRef, upperRef)+        | (keyValue, lowerRef) <- zip (keys size) elementRefs,+          bitValue <- dimensionBits,+          keyValue .&. bitValue == 0,+          let upperValue = keyValue + bitValue,+          upperValue < size,+          Just upperRef <- [elementRefByValue Vector.!? upperValue]+        ]++declareGridPresentationEdges :: Int -> [Presentation.ElemRef Int] -> Presentation.LatticeBuilder Int ()+declareGridPresentationEdges size elementRefs =+  let elementRefByValue = Vector.fromList elementRefs+   in Presentation.belowAll+        [ (lowerRef, upperRef)+        | (keyValue, lowerRef) <- zip (keys size) elementRefs,+          upperValue <- gridUpperCovers size keyValue,+          Just upperRef <- [elementRefByValue Vector.!? upperValue]+        ]++shapeJoinMeetTable :: Shape -> Int -> Map.Map (Int, Int) (Int, Int)+shapeJoinMeetTable shape size =+  Map.fromAscList+    [ ((leftValue, rightValue), (shapeJoin shape size leftValue rightValue, shapeMeet shape size leftValue rightValue))+    | leftValue <- keys size,+      rightValue <- keys size+    ]++shapeJoin :: Shape -> Int -> Int -> Int -> Int+shapeJoin shape size leftValue rightValue =+  case shape of+    Chain -> max leftValue rightValue+    Fan -> fanJoin size leftValue rightValue+    BooleanCube -> leftValue .|. rightValue+    DenseGrid ->+      gridKey+        size+        (max (gridRow size leftValue) (gridRow size rightValue))+        (max (gridColumn size leftValue) (gridColumn size rightValue))++shapeMeet :: Shape -> Int -> Int -> Int -> Int+shapeMeet shape size leftValue rightValue =+  case shape of+    Chain -> min leftValue rightValue+    Fan -> fanMeet size leftValue rightValue+    BooleanCube -> leftValue .&. rightValue+    DenseGrid ->+      gridKey+        size+        (min (gridRow size leftValue) (gridRow size rightValue))+        (min (gridColumn size leftValue) (gridColumn size rightValue))++fanJoin :: Int -> Int -> Int -> Int+fanJoin size leftValue rightValue+  | leftValue == bottomKey = rightValue+  | rightValue == bottomKey = leftValue+  | leftValue == rightValue = leftValue+  | leftValue == topKey size || rightValue == topKey size = topKey size+  | otherwise = topKey size++fanMeet :: Int -> Int -> Int -> Int+fanMeet size leftValue rightValue+  | leftValue == topKey size = rightValue+  | rightValue == topKey size = leftValue+  | leftValue == rightValue = leftValue+  | leftValue == bottomKey || rightValue == bottomKey = bottomKey+  | otherwise = bottomKey++rawRelationRows :: Shape -> Int -> Vector.Vector IntSet.IntSet+rawRelationRows shape size =+  Vector.fromList+    [ IntSet.fromAscList (upperKeys shape size leftKey)+    | leftKey <- keys size+    ]++hackageBooleanCubeElements :: Int -> [IntSet.IntSet]+hackageBooleanCubeElements size =+  fmap (hackageBooleanCubeElement (booleanCubeBits size)) (keys size)++hackageBooleanCubeElement :: [Int] -> Int -> IntSet.IntSet+hackageBooleanCubeElement dimensionBits keyValue =+  IntSet.fromAscList+    [ bitOrdinal+    | (bitOrdinal, bitValue) <- zip [0 ..] dimensionBits,+      keyValue .&. bitValue /= 0+    ]++booleanCubeBits :: Int -> [Int]+booleanCubeBits size =+  takeWhile (< size) (iterate (* 2) 1)++decl :: Shape -> Int -> ContextOrderDecl Int+decl shape size =+  contextOrderDecl (topKey size) bottomKey (coverEdges shape size)++tallGridDecl :: Int -> ContextOrderDecl Int+tallGridDecl height =+  contextOrderDecl (tallGridTopKey height) bottomKey (tallGridCoverEdges height)++tallGridCoverEdges :: Int -> [(Int, Int)]+tallGridCoverEdges height =+  [ (keyValue, upperValue)+  | keyValue <- keys (tallGridElementCount height),+    upperValue <- tallGridUpperCovers height keyValue+  ]++tallGridUniverse :: Int -> Set.Set Int+tallGridUniverse height =+  universe (tallGridElementCount height)++coverEdges :: Shape -> Int -> [(Int, Int)]+coverEdges shape size =+  case shape of+    Chain -> fmap (\keyValue -> (keyValue, keyValue + 1)) [0 .. size - 2]+    Fan ->+      fmap (\keyValue -> (bottomKey, keyValue)) (atomKeys size)+        <> fmap (\keyValue -> (keyValue, topKey size)) (atomKeys size)+    BooleanCube ->+      booleanCubeCoverEdges size+    DenseGrid ->+      [ (keyValue, upperValue)+      | keyValue <- keys size,+        upperValue <- gridUpperCovers size keyValue+      ]++booleanCubeCoverEdges :: Int -> [(Int, Int)]+booleanCubeCoverEdges size =+  [ (keyValue, keyValue + bitValue)+  | keyValue <- keys size,+    bitValue <- takeWhile (< size) (iterate (* 2) 1),+    keyValue .&. bitValue == 0,+    keyValue + bitValue < size+  ]++upperKeys :: Shape -> Int -> Int -> [Int]+upperKeys shape size keyValue =+  case shape of+    Chain -> [keyValue .. topKey size]+    Fan+      | keyValue == bottomKey -> keys size+      | keyValue == topKey size -> [topKey size]+      | otherwise -> [keyValue, topKey size]+    BooleanCube ->+      [candidateKey | candidateKey <- keys size, keyValue .&. candidateKey == keyValue]+    DenseGrid ->+      [candidateKey | candidateKey <- keys size, gridKeyLeq size keyValue candidateKey]++supportSeeds :: Shape -> Int -> [Int]+supportSeeds shape size =+  case shape of+    Chain ->+      [size `div` 3, (2 * size) `div` 3, topKey size]+    Fan ->+      take 8 (atomKeys size)+    BooleanCube ->+      take 16 (booleanCubeMiddleLayer size)+    DenseGrid ->+      take 16 (gridMiddleLayer size)++wideSupportSeeds :: Shape -> Int -> [Int]+wideSupportSeeds shape size =+  case shape of+    Chain ->+      [size `div` 3, (2 * size) `div` 3, topKey size]+    Fan ->+      take 16 (atomKeys size)+    BooleanCube ->+      take 32 (booleanCubeMiddleLayer size)+    DenseGrid ->+      take 32 (gridMiddleLayer size)++shiftedWideSupportSeeds :: Shape -> Int -> [Int]+shiftedWideSupportSeeds shape size =+  case shape of+    Chain ->+      [max bottomKey (size `div` 4), max bottomKey ((3 * size) `div` 4)]+    Fan ->+      take 16 (drop 16 (atomKeys size) <> atomKeys size)+    BooleanCube ->+      take 32 (drop 32 (booleanCubeMiddleLayer size) <> booleanCubeMiddleLayer size)+    DenseGrid ->+      take 32 (drop 32 (gridMiddleLayer size) <> gridMiddleLayer size)++booleanCubeMiddleLayer :: Int -> [Int]+booleanCubeMiddleLayer size =+  [ keyValue+  | keyValue <- keys size,+    popCount keyValue == targetWeight+  ]+  where+    targetWeight =+      length (takeWhile (< size) (iterate (* 2) 1)) `quot` 2++joinSeedStep :: Shape -> Int -> Int -> Int+joinSeedStep shape size =+  case shape of+    Chain ->+      max (fixpointSeed shape size)+    Fan ->+      fanJoinSeed size (fixpointSeed shape size)+    BooleanCube ->+      (.|. fixpointSeed shape size)+    DenseGrid ->+      gridJoinSeed size (fixpointSeed shape size)++meetSeedStep :: Shape -> Int -> Int -> Int+meetSeedStep shape size =+  case shape of+    Chain ->+      min (fixpointSeed shape size)+    Fan ->+      fanMeetSeed size (fixpointSeed shape size)+    BooleanCube ->+      (.&. fixpointSeed shape size)+    DenseGrid ->+      gridMeetSeed size (fixpointSeed shape size)++fixpointSeed :: Shape -> Int -> Int+fixpointSeed shape size =+  case shape of+    Chain -> size `quot` 2+    Fan -> min (topKey size) 1+    BooleanCube ->+      foldl' (.|.) 0 (take everyOtherBit (takeWhile (< size) (iterate (* 2) 1)))+      where+        everyOtherBit =+          max 1 (length (takeWhile (< size) (iterate (* 2) 1)) `quot` 2)+    DenseGrid ->+      gridKey size (gridHeight size `quot` 2) (gridWidth size `quot` 2)++fanJoinSeed :: Int -> Int -> Int -> Int+fanJoinSeed size seed value+  | value == bottomKey = seed+  | value == seed = seed+  | value == topKey size = topKey size+  | otherwise = topKey size++fanMeetSeed :: Int -> Int -> Int -> Int+fanMeetSeed size seed value+  | value == topKey size = seed+  | value == seed = seed+  | value == bottomKey = bottomKey+  | otherwise = bottomKey++gridJoinSeed :: Int -> Int -> Int -> Int+gridJoinSeed size seed value =+  gridKey+    size+    (max (gridRow size seed) (gridRow size value))+    (max (gridColumn size seed) (gridColumn size value))++gridMeetSeed :: Int -> Int -> Int -> Int+gridMeetSeed size seed value =+  gridKey+    size+    (min (gridRow size seed) (gridRow size value))+    (min (gridColumn size seed) (gridColumn size value))++gridUpperCovers :: Int -> Int -> [Int]+gridUpperCovers size keyValue =+  [ gridKey size nextRow column+  | nextRow < gridHeight size+  ]+    <> [ gridKey size row nextColumn+       | nextColumn < width+       ]+  where+    width = gridWidth size+    row = gridRow size keyValue+    column = gridColumn size keyValue+    nextRow = row + 1+    nextColumn = column + 1++gridKeyLeq :: Int -> Int -> Int -> Bool+gridKeyLeq size leftKey rightKey =+  gridRow size leftKey <= gridRow size rightKey+    && gridColumn size leftKey <= gridColumn size rightKey++tallGridUpperCovers :: Int -> Int -> [Int]+tallGridUpperCovers height keyValue =+  [ tallGridKey nextRow column+  | nextRow < height+  ]+    <> [ tallGridKey row nextColumn+       | nextColumn < tallGridWidth+       ]+  where+    row = tallGridRow keyValue+    column = tallGridColumn keyValue+    nextRow = row + 1+    nextColumn = column + 1++tallGridKey :: Int -> Int -> Int+tallGridKey row column =+  row * tallGridWidth + column++tallGridRow :: Int -> Int+tallGridRow keyValue =+  keyValue `quot` tallGridWidth++tallGridColumn :: Int -> Int+tallGridColumn keyValue =+  keyValue `rem` tallGridWidth++tallGridElementCount :: Int -> Int+tallGridElementCount height =+  height * tallGridWidth++tallGridTopKey :: Int -> Int+tallGridTopKey height =+  tallGridElementCount height - 1++tallGridWidth :: Int+tallGridWidth = 2++gridMiddleLayer :: Int -> [Int]+gridMiddleLayer size =+  [ keyValue+  | keyValue <- keys size,+    gridRow size keyValue + gridColumn size keyValue == targetRank+  ]+  where+    targetRank =+      (gridHeight size + gridWidth size - 2) `quot` 2++gridKey :: Int -> Int -> Int -> Int+gridKey size row column =+  row * gridWidth size + column++gridRow :: Int -> Int -> Int+gridRow size keyValue =+  keyValue `quot` gridWidth size++gridColumn :: Int -> Int -> Int+gridColumn size keyValue =+  keyValue `rem` gridWidth size++gridHeight :: Int -> Int+gridHeight size =+  size `quot` gridWidth size++gridWidth :: Int -> Int+gridWidth size =+  foldl' selectFactor 1 [1 .. size]+  where+    selectFactor best candidate+      | candidate * candidate <= size && size `rem` candidate == 0 = candidate+      | otherwise = best++shapes :: [Shape]+shapes = [Chain, Fan, BooleanCube, DenseGrid]++compileSizes :: [Int]+compileSizes = [16, 64, 128]++querySizes :: [Int]+querySizes = [16, 64, 128, 256]++tablelessTallGridCompileHeights :: [Int]+tablelessTallGridCompileHeights = [32, 64, 128]++tablelessTallGridQueryHeights :: [Int]+tablelessTallGridQueryHeights = [32, 64, 128]++tablelessLimits :: ContextCompileLimits+tablelessLimits =+  defaultContextCompileLimits {cclMaximumBinaryTableBytes = Just 0}++universe :: Int -> Set.Set Int+universe = Set.fromAscList . keys++keys :: Int -> [Int]+keys size = [0 .. size - 1]++atomKeys :: Int -> [Int]+atomKeys size = [1 .. size - 2]++topKey :: Int -> Int+topKey size = size - 1++bottomKey :: Int+bottomKey = 0++shapeLabel :: Shape -> String+shapeLabel shape =+  case shape of+    Chain -> "chain-dense"+    Fan -> "fan-sparse"+    BooleanCube -> "boolean-cube"+    DenseGrid -> "dense-grid"++caseLabel :: String -> Int -> String+caseLabel label size =+  label <> " n=" <> show size
+ bench/finite-lattice/JoinMeet.hs view
@@ -0,0 +1,112 @@+module JoinMeet+  ( joinMeetComparisonBenchmarks,+  )+where++import Control.DeepSeq+  ( NFData (..),+  )+import Data.Bifunctor+  ( first,+  )+import Data.Map.Strict qualified as Map+import Fixtures+  ( Shape,+    assertFiniteFixture,+    caseLabel,+    compileLatticeEnv,+    keys,+    querySizes,+    shapeJoinMeetTable,+    shapeLabel,+    shapes,+  )+import Kernels+  ( joinMeetSweepWeight,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+    joinContext,+    meetContext,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++data PreparedJoinMeetComparison = PreparedJoinMeetComparison !Int !(ContextLattice Int) !(Map.Map (Int, Int) (Int, Int))++instance NFData PreparedJoinMeetComparison where+  rnf (PreparedJoinMeetComparison size lattice table) =+    rnf (size, lattice, Map.toAscList table)++joinMeetComparisonBenchmarks :: Benchmark+joinMeetComparisonBenchmarks =+  bgroup+    "join-meet-world-baseline"+    [ bgroup+        (shapeLabel shape)+        (fmap (joinMeetComparisonBenchmark shape) querySizes)+    | shape <- shapes+    ]++joinMeetComparisonBenchmark :: Shape -> Int -> Benchmark+joinMeetComparisonBenchmark shape size =+  env (prepareJoinMeetComparison shape size) $ \prepared ->+    bgroup+      (caseLabel "query sweep" size)+      [ bench "moonlight: compiled ContextLattice join/meet" (nf moonlightJoinMeetComparisonWeight prepared),+        bench "baseline: precomputed join/meet Data.Map lookup" (nf worldJoinMeetComparisonWeight prepared)+      ]++prepareJoinMeetComparison :: Shape -> Int -> IO PreparedJoinMeetComparison+prepareJoinMeetComparison shape size = do+  lattice <- compileLatticeEnv shape size+  let !table = shapeJoinMeetTable shape size+  assertFiniteFixture "join/meet table" (assertJoinMeetTableAgrees size lattice table)+  pure (PreparedJoinMeetComparison size lattice table)++assertJoinMeetTableAgrees :: Int -> ContextLattice Int -> Map.Map (Int, Int) (Int, Int) -> Either String ()+assertJoinMeetTableAgrees size lattice table =+  fmap (const ()) (traverse checkPair pairs)+  where+    pairs =+      [ (leftValue, rightValue)+      | leftValue <- keys size,+        rightValue <- keys size+      ]++    checkPair (leftValue, rightValue) = do+      joined <- first show (joinContext lattice leftValue rightValue)+      met <- first show (meetContext lattice leftValue rightValue)+      case Map.lookup (leftValue, rightValue) table of+        Just expected+          | expected == (joined, met) ->+              Right ()+          | otherwise ->+              Left+                ( "join/meet table mismatch for "+                    <> show (leftValue, rightValue)+                    <> ": baseline "+                    <> show expected+                    <> ", lattice "+                    <> show (joined, met)+                )+        Nothing ->+          Left ("missing join/meet table entry " <> show (leftValue, rightValue))++moonlightJoinMeetComparisonWeight :: PreparedJoinMeetComparison -> Either String Int+moonlightJoinMeetComparisonWeight (PreparedJoinMeetComparison size lattice _) =+  joinMeetSweepWeight size lattice++worldJoinMeetComparisonWeight :: PreparedJoinMeetComparison -> Either String Int+worldJoinMeetComparisonWeight (PreparedJoinMeetComparison size _ table) =+  fmap sum (traverse tablePairWeight [(leftValue, rightValue) | leftValue <- keys size, rightValue <- keys size])+  where+    tablePairWeight pairValue =+      case Map.lookup pairValue table of+        Just (joined, met) -> Right (joined + met)+        Nothing -> Left ("missing join/meet table entry " <> show pairValue)
+ bench/finite-lattice/Kernels.hs view
@@ -0,0 +1,130 @@+module Kernels+  ( leqSweepWeight,+    residentLeqSweepWeight,+    residentJoinMeetKeySweepWeight,+    joinMeetSweepWeight,+    implicationSweepWeight,+    implicationKeySweepWeight,+    fixpointPairWeight,+  )+where++import Data.Bifunctor+  ( first,+  )+import Fixtures+  ( Shape,+    joinSeedStep,+    keys,+    meetSeedStep,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+    joinContext,+    meetContext,+  )+import Moonlight.FiniteLattice.Fixpoint+  ( greatestContextFixpoint,+    leastContextFixpoint,+  )+import Moonlight.FiniteLattice.Heyting+  ( ContextHeyting,+    compileContextHeyting,+    impliesContext,+    residentHeytingBaseContext,+    residentImpliesKey,+    withResidentHeytingContext,+  )+import Moonlight.FiniteLattice.Resident+  ( ResidentContext,+    ResidentContextKey,+    residentContextElementKey,+    residentContextElements,+    residentContextKeyLeq,+    residentContextKeyOrdinal,+    residentContextKeys,+    residentJoinMeetKeys,+    withResidentContext,+  )++leqSweepWeight :: Int -> ContextLattice Int -> Int+leqSweepWeight _size lattice =+  withResidentContext lattice $ \contextValue ->+    residentLeqSweepWeight contextValue (residentContextKeys contextValue)++residentLeqSweepWeight ::+  ResidentContext s Int ->+  [ResidentContextKey s] ->+  Int+residentLeqSweepWeight contextValue contextKeys =+  length+    [ ()+    | leftKey <- contextKeys,+      rightKey <- contextKeys,+      residentContextKeyLeq contextValue leftKey rightKey+    ]++residentJoinMeetKeySweepWeight ::+  ResidentContext s Int ->+  [ResidentContextKey s] ->+  Either String Int+residentJoinMeetKeySweepWeight contextValue contextKeys =+  Right $+    sum+      [ let (joinKey, meetKey) = residentJoinMeetKeys contextValue leftKey rightKey+         in residentContextKeyOrdinal joinKey + residentContextKeyOrdinal meetKey+      | leftKey <- contextKeys,+        rightKey <- contextKeys+      ]++joinMeetSweepWeight :: Int -> ContextLattice Int -> Either String Int+joinMeetSweepWeight size lattice =+  fmap sum+    ( traverse+        joinMeetPairWeight+        [ (leftValue, rightValue)+        | leftValue <- keys size,+          rightValue <- keys size+        ]+    )+  where+    joinMeetPairWeight (leftValue, rightValue) = do+      joined <- first show (joinContext lattice leftValue rightValue)+      met <- first show (meetContext lattice leftValue rightValue)+      pure (joined + met)++implicationSweepWeight :: Int -> ContextLattice Int -> Either String Int+implicationSweepWeight size lattice = do+  heyting <- first show (compileContextHeyting lattice)+  fmap sum+    ( traverse+        (implicationPairWeight heyting)+        [ (leftValue, rightValue)+        | leftValue <- keys size,+          rightValue <- keys size+        ]+    )+  where+    implicationPairWeight :: ContextHeyting Int -> (Int, Int) -> Either String Int+    implicationPairWeight heyting (leftValue, rightValue) =+      first show (impliesContext heyting leftValue rightValue)++implicationKeySweepWeight :: ContextLattice Int -> Either String Int+implicationKeySweepWeight lattice = do+  heyting <- first show (compileContextHeyting lattice)+  pure $+    withResidentHeytingContext heyting $ \contextValue ->+      let baseContext = residentHeytingBaseContext contextValue+          contextKeys =+            residentContextElementKey <$> residentContextElements baseContext+       in sum+            [ residentContextKeyOrdinal (residentImpliesKey contextValue leftKey rightKey)+            | leftKey <- contextKeys,+              rightKey <- contextKeys+            ]++fixpointPairWeight :: Shape -> Int -> ContextLattice Int -> Either String (Int, Int)+fixpointPairWeight shape size lattice =+  (,)+    <$> first show (leastContextFixpoint lattice (joinSeedStep shape size))+    <*> first show (greatestContextFixpoint lattice (meetSeedStep shape size))
+ bench/finite-lattice/Main.hs view
@@ -0,0 +1,15 @@+module Main+  ( main,+  )+where++import FiniteLatticeBench+  ( finiteLatticeBenchmarkSuite,+  )+import Moonlight.Pale.Bench.Runner+  ( runBenchmark,+  )++main :: IO ()+main =+  runBenchmark finiteLatticeBenchmarkSuite
+ bench/finite-lattice/Rows.hs view
@@ -0,0 +1,134 @@+module Rows+  ( contextRowComparisonBenchmarks,+  )+where++import Control.DeepSeq+  ( NFData (..),+  )+import Data.Bifunctor+  ( first,+  )+import Data.IntSet qualified as IntSet+import Data.Vector qualified as Vector+import Fixtures+  ( Shape,+    assertFiniteFixture,+    caseLabel,+    compileLatticeEnv,+    keys,+    querySizes,+    rawRelationRows,+    shapeLabel,+    shapes,+  )+import Kernels+  ( leqSweepWeight,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+    leqContext,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++data RowOwner+  = PackedRows+  | IntSetRows+  deriving stock (Eq, Ord, Show)++data PreparedRows+  = PreparedPackedRows !Int !(ContextLattice Int)+  | PreparedIntSetRows !Int !(Vector.Vector IntSet.IntSet)++instance NFData PreparedRows where+  rnf prepared =+    case prepared of+      PreparedPackedRows size lattice ->+        rnf (size, lattice)+      PreparedIntSetRows size rows ->+        rnf (size, rows)++contextRowComparisonBenchmarks :: Benchmark+contextRowComparisonBenchmarks =+  bgroup+    "context-row-membership-baseline"+    [ bgroup+        (shapeLabel shape)+        [ bgroup+            (rowOwnerLabel rowOwner)+            (fmap (membershipBenchmark shape rowOwner) querySizes)+        | rowOwner <- rowOwners+        ]+    | shape <- shapes+    ]++membershipBenchmark :: Shape -> RowOwner -> Int -> Benchmark+membershipBenchmark shape rowOwner size =+  env (prepareRows shape rowOwner size) $ \rows ->+    bench (caseLabel "membership sweep" size) (nf membershipCount rows)++prepareRows :: Shape -> RowOwner -> Int -> IO PreparedRows+prepareRows shape rowOwner size =+  case rowOwner of+    PackedRows ->+      PreparedPackedRows size <$> compileLatticeEnv shape size+    IntSetRows -> do+      lattice <- compileLatticeEnv shape size+      let !rows = rawRelationRows shape size+      assertFiniteFixture "IntSet membership rows" (assertMembershipRowsAgree size lattice rows)+      pure (PreparedIntSetRows size rows)++assertMembershipRowsAgree :: Int -> ContextLattice Int -> Vector.Vector IntSet.IntSet -> Either String ()+assertMembershipRowsAgree size lattice rows+  | Vector.length rows /= size =+      Left ("membership row count " <> show (Vector.length rows) <> " /= " <> show size)+  | otherwise =+      fmap (const ()) (traverse checkMembership memberships)+  where+    memberships =+      [ (leftValue, rightValue, IntSet.member rightValue row)+      | (leftValue, row) <- zip (keys size) (Vector.toList rows),+        rightValue <- keys size+      ]++    checkMembership (leftValue, rightValue, baseline) = do+      actual <- first show (leqContext lattice leftValue rightValue)+      if actual == baseline+        then Right ()+        else+          Left+            ( "membership row mismatch for "+                <> show (leftValue, rightValue)+                <> ": baseline "+                <> show baseline+                <> ", lattice "+                <> show actual+            )++membershipCount :: PreparedRows -> Int+membershipCount prepared =+  case prepared of+    PreparedPackedRows size lattice ->+      leqSweepWeight size lattice+    PreparedIntSetRows size rows ->+      length+        [ ()+        | row <- Vector.toList rows,+          rightKey <- keys size,+          IntSet.member rightKey row+        ]++rowOwners :: [RowOwner]+rowOwners = [PackedRows, IntSetRows]++rowOwnerLabel :: RowOwner -> String+rowOwnerLabel rowOwner =+  case rowOwner of+    PackedRows -> "moonlight: packed context-key rows"+    IntSetRows -> "world: containers IntSet rows"
+ bench/finite-lattice/Support.hs view
@@ -0,0 +1,135 @@+module Support+  ( supportBenchmarks,+  )+where++import Data.Bifunctor+  ( first,+  )+import Fixtures+  ( Shape,+    caseLabel,+    compileLatticeEnv,+    keys,+    querySizes,+    shapeLabel,+    shapes,+    shiftedWideSupportSeeds,+    supportSeeds,+    topKey,+    wideSupportSeeds,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+  )+import Moonlight.FiniteLattice.Resident+  ( residentContextElements,+    withResidentContext,+  )+import Moonlight.FiniteLattice.Support+  ( principalSupport,+    residentSupportContainsElement,+    residentSupportFromElements,+    residentSupportKeys,+    residentSupportMeet,+    residentSupportReachableElements,+    residentSupportWithClosure,+    supportBasis,+    supportContains,+    supportGenerators,+    supportMeet,+    supportReachableLatticeContexts,+    supportUnion,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++supportBenchmarks :: Benchmark+supportBenchmarks =+  bgroup+    "support-basis"+    [ bgroup+        (shapeLabel shape)+        (supportBenchmarksForShape shape)+    | shape <- shapes+    ]++supportBenchmarksForShape :: Shape -> [Benchmark]+supportBenchmarksForShape shape =+  fmap (supportBenchmarksForSize shape) querySizes++supportBenchmarksForSize :: Shape -> Int -> Benchmark+supportBenchmarksForSize shape size =+  env (compileLatticeEnv shape size) $ \lattice ->+    bgroup+      (caseLabel "compiled support fixture" size)+      [ bench (caseLabel "normalize generators" size) (nf (supportNormalizeWeight shape size) lattice),+        bench (caseLabel "contains sweep" size) (nf (supportContainsSweepWeight shape size) lattice),+        bench (caseLabel "resident wide contains cached" size) (nf (residentSupportContainsWeight shape size) lattice),+        bench (caseLabel "union/meet" size) (nf (supportUnionMeetWeight shape size) lattice),+        bench (caseLabel "resident wide meet" size) (nf (residentSupportMeetWeight shape size) lattice),+        bench (caseLabel "reachable contexts" size) (nf (supportReachableWeight shape size) lattice),+        bench (caseLabel "resident wide reachable" size) (nf (residentSupportReachableWeight shape size) lattice)+      ]++supportNormalizeWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+supportNormalizeWeight shape size lattice =+  length . supportGenerators <$> first show (supportBasis lattice (supportSeeds shape size))++supportContainsSweepWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+supportContainsSweepWeight shape size lattice = do+  support <- first show (supportBasis lattice (supportSeeds shape size))+  sum . fmap fromEnum+    <$> traverse+      (\candidate -> first show (supportContains lattice support candidate))+      (keys size)++supportUnionMeetWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+supportUnionMeetWeight shape size lattice = do+  leftSupport <- first show (supportBasis lattice (supportSeeds shape size))+  let rightSupport = principalSupport (topKey size)+  unionSupport <- first show (supportUnion lattice leftSupport rightSupport)+  meetSupport <- first show (supportMeet lattice leftSupport rightSupport)+  pure (length (supportGenerators unionSupport) + length (supportGenerators meetSupport))++supportReachableWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+supportReachableWeight shape size lattice = do+  support <- first show (supportBasis lattice (supportSeeds shape size))+  length <$> first show (supportReachableLatticeContexts lattice support)++residentSupportContainsWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+residentSupportContainsWeight shape size lattice =+  withResidentContext lattice $ \contextValue -> do+    support <- first show (residentSupportFromElements contextValue (wideSupportSeeds shape size))+    let cachedSupport = residentSupportWithClosure contextValue support+    pure+      ( length+          [ ()+          | contextElement <- residentContextElements contextValue,+            residentSupportContainsElement contextValue cachedSupport contextElement+          ]+      )++residentSupportReachableWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+residentSupportReachableWeight shape size lattice =+  withResidentContext lattice $ \contextValue -> do+    support <- first show (residentSupportFromElements contextValue (wideSupportSeeds shape size))+    pure (length (residentSupportReachableElements contextValue support))++residentSupportMeetWeight :: Shape -> Int -> ContextLattice Int -> Either String Int+residentSupportMeetWeight shape size lattice =+  withResidentContext lattice $ \contextValue -> do+    leftSupport <- first show (residentSupportFromElements contextValue (wideSupportSeeds shape size))+    rightSupport <- first show (residentSupportFromElements contextValue (shiftedWideSupportSeeds shape size))+    pure+      ( length+          ( residentSupportKeys+              contextValue+              (residentSupportMeet contextValue leftSupport rightSupport)+          )+      )
+ bench/finite-lattice/Tableless.hs view
@@ -0,0 +1,88 @@+module Tableless+  ( tablelessFallbackBenchmarks,+  )+where++import Fixtures+  ( Shape (..),+    caseLabel,+    compileTablelessLatticeEnv,+    compileTablelessLatticeWeight,+    compileTablelessTallGridEnv,+    compileTablelessTallGridWeight,+    compileSizes,+    querySizes,+    tablelessTallGridCompileHeights,+    tablelessTallGridQueryHeights,+    tallGridElementCount,+  )+import Kernels+  ( implicationKeySweepWeight,+    implicationSweepWeight,+    joinMeetSweepWeight,+    residentJoinMeetKeySweepWeight,+    residentLeqSweepWeight,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+  )+import Moonlight.FiniteLattice.Resident+  ( residentContextKeys,+    withResidentContext,+  )+import Test.Tasty.Bench+  ( Benchmark,+    bench,+    bgroup,+    env,+    nf,+  )++tablelessFallbackBenchmarks :: Benchmark+tablelessFallbackBenchmarks =+  bgroup+    "finite-lattice-tableless"+    [ bgroup+        "dense-grid"+        (tablelessDenseGridCompileBenchmarks <> fmap tablelessDenseGridQueryBenchmarks querySizes),+      bgroup+        "tall-grid"+        (tablelessTallGridCompileBenchmarks <> fmap tablelessTallGridQueryBenchmarks tablelessTallGridQueryHeights)+    ]++tablelessDenseGridCompileBenchmarks :: [Benchmark]+tablelessDenseGridCompileBenchmarks =+  [ bench (caseLabel "compile/binary-table-budget" size) (nf (compileTablelessLatticeWeight DenseGrid) size)+  | size <- compileSizes+  ]++tablelessDenseGridQueryBenchmarks :: Int -> Benchmark+tablelessDenseGridQueryBenchmarks size =+  env (compileTablelessLatticeEnv DenseGrid size) $ \lattice ->+    bgroup+      (caseLabel "compiled query fixture" size)+      (tablelessQueryBenchmarkCases size lattice)++tablelessTallGridCompileBenchmarks :: [Benchmark]+tablelessTallGridCompileBenchmarks =+  [ bench (caseLabel "compile/binary-table-budget" (tallGridElementCount height)) (nf compileTablelessTallGridWeight height)+  | height <- tablelessTallGridCompileHeights+  ]++tablelessTallGridQueryBenchmarks :: Int -> Benchmark+tablelessTallGridQueryBenchmarks height =+  env (compileTablelessTallGridEnv height) $ \lattice ->+    bgroup+      (caseLabel "compiled query fixture" (tallGridElementCount height))+      (tablelessQueryBenchmarkCases (tallGridElementCount height) lattice)++tablelessQueryBenchmarkCases :: Int -> ContextLattice Int -> [Benchmark]+tablelessQueryBenchmarkCases size lattice =+  withResidentContext lattice $ \contextValue ->+    let contextKeys = residentContextKeys contextValue+     in [ bench (caseLabel "key <= sweep" size) (nf (residentLeqSweepWeight contextValue) contextKeys),+          bench (caseLabel "key join/meet sweep" size) (nf (residentJoinMeetKeySweepWeight contextValue) contextKeys),+          bench (caseLabel "join/meet sweep" size) (nf (joinMeetSweepWeight size) lattice),+          bench (caseLabel "key heyting implication sweep" size) (nf implicationKeySweepWeight lattice),+          bench (caseLabel "heyting implication sweep" size) (nf (implicationSweepWeight size) lattice)+        ]
+ docs/finite-lattice/BENCHMARKS-m4-pro.md view
@@ -0,0 +1,90 @@+# moonlight-algebra finite-lattice benchmarks on Apple M4 Pro++This file records only post-change measurements from the current package+topology; stale timings are never pasted forward.++## 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.2 (25F84) |+| GHC | 9.14.1 |+| Cabal | 3.16.1.0 |+| Benchmark runner | `tasty-bench` |+| Cabal target | `moonlight-algebra:bench:moonlight-algebra-finite-lattice-bench` |+| Cabal parallelism | `-j1` |+| Benchmark timeout | `--timeout=1s` |+| CSV source | `/tmp/moonlight-algebra-finite-lattice-bench-m4-pro-all.csv` |++## Required commands++```sh+cd /Users/bluerose/Developer/pale-meridian/compiler+cabal bench moonlight-algebra:bench:moonlight-algebra-finite-lattice-bench -j1 --benchmark-options='--timeout=1s --csv=/tmp/moonlight-algebra-finite-lattice-bench-m4-pro-all.csv'+```++## 2026-07-20 finite-lattice result++All 373 benchmark cases pass. Times are `tasty-bench` means converted from+picoseconds; the full CSV is at the path above. `n` is the declared element+count of the compiled lattice.++### Compilation cost by topology (`compile/order+operations`)++| Topology | n=16 | n=64 | n=128 |+|---|---:|---:|---:|+| chain-dense | 3.96 µs | 18.2 µs | 39.8 µs |+| fan-sparse | 10.1 µs | 52.6 µs | 117 µs |+| boolean-cube | 13.2 µs | 95.3 µs | 256 µs |+| dense-grid | 66.4 µs | 1.04 ms | 5.91 ms |++Dense-grid grows fastest of the four; at n=128 it is in milliseconds where the+sparser topologies remain in microseconds.++### Compiled-query operations (chain-dense fixture, n=128)++Rows prefixed `key` resolve through resident branded keys (array indexing); the+unprefixed rows resolve each domain value through the value→key map on every+call.++| Operation | Time |+|---|---:|+| key `<=` sweep | 37.7 µs |+| key join/meet sweep | 41.0 µs |+| join/meet sweep | 3.05 ms |+| least/greatest fixpoint | 19.7 µs |+| key Heyting implication sweep | 69.9 µs |+| Heyting implication sweep | 1.44 ms |++### Referent: `finite-lattice` vs Hackage `lattices` (boolean-cube, n=256)++| Operation | moonlight | `lattices` (IntSet) |+|---|---:|---:|+| `<=` sweep (resident key) | 214 µs | 369 µs |+| join sweep (public) | 8.23 ms | 332 µs |+| meet sweep (public) | 8.09 ms | 334 µs |+| join/meet sweep (resident key) | 1.18 ms | 616 µs |++### Referent: compiled `ContextLattice` join/meet vs precomputed `Data.Map` (n=256)++| Topology | ContextLattice | precomputed `Data.Map` |+|---|---:|---:|+| chain-dense | 20.3 ms | 5.58 ms |+| fan-sparse | 20.0 ms | 5.45 ms |+| boolean-cube | 20.7 ms | 5.49 ms |+| dense-grid | 20.3 ms | 5.44 ms |++### Referent: packed context-key rows vs `containers` IntSet rows (membership sweep, n=256)++| Topology | packed rows | IntSet rows |+|---|---:|---:|+| chain-dense | 224 µs | 256 µs |+| fan-sparse | 191 µs | 227 µs |+| boolean-cube | 210 µs | 265 µs |+| dense-grid | 245 µs | 274 µs |
+ docs/finite-lattice/CHANGELOG.md view
@@ -0,0 +1,9 @@+# Changelog++## 0.1.0.0 - unreleased++- Initial release of the compiled finite context lattice public sublibrary+  inside `moonlight-algebra`.+- Owns checked context-order compilation, dense join/meet/order plans, cover+  edges, Heyting implication, finite fixpoint iteration, resident branded keys,+  support bases, and finite lattice presentation builders.
+ moonlight-algebra.cabal view
@@ -0,0 +1,310 @@+cabal-version:       3.4+name:                moonlight-algebra+version:             0.1.0.0+homepage:            https://github.com/PaleRoses/moonlight+bug-reports:         https://github.com/PaleRoses/moonlight/issues+synopsis:            Algebraic type class tower for Pale Meridian.+description:         A tower of pure, law-governed algebraic structures: semigroups, monoids and groups, lattices up to Heyting and Boolean algebras, integral and Euclidean domains, modules and vector spaces, modular arithmetic, and free constructions, plus the public finite-lattice sublibrary for checked finite-order compilation and dense query plans.+license:             MIT+license-file:        LICENSE+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+  docs/finite-lattice/CHANGELOG.md+  docs/finite-lattice/BENCHMARKS-m4-pro.md++source-repository head+  type:     git+  location: https://github.com/PaleRoses/moonlight.git+  subdir:   moonlight-algebra++common shared-properties+  default-language: GHC2024+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -Wno-missing-import-lists+  default-extensions:+    TypeFamilies+    UndecidableInstances++library abstract+  import: shared-properties+  visibility: public+  hs-source-dirs: src-abstract+  exposed-modules:+    Moonlight.Algebra.Pure.Action+    Moonlight.Algebra.Pure.EndoPatch+    Moonlight.Algebra.Pure.FreeAbelianGroup+    Moonlight.Algebra.Pure.FreeMonoid+    Moonlight.Algebra.Pure.GCD+    Moonlight.Algebra.Pure.Group+    Moonlight.Algebra.Pure.Lattice+    Moonlight.Algebra.Pure.LaneVector+    Moonlight.Algebra.Pure.Magnitude+    Moonlight.Algebra.Pure.Module+    Moonlight.Algebra.Pure.NumberTheory+    Moonlight.Algebra.Pure.Orientation+    Moonlight.Algebra.Pure.Polynomial+    Moonlight.Algebra.Pure.PowerSet+    Moonlight.Algebra.Pure.Product+    Moonlight.Algebra.Pure.Quotient+    Moonlight.Algebra.Pure.Ring+    Moonlight.Algebra.Pure.SparseVec+    Moonlight.Algebra.Pure.Zn+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:moonlight-algebra-internal+    , moonlight-core >= 0.1 && < 0.2+    , vector >= 0.13 && < 0.14++library+  import: shared-properties+  hs-source-dirs: src-public+  exposed-modules:+    Moonlight.Algebra+  build-depends:+    base >= 4.22 && < 5+    , moonlight-algebra:abstract+    , moonlight-core >= 0.1 && < 0.2++library finite-lattice+  import: shared-properties+  visibility: public+  hs-source-dirs: src-finite-lattice+  default-extensions:+    FunctionalDependencies+  exposed-modules:+    Moonlight.FiniteLattice+    Moonlight.FiniteLattice.Core+    Moonlight.FiniteLattice.Cover+    Moonlight.FiniteLattice.Fixpoint+    Moonlight.FiniteLattice.Heyting+    Moonlight.FiniteLattice.Presentation+    Moonlight.FiniteLattice.Resident+    Moonlight.FiniteLattice.Support+  other-modules:+    Moonlight.FiniteLattice.Internal.Compile+    Moonlight.FiniteLattice.Internal.Dense+    Moonlight.FiniteLattice.Internal.Distributive+    Moonlight.FiniteLattice.Internal.Index+    Moonlight.FiniteLattice.Internal.Invariant+    Moonlight.FiniteLattice.Internal.Key+    Moonlight.FiniteLattice.Internal.Layout+    Moonlight.FiniteLattice.Internal.Plan+    Moonlight.FiniteLattice.Internal.Recognize+    Moonlight.FiniteLattice.Internal.Relation+    Moonlight.FiniteLattice.Internal.Topological+    Moonlight.FiniteLattice.Internal.Types+    Moonlight.FiniteLattice.Internal.Validate+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:abstract+    , moonlight-core >= 0.1 && < 0.2+    , vector >= 0.13 && < 0.14++library moonlight-algebra-internal+  import: shared-properties+  visibility: private+  hs-source-dirs: src-internal+  exposed-modules:+    Moonlight.Algebra.Unsafe.GCDWitness+  build-depends:+    base >= 4.22 && < 5+    , moonlight-core >= 0.1 && < 0.2++library moonlight-algebra-laws+  import: shared-properties+  visibility: private+  hs-source-dirs: src-laws+  exposed-modules:+    Moonlight.Algebra.Effect.LawNames+    Moonlight.Algebra.Effect.Laws+    Moonlight.Algebra.Test.Generators+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , hedgehog >= 1.2 && < 1.8+    , moonlight-algebra+    , moonlight-algebra:moonlight-algebra-internal+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:test-laws >= 0.1 && < 0.2+    , tasty >= 1.4 && < 1.6+    , tasty-hedgehog >= 1.4 && < 1.5+    , tasty-hunit >= 0.10 && < 0.11+    , vector >= 0.13 && < 0.14++test-suite moonlight-algebra-abstract-test+  type: exitcode-stdio-1.0+  default-language: GHC2024+  hs-source-dirs: test/abstract+  main-is: Main.hs+  other-modules:+    AbstractTests+    OrderedLatticeSpec+    SparseVecSpec+  ghc-options: -Wall -Wcompat+  default-extensions:+    TypeFamilies+    UndecidableInstances+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra+    , moonlight-algebra:abstract+    , moonlight-algebra:moonlight-algebra-laws+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:test >= 0.1 && < 0.2+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , tasty-hedgehog >= 1.4 && < 1.5+    , hedgehog >= 1.2 && < 1.8++test-suite moonlight-algebra-finite-lattice-test+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: test/finite-lattice+  main-is: Main.hs+  other-modules:+    FiniteLatticeSpec+    FiniteLatticeTests+    LawSpec+    PresentationSpec+  default-extensions:+    FunctionalDependencies+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-algebra:finite-lattice+    , moonlight-pale:test >= 0.1 && < 0.2+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , tasty-quickcheck >= 0.10 && < 0.12+    , QuickCheck >= 2.14 && < 2.19++test-suite moonlight-algebra-test+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test/aggregate+    test/abstract+    test/finite-lattice+  main-is: Main.hs+  other-modules:+    AbstractTests+    FiniteLatticeSpec+    FiniteLatticeTests+    LawSpec+    OrderedLatticeSpec+    PresentationSpec+    SparseVecSpec+  default-extensions:+    FunctionalDependencies+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , hedgehog >= 1.2 && < 1.8+    , moonlight-algebra+    , moonlight-algebra:abstract+    , moonlight-algebra:finite-lattice+    , moonlight-algebra:moonlight-algebra-laws+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:test >= 0.1 && < 0.2+    , tasty >= 1.4 && < 1.6+    , tasty-hedgehog >= 1.4 && < 1.5+    , tasty-hunit >= 0.10 && < 0.11+    , tasty-quickcheck >= 0.10 && < 0.12+    , QuickCheck >= 2.14 && < 2.19++benchmark moonlight-algebra-abstract-bench+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: bench/abstract+  main-is: Main.hs+  other-modules:+    AbstractBench+  ghc-options: -O2+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.4 && < 1.6+    , moonlight-algebra+    , moonlight-algebra:abstract+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:bench >= 0.1 && < 0.2+    , tasty-bench >= 0.3 && < 0.6+    , vector >= 0.13 && < 0.14++benchmark moonlight-algebra-finite-lattice-bench+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs: bench/finite-lattice+  main-is: Main.hs+  other-modules:+    Atomic+    Finite+    FiniteLatticeBench+    Fixtures+    JoinMeet+    Kernels+    Rows+    Support+    Tableless+  default-extensions:+    FunctionalDependencies+  ghc-options: -O2+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.4 && < 1.6+    , lattices >= 2.2 && < 2.3+    , moonlight-algebra:finite-lattice+    , moonlight-pale:bench >= 0.1 && < 0.2+    , tasty-bench >= 0.3 && < 0.6+    , vector >= 0.13 && < 0.14++benchmark moonlight-algebra-bench+  import: shared-properties+  type: exitcode-stdio-1.0+  hs-source-dirs:+    bench/aggregate+    bench/abstract+    bench/finite-lattice+  main-is: Main.hs+  other-modules:+    AbstractBench+    Atomic+    Finite+    FiniteLatticeBench+    Fixtures+    JoinMeet+    Kernels+    Rows+    Support+    Tableless+  default-extensions:+    FunctionalDependencies+  ghc-options: -O2+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.4 && < 1.6+    , lattices >= 2.2 && < 2.3+    , moonlight-algebra+    , moonlight-algebra:abstract+    , moonlight-algebra:finite-lattice+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-pale:bench >= 0.1 && < 0.2+    , tasty-bench >= 0.3 && < 0.6+    , vector >= 0.13 && < 0.14
+ src-abstract/Moonlight/Algebra/Pure/Action.hs view
@@ -0,0 +1,21 @@+-- | Monoid actions on a carrier ('Action'), with the group-acting refinement+-- 'InvertibleAction'.+--+-- Laws: @act mempty = id@ and @act (x <> y) = act x . act y@; an invertible+-- action additionally has @act (groupInverse m)@ inverse to @act m@.+module Moonlight.Algebra.Pure.Action+  ( Action (..),+    InvertibleAction,+  )+where++import Data.Kind (Constraint, Type)+import Moonlight.Algebra.Pure.Group (Group)+import Prelude (Monoid)++type Action :: Type -> Type -> Constraint+class Monoid m => Action m s where+  act :: m -> s -> s++type InvertibleAction :: Type -> Type -> Constraint+class (Group m, Action m s) => InvertibleAction m s
+ src-abstract/Moonlight/Algebra/Pure/EndoPatch.hs view
@@ -0,0 +1,43 @@+module Moonlight.Algebra.Pure.EndoPatch+  ( EndoPatch,+    endoPatch,+    endoPatchAssignments,+    endoPatchAdds,+    endoPatchRemoves,+  )+where++import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)++type EndoPatch :: Type -> Type+newtype EndoPatch key = EndoPatch+  { endoPatchAssignments :: Map key Bool+  }+  deriving stock (Eq, Show)++endoPatch :: Ord key => Set key -> Set key -> EndoPatch key+endoPatch adds removes =+  EndoPatch+    ( Map.union+        (Map.fromSet (const True) adds)+        (Map.fromSet (const False) removes)+    )++endoPatchAdds :: EndoPatch key -> Set key+endoPatchAdds =+  Map.keysSet . Map.filter id . endoPatchAssignments++endoPatchRemoves :: EndoPatch key -> Set key+endoPatchRemoves =+  Map.keysSet . Map.filter not . endoPatchAssignments++instance Ord key => Semigroup (EndoPatch key) where+  leftPatch <> rightPatch =+    EndoPatch+      (Map.union (endoPatchAssignments rightPatch) (endoPatchAssignments leftPatch))++instance Ord key => Monoid (EndoPatch key) where+  mempty = EndoPatch Map.empty
+ src-abstract/Moonlight/Algebra/Pure/FreeAbelianGroup.hs view
@@ -0,0 +1,51 @@+-- | The free abelian group on a set of generators, as finite formal sums backed+-- by 'Moonlight.Algebra.Pure.SparseVec.SparseVec'.+--+-- Laws: the universal abelian group on its generators — addition is associative+-- and commutative, the empty sum is the identity, every element has an inverse.+module Moonlight.Algebra.Pure.FreeAbelianGroup+  ( FreeAbelianGroup,+    fromTerms,+    toTerms,+    singleton,+    normalizeFreeAbelianGroup,+  )+where++import Data.Coerce (coerce)+import Data.Kind (Type)+import Moonlight.Algebra.Pure.Module (FreeModule (..), Module (..))+import Moonlight.Algebra.Pure.SparseVec (SparseVec)+import qualified Moonlight.Algebra.Pure.SparseVec as SparseVec+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid,+    IsoNorm (..),+    isoNormalize,+  )++type FreeAbelianGroup :: Type -> Type+newtype FreeAbelianGroup g = FreeAbelianGroup (SparseVec Integer g)+  deriving stock (Eq, Show)+  deriving newtype+    ( AdditiveMonoid,+      AdditiveGroup,+      Module Integer,+      FreeModule Integer+    )++fromTerms :: Ord g => [(g, Integer)] -> FreeAbelianGroup g+fromTerms = coerce SparseVec.fromEntries++toTerms :: FreeAbelianGroup g -> [(g, Integer)]+toTerms = coerce SparseVec.toEntries++singleton :: Ord g => g -> Integer -> FreeAbelianGroup g+singleton basisElement weight = fromTerms [(basisElement, weight)]++normalizeFreeAbelianGroup :: Ord g => FreeAbelianGroup g -> FreeAbelianGroup g+normalizeFreeAbelianGroup = isoNormalize++instance Ord g => IsoNorm (FreeAbelianGroup g) [(g, Integer)] where+  isoFrom = fromTerms+  isoTo = toTerms
+ src-abstract/Moonlight/Algebra/Pure/FreeMonoid.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveTraversable #-}++-- | The free monoid: 'Batch', a @newtype@ over a list carrying the+-- standard 'Semigroup'/'Monoid' instances.+--+-- Laws: concatenation is associative with the empty batch as two-sided identity.+module Moonlight.Algebra.Pure.FreeMonoid+  ( Batch (..),+    singletonBatch,+  )+where++import Data.Kind (Type)++type Batch :: Type -> Type+newtype Batch a = Batch [a]+  deriving stock (Eq, Show, Functor, Foldable, Traversable)+  deriving newtype (Semigroup, Monoid)++singletonBatch :: a -> Batch a+singletonBatch value = Batch [value]
+ src-abstract/Moonlight/Algebra/Pure/GCD.hs view
@@ -0,0 +1,114 @@++-- | GCD, extended GCD, modular inverse and CRT over Euclidean domains.+--+-- Laws: 'extGcd' yields a Bézout identity @a*x + b*y = gcd a b@; 'modInverse'+-- inverts a unit modulo the given modulus when one exists.+module Moonlight.Algebra.Pure.GCD+  ( NonZeroModulus,+    withNonZeroModulus,+    withNonZeroModulusValue,+    CanonicalResidue,+    CrtMod,+    mkCanonicalResidue,+    withCanonicalResidue,+    gcd,+    extGcd,+    modInverse,+    crt,+  )+where++import Prelude hiding (gcd)+import Data.Kind (Type)+import Moonlight.Algebra.Pure.Ring+  ( CanonicalEuclideanDomain (..),+    EuclideanDomain (..),+    GCDDomain (..),+    IntegralDomain (..),+    mkNonZeroDivisor,+  )+import Moonlight.Algebra.Unsafe.GCDWitness+  ( CanonicalResidue (..),+    NonZeroModulus,+    canonicalResidueModulus,+    canonicalResidueValue,+    mkNonZeroInternal,+    nonZeroValue,+    retagNonZero,+  )+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+  )++withNonZeroModulus ::+  IntegralDomain a =>+  a ->+  (forall modulus. NonZeroModulus modulus a -> r) ->+  Maybe r+withNonZeroModulus value use =+  use <$> mkNonZeroInternal isZero value++withNonZeroModulusValue :: NonZeroModulus modulus a -> (a -> r) -> r+withNonZeroModulusValue modulus use = use (nonZeroValue modulus)++mkCanonicalResidue :: CanonicalEuclideanDomain a => NonZeroModulus modulus a -> a -> CanonicalResidue modulus a+mkCanonicalResidue modulus value =+  CanonicalResidue modulus (normalize modulus value)++withCanonicalResidue ::+  CanonicalResidue modulus a ->+  (NonZeroModulus modulus a -> a -> r) ->+  r+withCanonicalResidue residue use =+  use (canonicalResidueModulus residue) (canonicalResidueValue residue)++gcd :: GCDDomain a => a -> a -> a+gcd = gcdDomain++extGcd :: GCDDomain a => a -> a -> (a, a, a)+extGcd = extendedGcdDomain++modInverse :: CanonicalEuclideanDomain a => a -> NonZeroModulus modulus a -> Maybe a+modInverse value modulus = do+  let (gcdValue, inverseCandidate, _) = extGcd value (nonZeroValue modulus)+  gcdInv <- unitInverse gcdValue+  Just (normalize modulus (mul inverseCandidate gcdInv))++type CrtMod :: Type -> Type -> Type+data CrtMod left right++crt ::+  forall left right a.+  CanonicalEuclideanDomain a =>+  CanonicalResidue left a ->+  CanonicalResidue right a ->+  Maybe (CanonicalResidue (CrtMod left right) a)+crt left right = do+  divisorRefined <- mkNonZeroDivisor divisor+  let (diffQuotient, diffRemainder) =+        divideWithRemainder (sub rightResidue leftResidue) divisorRefined+      (reducedRightModulusValue, reducedRightRemainder) =+        divideWithRemainder rightModulusValue divisorRefined+  if diffRemainder /= zero || reducedRightRemainder /= zero+    then Nothing+    else do+      reducedRightModulus <- (mkNonZeroInternal isZero reducedRightModulusValue :: Maybe (NonZeroModulus right a))+      let offset = normalize reducedRightModulus (mul diffQuotient leftCoefficient)+          candidate = add leftResidue (mul leftModulusValue offset)+          combinedModulusValue = mul leftModulusValue reducedRightModulusValue+      combinedModulus <- (mkNonZeroInternal isZero combinedModulusValue :: Maybe (NonZeroModulus (CrtMod left right) a))+      pure (mkCanonicalResidue combinedModulus candidate)+  where+    leftResidue = canonicalResidueValue left+    rightResidue = canonicalResidueValue right+    leftModulus = canonicalResidueModulus left+    rightModulus = canonicalResidueModulus right+    leftModulusValue = nonZeroValue leftModulus+    rightModulusValue = nonZeroValue rightModulus+    (divisor, leftCoefficient, _) = extGcd leftModulusValue rightModulusValue++normalize :: CanonicalEuclideanDomain a => NonZeroModulus modulus a -> a -> a+normalize modulus value =+  canonicalRemainder value (retagNonZero modulus)
+ src-abstract/Moonlight/Algebra/Pure/Group.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE GHC2024 #-}++-- | Lawful group refinements over the standard 'Semigroup' and 'Monoid'+-- classes, plus operation-selecting wrappers for carriers with more than one+-- legitimate monoidal structure.+--+-- A raw carrier such as 'Integer' admits both additive and multiplicative+-- monoids. Haskell instances are global, so 'Additive' and 'Multiplicative'+-- make the selected operation explicit instead of pretending the carrier has+-- one canonical monoid.+module Moonlight.Algebra.Pure.Group+  ( Additive (..),+    Multiplicative (..),+    Semigroup (..),+    Monoid (..),+    Group (..),+    AbelianGroup,+  )+where++import Data.Kind (Constraint, Type)+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+  )+import Prelude+  ( Eq,+    Monoid (..),+    Num,+    Ord,+    Semigroup (..),+    Show,+  )++type Additive :: Type -> Type+newtype Additive a = Additive {getAdditive :: a}+  deriving stock (Eq, Ord, Show)+  deriving newtype (Num)++type Multiplicative :: Type -> Type+newtype Multiplicative a = Multiplicative {getMultiplicative :: a}+  deriving stock (Eq, Ord, Show)+  deriving newtype (Num)++type Group :: Type -> Constraint+class Monoid group => Group group where+  groupInverse :: group -> group++  groupDifference :: group -> group -> group+  groupDifference left right =+    left <> groupInverse right++type AbelianGroup :: Type -> Constraint+class Group group => AbelianGroup group++instance AdditiveMonoid a => Semigroup (Additive a) where+  Additive left <> Additive right =+    Additive (add left right)++instance AdditiveMonoid a => Monoid (Additive a) where+  mempty =+    Additive zero++instance AdditiveGroup a => Group (Additive a) where+  groupInverse (Additive value) =+    Additive (neg value)++instance AdditiveGroup a => AbelianGroup (Additive a)++instance MultiplicativeMonoid a => Semigroup (Multiplicative a) where+  Multiplicative left <> Multiplicative right =+    Multiplicative (mul left right)++instance MultiplicativeMonoid a => Monoid (Multiplicative a) where+  mempty =+    Multiplicative one
+ src-abstract/Moonlight/Algebra/Pure/LaneVector.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-}++module Moonlight.Algebra.Pure.LaneVector+  ( LaneVector,+    laneCount,+    laneVectorZero,+    laneVectorFromLanes,+    laneVectorLanes,+  )+where++import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+  )+import Prelude+  ( Eq,+    Int,+    Ordering (..),+    Show,+    compare,+    negate,+    (-),+    (+),+  )++newtype LaneVector = LaneVector (UVector.Vector Word64)+  deriving stock (Eq, Show)++laneCount :: Int+laneCount = 16+{-# INLINE laneCount #-}++laneVectorZero :: LaneVector+laneVectorZero =+  LaneVector (UVector.replicate laneCount 0)+{-# INLINE laneVectorZero #-}++laneVectorFromLanes :: UVector.Vector Word64 -> LaneVector+laneVectorFromLanes lanes =+  let inputLaneCount = UVector.length lanes+   in case compare inputLaneCount laneCount of+        LT ->+          LaneVector+            ( lanes+                UVector.++ UVector.replicate (laneCount - inputLaneCount) 0+            )+        EQ -> LaneVector lanes+        GT -> LaneVector (UVector.force (UVector.take laneCount lanes))+{-# INLINE laneVectorFromLanes #-}++laneVectorLanes :: LaneVector -> UVector.Vector Word64+laneVectorLanes (LaneVector lanes) =+  lanes+{-# INLINE laneVectorLanes #-}++instance AdditiveMonoid LaneVector where+  zero = laneVectorZero+  add (LaneVector left) (LaneVector right) =+    LaneVector (UVector.zipWith (+) left right)+  {-# INLINE zero #-}+  {-# INLINE add #-}++instance AdditiveGroup LaneVector where+  neg (LaneVector lanes) =+    LaneVector (UVector.map negate lanes)+  {-# INLINE neg #-}++  sub (LaneVector left) (LaneVector right) =+    LaneVector (UVector.zipWith (-) left right)+  {-# INLINE sub #-}
+ src-abstract/Moonlight/Algebra/Pure/Lattice.hs view
@@ -0,0 +1,402 @@+-- | The lattice class tower: join/meet semilattices and their bounded forms,+-- lattices, distributive, Heyting and Boolean algebras, with fixpoint helpers.+--+-- Laws: join and meet are idempotent, commutative and associative; bounded+-- variants add an identity; lattices satisfy absorption; distributive adds+-- distributivity; Heyting adds residuation; Boolean adds complementation.+module Moonlight.Algebra.Pure.Lattice+  ( JoinSemilattice (..),+    BoundedJoinSemilattice (..),+    MeetSemilattice (..),+    BoundedMeetSemilattice (..),+    Lattice,+    OrderedLattice,+    BoundedLattice,+    DistributiveLattice,+    HeytingAlgebra (..),+    BooleanAlgebra (..),+    FixpointDivergence (..),+    Join (..),+    Meet (..),+    iterateFixpointFrom,+    leastFixpoint,+    greatestFixpoint,+    leastPreFixpoint,+    leastPreFixpointFrom,+    greatestPostFixpoint,+    greatestPostFixpointFrom,+    joinLeq,+    meetLeq,+    joins,+    joins1,+    meets,+    meets1,+    fromBool,+  )+where++import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Core+  ( FixpointDivergence (..),+    PartialOrder,+    fixpointBounded,+  )+import Numeric.Natural+  ( Natural,+  )++type Join :: Type -> Type+newtype Join a = Join {getJoin :: a}+  deriving stock (Eq, Ord, Show)++type Meet :: Type -> Type+newtype Meet a = Meet {getMeet :: a}+  deriving stock (Eq, Ord, Show)++type JoinSemilattice :: Type -> Constraint+class JoinSemilattice a where+  join :: a -> a -> a++instance JoinSemilattice () where+  join _ _ = ()++instance JoinSemilattice Bool where+  join = (||)++instance Ord a => JoinSemilattice (Set.Set a) where+  join = Set.union++instance JoinSemilattice IntSet.IntSet where+  join = IntSet.union++instance (Ord key, JoinSemilattice value) => JoinSemilattice (Map.Map key value) where+  join = Map.unionWith join++instance JoinSemilattice value => JoinSemilattice (IntMap.IntMap value) where+  join = IntMap.unionWith join++instance (JoinSemilattice left, JoinSemilattice right) => JoinSemilattice (left, right) where+  join (leftA, rightA) (leftB, rightB) =+    (join leftA leftB, join rightA rightB)++instance JoinSemilattice value => JoinSemilattice (key -> value) where+  join left right key =+    join (left key) (right key)++instance JoinSemilattice a => Semigroup (Join a) where+  Join left <> Join right =+    Join (join left right)++type BoundedJoinSemilattice :: Type -> Constraint+class JoinSemilattice a => BoundedJoinSemilattice a where+  bottom :: a++instance BoundedJoinSemilattice () where+  bottom = ()++instance BoundedJoinSemilattice Bool where+  bottom = False++instance Ord a => BoundedJoinSemilattice (Set.Set a) where+  bottom = Set.empty++instance BoundedJoinSemilattice IntSet.IntSet where+  bottom = IntSet.empty++instance (Ord key, JoinSemilattice value) => BoundedJoinSemilattice (Map.Map key value) where+  bottom = Map.empty++instance JoinSemilattice value => BoundedJoinSemilattice (IntMap.IntMap value) where+  bottom = IntMap.empty++instance+  (BoundedJoinSemilattice left, BoundedJoinSemilattice right) =>+  BoundedJoinSemilattice (left, right)+  where+  bottom =+    (bottom, bottom)++instance BoundedJoinSemilattice value => BoundedJoinSemilattice (key -> value) where+  bottom =+    const bottom++instance BoundedJoinSemilattice a => Monoid (Join a) where+  mempty =+    Join bottom++type MeetSemilattice :: Type -> Constraint+class MeetSemilattice a where+  meet :: a -> a -> a++instance MeetSemilattice () where+  meet _ _ = ()++instance MeetSemilattice Bool where+  meet = (&&)++instance Ord a => MeetSemilattice (Set.Set a) where+  meet = Set.intersection++instance MeetSemilattice IntSet.IntSet where+  meet = IntSet.intersection++instance (Ord key, MeetSemilattice value) => MeetSemilattice (Map.Map key value) where+  meet = Map.intersectionWith meet++instance MeetSemilattice value => MeetSemilattice (IntMap.IntMap value) where+  meet = IntMap.intersectionWith meet++instance (MeetSemilattice left, MeetSemilattice right) => MeetSemilattice (left, right) where+  meet (leftA, rightA) (leftB, rightB) =+    (meet leftA leftB, meet rightA rightB)++instance MeetSemilattice value => MeetSemilattice (key -> value) where+  meet left right key =+    meet (left key) (right key)++instance MeetSemilattice a => Semigroup (Meet a) where+  Meet left <> Meet right =+    Meet (meet left right)++type BoundedMeetSemilattice :: Type -> Constraint+class MeetSemilattice a => BoundedMeetSemilattice a where+  top :: a++instance BoundedMeetSemilattice () where+  top = ()++instance BoundedMeetSemilattice Bool where+  top = True++instance+  (BoundedMeetSemilattice left, BoundedMeetSemilattice right) =>+  BoundedMeetSemilattice (left, right)+  where+  top =+    (top, top)++instance BoundedMeetSemilattice value => BoundedMeetSemilattice (key -> value) where+  top =+    const top++instance BoundedMeetSemilattice a => Monoid (Meet a) where+  mempty =+    Meet top++type Lattice :: Type -> Constraint+class (JoinSemilattice a, MeetSemilattice a) => Lattice a++type OrderedLattice :: Type -> Constraint+class (PartialOrder a, Lattice a) => OrderedLattice a++type BoundedLattice :: Type -> Constraint+type BoundedLattice a = (Lattice a, BoundedJoinSemilattice a, BoundedMeetSemilattice a)++instance Lattice ()++instance OrderedLattice ()++instance Lattice Bool++instance OrderedLattice Bool++instance Ord a => Lattice (Set.Set a)++instance Ord a => OrderedLattice (Set.Set a)++instance Lattice IntSet.IntSet++instance OrderedLattice IntSet.IntSet++instance (Ord key, Lattice value) => Lattice (Map.Map key value)++instance (Ord key, OrderedLattice value) => OrderedLattice (Map.Map key value)++instance Lattice value => Lattice (IntMap.IntMap value)++instance OrderedLattice value => OrderedLattice (IntMap.IntMap value)++instance (Lattice left, Lattice right) => Lattice (left, right)++instance (OrderedLattice left, OrderedLattice right) => OrderedLattice (left, right)++instance Lattice value => Lattice (key -> value)++type DistributiveLattice :: Type -> Constraint+class Lattice a => DistributiveLattice a++instance DistributiveLattice ()++instance DistributiveLattice Bool++instance Ord a => DistributiveLattice (Set.Set a)++instance DistributiveLattice IntSet.IntSet++instance+  (Ord key, DistributiveLattice value) =>+  DistributiveLattice (Map.Map key value)++instance DistributiveLattice value => DistributiveLattice (IntMap.IntMap value)++instance+  (DistributiveLattice left, DistributiveLattice right) =>+  DistributiveLattice (left, right)++instance DistributiveLattice value => DistributiveLattice (key -> value)++infixr 5 <=>++type HeytingAlgebra :: Type -> Constraint+class (BoundedLattice a, DistributiveLattice a) => HeytingAlgebra a where+  implies :: a -> a -> a+  neg :: a -> a+  neg value =+    implies value bottom+  (<=>) :: a -> a -> a+  left <=> right =+    meet (implies left right) (implies right left)++instance HeytingAlgebra () where+  implies _ _ = ()++instance HeytingAlgebra Bool where+  implies left right =+    not left || right++instance+  (HeytingAlgebra left, HeytingAlgebra right) =>+  HeytingAlgebra (left, right)+  where+  implies (leftA, rightA) (leftB, rightB) =+    (implies leftA leftB, implies rightA rightB)++instance HeytingAlgebra value => HeytingAlgebra (key -> value) where+  implies left right key =+    implies (left key) (right key)++type BooleanAlgebra :: Type -> Constraint+class HeytingAlgebra a => BooleanAlgebra a where+  complement :: a -> a+  symmetricDifference :: a -> a -> a+  symmetricDifference left right =+    join+      (meet left (complement right))+      (meet (complement left) right)++instance BooleanAlgebra () where+  complement _ = ()++instance BooleanAlgebra Bool where+  complement =+    not++instance+  (BooleanAlgebra left, BooleanAlgebra right) =>+  BooleanAlgebra (left, right)+  where+  complement (left, right) =+    (complement left, complement right)++instance BooleanAlgebra value => BooleanAlgebra (key -> value) where+  complement value key =+    complement (value key)++iterateFixpointFrom ::+  Eq a =>+  Natural ->+  a ->+  (a -> a) ->+  Either (FixpointDivergence a) a+iterateFixpointFrom budget seed step =+  fixpointBounded budget step seed+{-# INLINE iterateFixpointFrom #-}++leastFixpoint ::+  (Eq a, BoundedJoinSemilattice a) =>+  Natural ->+  (a -> a) ->+  Either (FixpointDivergence a) a+leastFixpoint budget =+  iterateFixpointFrom budget bottom+{-# INLINE leastFixpoint #-}++greatestFixpoint ::+  (Eq a, BoundedMeetSemilattice a) =>+  Natural ->+  (a -> a) ->+  Either (FixpointDivergence a) a+greatestFixpoint budget =+  iterateFixpointFrom budget top+{-# INLINE greatestFixpoint #-}++leastPreFixpoint ::+  (Eq a, BoundedJoinSemilattice a) =>+  Natural ->+  (a -> a) ->+  Either (FixpointDivergence a) a+leastPreFixpoint budget =+  leastPreFixpointFrom budget bottom+{-# INLINE leastPreFixpoint #-}++leastPreFixpointFrom ::+  (Eq a, JoinSemilattice a) =>+  Natural ->+  a ->+  (a -> a) ->+  Either (FixpointDivergence a) a+leastPreFixpointFrom budget seed step =+  fixpointBounded budget (\current -> join current (step current)) seed+{-# INLINE leastPreFixpointFrom #-}++greatestPostFixpoint ::+  (Eq a, BoundedMeetSemilattice a) =>+  Natural ->+  (a -> a) ->+  Either (FixpointDivergence a) a+greatestPostFixpoint budget =+  greatestPostFixpointFrom budget top+{-# INLINE greatestPostFixpoint #-}++greatestPostFixpointFrom ::+  (Eq a, MeetSemilattice a) =>+  Natural ->+  a ->+  (a -> a) ->+  Either (FixpointDivergence a) a+greatestPostFixpointFrom budget seed step =+  fixpointBounded budget (\current -> meet current (step current)) seed+{-# INLINE greatestPostFixpointFrom #-}++joinLeq :: (Eq a, JoinSemilattice a) => a -> a -> Bool+joinLeq left right =+  join left right == right++meetLeq :: (Eq a, MeetSemilattice a) => a -> a -> Bool+meetLeq left right =+  meet left right == left++joins :: (BoundedJoinSemilattice a, Foldable foldable) => foldable a -> a+joins =+  foldl' join bottom++joins1 :: JoinSemilattice a => NonEmpty a -> a+joins1 (first :| rest) =+  foldl' join first rest++meets :: (BoundedMeetSemilattice a, Foldable foldable) => foldable a -> a+meets =+  foldl' meet top++meets1 :: MeetSemilattice a => NonEmpty a -> a+meets1 (first :| rest) =+  foldl' meet first rest++fromBool :: BoundedLattice a => Bool -> a+fromBool value =+  if value then top else bottom
+ src-abstract/Moonlight/Algebra/Pure/Magnitude.hs view
@@ -0,0 +1,21 @@+-- | Real-valued magnitudes of obstructions ('HasMagnitude'), plus a total+-- summing the magnitudes carried by a validation.+module Moonlight.Algebra.Pure.Magnitude+  ( HasMagnitude (..),+    totalObstructionMagnitude,+  )+where++import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty)+import Moonlight.Core (Validation (..))++type HasMagnitude :: Type -> Constraint+class HasMagnitude obstruction where+  obstructionMagnitude :: obstruction -> Double++totalObstructionMagnitude :: HasMagnitude obstruction => Validation (NonEmpty obstruction) value -> Double+totalObstructionMagnitude validationValue =+  case validationValue of+    Valid _ -> 0.0+    Invalid obstructions -> sum (fmap obstructionMagnitude obstructions)
+ src-abstract/Moonlight/Algebra/Pure/Module.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Modules, free modules, vector spaces and bilinear spaces over a ring.+--+-- Laws: scaling distributes over module and ring addition, is compatible with+-- ring multiplication and is unital; a vector space is a module over a field.+-- A 'BilinearSpace' supplies a bilinear form only. It deliberately does not+-- claim conjugation or positivity.+module Moonlight.Algebra.Pure.Module+  ( Module (..),+    FreeModule (..),+    VectorSpace,+    BilinearSpace (..),+  )+where++import Data.Kind (Constraint, Type)+import Moonlight.Core (AdditiveGroup, Field, Ring)++type Module :: Type -> Type -> Constraint+class (Ring scalar, AdditiveGroup moduleValue) => Module scalar moduleValue where+  scale :: scalar -> moduleValue -> moduleValue++type FreeModule :: Type -> Type -> Constraint+class Module scalar moduleValue => FreeModule scalar moduleValue where+  type Basis scalar moduleValue :: Type+  support :: moduleValue -> [Basis scalar moduleValue]+  coefficient :: Basis scalar moduleValue -> moduleValue -> scalar+  generator :: Basis scalar moduleValue -> moduleValue++type VectorSpace :: Type -> Type -> Constraint+class (Field scalar, Module scalar vector) => VectorSpace scalar vector++type BilinearSpace :: Type -> Type -> Constraint+class VectorSpace scalar vector => BilinearSpace scalar vector where+  bilinearForm :: vector -> vector -> scalar+  quadraticForm :: vector -> scalar+  quadraticForm vector = bilinearForm vector vector
+ src-abstract/Moonlight/Algebra/Pure/NumberTheory.hs view
@@ -0,0 +1,95 @@+-- | Elementary number theory: primality, divisors, prime-power factorisation,+-- the Moebius function, and counts of group elements by multiplicative order.+module Moonlight.Algebra.Pure.NumberTheory+  ( countElementsWithOrderDividing,+    countExactOrderElements,+    divisorsFromPrimePowers,+    divisorsOf,+    isPrime,+    mobiusValue,+    primePowerFactors,+    primePowerPart,+  )+where++import Data.Function ((&))+import Moonlight.Algebra.Pure.GCD (gcd)+import Prelude hiding (gcd)++countExactOrderElements :: Integer -> [Integer] -> Integer+countExactOrderElements orderValue cyclicOrders+  | normalizedOrder <= 0 = 0+  | otherwise =+      divisorsOf normalizedOrder+        & fmap+          ( \divisorValue ->+              mobiusValue (normalizedOrder `div` divisorValue)+                * countElementsWithOrderDividing divisorValue cyclicOrders+          )+        & sum+  where normalizedOrder = abs orderValue++countElementsWithOrderDividing :: Integer -> [Integer] -> Integer+countElementsWithOrderDividing divisorValue =+  product . fmap (\cyclicOrder -> gcd (abs cyclicOrder) divisorValue)++mobiusValue :: Integer -> Integer+mobiusValue value+  | normalizedValue == 0 = 0+  | primePowers & any ((> 1) . snd) = 0+  | even (length primePowers) = 1+  | otherwise = -1+  where+    normalizedValue = abs value+    primePowers = primePowerFactors normalizedValue++divisorsOf :: Integer -> [Integer]+divisorsOf value+  | normalizedValue <= 0 = []+  | otherwise = divisorsFromPrimePowers (primePowerFactors normalizedValue)+  where normalizedValue = abs value++divisorsFromPrimePowers :: [(Integer, Int)] -> [Integer]+divisorsFromPrimePowers primePowers =+  case primePowers of+    [] -> [1]+    (primeValue, exponentValue) : remainingPrimePowers ->+      let remainingDivisors = divisorsFromPrimePowers remainingPrimePowers+          primePowersAtFactor = take (exponentValue + 1) (iterate (* primeValue) 1)+       in primePowersAtFactor >>= (\powerValue -> fmap (powerValue *) remainingDivisors)++primePowerFactors :: Integer -> [(Integer, Int)]+primePowerFactors value =+  factorFrom 2 (abs value)++primePowerPart :: Integer -> Integer -> Integer+primePowerPart primeValue value =+  let normalizedPrime = abs primeValue+      normalizedValue = abs value+   in if not (isPrime normalizedPrime)+        then 1+        else+          case lookup normalizedPrime (primePowerFactors normalizedValue) of+            Nothing -> 1+            Just exponentValue -> normalizedPrime ^ exponentValue++isPrime :: Integer -> Bool+isPrime value =+  let normalizedValue = abs value+   in normalizedValue > 1+        && primePowerFactors normalizedValue == [(normalizedValue, 1)]++factorFrom :: Integer -> Integer -> [(Integer, Int)]+factorFrom candidateValue remainingValue+  | remainingValue <= 1 = []+  | candidateValue * candidateValue > remainingValue = [(remainingValue, 1)]+  | remainingValue `mod` candidateValue == 0 =+      let (multiplicityValue, reducedValue) = factorMultiplicity candidateValue remainingValue 0+       in (candidateValue, multiplicityValue) : factorFrom (candidateValue + 1) reducedValue+  | otherwise = factorFrom (candidateValue + 1) remainingValue++factorMultiplicity :: Integer -> Integer -> Int -> (Int, Integer)+factorMultiplicity primeValue remainingValue multiplicityValue+  | remainingValue `mod` primeValue == 0 =+      factorMultiplicity primeValue (remainingValue `div` primeValue) (multiplicityValue + 1)+  | otherwise = (multiplicityValue, remainingValue)
+ src-abstract/Moonlight/Algebra/Pure/Orientation.hs view
@@ -0,0 +1,48 @@+-- | The two-element sign/orientation type 'Orientation', with the magma+-- structure that composes signs.+--+-- Laws: forms the two-element group ℤ/2 — @Positive@ is the identity and+-- @Negative@ is its own inverse.+module Moonlight.Algebra.Pure.Orientation+  ( Orientation (..),+    flipOrientation,+  )+where++import Data.Kind (Type)+import Moonlight.Algebra.Pure.Group+  ( AbelianGroup,+    Group (..),+  )+import Prelude+  ( Eq,+    Monoid (..),+    Ord,+    Read,+    Semigroup (..),+    Show,+    id,+  )++type Orientation :: Type+data Orientation+  = Positive+  | Negative+  deriving stock (Eq, Ord, Show, Read)++flipOrientation :: Orientation -> Orientation+flipOrientation Positive = Negative+flipOrientation Negative = Positive++instance Semigroup Orientation where+  Positive <> other = other+  Negative <> Positive = Negative+  Negative <> Negative = Positive++instance Monoid Orientation where+  mempty = Positive++instance Group Orientation where+  groupInverse = id++instance AbelianGroup Orientation
+ src-abstract/Moonlight/Algebra/Pure/Polynomial.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TypeApplications #-}++-- | Univariate polynomials over a coefficient ring; a 'FreeModule' on monomial+-- degrees.+--+-- Laws: addition forms an additive group with the zero polynomial as identity and+-- scaling acts coefficient-wise (the module laws).+module Moonlight.Algebra.Pure.Polynomial+  ( Polynomial,+    fromCoefficients,+    toCoefficients,+    normalizePolynomial,+    evaluatePolynomial,+    monomial,+  )+where++import Data.Kind (Type)+import Data.List (genericReplicate)+import Numeric.Natural (Natural)+import Moonlight.Algebra.Pure.Module+  ( FreeModule (..),+    BilinearSpace (..),+    Module (..),+    VectorSpace,+  )+import Moonlight.Algebra.Pure.Ring+  ( CommutativeRing,+    Semiring,+  )+import Moonlight.Algebra.Pure.SparseVec (SparseVec)+import qualified Moonlight.Algebra.Pure.SparseVec as SparseVec+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    Field,+    MultiplicativeMonoid (..),+    Ring,+  )++type Polynomial :: Type -> Type+newtype Polynomial r = Polynomial (SparseVec r Natural)+  deriving stock (Eq)++instance (Show r, AdditiveMonoid r) => Show (Polynomial r) where+  show polynomialValue =+    "Polynomial " <> show (toCoefficients polynomialValue)++fromCoefficients :: (Eq r, AdditiveMonoid r) => [r] -> Polynomial r+fromCoefficients =+  fromSparseVec . SparseVec.fromEntries . zip [0 ..]++toCoefficients :: AdditiveMonoid r => Polynomial r -> [r]+toCoefficients = denseCoefficientsFromTerms . SparseVec.toEntries . asSparseVec++normalizePolynomial :: Polynomial r -> Polynomial r+normalizePolynomial = id++evaluatePolynomial :: Ring r => r -> Polynomial r -> r+evaluatePolynomial value =+  foldr+    (\termValue accumulator -> add termValue (mul value accumulator))+    zero+    . toCoefficients++monomial :: (Eq r, AdditiveMonoid r) => Natural -> r -> Polynomial r+monomial degreeValue coefficientValue =+  fromSparseVec (SparseVec.fromEntries [(degreeValue, coefficientValue)])++asSparseVec :: Polynomial r -> SparseVec r Natural+asSparseVec (Polynomial sparsePolynomial) =+  sparsePolynomial++fromSparseVec :: SparseVec r Natural -> Polynomial r+fromSparseVec =+  Polynomial++denseCoefficientsFromTerms :: AdditiveMonoid r => [(Natural, r)] -> [r]+denseCoefficientsFromTerms = go 0+  where+    go :: (Integral degree, AdditiveMonoid coeff) => degree -> [(degree, coeff)] -> [coeff]+    go _ [] = []+    go expectedDegree remainingTerms@((degreeValue, termValue) : restTerms)+      | expectedDegree < degreeValue =+          genericReplicate (degreeValue - expectedDegree) zero+            <> go degreeValue remainingTerms+      | otherwise = termValue : go (expectedDegree + 1) restTerms++multiplyPolynomials :: (Eq r, Semiring r) => Polynomial r -> Polynomial r -> Polynomial r+multiplyPolynomials leftPolynomial rightPolynomial =+  fromSparseVec+    ( SparseVec.fromEntries+        [ (leftDegree + rightDegree, mul leftCoefficient rightCoefficient)+          | (leftDegree, leftCoefficient) <- SparseVec.toEntries (asSparseVec leftPolynomial),+            (rightDegree, rightCoefficient) <- SparseVec.toEntries (asSparseVec rightPolynomial)+        ]+    )++instance (Eq r, AdditiveMonoid r) => AdditiveMonoid (Polynomial r) where+  zero = fromSparseVec zero+  add left right =+    fromSparseVec (add (asSparseVec left) (asSparseVec right))++instance (Eq r, AdditiveGroup r) => AdditiveGroup (Polynomial r) where+  neg =+    fromSparseVec . neg . asSparseVec+  sub left right = add left (neg right)++instance (Eq r, Semiring r) => MultiplicativeMonoid (Polynomial r) where+  one = monomial 0 one+  mul = multiplyPolynomials++instance (Eq r, Ring r) => Ring (Polynomial r)++instance (Eq r, Semiring r) => Semiring (Polynomial r)++instance (Eq r, CommutativeRing r) => CommutativeRing (Polynomial r)++instance (Eq r, Ring r) => Module r (Polynomial r) where+  scale scalar =+    fromSparseVec . scale scalar . asSparseVec++instance (Eq r, Ring r) => FreeModule r (Polynomial r) where+  type Basis r (Polynomial r) = Natural+  support = support @r . asSparseVec+  coefficient degreeValue = SparseVec.lookupEntry degreeValue . asSparseVec+  generator degreeValue = monomial degreeValue one++instance (Eq k, Field k) => VectorSpace k (Polynomial k)++instance (Eq k, Field k) => BilinearSpace k (Polynomial k) where+  bilinearForm leftPolynomial rightPolynomial =+    let rightSparse = asSparseVec rightPolynomial+     in foldr+          add+          zero+          [ mul leftCoefficient (SparseVec.lookupEntry degreeValue rightSparse)+            | (degreeValue, leftCoefficient) <- SparseVec.toEntries (asSparseVec leftPolynomial)+          ]
+ src-abstract/Moonlight/Algebra/Pure/PowerSet.hs view
@@ -0,0 +1,77 @@+-- | Finite power sets ('PowerSet') as a 'BooleanAlgebra': join is union, meet is+-- intersection.+--+-- Laws: a distributive (Boolean) lattice — union and intersection are+-- idempotent, commutative, associative, absorptive, distributive, complemented.+module Moonlight.Algebra.Pure.PowerSet+  ( PowerSet,+    fromList,+    toPowerSetList,+    normalizePowerSet,+    member,+  )+where++import Data.Kind (Type)+import qualified Data.Set as Set+import Moonlight.Algebra.Pure.Lattice+  ( BooleanAlgebra (..),+    BoundedJoinSemilattice (..),+    BoundedMeetSemilattice (..),+    DistributiveLattice,+    HeytingAlgebra (..),+    JoinSemilattice (..),+    Lattice,+    MeetSemilattice (..),+    OrderedLattice,+  )+import Moonlight.Core+  ( FiniteUniverse,+    IsoNorm (..),+    PartialOrder (..),+    finiteUniverseSet,+    isoNormalize,+  )++type PowerSet :: Type -> Type+newtype PowerSet a = PowerSet (Set.Set a)+  deriving stock (Eq, Ord, Show, Read)+  deriving newtype+    ( JoinSemilattice,+      BoundedJoinSemilattice,+      MeetSemilattice,+      PartialOrder,+      Lattice,+      OrderedLattice,+      DistributiveLattice+    )++fromList :: Ord a => [a] -> PowerSet a+fromList = PowerSet . Set.fromList++toPowerSetList :: PowerSet a -> [a]+toPowerSetList (PowerSet elements) = Set.toAscList elements++normalizePowerSet :: Ord a => PowerSet a -> PowerSet a+normalizePowerSet = isoNormalize++member :: Ord a => a -> PowerSet a -> Bool+member value (PowerSet elements) = Set.member value elements++universeSet :: (Ord a, FiniteUniverse a) => Set.Set a+universeSet =+  finiteUniverseSet++instance Ord a => IsoNorm (PowerSet a) [a] where+  isoFrom = fromList+  isoTo = toPowerSetList++instance (Ord a, FiniteUniverse a) => BoundedMeetSemilattice (PowerSet a) where+  top = PowerSet universeSet++instance (Ord a, FiniteUniverse a) => HeytingAlgebra (PowerSet a) where+  implies left = join (complement left)++instance (Ord a, FiniteUniverse a) => BooleanAlgebra (PowerSet a) where+  complement (PowerSet elements) =+    PowerSet (Set.difference universeSet elements)
+ src-abstract/Moonlight/Algebra/Pure/Product.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE RoleAnnotations #-}++-- | Finite @n@-fold product algebras ('ProductAlgebra', arity at the type level)+-- with lattice, ring and module structure defined coordinatewise.+--+-- Laws: every law holds in the product exactly when it holds in each component.+module Moonlight.Algebra.Pure.Product+  ( ProductAlgebra,+    mkProductAlgebra,+    toProductList,+  )+where++import Data.Kind (Type)+import Data.List (genericLength, genericReplicate)+import Data.Proxy (Proxy (..))+import GHC.TypeNats (KnownNat, Nat, natVal)+import Numeric.Natural (Natural)+import Moonlight.Algebra.Pure.Lattice+  ( BoundedJoinSemilattice (..),+    BoundedMeetSemilattice (..),+    BooleanAlgebra (..),+    DistributiveLattice,+    HeytingAlgebra (implies),+    JoinSemilattice (..),+    Lattice,+    MeetSemilattice (..),+    OrderedLattice,+  )+import Moonlight.Algebra.Pure.Module (BilinearSpace (..), Module (..), VectorSpace)+import Moonlight.Algebra.Pure.Ring+  ( CommutativeRing,+    Semiring,+  )+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    Field,+    MultiplicativeMonoid (..),+    PartialOrder (..),+    Ring,+  )++type ProductAlgebra :: Nat -> Type -> Type+type role ProductAlgebra nominal representational+newtype ProductAlgebra (n :: Nat) a = ProductAlgebra [a]+  deriving stock (Eq, Show, Functor)++mkProductAlgebra :: forall n a. KnownNat n => [a] -> Maybe (ProductAlgebra n a)+mkProductAlgebra values+  | genericLength values == expectedArity (Proxy @n) = Just (ProductAlgebra values)+  | otherwise = Nothing++toProductList :: ProductAlgebra n a -> [a]+toProductList (ProductAlgebra values) = values++liftProduct2 :: (a -> b -> c) -> ProductAlgebra n a -> ProductAlgebra n b -> ProductAlgebra n c+liftProduct2 combine (ProductAlgebra left) (ProductAlgebra right) =+  ProductAlgebra (zipWith combine left right)++expectedArity :: forall n. KnownNat n => Proxy n -> Natural+expectedArity _ = natVal (Proxy @n)++instance KnownNat n => Applicative (ProductAlgebra n) where+  pure value = ProductAlgebra (genericReplicate (expectedArity (Proxy @n)) value)+  ProductAlgebra transforms <*> ProductAlgebra values =+    ProductAlgebra (zipWith ($) transforms values)++instance (KnownNat n, AdditiveMonoid a) => AdditiveMonoid (ProductAlgebra n a) where+  zero = pure zero+  add = liftProduct2 add++instance (KnownNat n, AdditiveGroup a) => AdditiveGroup (ProductAlgebra n a) where+  neg = fmap neg+  sub left right = add left (neg right)++instance (KnownNat n, MultiplicativeMonoid a) => MultiplicativeMonoid (ProductAlgebra n a) where+  one = pure one+  mul = liftProduct2 mul++instance (KnownNat n, Ring a) => Ring (ProductAlgebra n a)++instance (KnownNat n, Semiring a) => Semiring (ProductAlgebra n a)++instance (KnownNat n, CommutativeRing a) => CommutativeRing (ProductAlgebra n a)++instance (KnownNat n, Ring r) => Module r (ProductAlgebra n r) where+  scale scalar = fmap (mul scalar)++instance (KnownNat n, Field k) => VectorSpace k (ProductAlgebra n k)++instance (KnownNat n, Field k) => BilinearSpace k (ProductAlgebra n k) where+  bilinearForm (ProductAlgebra left) (ProductAlgebra right) =+    foldr add zero (zipWith mul left right)++instance JoinSemilattice a => JoinSemilattice (ProductAlgebra n a) where+  join = liftProduct2 join++instance (KnownNat n, BoundedJoinSemilattice a) => BoundedJoinSemilattice (ProductAlgebra n a) where+  bottom = pure bottom++instance MeetSemilattice a => MeetSemilattice (ProductAlgebra n a) where+  meet = liftProduct2 meet++instance PartialOrder a => PartialOrder (ProductAlgebra n a) where+  leq (ProductAlgebra left) (ProductAlgebra right) =+    and (zipWith leq left right)++instance (KnownNat n, BoundedMeetSemilattice a) => BoundedMeetSemilattice (ProductAlgebra n a) where+  top = pure top++instance Lattice a => Lattice (ProductAlgebra n a)++instance OrderedLattice a => OrderedLattice (ProductAlgebra n a)++instance DistributiveLattice a => DistributiveLattice (ProductAlgebra n a)++instance (KnownNat n, HeytingAlgebra a) => HeytingAlgebra (ProductAlgebra n a) where+  implies = liftProduct2 implies++instance (KnownNat n, BooleanAlgebra a) => BooleanAlgebra (ProductAlgebra n a) where+  complement = fmap complement
+ src-abstract/Moonlight/Algebra/Pure/Quotient.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++-- | Elements of a quotient ring under a branded runtime modulus.+--+-- The context carries the modulus witness. Quotient values carry only their+-- canonical representative and cannot be combined across different modulus+-- brands.+module Moonlight.Algebra.Pure.Quotient+  ( QuotientContext,+    Quotient,+    withQuotientContext,+    quotient,+    quotientRepresentative,+    zeroQuotient,+    oneQuotient,+    negateQuotient,+    addQuotient,+    subtractQuotient,+    multiplyQuotient,+  )+where++import Data.Kind (Type)+import Moonlight.Algebra.Pure.GCD+  ( NonZeroModulus,+    withNonZeroModulus,+  )+import Moonlight.Algebra.Pure.Ring+  ( CanonicalEuclideanDomain (..),+    IntegralDomain,+  )+import Moonlight.Algebra.Unsafe.GCDWitness (retagNonZero)+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+  )++type QuotientContext :: Type -> Type -> Type+newtype QuotientContext modulus a =+  QuotientContext (NonZeroModulus modulus a)++type role QuotientContext nominal representational++type Quotient :: Type -> Type -> Type+newtype Quotient modulus a =+  Quotient a+  deriving stock (Eq, Ord, Show)++type role Quotient nominal representational++withQuotientContext ::+  IntegralDomain a =>+  a ->+  (forall modulus. QuotientContext modulus a -> result) ->+  Maybe result+withQuotientContext modulus continuation =+  withNonZeroModulus modulus (continuation . QuotientContext)++quotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  a ->+  Quotient modulus a+quotient context =+  Quotient . normalize context++quotientRepresentative ::+  Quotient modulus a ->+  a+quotientRepresentative (Quotient value) =+  value++zeroQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a+zeroQuotient context =+  quotient context zero++oneQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a+oneQuotient context =+  quotient context one++negateQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a ->+  Quotient modulus a+negateQuotient context (Quotient value) =+  quotient context (neg value)++addQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a ->+  Quotient modulus a ->+  Quotient modulus a+addQuotient context (Quotient left) (Quotient right) =+  quotient context (add left right)++subtractQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a ->+  Quotient modulus a ->+  Quotient modulus a+subtractQuotient context (Quotient left) (Quotient right) =+  quotient context (sub left right)++multiplyQuotient ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  Quotient modulus a ->+  Quotient modulus a ->+  Quotient modulus a+multiplyQuotient context (Quotient left) (Quotient right) =+  quotient context (mul left right)++normalize ::+  CanonicalEuclideanDomain a =>+  QuotientContext modulus a ->+  a ->+  a+normalize (QuotientContext modulus) value =+  canonicalRemainder value (retagNonZero modulus)
+ src-abstract/Moonlight/Algebra/Pure/Ring.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ConstraintKinds #-}++-- | Domain refinements over the canonical numeric tower in "Moonlight.Core".+--+-- 'Semiring' and 'CommutativeRing' are re-exported from "Moonlight.Core"; they+-- carry no second copies of @zero@, @one@, @add@, or @mul@. This module adds the+-- progressively stronger integral, GCD, Euclidean, and canonical-remainder+-- laws.+module Moonlight.Algebra.Pure.Ring+  ( Semiring,+    CommutativeRing,+    IntegralDomain (..),+    GCDDomain (..),+    NonZeroDivisor,+    mkNonZeroDivisor,+    nonZeroDivisorValue,+    EuclideanDomain (..),+    CanonicalEuclideanDomain (..),+  )+where++import Data.Kind (Constraint, Type)+import Data.Maybe (isJust)+import Moonlight.Algebra.Unsafe.GCDWitness+  ( NonZero,+    mkNonZeroInternal,+    nonZeroValue,+  )+import Moonlight.Core+  ( CommutativeRing,+    Semiring,+    zero,+  )+import Numeric.Natural (Natural)+import Prelude+  ( Eq,+    Bool,+    Integer,+    Maybe (..),+    Ord,+    abs,+    divMod,+    fromInteger,+    gcd,+    mod,+    otherwise,+    signum,+    (*),+    (-),+    (==),+    (.),+  )++type IntegralDomain :: Type -> Constraint+class (CommutativeRing a, Eq a) => IntegralDomain a where+  isZero :: a -> Bool+  isZero value = value == zero++  unitInverse :: a -> Maybe a++  isUnit :: a -> Bool+  isUnit = isJust . unitInverse++type GCDDomain :: Type -> Constraint+class IntegralDomain a => GCDDomain a where+  gcdDomain :: a -> a -> a+  extendedGcdDomain :: a -> a -> (a, a, a)++data EuclideanDivisor++type NonZeroDivisor :: Type -> Type+type NonZeroDivisor a = NonZero EuclideanDivisor a++mkNonZeroDivisor :: IntegralDomain a => a -> Maybe (NonZeroDivisor a)+mkNonZeroDivisor =+  mkNonZeroInternal isZero++nonZeroDivisorValue :: NonZeroDivisor a -> a+nonZeroDivisorValue =+  nonZeroValue++type EuclideanDomain :: Type -> Constraint+class (GCDDomain a, Ord (Degree a)) => EuclideanDomain a where+  type Degree a :: Type+  divideWithRemainder :: a -> NonZeroDivisor a -> (a, a)+  degree :: a -> Degree a++type CanonicalEuclideanDomain :: Type -> Constraint+class EuclideanDomain a => CanonicalEuclideanDomain a where+  canonicalRemainder :: a -> NonZeroDivisor a -> a++instance IntegralDomain Integer where+  unitInverse value+    | abs value == 1 = Just value+    | otherwise = Nothing++instance GCDDomain Integer where+  gcdDomain left right = abs (gcd left right)+  extendedGcdDomain = integerExtendedGcd++instance EuclideanDomain Integer where+  type Degree Integer = Natural+  divideWithRemainder value divisor =+    divMod value (nonZeroDivisorValue divisor)+  degree value = fromInteger (abs value)++instance CanonicalEuclideanDomain Integer where+  canonicalRemainder value divisor =+    value `mod` abs (nonZeroDivisorValue divisor)++integerExtendedGcd :: Integer -> Integer -> (Integer, Integer, Integer)+integerExtendedGcd left right+  | right == 0 = (abs left, signum left, 0)+  | otherwise =+      let (quotient, remainder) = divMod left right+          (gcdValue, coeffRight, coeffRemainder) = integerExtendedGcd right remainder+       in (gcdValue, coeffRemainder, coeffRight - quotient * coeffRemainder)
+ src-abstract/Moonlight/Algebra/Pure/SparseVec.hs view
@@ -0,0 +1,304 @@+-- | Finitely-supported sparse vectors keyed by a basis type, plus compiled+-- integer-coordinate sparse kernels for repeated linear substitutions.+--+-- Laws: addition forms an abelian group with the empty vector as identity and+-- scaling is the ring action; the normal form drops all zero entries.+module Moonlight.Algebra.Pure.SparseVec+  ( SparseVec,+    SparseIxVec,+    SparseLinearMap,+    SparseLinearMapCompileError (..),+    SparseLinearMapError (..),+    fromEntries,+    toEntries,+    sparseIxVecFromEntries,+    sparseIxVecToEntries,+    compileSparseLinearMap,+    sparseLinearMapToEntries,+    applySparseLinearMap,+    normalize,+    lookupEntry,+    extendLinear,+  )+where++import Control.Exception (assert)+import Data.List qualified as List+import Data.Kind (Type)+import Data.Maybe (isJust, mapMaybe)+import Data.Vector qualified as BoxedVector+import Data.Vector.Unboxed qualified as UVector+import qualified Data.Map.Strict as Map+import Moonlight.Algebra.Pure.Module (FreeModule (..), Module (..))+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    IsoNorm (..),+    MultiplicativeMonoid (..),+    Ring,+    isoNormalize,+  )++type SparseVec :: Type -> Type -> Type+newtype SparseVec r g = SparseVec (Map.Map g r)+  deriving stock (Eq, Show)++type SparseIxVec :: Type -> Type+data SparseIxVec r = SparseIxVec+  { sivIndices :: !(UVector.Vector Int),+    sivValues :: !(BoxedVector.Vector r)+  }+  deriving stock (Eq, Show)++type SparseLinearMap :: Type -> Type+data SparseLinearMap r = SparseLinearMap+  { slmOffsets :: !(UVector.Vector Int),+    slmTargets :: !(UVector.Vector Int),+    slmValues :: !(BoxedVector.Vector r),+    slmTargetsMonotoneBySource :: !Bool+  }+  deriving stock (Eq, Show)++type SparseLinearMapCompileError :: Type+data SparseLinearMapCompileError+  = SparseLinearMapNegativeSourceCount !Int+  | SparseLinearMapOffsetCountOverflow !Integer+  | SparseLinearMapEntryCountOverflow !Integer+  deriving stock (Eq, Ord, Show)++type SparseLinearMapError :: Type+data SparseLinearMapError+  = SparseLinearMapSourceOutOfBounds !Int+  deriving stock (Eq, Ord, Show)++fromEntries :: (Eq r, AdditiveMonoid r, Ord g) => [(g, r)] -> SparseVec r g+fromEntries =+  SparseVec . Map.mapMaybe normalizeEntry . Map.fromListWith add++toEntries :: SparseVec r g -> [(g, r)]+toEntries (SparseVec entries) = Map.toAscList entries++sparseIxVecFromEntries :: (Eq r, AdditiveMonoid r) => [(Int, r)] -> SparseIxVec r+sparseIxVecFromEntries =+  sparseIxVecFromConsolidatedEntries . consolidateSortedIxEntries . List.sortOn fst+{-# INLINE sparseIxVecFromEntries #-}++sparseIxVecToEntries :: SparseIxVec r -> [(Int, r)]+sparseIxVecToEntries vectorValue =+  zip (UVector.toList (sivIndices vectorValue)) (BoxedVector.toList (sivValues vectorValue))+{-# INLINE sparseIxVecToEntries #-}++sparseLinearMapToEntries :: SparseLinearMap r -> [(Int, Int, r)]+sparseLinearMapToEntries linearMap =+  [ ( sourceIndex,+      unboxedIndexInvariant (slmTargets linearMap) entryOffset,+      boxedIndexInvariant (slmValues linearMap) entryOffset+    )+  | sourceIndex <- [0 .. sparseLinearMapSourceCount linearMap - 1],+    let startOffset = unboxedIndexInvariant (slmOffsets linearMap) sourceIndex,+    let endOffset = unboxedIndexInvariant (slmOffsets linearMap) (sourceIndex + 1),+    entryOffset <- [startOffset .. endOffset - 1]+  ]+{-# INLINE sparseLinearMapToEntries #-}++compileSparseLinearMap ::+  (Eq r, AdditiveMonoid r) =>+  Int ->+  (Int -> [(Int, r)]) ->+  Either SparseLinearMapCompileError (SparseLinearMap r)+compileSparseLinearMap sourceCount substitutionEntries+  | sourceCount < 0 =+      Left (SparseLinearMapNegativeSourceCount sourceCount)+  | requestedOffsetCount > toInteger (maxBound :: Int) =+      Left (SparseLinearMapOffsetCountOverflow requestedOffsetCount)+  | totalEntryCount > toInteger (maxBound :: Int) =+      Left (SparseLinearMapEntryCountOverflow totalEntryCount)+  | otherwise =+      Right+        SparseLinearMap+          { slmOffsets = UVector.fromList (fmap fromInteger offsetIntegers),+            slmTargets = UVector.concat (fmap sivIndices sourceSegments),+            slmValues = BoxedVector.concat (fmap sivValues sourceSegments),+            slmTargetsMonotoneBySource = sparseIxSegmentsAreMonotone sourceSegments+          }+  where+    requestedOffsetCount =+      toInteger sourceCount + 1++    sourceSegments =+      [ sparseIxVecFromEntries (substitutionEntries sourceIndex)+      | sourceIndex <- [0 .. sourceCount - 1]+      ]++    segmentLengths =+      fmap (toInteger . UVector.length . sivIndices) sourceSegments++    offsetIntegers =+      scanl (+) 0 segmentLengths++    totalEntryCount =+      List.foldl' (+) 0 segmentLengths+{-# INLINE compileSparseLinearMap #-}++applySparseLinearMap ::+  (Eq r, Ring r) =>+  SparseLinearMap r ->+  SparseIxVec r ->+  Either SparseLinearMapError (SparseIxVec r)+applySparseLinearMap linearMap vectorValue =+  fmap+    (sparseIxVecFromEmittedEntries linearMap . foldMap emittedEntriesForSource)+    (traverse checkSourceEntry (sparseIxVecToEntries vectorValue))+  where+    sourceCount =+      sparseLinearMapSourceCount linearMap++    checkSourceEntry sourceEntry@(sourceIndex, _)+      | sourceIndex >= 0 && sourceIndex < sourceCount =+          Right sourceEntry+      | otherwise =+          Left (SparseLinearMapSourceOutOfBounds sourceIndex)++    emittedEntriesForSource (sourceIndex, scalar) =+      [ ( unboxedIndexInvariant (slmTargets linearMap) entryOffset,+          mul scalar (boxedIndexInvariant (slmValues linearMap) entryOffset)+        )+      | entryOffset <- [startOffset .. endOffset - 1]+      ]+      where+        startOffset =+          unboxedIndexInvariant (slmOffsets linearMap) sourceIndex++        endOffset =+          unboxedIndexInvariant (slmOffsets linearMap) (sourceIndex + 1)+{-# INLINE applySparseLinearMap #-}++sparseIxVecFromEmittedEntries :: (Eq r, AdditiveMonoid r) => SparseLinearMap r -> [(Int, r)] -> SparseIxVec r+sparseIxVecFromEmittedEntries linearMap+  | slmTargetsMonotoneBySource linearMap =+      sparseIxVecFromConsolidatedEntries . consolidateSortedIxEntries+  | otherwise =+      sparseIxVecFromEntries+{-# INLINE sparseIxVecFromEmittedEntries #-}++sparseIxSegmentsAreMonotone :: [SparseIxVec r] -> Bool+sparseIxSegmentsAreMonotone =+  isJust . List.foldl' boundaryStep (Just Nothing) . mapMaybe sparseIxVecBounds+  where+    boundaryStep :: Maybe (Maybe Int) -> (Int, Int) -> Maybe (Maybe Int)+    boundaryStep Nothing _ = Nothing+    boundaryStep (Just previousLast) (firstTarget, lastTarget)+      | firstTarget <= lastTarget && maybe True (<= firstTarget) previousLast = Just (Just lastTarget)+      | otherwise = Nothing+{-# INLINE sparseIxSegmentsAreMonotone #-}++sparseIxVecBounds :: SparseIxVec r -> Maybe (Int, Int)+sparseIxVecBounds vectorValue =+  (,)+    <$> sivIndices vectorValue UVector.!? 0+    <*> sivIndices vectorValue UVector.!? (UVector.length (sivIndices vectorValue) - 1)+{-# INLINE sparseIxVecBounds #-}++sparseLinearMapSourceCount :: SparseLinearMap r -> Int+sparseLinearMapSourceCount linearMap =+  max 0 (UVector.length (slmOffsets linearMap) - 1)+{-# INLINE sparseLinearMapSourceCount #-}++boxedIndexInvariant :: BoxedVector.Vector a -> Int -> a+boxedIndexInvariant vector index =+  assert (index >= 0 && index < BoxedVector.length vector) $+    BoxedVector.unsafeIndex vector index+{-# INLINE boxedIndexInvariant #-}++unboxedIndexInvariant :: UVector.Unbox a => UVector.Vector a -> Int -> a+unboxedIndexInvariant vector index =+  assert (index >= 0 && index < UVector.length vector) $+    UVector.unsafeIndex vector index+{-# INLINE unboxedIndexInvariant #-}++normalize :: (Eq r, AdditiveMonoid r, Ord g) => SparseVec r g -> SparseVec r g+normalize = isoNormalize++lookupEntry :: (AdditiveMonoid r, Ord g) => g -> SparseVec r g -> r+lookupEntry basisElement (SparseVec entries) = Map.findWithDefault zero basisElement entries++extendLinear ::+  (Eq r, Ring r, Ord targetBasis) =>+  (sourceBasis -> SparseVec r targetBasis) ->+  SparseVec r sourceBasis ->+  SparseVec r targetBasis+extendLinear substituteBasis (SparseVec entries) =+  fromEntries+    ( foldMap+        scaledSubstitutionEntries+        (Map.toAscList entries)+    )+  where+    scaledSubstitutionEntries (basisElement, scalar) =+      fmap+        (\(targetBasis, targetCoefficient) -> (targetBasis, mul scalar targetCoefficient))+        (toEntries (substituteBasis basisElement))++normalizeEntry :: (Eq r, AdditiveMonoid r) => r -> Maybe r+normalizeEntry entryValue+  | entryValue == zero = Nothing+  | otherwise = Just entryValue++combineEntries ::+  (Eq r, AdditiveMonoid r) =>+  key ->+  r ->+  r ->+  Maybe r+combineEntries _key leftValue rightValue =+  normalizeEntry (add leftValue rightValue)++consolidateSortedIxEntries :: (Eq r, AdditiveMonoid r) => [(Int, r)] -> [(Int, r)]+consolidateSortedIxEntries =+  foldr combineEntry []+  where+    combineEntry ::+      (Eq r, AdditiveMonoid r) =>+      (Int, r) ->+      [(Int, r)] ->+      [(Int, r)]+    combineEntry (indexValue, coefficientValue) consolidatedEntries =+      case consolidatedEntries of+        (nextIndex, nextCoefficient) : rest+          | indexValue == nextIndex ->+              maybe rest (\combined -> (indexValue, combined) : rest) (normalizeEntry (add coefficientValue nextCoefficient))+        _ ->+          maybe consolidatedEntries (\nonZero -> (indexValue, nonZero) : consolidatedEntries) (normalizeEntry coefficientValue)+{-# INLINE consolidateSortedIxEntries #-}++sparseIxVecFromConsolidatedEntries :: [(Int, r)] -> SparseIxVec r+sparseIxVecFromConsolidatedEntries entries =+  SparseIxVec+    { sivIndices = UVector.fromList (fmap fst entries),+      sivValues = BoxedVector.fromList (fmap snd entries)+    }+{-# INLINE sparseIxVecFromConsolidatedEntries #-}++instance (Eq r, AdditiveMonoid r, Ord g) => IsoNorm (SparseVec r g) [(g, r)] where+  isoFrom = fromEntries+  isoTo = toEntries++instance (Eq r, AdditiveMonoid r, Ord g) => AdditiveMonoid (SparseVec r g) where+  zero = SparseVec Map.empty+  add (SparseVec left) (SparseVec right) =+    SparseVec (Map.mergeWithKey combineEntries id id left right)++instance (Eq r, AdditiveGroup r, Ord g) => AdditiveGroup (SparseVec r g) where+  neg (SparseVec entries) =+    SparseVec (Map.map neg entries)+  sub left right = add left (neg right)++instance (Eq r, Ring r, Ord g) => Module r (SparseVec r g) where+  scale scalar (SparseVec entries) =+    SparseVec (Map.mapMaybe (normalizeEntry . mul scalar) entries)++instance (Eq r, Ring r, Ord g) => FreeModule r (SparseVec r g) where+  type Basis r (SparseVec r g) = g+  support (SparseVec entries) = Map.keys entries+  coefficient = lookupEntry+  generator basisElement = fromEntries [(basisElement, one)]
+ src-abstract/Moonlight/Algebra/Pure/Zn.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE RoleAnnotations #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Integers modulo a type-level natural ('Zn'), carrying the additive group+-- and 'CommutativeRing' instances.+--+-- Laws: @Zn n@ is a commutative ring under arithmetic modulo @n@ (a field exactly+-- when @n@ is prime).+module Moonlight.Algebra.Pure.Zn+  ( Zn,+    mkZn,+    unZn,+    znModulus,+  )+where++import Data.Kind (Type)+import GHC.TypeNats (KnownNat, Nat, natVal, type (<=))+import Moonlight.Algebra.Pure.Ring (CommutativeRing, Semiring)+import Moonlight.Core+  ( AdditiveGroup (..),+    AdditiveMonoid (..),+    MultiplicativeMonoid (..),+    Ring,+  )+import Data.Proxy (Proxy (..))++type Zn :: Nat -> Type+type role Zn nominal+newtype Zn (n :: Nat) = Zn Integer+  deriving stock (Eq, Ord)++unZn :: Zn n -> Integer+unZn (Zn value) = value++znModulus :: forall n proxy. KnownNat n => proxy n -> Integer+znModulus _ = toInteger (natVal (Proxy @n))++mkZn :: forall n. (KnownNat n, 1 <= n) => Integer -> Zn n+mkZn value = Zn (value `mod` znModulus (Proxy @n))++instance (KnownNat n, 1 <= n) => Show (Zn n) where+  show value = show (unZn value) <> " (mod " <> show (znModulus (Proxy @n)) <> ")"++instance (KnownNat n, 1 <= n) => AdditiveMonoid (Zn n) where+  zero = mkZn @n 0+  add (Zn left) (Zn right) = mkZn @n (left + right)++instance (KnownNat n, 1 <= n) => AdditiveGroup (Zn n) where+  neg (Zn value) = mkZn @n (negate value)+  sub (Zn left) (Zn right) = mkZn @n (left - right)++instance (KnownNat n, 1 <= n) => MultiplicativeMonoid (Zn n) where+  one = mkZn @n 1+  mul (Zn left) (Zn right) = mkZn @n (left * right)++instance (KnownNat n, 1 <= n) => Ring (Zn n)++instance (KnownNat n, 1 <= n) => Semiring (Zn n)++instance (KnownNat n, 1 <= n) => CommutativeRing (Zn n)
+ src-finite-lattice/Moonlight/FiniteLattice.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice+  ( module Moonlight.FiniteLattice.Core,+    module Moonlight.FiniteLattice.Resident,+    module Moonlight.FiniteLattice.Cover,+    module Moonlight.FiniteLattice.Fixpoint,+    module Moonlight.FiniteLattice.Heyting,+    module Moonlight.FiniteLattice.Presentation,+    module Moonlight.FiniteLattice.Support,+  )+where++import Moonlight.FiniteLattice.Core+import Moonlight.FiniteLattice.Cover+import Moonlight.FiniteLattice.Fixpoint+import Moonlight.FiniteLattice.Heyting+import Moonlight.FiniteLattice.Presentation+import Moonlight.FiniteLattice.Resident+import Moonlight.FiniteLattice.Support
+ src-finite-lattice/Moonlight/FiniteLattice/Core.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE GHC2024 #-}++-- | The 'ContextLattice' carrier, built by checked compilation from a declared+-- finite order, and the value-level 'joinContext', 'meetContext', 'leqContext'+-- queries against it.+module Moonlight.FiniteLattice.Core+  ( ContextLattice,+    clTop,+    clBottom,+    ContextOrderDecl (..),+    ContextCompileLimits (..),+    defaultContextCompileLimits,+    unlimitedContextCompileLimits,+    ContextRepresentation (..),+    ContextLatticeCompileError (..),+    ContextLatticeLookupError (..),+    contextOrderDecl,+    compileContextLattice,+    compileContextLatticeWith,+    contextLatticeFromClosedOrder,+    contextLatticeFromClosedOrderWith,+    singletonContextLattice,+    latticeContext,+    orderedLatticeContext,+    contextLatticeSize,+    contextLatticeElements,+    contextMember,+    joinContext,+    meetContext,+    leqContext,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.FiniteLattice.Internal.Compile+  ( compileContextLattice,+    compileContextLatticeWith,+    contextLatticeFromClosedOrder,+    contextLatticeFromClosedOrderWith,+    singletonContextLattice,+  )+import Moonlight.FiniteLattice.Internal.Key (ContextKey)+import Moonlight.FiniteLattice.Internal.Plan+  ( contextPlanJoinKey,+    contextPlanLeq,+    contextPlanMeetKey,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextCompileLimits (..),+    ContextLatticeCompileError (..),+    ContextLatticeLookupError (..),+    ContextOrderDecl (..),+    ContextRepresentation (..),+    contextKeyForMaybe,+    contextValueForKey,+    defaultContextCompileLimits,+    unlimitedContextCompileLimits,+  )+import Moonlight.Algebra.Pure.Lattice+  ( BoundedJoinSemilattice (bottom),+    BoundedMeetSemilattice (top),+    JoinSemilattice (join),+    Lattice,+    MeetSemilattice (meet),+    OrderedLattice,+  )+import Moonlight.Core+  ( FiniteUniverse,+    finiteUniverseList,+    leq,+  )++contextOrderDecl ::+  Ord c =>+  c ->+  c ->+  [(c, c)] ->+  ContextOrderDecl c+contextOrderDecl topValue bottomValue generatingPairs =+  ContextOrderDecl+    { codTop = topValue,+      codBottom = bottomValue,+      codGeneratingPairs = Set.fromList generatingPairs+    }++contextLatticeSize :: ContextLattice c -> Int+contextLatticeSize = clSize+{-# INLINE contextLatticeSize #-}++contextLatticeElements :: ContextLattice c -> [c]+contextLatticeElements =+  Vector.toList . clContextsByKey++contextMember :: Ord c => ContextLattice c -> c -> Bool+contextMember lattice =+  (`Map.member` clKeyByContext lattice)++-- | Value-level boundary query; repeated validation is a performance tax, so descend once into 'Moonlight.FiniteLattice.Resident' for steady-state algebra.+joinContext ::+  Ord c =>+  ContextLattice c ->+  c ->+  c ->+  Either (ContextLatticeLookupError c) c+joinContext lattice leftContext rightContext = do+  leftKey <- lookupContextKey lattice leftContext+  rightKey <- lookupContextKey lattice rightContext+  let joinedKey = contextPlanJoinKey (clPlan lattice) leftKey rightKey+  pure+    ( contextValueForKey+        lattice+        joinedKey+    )++meetContext ::+  Ord c =>+  ContextLattice c ->+  c ->+  c ->+  Either (ContextLatticeLookupError c) c+meetContext lattice leftContext rightContext = do+  leftKey <- lookupContextKey lattice leftContext+  rightKey <- lookupContextKey lattice rightContext+  let metKey = contextPlanMeetKey (clPlan lattice) leftKey rightKey+  pure+    ( contextValueForKey+        lattice+        metKey+    )++leqContext ::+  Ord c =>+  ContextLattice c ->+  c ->+  c ->+  Either (ContextLatticeLookupError c) Bool+leqContext lattice leftContext rightContext = do+  leftKey <- lookupContextKey lattice leftContext+  rightKey <- lookupContextKey lattice rightContext+  pure (contextPlanLeq (clPlan lattice) leftKey rightKey)++lookupContextKey ::+  Ord c =>+  ContextLattice c ->+  c ->+  Either (ContextLatticeLookupError c) ContextKey+lookupContextKey lattice contextValue =+  maybe+    (Left (ContextLatticeUnknownContext contextValue))+    Right+    (contextKeyForMaybe lattice contextValue)++-- | Checked construction from the declared finite instances. This deliberately+-- returns 'Either': typeclass laws are promises, not runtime evidence.+latticeContext ::+  ( Ord c,+    Lattice c,+    BoundedJoinSemilattice c,+    BoundedMeetSemilattice c,+    Enum c,+    Bounded c+  ) =>+  Either (ContextLatticeCompileError c) (ContextLattice c)+latticeContext =+  contextLatticeFromClosedOrder+    top+    bottom+    [minBound .. maxBound]+    (\leftContext rightContext -> join leftContext rightContext == rightContext)+    join+    meet++orderedLatticeContext ::+  ( Ord c,+    OrderedLattice c,+    BoundedJoinSemilattice c,+    BoundedMeetSemilattice c,+    FiniteUniverse c+  ) =>+  Either (ContextLatticeCompileError c) (ContextLattice c)+orderedLatticeContext =+  contextLatticeFromClosedOrder+    top+    bottom+    finiteUniverseList+    leq+    join+    meet
+ src-finite-lattice/Moonlight/FiniteLattice/Cover.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Cover+  ( strictOrderPairs,+    coverPairs,+    upperCovers,+    lowerCovers,+    residentUpperCoverKeys,+    residentLowerCoverKeys,+  )+where++import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    contextKeySetToAscList,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( contextPlanLowerCoverKeys,+    contextPlanUpperCoverKeys,+    contextPlanUpperKeys,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextLatticeLookupError (..),+    ResidentContext (..),+    ResidentContextKey,+    ResidentContextKeySet (..),+    contextKeyForMaybe,+    contextKeyFromResidentKey,+    contextValueForKey,+  )++-- | Every strict comparable pair, oriented @(lower, upper)@.+strictOrderPairs :: ContextLattice c -> [(c, c)]+strictOrderPairs lattice =+  [ ( contextValueForKey lattice lowerKey,+      contextValueForKey lattice (ContextKey upperOrdinal)+    )+  | lowerOrdinal <- [0 .. clSize lattice - 1],+    let lowerKey = ContextKey lowerOrdinal,+    upperOrdinal <-+      contextKeySetToAscList+        (contextPlanUpperKeys (clPlan lattice) lowerKey),+    upperOrdinal /= lowerOrdinal+  ]++-- | Hasse edges, oriented @(lower, upper)@.+coverPairs :: ContextLattice c -> [(c, c)]+coverPairs lattice =+  [ ( contextValueForKey lattice lowerKey,+      contextValueForKey lattice (ContextKey upperOrdinal)+    )+  | lowerOrdinal <- [0 .. clSize lattice - 1],+    let lowerKey = ContextKey lowerOrdinal,+    upperOrdinal <-+      contextKeySetToAscList+        (contextPlanUpperCoverKeys (clPlan lattice) lowerKey)+  ]++upperCovers ::+  Ord c =>+  ContextLattice c ->+  c ->+  Either (ContextLatticeLookupError c) [c]+upperCovers lattice lower = do+  lowerKey <- lookupContextKey lattice lower+  let upperKeySet = contextPlanUpperCoverKeys (clPlan lattice) lowerKey+  pure+    [ contextValueForKey lattice (ContextKey upperOrdinal)+    | upperOrdinal <-+        contextKeySetToAscList+          upperKeySet+    ]++lowerCovers ::+  Ord c =>+  ContextLattice c ->+  c ->+  Either (ContextLatticeLookupError c) [c]+lowerCovers lattice upper = do+  upperKey <- lookupContextKey lattice upper+  let lowerKeySet = contextPlanLowerCoverKeys (clPlan lattice) upperKey+  pure+    [ contextValueForKey lattice (ContextKey lowerOrdinal)+    | lowerOrdinal <-+        contextKeySetToAscList+          lowerKeySet+    ]++residentUpperCoverKeys ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKeySet s+residentUpperCoverKeys (ResidentContext lattice) key =+  ResidentContextKeySet+    ( contextPlanUpperCoverKeys+        (clPlan lattice)+        (contextKeyFromResidentKey key)+    )++residentLowerCoverKeys ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKeySet s+residentLowerCoverKeys (ResidentContext lattice) key =+  ResidentContextKeySet+    ( contextPlanLowerCoverKeys+        (clPlan lattice)+        (contextKeyFromResidentKey key)+    )++lookupContextKey ::+  Ord c =>+  ContextLattice c ->+  c ->+  Either (ContextLatticeLookupError c) ContextKey+lookupContextKey lattice contextValue =+  maybe+    (Left (ContextLatticeUnknownContext contextValue))+    Right+    (contextKeyForMaybe lattice contextValue)
+ src-finite-lattice/Moonlight/FiniteLattice/Fixpoint.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++-- | Compiled monotone endomaps over a 'ContextLattice' and their least and+-- greatest fixed points.+module Moonlight.FiniteLattice.Fixpoint+  ( ResidentMonotoneMap,+    ContextMonotoneMapError (..),+    compileResidentMonotoneMap,+    compileResidentMonotoneKeyMap,+    leastResidentFixpoint,+    greatestResidentFixpoint,+    leastContextFixpoint,+    greatestContextFixpoint,+  )+where++import Data.Kind (Type)+import Data.Vector.Unboxed qualified as UVector+import Moonlight.FiniteLattice.Internal.Invariant+  ( unboxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    contextKeySetFind,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( contextPlanLeq,+    contextPlanMonotonicityTargets,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ResidentContext (..),+    ResidentContextElement,+    ResidentContextKey (..),+    contextKeyForMaybe,+    contextValueForKey,+    residentContextElementForKey,+    residentContextElementValue,+    residentKeyFromContextKey,+  )+import Moonlight.FiniteLattice.Resident+  ( withResidentContext,+  )++type ResidentMonotoneMap :: Type -> Type+newtype ResidentMonotoneMap s = ResidentMonotoneMap+  { residentMonotoneMapImage :: UVector.Vector Int+  }++type role ResidentMonotoneMap nominal++type ContextMonotoneMapError :: Type -> Type+data ContextMonotoneMapError c+  = ContextEndomapOutsideUniverse !c !c+  | ContextEndomapNotMonotone !c !c !c !c+  deriving stock (Eq, Ord, Show, Read)++type role ContextMonotoneMapError nominal++compileResidentMonotoneMap ::+  Ord c =>+  ResidentContext s c ->+  (c -> c) ->+  Either (ContextMonotoneMapError c) (ResidentMonotoneMap s)+compileResidentMonotoneMap (ResidentContext lattice) step = do+  image <-+    UVector.generateM+      (clSize lattice)+      (compileImageAt lattice step)+  validateMonotonicity lattice image+  pure (ResidentMonotoneMap image)++-- | Like 'compileResidentMonotoneMap', but closure is structural — branded keys+-- cannot leave the context — so only monotonicity is checked.+compileResidentMonotoneKeyMap ::+  ResidentContext s c ->+  (ResidentContextKey s -> ResidentContextKey s) ->+  Either (ContextMonotoneMapError c) (ResidentMonotoneMap s)+compileResidentMonotoneKeyMap (ResidentContext lattice) step =+  let image =+        UVector.generate+          (clSize lattice)+          ( \keyOrdinal ->+              residentContextKeyOrdinal+                (step (residentKeyFromContextKey (ContextKey keyOrdinal)))+          )+   in validateMonotonicity lattice image *> pure (ResidentMonotoneMap image)++compileImageAt ::+  Ord c =>+  ContextLattice c ->+  (c -> c) ->+  Int ->+  Either (ContextMonotoneMapError c) Int+compileImageAt lattice step keyOrdinal =+  let input = contextValueForKey lattice (ContextKey keyOrdinal)+      output = step input+   in case contextKeyForMaybe lattice output of+        Nothing ->+          Left (ContextEndomapOutsideUniverse input output)+        Just outputKey -> Right (contextKeyOrdinal outputKey)++validateMonotonicity ::+  ContextLattice c ->+  UVector.Vector Int ->+  Either (ContextMonotoneMapError c) ()+validateMonotonicity lattice image =+  checkLower 0+  where+    checkLower !lowerOrdinal+      | lowerOrdinal >= clSize lattice = Right ()+      | otherwise = do+          let targets =+                contextPlanMonotonicityTargets (clPlan lattice) (ContextKey lowerOrdinal)+          case contextKeySetFind (violates lowerOrdinal) targets of+            Nothing -> checkLower (lowerOrdinal + 1)+            Just upperOrdinal ->+              let lowerKey = ContextKey lowerOrdinal+                  upperKey = ContextKey upperOrdinal+                  lowerImageKey = imageKey image lowerKey+                  upperImageKey = imageKey image upperKey+               in Left+                    ( ContextEndomapNotMonotone+                        (contextValueForKey lattice lowerKey)+                        (contextValueForKey lattice upperKey)+                        (contextValueForKey lattice lowerImageKey)+                        (contextValueForKey lattice upperImageKey)+                    )++    violates lowerOrdinal upperOrdinal =+      not+        ( contextPlanLeq+            (clPlan lattice)+            (imageKey image (ContextKey lowerOrdinal))+            (imageKey image (ContextKey upperOrdinal))+        )++-- | Least fixed point of a compiled monotone endomap.+--+-- The orbit from bottom is ascending (bottom <= x1; and @xn <= x(n+1)@ gives+-- @f xn <= f x(n+1)@ by monotonicity), so finiteness forces stabilization;+-- induction gives @xn <= p@ for every fixed point @p@, so it is the least.+leastResidentFixpoint ::+  ResidentContext s c ->+  ResidentMonotoneMap s ->+  ResidentContextElement s c+leastResidentFixpoint context@(ResidentContext lattice) monotoneMap =+  residentContextElementForKey+    context+    (residentKeyFromContextKey (iterateToFixpoint monotoneMap (clBottomKey lattice)))++-- | Greatest fixed point; the order-dual proof starts from top.+greatestResidentFixpoint ::+  ResidentContext s c ->+  ResidentMonotoneMap s ->+  ResidentContextElement s c+greatestResidentFixpoint context@(ResidentContext lattice) monotoneMap =+  residentContextElementForKey+    context+    (residentKeyFromContextKey (iterateToFixpoint monotoneMap (clTopKey lattice)))++leastContextFixpoint ::+  Ord c =>+  ContextLattice c ->+  (c -> c) ->+  Either (ContextMonotoneMapError c) c+leastContextFixpoint lattice step =+  withResidentContext lattice $ \context -> do+    monotoneMap <- compileResidentMonotoneMap context step+    pure+      (residentContextElementValue (leastResidentFixpoint context monotoneMap))++greatestContextFixpoint ::+  Ord c =>+  ContextLattice c ->+  (c -> c) ->+  Either (ContextMonotoneMapError c) c+greatestContextFixpoint lattice step =+  withResidentContext lattice $ \context -> do+    monotoneMap <- compileResidentMonotoneMap context step+    pure+      (residentContextElementValue (greatestResidentFixpoint context monotoneMap))++iterateToFixpoint :: ResidentMonotoneMap s -> ContextKey -> ContextKey+iterateToFixpoint monotoneMap =+  go+  where+    go !currentKey =+      let nextKey = imageKey (residentMonotoneMapImage monotoneMap) currentKey+       in if nextKey == currentKey+            then currentKey+            else go nextKey++imageKey :: UVector.Vector Int -> ContextKey -> ContextKey+imageKey image (ContextKey keyOrdinal) =+  ContextKey (unboxedIndexInvariant image keyOrdinal)+{-# INLINE imageKey #-}
+ src-finite-lattice/Moonlight/FiniteLattice/Heyting.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++-- | Heyting implication over compiled finite context lattices: the relative+-- pseudocomplement as a precompiled query, with resident-key variants.+module Moonlight.FiniteLattice.Heyting+  ( ContextHeyting,+    contextHeytingLattice,+    ContextHeytingCompileError (..),+    compileContextHeyting,+    impliesContext,+    ResidentHeytingContext,+    residentHeytingBaseContext,+    withResidentHeytingContext,+    residentImpliesKey,+    residentImplies,+  )+where++import Data.Bits+  ( (.&.),+    (.|.),+    complement,+  )+import Data.Foldable (asum)+import Data.Kind (Type)+import Moonlight.FiniteLattice.Internal.Distributive+  ( ContextDistributivePlan,+    distributivePlanFromDenseComponents,+    distributiveResidualKey,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    contextKeySetAll,+    contextKeySetChunkCount,+    contextKeySetDifference,+    contextKeySetFind,+    contextKeySetFoldr,+    contextKeySetUnionImages,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( ContextBooleanPlan (..),+    ContextBoundedFanPlan (..),+    ContextDenseTablePlan (..),+    ContextMaskPlan (..),+    ContextPlan (..),+    ContextTotalOrderPlan (..),+    booleanKeyForMask,+    booleanMaskForKey,+    contextPlanJoinKey,+    contextPlanLeq,+    contextPlanLowerKeys,+    contextPlanMeetKey,+    contextPlanUpperKeys,+    totalOrderKeyRank,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextLatticeLookupError (..),+    ResidentContext (..),+    ResidentContextElement (..),+    ResidentContextKey,+    contextKeyForMaybe,+    contextKeyFromResidentKey,+    contextValueForKey,+    residentContextElementForKey,+    residentKeyFromContextKey,+  )++type ContextHeyting :: Type -> Type+data ContextHeyting c = ContextHeyting !(ContextLattice c) !ContextResidualPlan++type role ContextHeyting nominal++contextHeytingLattice :: ContextHeyting c -> ContextLattice c+contextHeytingLattice (ContextHeyting lattice _) =+  lattice+{-# INLINE contextHeytingLattice #-}++type ContextResidualPlan :: Type+data ContextResidualPlan+  = LazyDenseResidualPlan !ContextKeySet !Int+  | BirkhoffResidualPlan !ContextDistributivePlan+  | OrdinalTotalOrderResidualPlan !Int+  | TotalOrderResidualPlan !ContextTotalOrderPlan+  | BooleanResidualPlan !ContextBooleanPlan++type ContextHeytingCompileError :: Type -> Type+data ContextHeytingCompileError c+  -- | Antecedent, consequent, and the join of every candidate+  -- @x@ satisfying @antecedent ∧ x <= consequent@. The join is not itself a+  -- candidate, which proves that no greatest candidate exists.+  = ContextResidualDoesNotExist !c !c !c+  deriving stock (Eq, Ord, Show, Read)++type role ContextHeytingCompileError nominal++compileContextHeyting ::+  ContextLattice c ->+  Either (ContextHeytingCompileError c) (ContextHeyting c)+compileContextHeyting lattice =+  ContextHeyting lattice <$> compileResidualPlan lattice++compileResidualPlan ::+  ContextLattice c ->+  Either (ContextHeytingCompileError c) ContextResidualPlan+compileResidualPlan lattice =+  case clPlan lattice of+    OrdinalTotalOrderPlan size ->+      Right (OrdinalTotalOrderResidualPlan size)+    TotalOrderPlan plan ->+      Right (TotalOrderResidualPlan plan)+    MaskPlan (BooleanPlan plan) ->+      Right (BooleanResidualPlan plan)+    MaskPlan (DistributivePlan distributivePlan) ->+      Right (BirkhoffResidualPlan distributivePlan)+    MaskPlan (DenseRowsPlan _) ->+      validateDenseResidual lattice+    OrdinalBoundedFanPlan size ->+      rejectNonHeytingOrdinalFan lattice size+    BoundedFanPlan plan ->+      rejectNonHeytingFan lattice plan+    DensePlan tablePlan ->+      maybe+        (validateDenseResidual lattice)+        (Right . BirkhoffResidualPlan)+        ( distributivePlanFromDenseComponents+            (cdtpSize tablePlan)+            (clTopKey lattice)+            (clBottomKey lattice)+            (cdtpUpperRows tablePlan)+            (cdtpLowerRows tablePlan)+            (cdtpJoinTable tablePlan)+            (cdtpMeetTable tablePlan)+        )++-- In a fan with at least three atoms, choose an atom a and b = bottom. Every+-- other atom is a candidate for a => b; the join of two such atoms is top, but+-- a ∧ top = a is not <= bottom. Therefore the residual does not exist.+rejectNonHeytingFan ::+  ContextLattice c ->+  ContextBoundedFanPlan ->+  Either (ContextHeytingCompileError c) ContextResidualPlan+rejectNonHeytingFan lattice plan =+  case contextKeySetFind (const True) (cbfAtomKeys plan) of+    Nothing -> validateDenseResidual lattice+    Just atomOrdinal ->+      Left+        ( ContextResidualDoesNotExist+            (contextValueForKey lattice (ContextKey atomOrdinal))+            (contextValueForKey lattice (cbfBottomKey plan))+            (contextValueForKey lattice (cbfTopKey plan))+        )++rejectNonHeytingOrdinalFan ::+  ContextLattice c ->+  Int ->+  Either (ContextHeytingCompileError c) ContextResidualPlan+rejectNonHeytingOrdinalFan lattice size =+  Left+    ( ContextResidualDoesNotExist+        (contextValueForKey lattice (ContextKey 1))+        (contextValueForKey lattice (ContextKey 0))+        (contextValueForKey lattice (ContextKey (size - 1)))+    )++validateDenseResidual ::+  ContextLattice c ->+  Either (ContextHeytingCompileError c) ContextResidualPlan+validateDenseResidual lattice =+  case asum (residualObstruction <$> residualPairs) of+    Just obstruction -> Left obstruction+    Nothing -> Right (LazyDenseResidualPlan allKeys chunkCount)+  where+    size = clSize lattice+    chunkCount = contextKeySetChunkCount size+    allKeys = contextKeySetAll size+    plan = clPlan lattice+    residualPairs =+      [ (ContextKey antecedentOrdinal, ContextKey consequentOrdinal)+      | antecedentOrdinal <- [0 .. size - 1],+        consequentOrdinal <- [0 .. size - 1]+      ]++    residualObstruction (antecedentKey, consequentKey) =+      let candidateJoin =+            residualCandidateJoin allKeys chunkCount lattice antecedentKey consequentKey+          candidateMeet = contextPlanMeetKey plan antecedentKey candidateJoin+       in if contextPlanLeq plan candidateMeet consequentKey+            then Nothing+            else+              Just+                ( ContextResidualDoesNotExist+                    (contextValueForKey lattice antecedentKey)+                    (contextValueForKey lattice consequentKey)+                    (contextValueForKey lattice candidateJoin)+                )++-- C = {x | a ∧ x <= b}, r = join C. Bottom ∈ C, so C is nonempty; the residual+-- exists iff r ∈ C, where it is then the greatest member. Candidates avoid+-- recomputing meets: a ∧ x <= b iff lower(a) ∩ lower(x) ⊆ lower(b) iff x is+-- above no y ∈ lower(a) \\ lower(b). So C is all keys minus the upward closure+-- of those forbidden lower keys.+residualCandidateJoin ::+  ContextKeySet ->+  Int ->+  ContextLattice c ->+  ContextKey ->+  ContextKey ->+  ContextKey+residualCandidateJoin allKeys chunkCount lattice antecedentKey consequentKey =+  contextKeySetFoldr joinCandidate (clBottomKey lattice) candidateKeys+  where+    plan = clPlan lattice+    candidateKeys =+      residualCandidateKeys allKeys chunkCount lattice antecedentKey consequentKey++    joinCandidate !candidateOrdinal !candidateJoin =+      contextPlanJoinKey plan candidateJoin (ContextKey candidateOrdinal)++residualCandidateKeys ::+  ContextKeySet ->+  Int ->+  ContextLattice c ->+  ContextKey ->+  ContextKey ->+  ContextKeySet+residualCandidateKeys allKeys chunkCount lattice antecedentKey consequentKey =+  contextKeySetDifference allKeys rejectedKeys+  where+    plan = clPlan lattice+    forbiddenLowerKeys =+      contextKeySetDifference+        (contextPlanLowerKeys plan antecedentKey)+        (contextPlanLowerKeys plan consequentKey)+    rejectedKeys =+      contextKeySetUnionImages+        chunkCount+        (contextPlanUpperKeys plan . ContextKey)+        forbiddenLowerKeys++impliesContext ::+  Ord c =>+  ContextHeyting c ->+  c ->+  c ->+  Either (ContextLatticeLookupError c) c+impliesContext (ContextHeyting lattice residualPlan) antecedent consequent = do+  antecedentKey <- lookupContextKey lattice antecedent+  consequentKey <- lookupContextKey lattice consequent+  pure+    ( contextValueForKey+        lattice+        (residualKey lattice residualPlan antecedentKey consequentKey)+    )++lookupContextKey ::+  Ord c =>+  ContextLattice c ->+  c ->+  Either (ContextLatticeLookupError c) ContextKey+lookupContextKey lattice contextValue =+  maybe+    (Left (ContextLatticeUnknownContext contextValue))+    Right+    (contextKeyForMaybe lattice contextValue)++type ResidentHeytingContext :: Type -> Type -> Type+data ResidentHeytingContext s c = ResidentHeytingContext+  { residentHeytingBaseContext :: !(ResidentContext s c),+    residentHeytingResidualPlan :: !ContextResidualPlan+  }++type role ResidentHeytingContext nominal nominal++withResidentHeytingContext ::+  ContextHeyting c ->+  (forall s. ResidentHeytingContext s c -> result) ->+  result+withResidentHeytingContext (ContextHeyting lattice residualPlan) continuation =+  continuation+    ResidentHeytingContext+      { residentHeytingBaseContext = ResidentContext lattice,+        residentHeytingResidualPlan = residualPlan+      }++residentImpliesKey ::+  ResidentHeytingContext s c ->+  ResidentContextKey s ->+  ResidentContextKey s ->+  ResidentContextKey s+residentImpliesKey context antecedentKey consequentKey =+  case residentHeytingBaseContext context of+    ResidentContext lattice ->+      residentKeyFromContextKey+        ( residualKey+            lattice+            (residentHeytingResidualPlan context)+            (contextKeyFromResidentKey antecedentKey)+            (contextKeyFromResidentKey consequentKey)+        )+{-# INLINE residentImpliesKey #-}++residentImplies ::+  ResidentHeytingContext s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c+residentImplies context antecedent consequent =+  residentContextElementForKey+    (residentHeytingBaseContext context)+    ( residentImpliesKey+        context+        (residentContextElementKey antecedent)+        (residentContextElementKey consequent)+    )++residualKey ::+  ContextLattice c ->+  ContextResidualPlan ->+  ContextKey ->+  ContextKey ->+  ContextKey+residualKey lattice residualPlan antecedentKey consequentKey =+  case residualPlan of+    LazyDenseResidualPlan allKeys chunkCount ->+      residualCandidateJoin allKeys chunkCount lattice antecedentKey consequentKey+    BirkhoffResidualPlan plan ->+      distributiveResidualKey plan antecedentKey consequentKey+    OrdinalTotalOrderResidualPlan size ->+      if contextKeyOrdinal antecedentKey <= contextKeyOrdinal consequentKey+            then ContextKey (size - 1)+            else consequentKey+    TotalOrderResidualPlan plan ->+      if+            totalOrderKeyRank plan antecedentKey+              <= totalOrderKeyRank plan consequentKey+            then ctoTopKey plan+            else consequentKey+    BooleanResidualPlan plan ->+      booleanKeyForMask+            plan+            ( (complement (booleanMaskForKey plan antecedentKey) .&. cboFullMask plan)+                .|. booleanMaskForKey plan consequentKey+            )+{-# INLINE residualKey #-}
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Compile.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Compile+  ( compileContextLattice,+    compileContextLatticeWith,+    contextLatticeFromClosedOrder,+    contextLatticeFromClosedOrderWith,+    singletonContextLattice,+  )+where++import Control.Monad (unless, when)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Data.Vector.Unboxed qualified as UVector+import Moonlight.FiniteLattice.Internal.Dense+  ( compileDensePlan,+  )+import Moonlight.FiniteLattice.Internal.Index+  ( ContextIndex (..),+    contextIndexFromUniverse,+    contextIndexValueForKey,+    contextLatticeFromPlan,+    encodeRelationKeyPairs,+    firstDuplicate,+    lookupCompileKey,+    reflexiveKeyPairs,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+  )+import Moonlight.FiniteLattice.Internal.Layout+  ( checkedRelationWordCount,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( ContextPlan (..),+    ContextTotalOrderPlan (..),+  )+import Moonlight.FiniteLattice.Internal.Recognize+  ( specializedContextPlanFromDeclaredPairs,+    specializedContextPlanFromRows,+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( lowerRowsFromUpperRows,+    relationRowsFromKeyPairs,+    relationRowsGenerate,+    transitiveClosureRows,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextCompileLimits,+    ContextLatticeCompileError (..),+    ContextOrderDecl (..),+    defaultContextCompileLimits,+  )+import Moonlight.FiniteLattice.Internal.Validate+  ( validateAntisymmetryRows,+    validateBottomLeastRows,+    validateClosedOrderRows,+    validateDeclaredUniverse,+    validateSuppliedOperations,+    validateTopGreatestRows,+  )++compileContextLattice ::+  Ord c =>+  Set c ->+  ContextOrderDecl c ->+  Either (ContextLatticeCompileError c) (ContextLattice c)+compileContextLattice =+  compileContextLatticeWith defaultContextCompileLimits++compileContextLatticeWith ::+  Ord c =>+  ContextCompileLimits ->+  Set c ->+  ContextOrderDecl c ->+  Either (ContextLatticeCompileError c) (ContextLattice c)+compileContextLatticeWith limits universe declaration = do+  validateDeclaredUniverse universe declaration+  index <- contextIndexFromUniverse universe+  declaredPairs <-+    encodeRelationKeyPairs index (codGeneratingPairs declaration)+  topKey <-+    lookupCompileKey+      index+      (codTop declaration)+      (ContextLatticeUnknownTop (codTop declaration))+  bottomKey <-+    lookupCompileKey+      index+      (codBottom declaration)+      (ContextLatticeUnknownBottom (codBottom declaration))+  plan <-+    case+      specializedContextPlanFromDeclaredPairs+        (ciSize index)+        topKey+        bottomKey+        declaredPairs+      of+      Just specializedPlan -> Right specializedPlan+      Nothing -> do+        _ <- checkedRelationWordCount limits (ciSize index)+        let initialUpperRows =+              relationRowsFromKeyPairs+                (ciSize index)+                (reflexiveKeyPairs index <> declaredPairs)+            upperRows = transitiveClosureRows initialUpperRows+        validateAntisymmetryRows index upperRows+        validateTopGreatestRows index upperRows topKey+        validateBottomLeastRows index upperRows bottomKey+        let lowerRows = lowerRowsFromUpperRows upperRows+        case+          specializedContextPlanFromRows+            (ciSize index)+            topKey+            bottomKey+            upperRows+            lowerRows+          of+          Just specializedPlan -> Right specializedPlan+          Nothing -> compileDensePlan limits index topKey bottomKey upperRows lowerRows+  pure+    ( contextLatticeFromPlan+        (codTop declaration)+        (codBottom declaration)+        topKey+        bottomKey+        index+        plan+    )++contextLatticeFromClosedOrder ::+  Ord c =>+  c ->+  c ->+  [c] ->+  (c -> c -> Bool) ->+  (c -> c -> c) ->+  (c -> c -> c) ->+  Either (ContextLatticeCompileError c) (ContextLattice c)+contextLatticeFromClosedOrder =+  contextLatticeFromClosedOrderWith defaultContextCompileLimits++contextLatticeFromClosedOrderWith ::+  Ord c =>+  ContextCompileLimits ->+  c ->+  c ->+  [c] ->+  (c -> c -> Bool) ->+  (c -> c -> c) ->+  (c -> c -> c) ->+  Either (ContextLatticeCompileError c) (ContextLattice c)+contextLatticeFromClosedOrderWith limits topValue bottomValue objects leqFn joinFn meetFn = do+  case firstDuplicate objects of+    Just duplicate -> Left (ContextLatticeDuplicateElement duplicate)+    Nothing -> Right ()+  when (null objects) (Left ContextLatticeEmptyUniverse)+  let universe = Set.fromList objects+  index <- contextIndexFromUniverse universe+  let size = ciSize index+  unless (Set.member topValue universe) (Left (ContextLatticeUnknownTop topValue))+  unless (Set.member bottomValue universe) (Left (ContextLatticeUnknownBottom bottomValue))+  _ <- checkedRelationWordCount limits size+  topKey <-+    lookupCompileKey+      index+      topValue+      (ContextLatticeUnknownTop topValue)+  bottomKey <-+    lookupCompileKey+      index+      bottomValue+      (ContextLatticeUnknownBottom bottomValue)+  let upperRows =+        relationRowsGenerate size $ \leftOrdinal rightOrdinal ->+          leqFn+            (contextIndexValueForKey index (ContextKey leftOrdinal))+            (contextIndexValueForKey index (ContextKey rightOrdinal))+  validateClosedOrderRows index upperRows topKey bottomKey+  let lowerRows = lowerRowsFromUpperRows upperRows+  plan <-+    case+      specializedContextPlanFromRows+        size+        topKey+        bottomKey+        upperRows+        lowerRows+      of+      Just specializedPlan -> Right specializedPlan+      Nothing -> compileDensePlan limits index topKey bottomKey upperRows lowerRows+  validateSuppliedOperations index plan joinFn meetFn+  pure+    ( contextLatticeFromPlan+        topValue+        bottomValue+        topKey+        bottomKey+        index+        plan+    )++singletonContextLattice :: c -> ContextLattice c+singletonContextLattice contextValue =+  ContextLattice+    { clTop = contextValue,+      clBottom = contextValue,+      clTopKey = singletonKey,+      clBottomKey = singletonKey,+      clContextsByKey = Vector.singleton contextValue,+      clKeyByContext = Map.singleton contextValue singletonKey,+      clPlan =+        TotalOrderPlan+          ContextTotalOrderPlan+            { ctoTopKey = singletonKey,+              ctoRankByKey = UVector.singleton 0,+              ctoKeyByRank = UVector.singleton 0+            },+      clSize = 1+    }+  where+    singletonKey = ContextKey 0
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Dense.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Dense+  ( compileDensePlan,+  )+where++import Moonlight.FiniteLattice.Internal.Distributive+  ( ContextDistributiveRowsResult (..),+    distributivePlanFromRows,+  )+import Moonlight.FiniteLattice.Internal.Index+  ( ContextIndex (..),+    contextIndexValueForKey,+    decodeIndexKeys,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    ContextKeyTable,+    contextKeySetToAscList,+    contextKeyTableGenerateM,+  )+import Moonlight.FiniteLattice.Internal.Layout+  ( checkedPairCellCount,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( ContextDenseRowsPlan (..),+    ContextDenseTablePlan (..),+    ContextMaskPlan (..),+    ContextPlan (..),+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( ContextRowIndex,+    ContextRows,+    contextRowIndexFromRows,+    rowJoinCandidateKeys,+    rowJoinKeyMaybe,+    rowMeetCandidateKeys,+    rowMeetKeyMaybe,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextCompileLimits,+    ContextLatticeCompileError (..),+  )++compileDensePlan ::+  Ord c =>+  ContextCompileLimits ->+  ContextIndex c ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Either (ContextLatticeCompileError c) ContextPlan+compileDensePlan limits index topKey bottomKey upperRows lowerRows =+  case checkedPairCellCount limits (ciSize index) of+    Just pairCellCount -> do+      (joinTable, meetTable) <-+        compileDenseLatticeTables+          index+          pairCellCount+          upperRows+          lowerRows+          upperRowIndex+          lowerRowIndex+      pure+        ( DensePlan+            ContextDenseTablePlan+              { cdtpSize = ciSize index,+                cdtpUpperRows = upperRows,+                cdtpLowerRows = lowerRows,+                cdtpJoinTable = joinTable,+                cdtpMeetTable = meetTable+              }+        )+    Nothing ->+      case+        distributivePlanFromRows+          (ciSize index)+          topKey+          bottomKey+          upperRows+          lowerRows+          upperRowIndex+          lowerRowIndex+        of+        ContextRowJoinAbsent leftKey rightKey candidates ->+          Left+            ( ContextLatticeJoinDoesNotExist+                (contextIndexValueForKey index leftKey)+                (contextIndexValueForKey index rightKey)+                (decodeIndexKeys index candidates)+            )+        ContextRowMeetAbsent leftKey rightKey candidates ->+          Left+            ( ContextLatticeMeetDoesNotExist+                (contextIndexValueForKey index leftKey)+                (contextIndexValueForKey index rightKey)+                (decodeIndexKeys index candidates)+            )+        ContextDenseRowsValidated ->+          Right (denseRowsPlan upperRows lowerRows upperRowIndex lowerRowIndex)+        ContextDistributiveRowsPlan distributivePlan ->+          Right (MaskPlan (DistributivePlan distributivePlan))+  where+    upperRowIndex = contextRowIndexFromRows upperRows+    lowerRowIndex = contextRowIndexFromRows lowerRows++denseRowsPlan ::+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextRowIndex ->+  ContextPlan+denseRowsPlan upperRows lowerRows upperRowIndex lowerRowIndex =+  MaskPlan+    ( DenseRowsPlan+        ContextDenseRowsPlan+          { cdrpUpperRows = upperRows,+            cdrpLowerRows = lowerRows,+            cdrpUpperRowIndex = upperRowIndex,+            cdrpLowerRowIndex = lowerRowIndex+          }+    )++compileDenseLatticeTables ::+  Ord c =>+  ContextIndex c ->+  Int ->+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextRowIndex ->+  Either+    (ContextLatticeCompileError c)+    (ContextKeyTable, ContextKeyTable)+compileDenseLatticeTables index pairCellCount upperRows lowerRows upperRowIndex lowerRowIndex = do+  joinTable <-+    contextKeyTableGenerateM size pairCellCount $ \offset ->+      let (leftOrdinal, rightOrdinal) = offset `quotRem` size+       in leastUpperBoundKey+            index+            upperRows+            lowerRows+            upperRowIndex+            (ContextKey leftOrdinal)+            (ContextKey rightOrdinal)+  meetTable <-+    contextKeyTableGenerateM size pairCellCount $ \offset ->+      let (leftOrdinal, rightOrdinal) = offset `quotRem` size+       in greatestLowerBoundKey+            index+            upperRows+            lowerRows+            lowerRowIndex+            (ContextKey leftOrdinal)+            (ContextKey rightOrdinal)+  pure (joinTable, meetTable)+  where+    size = ciSize index++leastUpperBoundKey ::+  Ord c =>+  ContextIndex c ->+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextKey ->+  ContextKey ->+  Either (ContextLatticeCompileError c) ContextKey+leastUpperBoundKey index upperRows lowerRows upperRowIndex leftKey rightKey =+  case rowJoinKeyMaybe upperRows lowerRows upperRowIndex leftKey rightKey of+    Just joinKey -> Right joinKey+    Nothing ->+      selectUniqueJoinKey+        index+        leftKey+        rightKey+        (rowJoinCandidateKeys upperRows lowerRows leftKey rightKey)++greatestLowerBoundKey ::+  Ord c =>+  ContextIndex c ->+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextKey ->+  ContextKey ->+  Either (ContextLatticeCompileError c) ContextKey+greatestLowerBoundKey index upperRows lowerRows lowerRowIndex leftKey rightKey =+  case rowMeetKeyMaybe upperRows lowerRows lowerRowIndex leftKey rightKey of+    Just meetKey -> Right meetKey+    Nothing ->+      selectUniqueMeetKey+        index+        leftKey+        rightKey+        (rowMeetCandidateKeys upperRows lowerRows leftKey rightKey)++selectUniqueJoinKey ::+  Ord c =>+  ContextIndex c ->+  ContextKey ->+  ContextKey ->+  ContextKeySet ->+  Either (ContextLatticeCompileError c) ContextKey+selectUniqueJoinKey index leftKey rightKey candidates =+  case contextKeySetToAscList candidates of+    [keyOrdinal] -> Right (ContextKey keyOrdinal)+    _ ->+      Left+        ( ContextLatticeJoinDoesNotExist+            (contextIndexValueForKey index leftKey)+            (contextIndexValueForKey index rightKey)+            (decodeIndexKeys index candidates)+        )++selectUniqueMeetKey ::+  Ord c =>+  ContextIndex c ->+  ContextKey ->+  ContextKey ->+  ContextKeySet ->+  Either (ContextLatticeCompileError c) ContextKey+selectUniqueMeetKey index leftKey rightKey candidates =+  case contextKeySetToAscList candidates of+    [keyOrdinal] -> Right (ContextKey keyOrdinal)+    _ ->+      Left+        ( ContextLatticeMeetDoesNotExist+            (contextIndexValueForKey index leftKey)+            (contextIndexValueForKey index rightKey)+            (decodeIndexKeys index candidates)+        )
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Distributive.hs view
@@ -0,0 +1,647 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Distributive+  ( ContextDistributivePlan (..),+    ContextDistributiveRowsResult (..),+    distributivePlanFromRows,+    distributivePlanFromDenseComponents,+    distributiveKeyLeq,+    distributiveJoinKey,+    distributiveMeetKey,+    distributiveJoinMeetKeys,+    distributiveUpperKeys,+    distributiveLowerKeys,+    distributiveUpperCoverKeys,+    distributiveLowerCoverKeys,+    distributiveResidualKey,+  )+where++import Data.Bits+  ( (.&.),+    (.|.),+    bit,+    complement,+    countTrailingZeros,+  )+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.FiniteLattice.Internal.Invariant+  ( ContextPlanInvariantError (..),+    invariantLookup,+    unboxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    ContextKeyTable,+    contextKeySetCardinality,+    contextKeySetDelete,+    contextKeySetFilter,+    contextKeySetFromKeys,+    contextKeySetIntersectsExcept,+    contextKeyTableLookup,+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( ContextRowIndex,+    ContextRows,+    contextKeyRelated,+    rowForRawKey,+    rowJoinCandidateKeys,+    rowJoinKeyMaybe,+    rowMeetCandidateKeys,+    rowMeetKeyMaybe,+  )++-- | A Birkhoff representation of a finite distributive lattice. Each element+-- is encoded as the downset of join-irreducible elements below it. Masks are+-- indexed by join-irreducible position, not by context-key ordinal.+data ContextDistributivePlan = ContextDistributivePlan+  { cdipSize :: !Int,+    cdipTopKey :: !ContextKey,+    cdipJoinIrreducibleKeyByIndex :: !(UVector.Vector Int),+    cdipMaskByKey :: !JoinIrreducibleMaskRows,+    cdipKeyByMask :: !(Map JoinIrreducibleMaskSignature ContextKey),+    cdipUpClosureByJoinIrreducible :: !JoinIrreducibleMaskRows,+    cdipFullMask :: !JoinIrreducibleMask+  }++data JoinIrreducibleMask = JoinIrreducibleMask !(UVector.Vector Word64)+  deriving stock (Eq, Show)++data JoinIrreducibleMaskRows = JoinIrreducibleMaskRows+  { jimrChunkCount :: !Int,+    jimrChunks :: !(UVector.Vector Word64)+  }+  deriving stock (Eq, Show)++data JoinIrreducibleMaskSignature+  = JoinIrreducibleMaskSignature0+  | JoinIrreducibleMaskSignature1 !Word64+  | JoinIrreducibleMaskSignature2 !Word64 !Word64+  | JoinIrreducibleMaskSignatureN ![Word64]+  deriving stock (Eq, Ord, Show)++data ContextDistributiveRowsResult+  = ContextDistributiveRowsPlan !ContextDistributivePlan+  | ContextDenseRowsValidated+  | ContextRowJoinAbsent !ContextKey !ContextKey !ContextKeySet+  | ContextRowMeetAbsent !ContextKey !ContextKey !ContextKeySet++distributivePlanFromRows ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextRowIndex ->+  ContextDistributiveRowsResult+distributivePlanFromRows size topKey bottomKey upperRows lowerRows upperRowIndex lowerRowIndex =+  validateRowOperationsAgainstMasks+    size+    upperRows+    lowerRows+    upperRowIndex+    lowerRowIndex+    candidatePlan+  where+    candidatePlan =+      distributivePlanCandidate+        size+        topKey+        bottomKey+        upperRows+        lowerRows++distributivePlanFromDenseComponents ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  ContextKeyTable ->+  ContextKeyTable ->+  Maybe ContextDistributivePlan+distributivePlanFromDenseComponents size topKey bottomKey upperRows lowerRows joinTable meetTable =+  candidatePlan >>= \plan ->+    if+      tableOperationsMatchMasks+        size+        joinTable+        meetTable+        (cdipMaskByKey plan)+        (cdipKeyByMask plan)+      then Just plan+      else Nothing+  where+    candidatePlan =+      distributivePlanCandidate+        size+        topKey+        bottomKey+        upperRows+        lowerRows++distributivePlanCandidate ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Maybe ContextDistributivePlan+distributivePlanCandidate size topKey bottomKey upperRows lowerRows = do+  guardMaybe (size > 0)+  let joinIrreducibleKeys = joinIrreducibleKeyOrdinals bottomKey size upperRows lowerRows+      joinIrreducibleCount = UVector.length joinIrreducibleKeys+      maskByKey = maskRowsForKeys size joinIrreducibleKeys upperRows+      fullMask = maskFull joinIrreducibleCount+      maskEntries =+        [ ( maskSignature (maskRowsRow maskByKey keyOrdinal),+            ContextKey keyOrdinal+          )+        | keyOrdinal <- [0 .. size - 1]+        ]+      keyByMask = Map.fromList maskEntries+  guardMaybe (Map.size keyByMask == size)+  guardMaybe (maskRowsRow maskByKey (contextKeyOrdinal bottomKey) == maskEmpty joinIrreducibleCount)+  guardMaybe (maskRowsRow maskByKey (contextKeyOrdinal topKey) == fullMask)+  let upClosureByJoinIrreducible =+        upClosureRowsForJoinIrreducibles joinIrreducibleKeys upperRows+  pure+    ContextDistributivePlan+      { cdipSize = size,+        cdipTopKey = topKey,+        cdipJoinIrreducibleKeyByIndex = joinIrreducibleKeys,+        cdipMaskByKey = maskByKey,+        cdipKeyByMask = keyByMask,+        cdipUpClosureByJoinIrreducible = upClosureByJoinIrreducible,+        cdipFullMask = fullMask+      }++distributiveKeyLeq :: ContextDistributivePlan -> ContextKey -> ContextKey -> Bool+distributiveKeyLeq plan leftKey rightKey =+  maskIsSubsetOf+    (distributiveMaskForKey plan leftKey)+    (distributiveMaskForKey plan rightKey)+{-# INLINE distributiveKeyLeq #-}++distributiveJoinKey :: ContextDistributivePlan -> ContextKey -> ContextKey -> ContextKey+distributiveJoinKey plan leftKey rightKey =+  distributiveKeyForMaskInvariant+    (ContextPlanJoinMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+    plan+    (maskUnion leftMask rightMask)+  where+    leftMask = distributiveMaskForKey plan leftKey+    rightMask = distributiveMaskForKey plan rightKey+{-# INLINE distributiveJoinKey #-}++distributiveMeetKey :: ContextDistributivePlan -> ContextKey -> ContextKey -> ContextKey+distributiveMeetKey plan leftKey rightKey =+  distributiveKeyForMaskInvariant+    (ContextPlanMeetMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+    plan+    (maskIntersection leftMask rightMask)+  where+    leftMask = distributiveMaskForKey plan leftKey+    rightMask = distributiveMaskForKey plan rightKey+{-# INLINE distributiveMeetKey #-}++distributiveJoinMeetKeys :: ContextDistributivePlan -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+distributiveJoinMeetKeys plan leftKey rightKey =+  ( distributiveKeyForMaskInvariant+      (ContextPlanJoinMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+      plan+      (maskUnion leftMask rightMask),+    distributiveKeyForMaskInvariant+      (ContextPlanMeetMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+      plan+      (maskIntersection leftMask rightMask)+  )+  where+    leftMask = distributiveMaskForKey plan leftKey+    rightMask = distributiveMaskForKey plan rightKey+{-# INLINE distributiveJoinMeetKeys #-}++distributiveUpperKeys :: ContextDistributivePlan -> ContextKey -> ContextKeySet+distributiveUpperKeys plan key =+  contextKeySetFromKeys+    (maskUniverseChunkCount plan)+    [ candidateOrdinal+    | candidateOrdinal <- [0 .. cdipSize plan - 1],+      maskIsSubsetOf keyMask (maskRowsRow (cdipMaskByKey plan) candidateOrdinal)+    ]+  where+    keyMask = distributiveMaskForKey plan key++distributiveLowerKeys :: ContextDistributivePlan -> ContextKey -> ContextKeySet+distributiveLowerKeys plan key =+  contextKeySetFromKeys+    (maskUniverseChunkCount plan)+    [ candidateOrdinal+    | candidateOrdinal <- [0 .. cdipSize plan - 1],+      maskIsSubsetOf (maskRowsRow (cdipMaskByKey plan) candidateOrdinal) keyMask+    ]+  where+    keyMask = distributiveMaskForKey plan key++distributiveUpperCoverKeys :: ContextDistributivePlan -> ContextKey -> ContextKeySet+distributiveUpperCoverKeys plan key@(ContextKey keyOrdinal) =+  contextKeySetFromKeys+    (maskUniverseChunkCount plan)+    (foldMap upperCoverKeyOrdinals [0 .. joinIrreducibleCount - 1])+  where+    keyMask = distributiveMaskForKey plan key+    joinIrreducibleCount = UVector.length (cdipJoinIrreducibleKeyByIndex plan)++    upperCoverKeyOrdinals joinIrreducibleIndex+      | maskMember joinIrreducibleIndex keyMask = []+      | not (maskIsSubsetOf requiredLowerMask keyMask) = []+      | otherwise =+          let ContextKey upperOrdinal =+                distributiveKeyForMaskInvariant+                (ContextPlanUpperCoverMissing keyOrdinal joinIrreducibleIndex)+                plan+                (maskUnion keyMask (maskSingleton joinIrreducibleCount joinIrreducibleIndex))+           in [upperOrdinal]+      where+        joinIrreducibleKey = ContextKey (unboxedIndexInvariant (cdipJoinIrreducibleKeyByIndex plan) joinIrreducibleIndex)+        joinIrreducibleMask = distributiveMaskForKey plan joinIrreducibleKey+        requiredLowerMask =+          maskDifference+            joinIrreducibleMask+            (maskSingleton joinIrreducibleCount joinIrreducibleIndex)++distributiveLowerCoverKeys :: ContextDistributivePlan -> ContextKey -> ContextKeySet+distributiveLowerCoverKeys plan key@(ContextKey keyOrdinal) =+  contextKeySetFromKeys+    (maskUniverseChunkCount plan)+    (foldMap lowerCoverKeyOrdinals [0 .. joinIrreducibleCount - 1])+  where+    keyMask = distributiveMaskForKey plan key+    joinIrreducibleCount = UVector.length (cdipJoinIrreducibleKeyByIndex plan)++    lowerCoverKeyOrdinals joinIrreducibleIndex+      | not (maskMember joinIrreducibleIndex keyMask) = []+      | not (maskNull strictUpperContainedMask) = []+      | otherwise =+          let ContextKey lowerOrdinal =+                distributiveKeyForMaskInvariant+                (ContextPlanLowerCoverMissing keyOrdinal joinIrreducibleIndex)+                plan+                (maskDifference keyMask singletonMask)+           in [lowerOrdinal]+      where+        singletonMask = maskSingleton joinIrreducibleCount joinIrreducibleIndex+        upperClosureMask = maskRowsRow (cdipUpClosureByJoinIrreducible plan) joinIrreducibleIndex+        strictUpperContainedMask =+          maskDifference+            (maskIntersection keyMask upperClosureMask)+            singletonMask++distributiveResidualKey ::+  ContextDistributivePlan ->+  ContextKey ->+  ContextKey ->+  ContextKey+distributiveResidualKey plan antecedentKey consequentKey =+  if maskNull forbiddenMask+    then cdipTopKey plan+    else+      distributiveKeyForMaskInvariant+        (ContextPlanResidualMissing (contextKeyOrdinal antecedentKey) (contextKeyOrdinal consequentKey))+        plan+        residualMask+  where+    antecedentMask = distributiveMaskForKey plan antecedentKey+    consequentMask = distributiveMaskForKey plan consequentKey+    forbiddenMask = maskDifference antecedentMask consequentMask+    rejectedMask =+      maskUnionImages+        (jimrChunkCount (cdipUpClosureByJoinIrreducible plan))+        (maskRowsRow (cdipUpClosureByJoinIrreducible plan))+        forbiddenMask+    residualMask = maskDifference (cdipFullMask plan) rejectedMask+{-# INLINE distributiveResidualKey #-}++distributiveMaskForKey :: ContextDistributivePlan -> ContextKey -> JoinIrreducibleMask+distributiveMaskForKey plan (ContextKey keyOrdinal) =+  maskRowsRow (cdipMaskByKey plan) keyOrdinal+{-# INLINE distributiveMaskForKey #-}++distributiveKeyForMask :: ContextDistributivePlan -> JoinIrreducibleMask -> Maybe ContextKey+distributiveKeyForMask plan mask =+  Map.lookup (maskSignature mask) (cdipKeyByMask plan)+{-# INLINE distributiveKeyForMask #-}++distributiveKeyForMaskInvariant ::+  ContextPlanInvariantError ->+  ContextDistributivePlan ->+  JoinIrreducibleMask ->+  ContextKey+distributiveKeyForMaskInvariant invariantError plan mask =+  invariantLookup invariantError (distributiveKeyForMask plan mask)+{-# INLINE distributiveKeyForMaskInvariant #-}++joinIrreducibleKeyOrdinals :: ContextKey -> Int -> ContextRows -> ContextRows -> UVector.Vector Int+joinIrreducibleKeyOrdinals bottomKey size upperRows lowerRows =+  UVector.fromList+    [ keyOrdinal+    | keyOrdinal <- [0 .. size - 1],+      ContextKey keyOrdinal /= bottomKey,+      contextKeySetCardinality+        (lowerCoverOrdinals upperRows lowerRows (ContextKey keyOrdinal))+        == 1+    ]++lowerCoverOrdinals :: ContextRows -> ContextRows -> ContextKey -> ContextKeySet+lowerCoverOrdinals upperRows lowerRows (ContextKey keyOrdinal) =+  maximalWithin+    upperRows+    (contextKeySetDelete keyOrdinal (rowForRawKey lowerRows keyOrdinal))++maximalWithin :: ContextRows -> ContextKeySet -> ContextKeySet+maximalWithin upperRows candidates =+  contextKeySetFilter isMaximal candidates+  where+    isMaximal candidateOrdinal =+      not+        ( contextKeySetIntersectsExcept+            candidateOrdinal+            candidates+            (rowForRawKey upperRows candidateOrdinal)+        )++maskRowsForKeys :: Int -> UVector.Vector Int -> ContextRows -> JoinIrreducibleMaskRows+maskRowsForKeys size joinIrreducibleKeys upperRows =+  maskRowsGenerate size (UVector.length joinIrreducibleKeys) $ \keyOrdinal joinIrreducibleIndex ->+    contextKeyRelated+      upperRows+      (ContextKey (unboxedIndexInvariant joinIrreducibleKeys joinIrreducibleIndex))+      (ContextKey keyOrdinal)++upClosureRowsForJoinIrreducibles :: UVector.Vector Int -> ContextRows -> JoinIrreducibleMaskRows+upClosureRowsForJoinIrreducibles joinIrreducibleKeys upperRows =+  maskRowsGenerate joinIrreducibleCount joinIrreducibleCount $ \sourceIndex targetIndex ->+    contextKeyRelated+      upperRows+      (ContextKey (unboxedIndexInvariant joinIrreducibleKeys sourceIndex))+      (ContextKey (unboxedIndexInvariant joinIrreducibleKeys targetIndex))+  where+    joinIrreducibleCount = UVector.length joinIrreducibleKeys++validateRowOperationsAgainstMasks ::+  Int ->+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextRowIndex ->+  Maybe ContextDistributivePlan ->+  ContextDistributiveRowsResult+validateRowOperationsAgainstMasks size upperRows lowerRows upperRowIndex lowerRowIndex candidatePlan =+  foldr+    validatePair+    initialResult+    [ (ContextKey leftOrdinal, ContextKey rightOrdinal)+    | leftOrdinal <- [0 .. size - 1],+      rightOrdinal <- [0 .. size - 1]+    ]+  where+    initialResult =+      maybe ContextDenseRowsValidated ContextDistributiveRowsPlan candidatePlan++    validatePair (leftKey, rightKey) remainingPairs =+      case rowJoinKeyMaybe upperRows lowerRows upperRowIndex leftKey rightKey of+        Nothing ->+          ContextRowJoinAbsent+            leftKey+            rightKey+            (rowJoinCandidateKeys upperRows lowerRows leftKey rightKey)+        Just joinKey ->+          case rowMeetKeyMaybe upperRows lowerRows lowerRowIndex leftKey rightKey of+            Nothing ->+              ContextRowMeetAbsent+                leftKey+                rightKey+                (rowMeetCandidateKeys upperRows lowerRows leftKey rightKey)+            Just meetKey ->+              case remainingPairs of+                ContextDistributiveRowsPlan plan+                  | rowOperationMatchesMasks plan leftKey rightKey joinKey meetKey ->+                      remainingPairs+                  | otherwise -> ContextDenseRowsValidated+                ContextDenseRowsValidated -> ContextDenseRowsValidated+                obstruction@(ContextRowJoinAbsent _ _ _) -> obstruction+                obstruction@(ContextRowMeetAbsent _ _ _) -> obstruction++rowOperationMatchesMasks ::+  ContextDistributivePlan ->+  ContextKey ->+  ContextKey ->+  ContextKey ->+  ContextKey ->+  Bool+rowOperationMatchesMasks candidatePlan (ContextKey leftOrdinal) (ContextKey rightOrdinal) joinKey meetKey =+  let leftMask = maskRowsRow (cdipMaskByKey candidatePlan) leftOrdinal+      rightMask = maskRowsRow (cdipMaskByKey candidatePlan) rightOrdinal+   in Map.lookup (maskSignature (maskUnion leftMask rightMask)) (cdipKeyByMask candidatePlan) == Just joinKey+        && Map.lookup (maskSignature (maskIntersection leftMask rightMask)) (cdipKeyByMask candidatePlan) == Just meetKey++tableOperationsMatchMasks ::+  Int ->+  ContextKeyTable ->+  ContextKeyTable ->+  JoinIrreducibleMaskRows ->+  Map JoinIrreducibleMaskSignature ContextKey ->+  Bool+tableOperationsMatchMasks size joinTable meetTable maskByKey keyByMask =+  all pairMatches+    [ (ContextKey leftOrdinal, ContextKey rightOrdinal)+    | leftOrdinal <- [0 .. size - 1],+      rightOrdinal <- [0 .. size - 1]+    ]+  where+    pairMatches (leftKey@(ContextKey leftOrdinal), rightKey@(ContextKey rightOrdinal)) =+      let leftMask = maskRowsRow maskByKey leftOrdinal+          rightMask = maskRowsRow maskByKey rightOrdinal+          joinMask = maskUnion leftMask rightMask+          meetMask = maskIntersection leftMask rightMask+          joinKey = contextKeyTableLookup joinTable leftKey rightKey+          meetKey = contextKeyTableLookup meetTable leftKey rightKey+       in Map.lookup (maskSignature joinMask) keyByMask == Just joinKey+            && Map.lookup (maskSignature meetMask) keyByMask == Just meetKey++maskRowsGenerate ::+  Int ->+  Int ->+  (Int -> Int -> Bool) ->+  JoinIrreducibleMaskRows+maskRowsGenerate rowCount bitCount member =+  JoinIrreducibleMaskRows+    { jimrChunkCount = chunkCount,+      jimrChunks =+        UVector.generate (rowCount * chunkCount) $ \flatIndex ->+          let (rowIndex, chunkIndex) = flatIndex `quotRem` chunkCount+              bitBase = chunkIndex * bitsPerChunk+           in generateChunk rowIndex bitBase 0 0+    }+  where+    chunkCount = maskChunkCount bitCount++    generateChunk !rowIndex !bitBase !bitIndex !chunkValue+      | bitIndex >= bitsPerChunk = chunkValue+      | maskBitIndex >= bitCount = chunkValue+      | member rowIndex maskBitIndex =+          generateChunk rowIndex bitBase (bitIndex + 1) (chunkValue .|. bit bitIndex)+      | otherwise =+          generateChunk rowIndex bitBase (bitIndex + 1) chunkValue+      where+        maskBitIndex = bitBase + bitIndex++maskRowsRow :: JoinIrreducibleMaskRows -> Int -> JoinIrreducibleMask+maskRowsRow rows rowIndex =+  JoinIrreducibleMask+    ( UVector.slice+        (rowIndex * jimrChunkCount rows)+        (jimrChunkCount rows)+        (jimrChunks rows)+    )+{-# INLINE maskRowsRow #-}++maskEmpty :: Int -> JoinIrreducibleMask+maskEmpty bitCount =+  JoinIrreducibleMask (UVector.replicate (maskChunkCount bitCount) 0)++maskFull :: Int -> JoinIrreducibleMask+maskFull bitCount+  | bitCount <= 0 = JoinIrreducibleMask UVector.empty+  | otherwise =+      JoinIrreducibleMask+        ( UVector.generate chunkCount $ \chunkIndex ->+            if chunkIndex == chunkCount - 1+              then finalChunk+              else maxBound+        )+  where+    chunkCount = maskChunkCount bitCount+    finalBitCount = bitCount .&. (bitsPerChunk - 1)+    finalChunk+      | finalBitCount == 0 = maxBound+      | otherwise = bit finalBitCount - 1++maskSingleton :: Int -> Int -> JoinIrreducibleMask+maskSingleton bitCount bitIndex =+  JoinIrreducibleMask+    ( UVector.generate (maskChunkCount bitCount) $ \chunkIndex ->+        if chunkIndex == bitIndex `quot` bitsPerChunk+          then bit (bitIndex .&. (bitsPerChunk - 1))+          else 0+    )++maskUnion :: JoinIrreducibleMask -> JoinIrreducibleMask -> JoinIrreducibleMask+maskUnion = maskZipWith (.|.)+{-# INLINE maskUnion #-}++maskIntersection :: JoinIrreducibleMask -> JoinIrreducibleMask -> JoinIrreducibleMask+maskIntersection = maskZipWith (.&.)+{-# INLINE maskIntersection #-}++maskDifference :: JoinIrreducibleMask -> JoinIrreducibleMask -> JoinIrreducibleMask+maskDifference = maskZipWith (\leftChunk rightChunk -> leftChunk .&. complement rightChunk)+{-# INLINE maskDifference #-}++maskIsSubsetOf :: JoinIrreducibleMask -> JoinIrreducibleMask -> Bool+maskIsSubsetOf (JoinIrreducibleMask leftChunks) (JoinIrreducibleMask rightChunks) =+  UVector.and+    ( UVector.zipWith+        (\leftChunk rightChunk -> leftChunk .&. complement rightChunk == 0)+        leftChunks+        rightChunks+    )+{-# INLINE maskIsSubsetOf #-}++maskNull :: JoinIrreducibleMask -> Bool+maskNull (JoinIrreducibleMask chunks) =+  UVector.all (== 0) chunks+{-# INLINE maskNull #-}++maskMember :: Int -> JoinIrreducibleMask -> Bool+maskMember bitIndex (JoinIrreducibleMask chunks)+  | chunkIndex >= UVector.length chunks = False+  | otherwise = unboxedIndexInvariant chunks chunkIndex .&. bit (bitIndex .&. (bitsPerChunk - 1)) /= 0+  where+    chunkIndex = bitIndex `quot` bitsPerChunk+{-# INLINE maskMember #-}++maskUnionImages ::+  Int ->+  (Int -> JoinIrreducibleMask) ->+  JoinIrreducibleMask ->+  JoinIrreducibleMask+maskUnionImages chunkCount image =+  maskFoldr+    (maskUnion . image)+    (JoinIrreducibleMask (UVector.replicate chunkCount 0))++maskFoldr :: (Int -> result -> result) -> result -> JoinIrreducibleMask -> result+maskFoldr step initial (JoinIrreducibleMask chunks) =+  UVector.ifoldr foldChunk initial chunks+  where+    foldChunk chunkIndex =+      foldWord (chunkIndex * bitsPerChunk)++    foldWord !baseIndex !remainingBits rest+      | remainingBits == 0 = rest+      | otherwise =+          let bitIndex = countTrailingZeros remainingBits+              nextBits = remainingBits .&. (remainingBits - 1)+           in step+                (baseIndex + bitIndex)+                (foldWord baseIndex nextBits rest)++maskZipWith ::+  (Word64 -> Word64 -> Word64) ->+  JoinIrreducibleMask ->+  JoinIrreducibleMask ->+  JoinIrreducibleMask+maskZipWith combine (JoinIrreducibleMask leftChunks) (JoinIrreducibleMask rightChunks) =+  JoinIrreducibleMask+    ( UVector.generate+        (UVector.length leftChunks)+        ( \chunkIndex ->+            combine+              (unboxedIndexInvariant leftChunks chunkIndex)+              (unboxedIndexInvariant rightChunks chunkIndex)+        )+    )+{-# INLINE maskZipWith #-}++maskSignature :: JoinIrreducibleMask -> JoinIrreducibleMaskSignature+maskSignature (JoinIrreducibleMask chunks) =+  case UVector.length chunks of+    0 -> JoinIrreducibleMaskSignature0+    1 -> JoinIrreducibleMaskSignature1 (unboxedIndexInvariant chunks 0)+    2 -> JoinIrreducibleMaskSignature2 (unboxedIndexInvariant chunks 0) (unboxedIndexInvariant chunks 1)+    _ -> JoinIrreducibleMaskSignatureN (UVector.toList chunks)++maskChunkCount :: Int -> Int+maskChunkCount bitCount+  | bitCount <= 0 = 0+  | otherwise = 1 + (bitCount - 1) `quot` bitsPerChunk+{-# INLINE maskChunkCount #-}++maskUniverseChunkCount :: ContextDistributivePlan -> Int+maskUniverseChunkCount plan =+  1 + (cdipSize plan - 1) `quot` bitsPerChunk+{-# INLINE maskUniverseChunkCount #-}++bitsPerChunk :: Int+bitsPerChunk = 64++guardMaybe :: Bool -> Maybe ()+guardMaybe condition =+  if condition then Just () else Nothing
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Index.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.FiniteLattice.Internal.Index+  ( ContextIndex (..),+    contextIndexFromUniverse,+    contextIndexValueForKey,+    lookupCompileKey,+    contextLatticeFromPlan,+    encodeRelationKeyPairs,+    reflexiveKeyPairs,+    decodeIndexKeys,+    firstDuplicate,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    contextKeySetToAscList,+  )+import Moonlight.FiniteLattice.Internal.Invariant+  ( boxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Plan (ContextPlan)+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextLatticeCompileError (..),+  )++data ContextIndex c = ContextIndex+  { ciContextsByKey :: !(Vector.Vector c),+    ciKeyByContext :: !(Map c ContextKey),+    ciSize :: !Int+  }++type role ContextIndex nominal++contextIndexFromUniverse :: Set c -> Either (ContextLatticeCompileError c) (ContextIndex c)+contextIndexFromUniverse universe =+  case contexts of+    [] -> Left ContextLatticeEmptyUniverse+    _ : _ ->+      Right+        ContextIndex+          { ciContextsByKey = Vector.fromList contexts,+            ciKeyByContext = Map.fromDistinctAscList keyEntries,+            ciSize = Set.size universe+          }+  where+    contexts = Set.toAscList universe+    keyEntries =+      zipWith+        (\contextValue keyOrdinal -> (contextValue, ContextKey keyOrdinal))+        contexts+        [0 ..]++contextIndexValueForKey :: ContextIndex c -> ContextKey -> c+contextIndexValueForKey index (ContextKey keyOrdinal) =+  contextIndexValueAtOrdinal index keyOrdinal+{-# INLINE contextIndexValueForKey #-}++lookupCompileKey ::+  Ord c =>+  ContextIndex c ->+  c ->+  ContextLatticeCompileError c ->+  Either (ContextLatticeCompileError c) ContextKey+lookupCompileKey index contextValue missingError =+  maybe+    (Left missingError)+    Right+    (Map.lookup contextValue (ciKeyByContext index))++contextLatticeFromPlan ::+  c ->+  c ->+  ContextKey ->+  ContextKey ->+  ContextIndex c ->+  ContextPlan ->+  ContextLattice c+contextLatticeFromPlan topValue bottomValue topKey bottomKey index plan =+  ContextLattice+    { clTop = topValue,+      clBottom = bottomValue,+      clTopKey = topKey,+      clBottomKey = bottomKey,+      clContextsByKey = ciContextsByKey index,+      clKeyByContext = ciKeyByContext index,+      clPlan = plan,+      clSize = ciSize index+    }++encodeRelationKeyPairs ::+  Ord c =>+  ContextIndex c ->+  Set (c, c) ->+  Either (ContextLatticeCompileError c) [(ContextKey, ContextKey)]+encodeRelationKeyPairs index relation =+  traverse encodePair (Set.toAscList relation)+  where+    encodePair pair@(lowerContext, upperContext) = do+      lowerKey <-+        maybe+          (Left (ContextLatticeUnknownRelationEndpoint pair))+          Right+          (Map.lookup lowerContext (ciKeyByContext index))+      upperKey <-+        maybe+          (Left (ContextLatticeUnknownRelationEndpoint pair))+          Right+          (Map.lookup upperContext (ciKeyByContext index))+      pure (lowerKey, upperKey)++reflexiveKeyPairs :: ContextIndex c -> [(ContextKey, ContextKey)]+reflexiveKeyPairs index =+  [ (ContextKey keyOrdinal, ContextKey keyOrdinal)+  | keyOrdinal <- [0 .. ciSize index - 1]+  ]++decodeIndexKeys :: Ord c => ContextIndex c -> ContextKeySet -> Set c+decodeIndexKeys index =+  Set.fromAscList+    . fmap (contextIndexValueForKey index . ContextKey)+    . contextKeySetToAscList++firstDuplicate :: Ord c => [c] -> Maybe c+firstDuplicate =+  go Set.empty+  where+    go :: Ord c => Set c -> [c] -> Maybe c+    go _ [] = Nothing+    go seen (contextValue : rest)+      | Set.member contextValue seen = Just contextValue+      | otherwise = go (Set.insert contextValue seen) rest++contextIndexValueAtOrdinal :: ContextIndex c -> Int -> c+contextIndexValueAtOrdinal index =+  boxedIndexInvariant (ciContextsByKey index)+{-# INLINE contextIndexValueAtOrdinal #-}
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Invariant.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Invariant+  ( ContextPlanInvariantError (..),+    invariantLookup,+    boxedIndexInvariant,+    unboxedIndexInvariant,+  )+where++import Control.Exception (Exception, assert, throw)+import Data.Maybe (fromMaybe)+import Data.Vector qualified as Vector+import Data.Vector.Unboxed qualified as UVector++-- | A validated runtime plan failed to produce the result established by its+-- constructor. The two integers are context-key ordinals, except for cover+-- failures where the second integer is the join-irreducible mask index.+data ContextPlanInvariantError+  = ContextPlanJoinMissing !Int !Int+  | ContextPlanMeetMissing !Int !Int+  | ContextPlanResidualMissing !Int !Int+  | ContextPlanUpperCoverMissing !Int !Int+  | ContextPlanLowerCoverMissing !Int !Int+  deriving stock (Eq, Ord, Show, Read)++instance Exception ContextPlanInvariantError++-- | Eliminate a constructor-private lookup whose presence was proved when the+-- plan was compiled. A miss is an internal defect, never a lattice value and+-- never a recoverable query failure.+invariantLookup :: ContextPlanInvariantError -> Maybe result -> result+invariantLookup obstruction = fromMaybe (throw obstruction)+{-# INLINE invariantLookup #-}++boxedIndexInvariant :: Vector.Vector a -> Int -> a+boxedIndexInvariant vector index =+  assert (index >= 0 && index < Vector.length vector) $+    Vector.unsafeIndex vector index+{-# INLINE boxedIndexInvariant #-}++unboxedIndexInvariant :: UVector.Unbox a => UVector.Vector a -> Int -> a+unboxedIndexInvariant vector index =+  assert (index >= 0 && index < UVector.length vector) $+    UVector.unsafeIndex vector index+{-# INLINE unboxedIndexInvariant #-}
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Key.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet (..),+    contextKeySetEmpty,+    contextKeySetAll,+    contextKeySetSingleton,+    contextKeySetFromKeys,+    contextKeySetUnion,+    contextKeySetIntersection,+    contextKeySetIntersects,+    contextKeySetUnionImages,+    contextKeySetImage2,+    contextKeySetDifference,+    contextKeySetDelete,+    contextKeySetMember,+    contextKeySetNull,+    contextKeySetCardinality,+    contextKeySetFilter,+    contextKeySetFind,+    contextKeySetFindDifference,+    contextKeySetIntersectsExcept,+    contextKeySetFoldr,+    contextKeySetToAscList,+    contextKeySetChunkCount,+    ContextKeyTable,+    contextKeyTableGenerateM,+    contextKeyTableLookup,+    pairKeyOffset,+  )+where++import Data.Bits+  ( (.&.),+    (.|.),+    bit,+    complement,+    countTrailingZeros,+    popCount,+  )+import Data.Kind (Type)+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.FiniteLattice.Internal.Invariant+  ( unboxedIndexInvariant,+  )++type ContextKey :: Type+newtype ContextKey = ContextKey+  { contextKeyOrdinal :: Int+  }+  deriving stock (Eq, Ord, Show)++type ContextKeySet :: Type+newtype ContextKeySet = ContextKeySet+  { contextKeySetChunks :: UVector.Vector Word64+  }+  deriving stock (Eq, Show)++contextKeySetEmpty :: Int -> ContextKeySet+contextKeySetEmpty chunkCount =+  ContextKeySet (UVector.replicate chunkCount 0)++contextKeySetAll :: Int -> ContextKeySet+contextKeySetAll size+  | size <= 0 =+      ContextKeySet UVector.empty+  | otherwise =+      ContextKeySet+        ( UVector.generate chunkCount $ \chunkIndex ->+            if chunkIndex == chunkCount - 1+              then finalChunk+              else maxBound+        )+  where+    chunkCount = contextKeySetChunkCount size+    finalBitCount = size .&. (contextKeyBitsPerChunk - 1)+    finalChunk+      | finalBitCount == 0 = maxBound+      | otherwise = bit finalBitCount - 1++contextKeySetSingleton :: Int -> ContextKey -> ContextKeySet+contextKeySetSingleton chunkCount (ContextKey keyOrdinal) =+  contextKeySetFromKeys chunkCount [keyOrdinal]++contextKeySetFromKeys :: Int -> [Int] -> ContextKeySet+contextKeySetFromKeys chunkCount keyOrdinals =+  ContextKeySet+    ( UVector.accum+        (.|.)+        (UVector.replicate chunkCount 0)+        [ (contextKeyChunkIndex keyOrdinal, contextKeyBitMask keyOrdinal)+        | keyOrdinal <- keyOrdinals,+          keyOrdinal >= 0,+          contextKeyChunkIndex keyOrdinal < chunkCount+        ]+    )++contextKeySetUnion :: ContextKeySet -> ContextKeySet -> ContextKeySet+contextKeySetUnion =+  contextKeySetZipWith (.|.)+{-# INLINE contextKeySetUnion #-}++contextKeySetIntersection :: ContextKeySet -> ContextKeySet -> ContextKeySet+contextKeySetIntersection =+  contextKeySetZipWith (.&.)+{-# INLINE contextKeySetIntersection #-}++contextKeySetIntersects :: ContextKeySet -> ContextKeySet -> Bool+contextKeySetIntersects left right =+  not (contextKeySetNull (contextKeySetIntersection left right))+{-# INLINE contextKeySetIntersects #-}++contextKeySetUnionImages ::+  Int ->+  (Int -> ContextKeySet) ->+  ContextKeySet ->+  ContextKeySet+contextKeySetUnionImages chunkCount image =+  contextKeySetFoldr+    (contextKeySetUnion . image)+    (contextKeySetEmpty chunkCount)++contextKeySetImage2 ::+  Int ->+  (Int -> Int -> Int) ->+  ContextKeySet ->+  ContextKeySet ->+  ContextKeySet+contextKeySetImage2 chunkCount combine leftKeys rightKeys =+  contextKeySetFromKeys chunkCount+    [ combine leftOrdinal rightOrdinal+    | leftOrdinal <- contextKeySetToAscList leftKeys,+      rightOrdinal <- contextKeySetToAscList rightKeys+    ]++contextKeySetDifference :: ContextKeySet -> ContextKeySet -> ContextKeySet+contextKeySetDifference =+  contextKeySetZipWith (\leftChunk rightChunk -> leftChunk .&. complement rightChunk)+{-# INLINE contextKeySetDifference #-}++contextKeySetDelete :: Int -> ContextKeySet -> ContextKeySet+contextKeySetDelete keyOrdinal keySet@(ContextKeySet chunks)+  | keyOrdinal < 0 || chunkIndex >= UVector.length chunks = keySet+  | otherwise =+      ContextKeySet+        ( UVector.imap+            ( \currentChunkIndex chunk ->+                if currentChunkIndex == chunkIndex+                  then chunk .&. complement mask+                  else chunk+            )+            chunks+        )+  where+    chunkIndex = contextKeyChunkIndex keyOrdinal+    mask = contextKeyBitMask keyOrdinal++contextKeySetMember :: Int -> ContextKeySet -> Bool+contextKeySetMember keyOrdinal (ContextKeySet chunks)+  | keyOrdinal < 0 = False+  | chunkIndex >= UVector.length chunks = False+  | otherwise =+      UVector.unsafeIndex chunks chunkIndex .&. contextKeyBitMask keyOrdinal /= 0+  where+    chunkIndex = contextKeyChunkIndex keyOrdinal+{-# INLINE contextKeySetMember #-}++contextKeySetNull :: ContextKeySet -> Bool+contextKeySetNull (ContextKeySet chunks) =+  UVector.all (== 0) chunks++contextKeySetCardinality :: ContextKeySet -> Int+contextKeySetCardinality (ContextKeySet chunks) =+  UVector.foldl' (\count chunkValue -> count + popCount chunkValue) 0 chunks++contextKeySetFilter :: (Int -> Bool) -> ContextKeySet -> ContextKeySet+contextKeySetFilter predicate (ContextKeySet chunks) =+  ContextKeySet (UVector.imap filterChunk chunks)+  where+    filterChunk chunkIndex =+      retainBits (chunkIndex * contextKeyBitsPerChunk) 0++    retainBits !baseOrdinal !retainedBits !remainingBits+      | remainingBits == 0 = retainedBits+      | otherwise =+          let bitIndex = countTrailingZeros remainingBits+              bitMask = bit bitIndex+              nextBits = remainingBits .&. (remainingBits - 1)+              nextRetainedBits =+                if predicate (baseOrdinal + bitIndex)+                  then retainedBits .|. bitMask+                  else retainedBits+           in retainBits baseOrdinal nextRetainedBits nextBits++contextKeySetFind :: (Int -> Bool) -> ContextKeySet -> Maybe Int+contextKeySetFind predicate (ContextKeySet chunks) =+  findChunk 0+  where+    chunkCount = UVector.length chunks++    findChunk !chunkIndex+      | chunkIndex >= chunkCount = Nothing+      | otherwise =+          case findWord+            (chunkIndex * contextKeyBitsPerChunk)+            (unboxedIndexInvariant chunks chunkIndex) of+            Nothing -> findChunk (chunkIndex + 1)+            found -> found++    findWord !baseOrdinal !remainingBits+      | remainingBits == 0 = Nothing+      | otherwise =+          let bitIndex = countTrailingZeros remainingBits+              keyOrdinal = baseOrdinal + bitIndex+              nextBits = remainingBits .&. (remainingBits - 1)+           in if predicate keyOrdinal+                then Just keyOrdinal+                else findWord baseOrdinal nextBits++-- | Find the least key in @left \\ right@. Sets must have the same internal+-- shape; every call in the compiled representation satisfies that invariant.+contextKeySetFindDifference :: ContextKeySet -> ContextKeySet -> Maybe Int+contextKeySetFindDifference (ContextKeySet leftChunks) (ContextKeySet rightChunks) =+  findChunk 0+  where+    chunkCount = UVector.length leftChunks++    findChunk !chunkIndex+      | chunkIndex >= chunkCount = Nothing+      | otherwise =+          let leftChunk = unboxedIndexInvariant leftChunks chunkIndex+              rightChunk = unboxedIndexInvariant rightChunks chunkIndex+              difference = leftChunk .&. complement rightChunk+           in if difference == 0+                then findChunk (chunkIndex + 1)+                else+                  Just+                    ( chunkIndex * contextKeyBitsPerChunk+                        + countTrailingZeros difference+                    )++-- | Whether the intersection contains a key other than the excluded key.+-- This avoids allocating an intersection for every Hasse-edge candidate.+contextKeySetIntersectsExcept ::+  Int ->+  ContextKeySet ->+  ContextKeySet ->+  Bool+contextKeySetIntersectsExcept excludedOrdinal (ContextKeySet leftChunks) (ContextKeySet rightChunks) =+  go 0+  where+    chunkCount = UVector.length leftChunks+    excludedChunk = contextKeyChunkIndex excludedOrdinal+    excludedMask = contextKeyBitMask excludedOrdinal++    go !chunkIndex+      | chunkIndex >= chunkCount = False+      | otherwise =+          let common =+                unboxedIndexInvariant leftChunks chunkIndex+                  .&. unboxedIndexInvariant rightChunks chunkIndex+              relevant =+                if chunkIndex == excludedChunk+                  then common .&. complement excludedMask+                  else common+           in relevant /= 0 || go (chunkIndex + 1)++contextKeySetFoldr :: (Int -> result -> result) -> result -> ContextKeySet -> result+contextKeySetFoldr step initial (ContextKeySet chunks) =+  UVector.ifoldr foldChunk initial chunks+  where+    foldChunk chunkIndex =+      foldWord (chunkIndex * contextKeyBitsPerChunk)++    foldWord !baseOrdinal !remainingBits rest+      | remainingBits == 0 = rest+      | otherwise =+          let bitIndex = countTrailingZeros remainingBits+              nextBits = remainingBits .&. (remainingBits - 1)+           in step+                (baseOrdinal + bitIndex)+                (foldWord baseOrdinal nextBits rest)++contextKeySetToAscList :: ContextKeySet -> [Int]+contextKeySetToAscList =+  contextKeySetFoldr (:) []++contextKeySetChunkCount :: Int -> Int+contextKeySetChunkCount size+  | size <= 0 = 0+  | otherwise = 1 + (size - 1) `quot` contextKeyBitsPerChunk+{-# INLINE contextKeySetChunkCount #-}++contextKeySetZipWith ::+  (Word64 -> Word64 -> Word64) ->+  ContextKeySet ->+  ContextKeySet ->+  ContextKeySet+contextKeySetZipWith combine (ContextKeySet leftChunks) (ContextKeySet rightChunks) =+  ContextKeySet+    ( UVector.generate+        (UVector.length leftChunks)+        ( \chunkIndex ->+            combine+              (unboxedIndexInvariant leftChunks chunkIndex)+              (unboxedIndexInvariant rightChunks chunkIndex)+        )+    )+{-# INLINE contextKeySetZipWith #-}++contextKeyChunkIndex :: Int -> Int+contextKeyChunkIndex keyOrdinal =+  keyOrdinal `quot` contextKeyBitsPerChunk+{-# INLINE contextKeyChunkIndex #-}++contextKeyBitMask :: Int -> Word64+contextKeyBitMask keyOrdinal =+  bit (keyOrdinal .&. (contextKeyBitsPerChunk - 1))+{-# INLINE contextKeyBitMask #-}++contextKeyBitsPerChunk :: Int+contextKeyBitsPerChunk = 64++type ContextKeyTable :: Type+data ContextKeyTable = ContextKeyTable+  { contextKeyTableSize :: !Int,+    contextKeyTableEntries :: !(UVector.Vector Int)+  }++contextKeyTableGenerateM ::+  Monad m =>+  Int ->+  Int ->+  (Int -> m ContextKey) ->+  m ContextKeyTable+contextKeyTableGenerateM size entryCount generateEntry =+  ContextKeyTable size+    <$> UVector.generateM+      entryCount+      (fmap contextKeyOrdinal . generateEntry)++-- | Total under the representation invariant: both keys are in @[0,n)@ and+-- the table contains exactly @n*n@ entries. Constructors never cross the+-- public module boundary.+contextKeyTableLookup :: ContextKeyTable -> ContextKey -> ContextKey -> ContextKey+contextKeyTableLookup table leftKey rightKey =+  ContextKey+    ( unboxedIndexInvariant+        (contextKeyTableEntries table)+        (pairKeyOffset (contextKeyTableSize table) leftKey rightKey)+    )+{-# INLINE contextKeyTableLookup #-}++pairKeyOffset :: Int -> ContextKey -> ContextKey -> Int+pairKeyOffset size (ContextKey leftOrdinal) (ContextKey rightOrdinal) =+  leftOrdinal * size + rightOrdinal+{-# INLINE pairKeyOffset #-}+
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Layout.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Layout+  ( checkedRelationWordCount,+    checkedPairCellCount,+  )+where++import Data.Word (Word64)+import Foreign.Storable (sizeOf)+import Moonlight.FiniteLattice.Internal.Key+  ( contextKeySetChunkCount,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextCompileLimits (..),+    ContextLatticeCompileError (..),+    ContextRepresentation (..),+  )+import Numeric.Natural (Natural)++data ContextLayoutFailure+  = ContextLayoutCountOverflow !Integer+  | ContextLayoutLimitExceeded !Integer !Natural+  deriving stock (Eq, Ord, Show, Read)++checkedRelationWordCount ::+  ContextCompileLimits ->+  Int ->+  Either (ContextLatticeCompileError c) Int+checkedRelationWordCount limits size =+  case+    checkedRepresentationProduct+      (cclMaximumRelationBytes limits)+      (sizeOf (0 :: Word64))+      2+      [size, contextKeySetChunkCount size]+    of+    Left (ContextLayoutCountOverflow requestedCount) ->+      Left (ContextLatticeRepresentationOverflow ContextRelationWords requestedCount)+    Left (ContextLayoutLimitExceeded requestedBytes maximumBytes) ->+      Left+        ( ContextLatticeRepresentationLimitExceeded+            ContextRelationWords+            requestedBytes+            maximumBytes+        )+    Right wordCount -> Right wordCount++checkedPairCellCount ::+  ContextCompileLimits ->+  Int ->+  Maybe Int+checkedPairCellCount limits size =+  either+    (const Nothing)+    Just+    ( checkedRepresentationProduct+        (cclMaximumBinaryTableBytes limits)+        (sizeOf (0 :: Int))+        2+        [size, size]+    )++checkedRepresentationProduct ::+  Maybe Natural ->+  Int ->+  Integer ->+  [Int] ->+  Either ContextLayoutFailure Int+checkedRepresentationProduct byteLimit bytesPerElement retainedCopies factors =+  case countResult of+    Left overflow ->+      Left overflow+    Right tableEntryCount ->+      case limitResult tableEntryCount of+        Left limitError -> Left limitError+        Right () -> Right (fromInteger tableEntryCount)+  where+    requestedCount =+      product (fmap toInteger factors)++    countResult+      | requestedCount <= toInteger (maxBound :: Int) =+          Right requestedCount+      | otherwise =+          Left (ContextLayoutCountOverflow requestedCount)++    requestedBytes requestedCountValue =+      requestedCountValue+        * toInteger bytesPerElement+        * retainedCopies++    limitResult requestedCountValue =+      case byteLimit of+        Nothing ->+          Right ()+        Just maximumBytes+          | requestedBytes requestedCountValue <= toInteger maximumBytes ->+              Right ()+          | otherwise ->+              Left+                ( ContextLayoutLimitExceeded+                    (requestedBytes requestedCountValue)+                    maximumBytes+                )
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Plan.hs view
@@ -0,0 +1,784 @@+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Plan+  ( ContextPlan (..),+    ContextDenseTablePlan (..),+    ContextMaskPlan (..),+    ContextDenseRowsPlan (..),+    ContextDistributivePlan (..),+    ContextTotalOrderPlan (..),+    ContextBoundedFanPlan (..),+    ContextBooleanPlan (..),+    contextPlanLeq,+    contextPlanJoinKey,+    contextPlanMeetKey,+    contextPlanJoinMeetKeys,+    contextPlanUpperKeys,+    contextPlanLowerKeys,+    contextPlanUpperCoverKeys,+    contextPlanLowerCoverKeys,+    contextPlanMonotonicityTargets,+    ordinalBoundedFanKeyLeq,+    totalOrderKeyRank,+    boundedFanKeyLeq,+    booleanMaskForKey,+    booleanKeyForMask,+  )+where++import Data.Bits+  ( (.&.),+    (.|.),+    bit,+    complement,+    testBit,+    xor,+  )+import Data.Kind (Type)+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.FiniteLattice.Internal.Distributive+  ( ContextDistributivePlan (..),+    distributiveJoinKey,+    distributiveJoinMeetKeys,+    distributiveKeyLeq,+    distributiveLowerCoverKeys,+    distributiveLowerKeys,+    distributiveMeetKey,+    distributiveUpperCoverKeys,+    distributiveUpperKeys,+  )+import Moonlight.FiniteLattice.Internal.Invariant+  ( ContextPlanInvariantError (..),+    invariantLookup,+    unboxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    ContextKeyTable,+    contextKeySetAll,+    contextKeySetChunkCount,+    contextKeySetDelete,+    contextKeySetEmpty,+    contextKeySetFilter,+    contextKeySetFromKeys,+    contextKeySetIntersectsExcept,+    contextKeySetSingleton,+    contextKeyTableLookup,+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( ContextRowIndex,+    ContextRows,+    contextKeyRelated,+    rowForKey,+    rowJoinKeyMaybe,+    rowMeetKeyMaybe,+  )++type ContextPlan :: Type+data ContextPlan+  = DensePlan !ContextDenseTablePlan+  | MaskPlan !ContextMaskPlan+  | OrdinalTotalOrderPlan !Int+  | TotalOrderPlan !ContextTotalOrderPlan+  | OrdinalBoundedFanPlan !Int+  | BoundedFanPlan !ContextBoundedFanPlan++type ContextDenseTablePlan :: Type+data ContextDenseTablePlan = ContextDenseTablePlan+  { cdtpSize :: !Int,+    cdtpUpperRows :: !ContextRows,+    cdtpLowerRows :: !ContextRows,+    cdtpJoinTable :: !ContextKeyTable,+    cdtpMeetTable :: !ContextKeyTable+  }++type ContextMaskPlan :: Type+data ContextMaskPlan+  = BooleanPlan !ContextBooleanPlan+  | DistributivePlan !ContextDistributivePlan+  | DenseRowsPlan !ContextDenseRowsPlan++type ContextDenseRowsPlan :: Type+data ContextDenseRowsPlan = ContextDenseRowsPlan+  { cdrpUpperRows :: !ContextRows,+    cdrpLowerRows :: !ContextRows,+    cdrpUpperRowIndex :: !ContextRowIndex,+    cdrpLowerRowIndex :: !ContextRowIndex+  }++type ContextTotalOrderPlan :: Type+data ContextTotalOrderPlan = ContextTotalOrderPlan+  { ctoTopKey :: !ContextKey,+    ctoRankByKey :: !(UVector.Vector Int),+    ctoKeyByRank :: !(UVector.Vector Int)+  }++type ContextBoundedFanPlan :: Type+data ContextBoundedFanPlan = ContextBoundedFanPlan+  { cbfSize :: !Int,+    cbfTopKey :: !ContextKey,+    cbfBottomKey :: !ContextKey,+    cbfAtomKeys :: !ContextKeySet,+    cbfAllKeys :: !ContextKeySet+  }++type ContextBooleanPlan :: Type+data ContextBooleanPlan = ContextBooleanPlan+  { cboAtomCount :: !Int,+    cboFullMask :: !Word64,+    cboMaskByKey :: !(UVector.Vector Word64),+    cboKeyByMask :: !(UVector.Vector Int)+  }++contextPlanLeq :: ContextPlan -> ContextKey -> ContextKey -> Bool+contextPlanLeq plan leftKey rightKey =+  case plan of+    DensePlan densePlan ->+      contextKeyRelated (cdtpUpperRows densePlan) leftKey rightKey+    MaskPlan maskPlan ->+      contextMaskPlanLeq maskPlan leftKey rightKey+    OrdinalTotalOrderPlan _ ->+      contextKeyOrdinal leftKey <= contextKeyOrdinal rightKey+    TotalOrderPlan totalOrderPlan ->+      totalOrderKeyRank totalOrderPlan leftKey+        <= totalOrderKeyRank totalOrderPlan rightKey+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanKeyLeq size leftKey rightKey+    BoundedFanPlan fanPlan ->+      boundedFanKeyLeq fanPlan leftKey rightKey+{-# INLINE contextPlanLeq #-}++contextPlanJoinKey :: ContextPlan -> ContextKey -> ContextKey -> ContextKey+contextPlanJoinKey plan leftKey rightKey =+  case plan of+    DensePlan tablePlan ->+      denseTableJoinKey tablePlan leftKey rightKey+    MaskPlan maskPlan ->+      contextMaskPlanJoinKey maskPlan leftKey rightKey+    OrdinalTotalOrderPlan _ ->+      if contextKeyOrdinal leftKey >= contextKeyOrdinal rightKey+            then leftKey+            else rightKey+    TotalOrderPlan totalOrderPlan ->+      if totalOrderKeyRank totalOrderPlan leftKey+            >= totalOrderKeyRank totalOrderPlan rightKey+            then leftKey+            else rightKey+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanJoinKey size leftKey rightKey+    BoundedFanPlan fanPlan ->+      boundedFanJoinKey fanPlan leftKey rightKey+{-# INLINE contextPlanJoinKey #-}++contextPlanMeetKey :: ContextPlan -> ContextKey -> ContextKey -> ContextKey+contextPlanMeetKey plan leftKey rightKey =+  case plan of+    DensePlan tablePlan ->+      denseTableMeetKey tablePlan leftKey rightKey+    MaskPlan maskPlan ->+      contextMaskPlanMeetKey maskPlan leftKey rightKey+    OrdinalTotalOrderPlan _ ->+      if contextKeyOrdinal leftKey <= contextKeyOrdinal rightKey+            then leftKey+            else rightKey+    TotalOrderPlan totalOrderPlan ->+      if totalOrderKeyRank totalOrderPlan leftKey+            <= totalOrderKeyRank totalOrderPlan rightKey+            then leftKey+            else rightKey+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanMeetKey size leftKey rightKey+    BoundedFanPlan fanPlan ->+      boundedFanMeetKey fanPlan leftKey rightKey+{-# INLINE contextPlanMeetKey #-}++contextPlanJoinMeetKeys :: ContextPlan -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+contextPlanJoinMeetKeys plan leftKey rightKey =+  case plan of+    DensePlan tablePlan ->+      denseTableJoinMeetKeys tablePlan leftKey rightKey+    MaskPlan maskPlan ->+      contextMaskPlanJoinMeetKeys maskPlan leftKey rightKey+    OrdinalTotalOrderPlan _ ->+      if contextKeyOrdinal leftKey >= contextKeyOrdinal rightKey+            then (leftKey, rightKey)+            else (rightKey, leftKey)+    TotalOrderPlan totalOrderPlan ->+      let leftRank = totalOrderKeyRank totalOrderPlan leftKey+          rightRank = totalOrderKeyRank totalOrderPlan rightKey+       in if leftRank >= rightRank+                then (leftKey, rightKey)+                else (rightKey, leftKey)+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanJoinMeetKeys size leftKey rightKey+    BoundedFanPlan fanPlan ->+      boundedFanJoinMeetKeys fanPlan leftKey rightKey+{-# INLINE contextPlanJoinMeetKeys #-}++contextPlanUpperKeys :: ContextPlan -> ContextKey -> ContextKeySet+contextPlanUpperKeys plan key =+  case plan of+    DensePlan densePlan ->+      rowForKey (cdtpUpperRows densePlan) key+    MaskPlan maskPlan ->+      contextMaskPlanUpperKeys maskPlan key+    OrdinalTotalOrderPlan size ->+      ordinalTotalOrderKeysFromRank size (contextKeyOrdinal key) (size - 1)+    TotalOrderPlan totalOrderPlan ->+      totalOrderKeysFromRank+        totalOrderPlan+        (totalOrderKeyRank totalOrderPlan key)+        (UVector.length (ctoRankByKey totalOrderPlan) - 1)+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanUpperKeys size key+    BoundedFanPlan fanPlan ->+      boundedFanUpperKeys fanPlan key++contextPlanLowerKeys :: ContextPlan -> ContextKey -> ContextKeySet+contextPlanLowerKeys plan key =+  case plan of+    DensePlan densePlan ->+      rowForKey (cdtpLowerRows densePlan) key+    MaskPlan maskPlan ->+      contextMaskPlanLowerKeys maskPlan key+    OrdinalTotalOrderPlan size ->+      ordinalTotalOrderKeysFromRank size 0 (contextKeyOrdinal key)+    TotalOrderPlan totalOrderPlan ->+      totalOrderKeysFromRank+        totalOrderPlan+        0+        (totalOrderKeyRank totalOrderPlan key)+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanLowerKeys size key+    BoundedFanPlan fanPlan ->+      boundedFanLowerKeys fanPlan key++contextPlanUpperCoverKeys :: ContextPlan -> ContextKey -> ContextKeySet+contextPlanUpperCoverKeys plan key =+  case plan of+    DensePlan densePlan ->+      denseTableUpperCoverKeys densePlan key+    MaskPlan maskPlan ->+      contextMaskPlanUpperCoverKeys maskPlan key+    OrdinalTotalOrderPlan size ->+      ordinalTotalOrderUpperCoverKeys size key+    TotalOrderPlan totalOrderPlan ->+      let nextRank = totalOrderKeyRank totalOrderPlan key + 1+          size = UVector.length (ctoKeyByRank totalOrderPlan)+          chunkCount = contextKeySetChunkCount size+       in if nextRank < size+                then+                  contextKeySetSingleton+                    chunkCount+                    (totalOrderKeyAtRank totalOrderPlan nextRank)+                else contextKeySetEmpty chunkCount+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanUpperCoverKeys size key+    BoundedFanPlan fanPlan+      | key == cbfBottomKey fanPlan -> cbfAtomKeys fanPlan+      | key == cbfTopKey fanPlan ->+          contextKeySetEmpty (contextKeySetChunkCount (cbfSize fanPlan))+      | otherwise ->+          contextKeySetSingleton+                (contextKeySetChunkCount (cbfSize fanPlan))+                (cbfTopKey fanPlan)++contextPlanLowerCoverKeys :: ContextPlan -> ContextKey -> ContextKeySet+contextPlanLowerCoverKeys plan key =+  case plan of+    DensePlan densePlan ->+      denseTableLowerCoverKeys densePlan key+    MaskPlan maskPlan ->+      contextMaskPlanLowerCoverKeys maskPlan key+    OrdinalTotalOrderPlan size ->+      ordinalTotalOrderLowerCoverKeys size key+    TotalOrderPlan totalOrderPlan ->+      let previousRank = totalOrderKeyRank totalOrderPlan key - 1+          size = UVector.length (ctoKeyByRank totalOrderPlan)+          chunkCount = contextKeySetChunkCount size+       in if previousRank >= 0+                then+                  contextKeySetSingleton+                    chunkCount+                    (totalOrderKeyAtRank totalOrderPlan previousRank)+                else contextKeySetEmpty chunkCount+    OrdinalBoundedFanPlan size ->+      ordinalBoundedFanLowerCoverKeys size key+    BoundedFanPlan fanPlan+      | key == cbfTopKey fanPlan -> cbfAtomKeys fanPlan+      | key == cbfBottomKey fanPlan ->+          contextKeySetEmpty (contextKeySetChunkCount (cbfSize fanPlan))+      | otherwise ->+          contextKeySetSingleton+                (contextKeySetChunkCount (cbfSize fanPlan))+                (cbfBottomKey fanPlan)++-- | Dense plans already contain the transitive relation, so scanning all+-- successors is cheaper than reconstructing the Hasse diagram. The reflexive+-- edge is harmless for monotonicity and avoids allocating a copied row merely+-- to delete one bit.+-- Specialized plans enumerate covers. Either set generates the order and is+-- sufficient for an exact monotonicity check.+contextPlanMonotonicityTargets :: ContextPlan -> ContextKey -> ContextKeySet+contextPlanMonotonicityTargets plan key =+  case plan of+    DensePlan _ ->+      contextPlanUpperKeys plan key+    MaskPlan maskPlan ->+      contextMaskPlanMonotonicityTargets maskPlan key+    _ -> contextPlanUpperCoverKeys plan key++contextMaskPlanLeq :: ContextMaskPlan -> ContextKey -> ContextKey -> Bool+contextMaskPlanLeq plan leftKey rightKey =+  case plan of+    BooleanPlan booleanPlan ->+      let leftMask = booleanMaskForKey booleanPlan leftKey+          rightMask = booleanMaskForKey booleanPlan rightKey+       in leftMask .&. rightMask == leftMask+    DistributivePlan distributivePlan ->+      distributiveKeyLeq distributivePlan leftKey rightKey+    DenseRowsPlan rowsPlan ->+      contextKeyRelated (cdrpUpperRows rowsPlan) leftKey rightKey+{-# INLINE contextMaskPlanLeq #-}++contextMaskPlanJoinKey :: ContextMaskPlan -> ContextKey -> ContextKey -> ContextKey+contextMaskPlanJoinKey plan leftKey rightKey =+  case plan of+    BooleanPlan booleanPlan ->+      booleanKeyForMask+            booleanPlan+            ( booleanMaskForKey booleanPlan leftKey+                .|. booleanMaskForKey booleanPlan rightKey+            )+    DistributivePlan distributivePlan ->+      distributiveJoinKey distributivePlan leftKey rightKey+    DenseRowsPlan rowsPlan ->+      denseRowsJoinKey rowsPlan leftKey rightKey+{-# INLINE contextMaskPlanJoinKey #-}++contextMaskPlanMeetKey :: ContextMaskPlan -> ContextKey -> ContextKey -> ContextKey+contextMaskPlanMeetKey plan leftKey rightKey =+  case plan of+    BooleanPlan booleanPlan ->+      booleanKeyForMask+            booleanPlan+            ( booleanMaskForKey booleanPlan leftKey+                .&. booleanMaskForKey booleanPlan rightKey+            )+    DistributivePlan distributivePlan ->+      distributiveMeetKey distributivePlan leftKey rightKey+    DenseRowsPlan rowsPlan ->+      denseRowsMeetKey rowsPlan leftKey rightKey+{-# INLINE contextMaskPlanMeetKey #-}++contextMaskPlanJoinMeetKeys :: ContextMaskPlan -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+contextMaskPlanJoinMeetKeys plan leftKey rightKey =+  case plan of+    BooleanPlan booleanPlan ->+      let leftMask = booleanMaskForKey booleanPlan leftKey+          rightMask = booleanMaskForKey booleanPlan rightKey+       in ( booleanKeyForMask booleanPlan (leftMask .|. rightMask),+              booleanKeyForMask booleanPlan (leftMask .&. rightMask)+            )+    DistributivePlan distributivePlan ->+      distributiveJoinMeetKeys distributivePlan leftKey rightKey+    DenseRowsPlan rowsPlan ->+      ( denseRowsJoinKey rowsPlan leftKey rightKey,+        denseRowsMeetKey rowsPlan leftKey rightKey+      )+{-# NOINLINE contextMaskPlanJoinMeetKeys #-}++contextMaskPlanUpperKeys :: ContextMaskPlan -> ContextKey -> ContextKeySet+contextMaskPlanUpperKeys plan key =+  case plan of+    BooleanPlan booleanPlan ->+      booleanUpperKeys booleanPlan key+    DistributivePlan distributivePlan ->+      distributiveUpperKeys distributivePlan key+    DenseRowsPlan rowsPlan ->+      rowForKey (cdrpUpperRows rowsPlan) key++contextMaskPlanLowerKeys :: ContextMaskPlan -> ContextKey -> ContextKeySet+contextMaskPlanLowerKeys plan key =+  case plan of+    BooleanPlan booleanPlan ->+      booleanLowerKeys booleanPlan key+    DistributivePlan distributivePlan ->+      distributiveLowerKeys distributivePlan key+    DenseRowsPlan rowsPlan ->+      rowForKey (cdrpLowerRows rowsPlan) key++contextMaskPlanUpperCoverKeys :: ContextMaskPlan -> ContextKey -> ContextKeySet+contextMaskPlanUpperCoverKeys plan key =+  case plan of+    BooleanPlan booleanPlan ->+      booleanUpperCoverKeys booleanPlan key+    DistributivePlan distributivePlan ->+      distributiveUpperCoverKeys distributivePlan key+    DenseRowsPlan rowsPlan ->+      denseRowsUpperCoverKeys rowsPlan key++contextMaskPlanLowerCoverKeys :: ContextMaskPlan -> ContextKey -> ContextKeySet+contextMaskPlanLowerCoverKeys plan key =+  case plan of+    BooleanPlan booleanPlan ->+      booleanLowerCoverKeys booleanPlan key+    DistributivePlan distributivePlan ->+      distributiveLowerCoverKeys distributivePlan key+    DenseRowsPlan rowsPlan ->+      denseRowsLowerCoverKeys rowsPlan key++contextMaskPlanMonotonicityTargets :: ContextMaskPlan -> ContextKey -> ContextKeySet+contextMaskPlanMonotonicityTargets plan key =+  case plan of+    BooleanPlan booleanPlan -> booleanUpperCoverKeys booleanPlan key+    DistributivePlan _ -> contextMaskPlanUpperKeys plan key+    DenseRowsPlan _ -> contextMaskPlanUpperKeys plan key++denseTableJoinKey :: ContextDenseTablePlan -> ContextKey -> ContextKey -> ContextKey+denseTableJoinKey plan =+  contextKeyTableLookup (cdtpJoinTable plan)+{-# INLINE denseTableJoinKey #-}++denseTableMeetKey :: ContextDenseTablePlan -> ContextKey -> ContextKey -> ContextKey+denseTableMeetKey plan =+  contextKeyTableLookup (cdtpMeetTable plan)+{-# INLINE denseTableMeetKey #-}++denseTableJoinMeetKeys :: ContextDenseTablePlan -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+denseTableJoinMeetKeys plan leftKey rightKey =+  ( contextKeyTableLookup (cdtpJoinTable plan) leftKey rightKey,+    contextKeyTableLookup (cdtpMeetTable plan) leftKey rightKey+  )+{-# INLINE denseTableJoinMeetKeys #-}++denseRowsJoinKey :: ContextDenseRowsPlan -> ContextKey -> ContextKey -> ContextKey+denseRowsJoinKey plan leftKey rightKey =+  invariantLookup+    (ContextPlanJoinMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+    (rowJoinKeyMaybe (cdrpUpperRows plan) (cdrpLowerRows plan) (cdrpUpperRowIndex plan) leftKey rightKey)+{-# INLINE denseRowsJoinKey #-}++denseRowsMeetKey :: ContextDenseRowsPlan -> ContextKey -> ContextKey -> ContextKey+denseRowsMeetKey plan leftKey rightKey =+  invariantLookup+    (ContextPlanMeetMissing (contextKeyOrdinal leftKey) (contextKeyOrdinal rightKey))+    (rowMeetKeyMaybe (cdrpUpperRows plan) (cdrpLowerRows plan) (cdrpLowerRowIndex plan) leftKey rightKey)+{-# INLINE denseRowsMeetKey #-}+++-- A candidate u is an upper cover of l iff there is no member of+-- (up(l) \\ {l}) ∩ down(u) other than u.+denseTableUpperCoverKeys :: ContextDenseTablePlan -> ContextKey -> ContextKeySet+denseTableUpperCoverKeys plan lowerKey =+  contextKeySetFilter isCover candidates+  where+    candidates =+      contextKeySetDelete+        (contextKeyOrdinal lowerKey)+        (rowForKey (cdtpUpperRows plan) lowerKey)++    isCover upperOrdinal =+      not+        ( contextKeySetIntersectsExcept+            upperOrdinal+            candidates+            (rowForKey (cdtpLowerRows plan) (ContextKey upperOrdinal))+        )++-- Dual of 'denseTableUpperCoverKeys'.+denseTableLowerCoverKeys :: ContextDenseTablePlan -> ContextKey -> ContextKeySet+denseTableLowerCoverKeys plan upperKey =+  contextKeySetFilter isCover candidates+  where+    candidates =+      contextKeySetDelete+        (contextKeyOrdinal upperKey)+        (rowForKey (cdtpLowerRows plan) upperKey)++    isCover lowerOrdinal =+      not+        ( contextKeySetIntersectsExcept+            lowerOrdinal+            candidates+            (rowForKey (cdtpUpperRows plan) (ContextKey lowerOrdinal))+        )++denseRowsUpperCoverKeys :: ContextDenseRowsPlan -> ContextKey -> ContextKeySet+denseRowsUpperCoverKeys plan lowerKey =+  contextKeySetFilter isCover candidates+  where+    candidates =+      contextKeySetDelete+        (contextKeyOrdinal lowerKey)+        (rowForKey (cdrpUpperRows plan) lowerKey)++    isCover upperOrdinal =+      not+        ( contextKeySetIntersectsExcept+            upperOrdinal+            candidates+            (rowForKey (cdrpLowerRows plan) (ContextKey upperOrdinal))+        )++denseRowsLowerCoverKeys :: ContextDenseRowsPlan -> ContextKey -> ContextKeySet+denseRowsLowerCoverKeys plan upperKey =+  contextKeySetFilter isCover candidates+  where+    candidates =+      contextKeySetDelete+        (contextKeyOrdinal upperKey)+        (rowForKey (cdrpLowerRows plan) upperKey)++    isCover lowerOrdinal =+      not+        ( contextKeySetIntersectsExcept+            lowerOrdinal+            candidates+            (rowForKey (cdrpUpperRows plan) (ContextKey lowerOrdinal))+        )+++totalOrderKeyRank :: ContextTotalOrderPlan -> ContextKey -> Int+totalOrderKeyRank plan (ContextKey keyOrdinal) =+  unboxedIndexInvariant (ctoRankByKey plan) keyOrdinal+{-# INLINE totalOrderKeyRank #-}++totalOrderKeyAtRank :: ContextTotalOrderPlan -> Int -> ContextKey+totalOrderKeyAtRank plan rank =+  ContextKey (unboxedIndexInvariant (ctoKeyByRank plan) rank)+{-# INLINE totalOrderKeyAtRank #-}++totalOrderKeysFromRank :: ContextTotalOrderPlan -> Int -> Int -> ContextKeySet+totalOrderKeysFromRank plan firstRank lastRank =+  contextKeySetFromKeys+    (contextKeySetChunkCount size)+    [ contextKeyOrdinal (totalOrderKeyAtRank plan rank)+    | rank <- [firstRank .. lastRank]+    ]+  where+    size = UVector.length (ctoKeyByRank plan)++ordinalTotalOrderKeysFromRank :: Int -> Int -> Int -> ContextKeySet+ordinalTotalOrderKeysFromRank size firstRank lastRank =+  contextKeySetFromKeys (contextKeySetChunkCount size) [firstRank .. lastRank]++ordinalTotalOrderUpperCoverKeys :: Int -> ContextKey -> ContextKeySet+ordinalTotalOrderUpperCoverKeys size (ContextKey keyOrdinal)+  | nextOrdinal < size =+      contextKeySetSingleton+        (contextKeySetChunkCount size)+        (ContextKey nextOrdinal)+  | otherwise = contextKeySetEmpty (contextKeySetChunkCount size)+  where+    nextOrdinal = keyOrdinal + 1++ordinalTotalOrderLowerCoverKeys :: Int -> ContextKey -> ContextKeySet+ordinalTotalOrderLowerCoverKeys size (ContextKey keyOrdinal)+  | previousOrdinal >= 0 =+      contextKeySetSingleton+        (contextKeySetChunkCount size)+        (ContextKey previousOrdinal)+  | otherwise = contextKeySetEmpty (contextKeySetChunkCount size)+  where+    previousOrdinal = keyOrdinal - 1++ordinalBoundedFanKeyLeq :: Int -> ContextKey -> ContextKey -> Bool+ordinalBoundedFanKeyLeq size (ContextKey leftOrdinal) (ContextKey rightOrdinal) =+  leftOrdinal == rightOrdinal+    || leftOrdinal == ordinalBottomOrdinal+    || rightOrdinal == ordinalTopOrdinal size+{-# INLINE ordinalBoundedFanKeyLeq #-}++ordinalBoundedFanJoinKey :: Int -> ContextKey -> ContextKey -> ContextKey+ordinalBoundedFanJoinKey size leftKey@(ContextKey leftOrdinal) rightKey@(ContextKey rightOrdinal)+  | leftOrdinal == ordinalBottomOrdinal = rightKey+  | rightOrdinal == ordinalBottomOrdinal = leftKey+  | leftOrdinal == rightOrdinal = leftKey+  | otherwise = ContextKey (ordinalTopOrdinal size)+{-# INLINE ordinalBoundedFanJoinKey #-}++ordinalBoundedFanMeetKey :: Int -> ContextKey -> ContextKey -> ContextKey+ordinalBoundedFanMeetKey size leftKey@(ContextKey leftOrdinal) rightKey@(ContextKey rightOrdinal)+  | leftOrdinal == ordinalTopOrdinal size = rightKey+  | rightOrdinal == ordinalTopOrdinal size = leftKey+  | leftOrdinal == rightOrdinal = leftKey+  | otherwise = ContextKey ordinalBottomOrdinal+{-# INLINE ordinalBoundedFanMeetKey #-}++ordinalBoundedFanJoinMeetKeys :: Int -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+ordinalBoundedFanJoinMeetKeys size leftKey rightKey =+  (ordinalBoundedFanJoinKey size leftKey rightKey, ordinalBoundedFanMeetKey size leftKey rightKey)+{-# INLINE ordinalBoundedFanJoinMeetKeys #-}++ordinalBoundedFanUpperKeys :: Int -> ContextKey -> ContextKeySet+ordinalBoundedFanUpperKeys size key@(ContextKey keyOrdinal)+  | keyOrdinal == ordinalBottomOrdinal = contextKeySetAll size+  | keyOrdinal == ordinalTopOrdinal size =+      contextKeySetSingleton chunkCount (ContextKey (ordinalTopOrdinal size))+  | otherwise =+      contextKeySetFromKeys chunkCount [contextKeyOrdinal key, ordinalTopOrdinal size]+  where+    chunkCount = contextKeySetChunkCount size++ordinalBoundedFanLowerKeys :: Int -> ContextKey -> ContextKeySet+ordinalBoundedFanLowerKeys size key@(ContextKey keyOrdinal)+  | keyOrdinal == ordinalBottomOrdinal =+      contextKeySetSingleton chunkCount (ContextKey ordinalBottomOrdinal)+  | keyOrdinal == ordinalTopOrdinal size = contextKeySetAll size+  | otherwise =+      contextKeySetFromKeys chunkCount [ordinalBottomOrdinal, contextKeyOrdinal key]+  where+    chunkCount = contextKeySetChunkCount size++ordinalBoundedFanUpperCoverKeys :: Int -> ContextKey -> ContextKeySet+ordinalBoundedFanUpperCoverKeys size (ContextKey keyOrdinal)+  | keyOrdinal == ordinalBottomOrdinal =+      contextKeySetFromKeys (contextKeySetChunkCount size) [1 .. ordinalTopOrdinal size - 1]+  | keyOrdinal == ordinalTopOrdinal size =+      contextKeySetEmpty (contextKeySetChunkCount size)+  | otherwise =+      contextKeySetSingleton (contextKeySetChunkCount size) (ContextKey (ordinalTopOrdinal size))++ordinalBoundedFanLowerCoverKeys :: Int -> ContextKey -> ContextKeySet+ordinalBoundedFanLowerCoverKeys size (ContextKey keyOrdinal)+  | keyOrdinal == ordinalTopOrdinal size =+      contextKeySetFromKeys (contextKeySetChunkCount size) [1 .. ordinalTopOrdinal size - 1]+  | keyOrdinal == ordinalBottomOrdinal =+      contextKeySetEmpty (contextKeySetChunkCount size)+  | otherwise =+      contextKeySetSingleton (contextKeySetChunkCount size) (ContextKey ordinalBottomOrdinal)++ordinalTopOrdinal :: Int -> Int+ordinalTopOrdinal size =+  size - 1+{-# INLINE ordinalTopOrdinal #-}++ordinalBottomOrdinal :: Int+ordinalBottomOrdinal =+  0+{-# INLINE ordinalBottomOrdinal #-}++boundedFanKeyLeq :: ContextBoundedFanPlan -> ContextKey -> ContextKey -> Bool+boundedFanKeyLeq plan leftKey rightKey =+  leftKey == rightKey+    || leftKey == cbfBottomKey plan+    || rightKey == cbfTopKey plan+{-# INLINE boundedFanKeyLeq #-}++boundedFanJoinKey :: ContextBoundedFanPlan -> ContextKey -> ContextKey -> ContextKey+boundedFanJoinKey plan leftKey rightKey+  | leftKey == cbfBottomKey plan = rightKey+  | rightKey == cbfBottomKey plan = leftKey+  | leftKey == rightKey = leftKey+  | otherwise = cbfTopKey plan+{-# INLINE boundedFanJoinKey #-}++boundedFanMeetKey :: ContextBoundedFanPlan -> ContextKey -> ContextKey -> ContextKey+boundedFanMeetKey plan leftKey rightKey+  | leftKey == cbfTopKey plan = rightKey+  | rightKey == cbfTopKey plan = leftKey+  | leftKey == rightKey = leftKey+  | otherwise = cbfBottomKey plan+{-# INLINE boundedFanMeetKey #-}++boundedFanJoinMeetKeys :: ContextBoundedFanPlan -> ContextKey -> ContextKey -> (ContextKey, ContextKey)+boundedFanJoinMeetKeys plan leftKey rightKey =+  (boundedFanJoinKey plan leftKey rightKey, boundedFanMeetKey plan leftKey rightKey)+{-# INLINE boundedFanJoinMeetKeys #-}++boundedFanUpperKeys :: ContextBoundedFanPlan -> ContextKey -> ContextKeySet+boundedFanUpperKeys plan key+  | key == cbfBottomKey plan = cbfAllKeys plan+  | key == cbfTopKey plan =+      contextKeySetSingleton chunkCount (cbfTopKey plan)+  | otherwise =+      contextKeySetFromKeys+        chunkCount+        [contextKeyOrdinal key, contextKeyOrdinal (cbfTopKey plan)]+  where+    chunkCount = contextKeySetChunkCount (cbfSize plan)++boundedFanLowerKeys :: ContextBoundedFanPlan -> ContextKey -> ContextKeySet+boundedFanLowerKeys plan key+  | key == cbfBottomKey plan =+      contextKeySetSingleton chunkCount (cbfBottomKey plan)+  | key == cbfTopKey plan = cbfAllKeys plan+  | otherwise =+      contextKeySetFromKeys+        chunkCount+        [contextKeyOrdinal (cbfBottomKey plan), contextKeyOrdinal key]+  where+    chunkCount = contextKeySetChunkCount (cbfSize plan)++booleanMaskForKey :: ContextBooleanPlan -> ContextKey -> Word64+booleanMaskForKey plan (ContextKey keyOrdinal) =+  unboxedIndexInvariant (cboMaskByKey plan) keyOrdinal+{-# INLINE booleanMaskForKey #-}++booleanKeyForMask :: ContextBooleanPlan -> Word64 -> ContextKey+booleanKeyForMask plan mask =+  ContextKey (unboxedIndexInvariant (cboKeyByMask plan) (fromIntegral mask))+{-# INLINE booleanKeyForMask #-}++booleanUpperKeys :: ContextBooleanPlan -> ContextKey -> ContextKeySet+booleanUpperKeys plan key =+  contextKeySetFromKeys+    (contextKeySetChunkCount size)+    [ contextKeyOrdinal (booleanKeyForMask plan (keyMask .|. freeSubmask))+    | freeSubmask <- submasks freeMask+    ]+  where+    size = UVector.length (cboMaskByKey plan)+    keyMask = booleanMaskForKey plan key+    freeMask = cboFullMask plan `xor` keyMask++booleanLowerKeys :: ContextBooleanPlan -> ContextKey -> ContextKeySet+booleanLowerKeys plan key =+  contextKeySetFromKeys+    (contextKeySetChunkCount size)+    [ contextKeyOrdinal (booleanKeyForMask plan lowerMask)+    | lowerMask <- submasks keyMask+    ]+  where+    size = UVector.length (cboMaskByKey plan)+    keyMask = booleanMaskForKey plan key++booleanUpperCoverKeys :: ContextBooleanPlan -> ContextKey -> ContextKeySet+booleanUpperCoverKeys plan key =+  contextKeySetFromKeys+    (contextKeySetChunkCount size)+    [ contextKeyOrdinal (booleanKeyForMask plan (keyMask .|. bit atomIndex))+    | atomIndex <- [0 .. cboAtomCount plan - 1],+      not (testBit keyMask atomIndex)+    ]+  where+    size = UVector.length (cboMaskByKey plan)+    keyMask = booleanMaskForKey plan key++booleanLowerCoverKeys :: ContextBooleanPlan -> ContextKey -> ContextKeySet+booleanLowerCoverKeys plan key =+  contextKeySetFromKeys+    (contextKeySetChunkCount size)+    [ contextKeyOrdinal+        ( booleanKeyForMask+            plan+            (keyMask .&. (cboFullMask plan .&. complement (bit atomIndex)))+        )+    | atomIndex <- [0 .. cboAtomCount plan - 1],+      testBit keyMask atomIndex+    ]+  where+    size = UVector.length (cboMaskByKey plan)+    keyMask = booleanMaskForKey plan key++submasks :: Word64 -> [Word64]+submasks mask =+  go mask+  where+    go submask+      | submask == 0 = [0]+      | otherwise = submask : go ((submask - 1) .&. mask)+
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Recognize.hs view
@@ -0,0 +1,607 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE TupleSections #-}++module Moonlight.FiniteLattice.Internal.Recognize+  ( specializedContextPlanFromDeclaredPairs,+    specializedContextPlanFromRows,+  )+where++import Control.Applicative ((<|>))+import Control.Monad (foldM)+import Data.Bits+  ( (.&.),+    (.|.),+    bit,+    countTrailingZeros,+  )+import Data.Foldable qualified as Foldable+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List (unfoldr)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector.Unboxed qualified as UVector+import Data.Word (Word64)+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    contextKeySetAll,+    contextKeySetCardinality,+    contextKeySetChunkCount,+    contextKeySetFromKeys,+    contextKeySetMember,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( ContextBooleanPlan (..),+    ContextBoundedFanPlan (..),+    ContextMaskPlan (..),+    ContextPlan (..),+    ContextTotalOrderPlan (..),+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( ContextRows,+    contextKeyRelated,+    rowForRawKey,+  )+import Moonlight.FiniteLattice.Internal.Topological+  ( topologicalOrder,+  )+specializedContextPlanFromDeclaredPairs ::+  Int ->+  ContextKey ->+  ContextKey ->+  [(ContextKey, ContextKey)] ->+  Maybe ContextPlan+specializedContextPlanFromDeclaredPairs size topKey bottomKey declaredPairs =+  totalOrderPlanFromDeclaredPairs size topKey bottomKey declaredPairs+    <|> booleanPlanFromDeclaredPairs size topKey bottomKey declaredPairs+    <|> boundedFanPlanFromDeclaredPairs size topKey bottomKey declaredPairs++specializedContextPlanFromRows ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Maybe ContextPlan+specializedContextPlanFromRows size topKey bottomKey upperRows lowerRows =+  totalOrderPlanFromRows size topKey bottomKey upperRows lowerRows+    <|> booleanPlanFromRows size topKey bottomKey upperRows lowerRows+    <|> boundedFanPlanFromRows size topKey bottomKey upperRows lowerRows++totalOrderPlanFromDeclaredPairs ::+  Int ->+  ContextKey ->+  ContextKey ->+  [(ContextKey, ContextKey)] ->+  Maybe ContextPlan+totalOrderPlanFromDeclaredPairs size topKey@(ContextKey topOrdinal) bottomKey@(ContextKey bottomOrdinal) declaredPairs+  | size <= 0 = Nothing+  | not (contextKeysInBounds size topKey bottomKey) = Nothing+  | size == 1 =+      if topKey == bottomKey && Set.null strictPairs+        then+          Just+            ( TotalOrderPlan+                ContextTotalOrderPlan+                  { ctoTopKey = topKey,+                    ctoRankByKey = UVector.singleton 0,+                    ctoKeyByRank = UVector.singleton bottomOrdinal+                  }+            )+        else Nothing+  | topKey == bottomKey = Nothing+  | Set.size strictPairs /= size - 1 = Nothing+  | IntMap.size successorBySource /= size - 1 = Nothing+  | IntMap.size predecessorByTarget /= size - 1 = Nothing+  | IntMap.member bottomOrdinal predecessorByTarget = Nothing+  | IntMap.member topOrdinal successorBySource = Nothing+  | otherwise = do+      let path = successorPath size successorBySource bottomOrdinal+      guardMaybe (length path == size)+      guardMaybe (IntSet.fromList path == allContextKeyOrdinals size)+      let rankByKey = totalOrderRankByKey size path+      guardMaybe (totalOrderKeyRankValue rankByKey bottomOrdinal == Just 0)+      guardMaybe (totalOrderKeyRankValue rankByKey topOrdinal == Just (size - 1))+      pure+        ( if path == [0 .. size - 1]+            then OrdinalTotalOrderPlan size+            else+              TotalOrderPlan+              ContextTotalOrderPlan+                { ctoTopKey = topKey,+                  ctoRankByKey = rankByKey,+                    ctoKeyByRank = UVector.fromList path+                  }+        )+  where+    strictPairs = declaredStrictPairOrdinals declaredPairs+    successorBySource = IntMap.fromList (Set.toAscList strictPairs)+    predecessorByTarget =+      IntMap.fromList+        [ (targetOrdinal, sourceOrdinal)+        | (sourceOrdinal, targetOrdinal) <- Set.toAscList strictPairs+        ]++totalOrderPlanFromRows ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Maybe ContextPlan+totalOrderPlanFromRows size topKey bottomKey upperRows lowerRows = do+  guardMaybe (size > 0)+  let rankEntries =+        [ (keyOrdinal, contextKeySetCardinality (rowForRawKey lowerRows keyOrdinal) - 1)+        | keyOrdinal <- [0 .. size - 1]+        ]+      ranks = IntSet.fromList (fmap snd rankEntries)+  guardMaybe (ranks == IntSet.fromDistinctAscList [0 .. size - 1])+  guardMaybe+    ( all+        (\keyOrdinal ->+           contextKeySetCardinality (rowForRawKey upperRows keyOrdinal)+             + contextKeySetCardinality (rowForRawKey lowerRows keyOrdinal)+             == size + 1+        )+        [0 .. size - 1]+    )+  let rankByKey =+        UVector.accum+          (\_ rank -> rank)+          (UVector.replicate size (-1))+          rankEntries+      keyByRank =+        UVector.accum+          (\_ keyOrdinal -> keyOrdinal)+          (UVector.replicate size (-1))+          [ (rank, keyOrdinal)+          | (keyOrdinal, rank) <- rankEntries+          ]+  guardMaybe (UVector.all (>= 0) rankByKey)+  guardMaybe (UVector.all (>= 0) keyByRank)+  guardMaybe (totalOrderKeyRankValue rankByKey (contextKeyOrdinal bottomKey) == Just 0)+  guardMaybe (totalOrderKeyRankValue rankByKey (contextKeyOrdinal topKey) == Just (size - 1))+  pure+    ( if all (uncurry (==)) rankEntries+        then OrdinalTotalOrderPlan size+        else+          TotalOrderPlan+            ContextTotalOrderPlan+              { ctoTopKey = topKey,+                ctoRankByKey = rankByKey,+                ctoKeyByRank = keyByRank+              }+    )++boundedFanPlanFromDeclaredPairs ::+  Int ->+  ContextKey ->+  ContextKey ->+  [(ContextKey, ContextKey)] ->+  Maybe ContextPlan+boundedFanPlanFromDeclaredPairs size topKey@(ContextKey topOrdinal) bottomKey@(ContextKey bottomOrdinal) declaredPairs+  | size < 3 = Nothing+  | topKey == bottomKey = Nothing+  | not (contextKeysInBounds size topKey bottomKey) = Nothing+  | declaredStrictPairOrdinals declaredPairs /= expectedPairs = Nothing+  | otherwise =+      Just+        ( if bottomOrdinal == 0 && topOrdinal == size - 1+            then OrdinalBoundedFanPlan size+            else+              BoundedFanPlan+                ContextBoundedFanPlan+                  { cbfSize = size,+                    cbfTopKey = topKey,+                    cbfBottomKey = bottomKey,+                    cbfAtomKeys = contextKeySetFromKeys chunkCount atomOrdinals,+                    cbfAllKeys = contextKeySetAll size+                  }+        )+  where+    chunkCount = contextKeySetChunkCount size+    atomOrdinals =+      [ keyOrdinal+      | keyOrdinal <- [0 .. size - 1],+        keyOrdinal /= topOrdinal,+        keyOrdinal /= bottomOrdinal+      ]+    expectedPairs =+      Set.fromList+        ( fmap (bottomOrdinal,) atomOrdinals+            <> fmap (,topOrdinal) atomOrdinals+        )++boundedFanPlanFromRows ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Maybe ContextPlan+boundedFanPlanFromRows size topKey bottomKey upperRows lowerRows = do+  guardMaybe (size >= 3 && topKey /= bottomKey)+  guardMaybe+    ( all+        (boundedFanKeyRowsMatch size topKey bottomKey upperRows lowerRows)+        [0 .. size - 1]+    )+  pure+    ( if contextKeyOrdinal bottomKey == 0 && contextKeyOrdinal topKey == size - 1+        then OrdinalBoundedFanPlan size+        else+          BoundedFanPlan+            ContextBoundedFanPlan+              { cbfSize = size,+                cbfTopKey = topKey,+                cbfBottomKey = bottomKey,+                cbfAtomKeys =+                  contextKeySetFromKeys+                    (contextKeySetChunkCount size)+                    [ keyOrdinal+                    | keyOrdinal <- [0 .. size - 1],+                      ContextKey keyOrdinal /= topKey,+                      ContextKey keyOrdinal /= bottomKey+                    ],+                cbfAllKeys = contextKeySetAll size+              }+    )++boundedFanKeyRowsMatch ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Int ->+  Bool+boundedFanKeyRowsMatch size topKey bottomKey upperRows lowerRows keyOrdinal+  | key == bottomKey =+      upperCardinality == size+        && lowerCardinality == 1+        && contextKeySetMember keyOrdinal lowerRow+  | key == topKey =+      upperCardinality == 1+        && lowerCardinality == size+        && contextKeySetMember keyOrdinal upperRow+  | otherwise =+      upperCardinality == 2+        && lowerCardinality == 2+        && contextKeySetMember keyOrdinal upperRow+        && contextKeySetMember (contextKeyOrdinal topKey) upperRow+        && contextKeySetMember keyOrdinal lowerRow+        && contextKeySetMember (contextKeyOrdinal bottomKey) lowerRow+  where+    key = ContextKey keyOrdinal+    upperRow = rowForRawKey upperRows keyOrdinal+    lowerRow = rowForRawKey lowerRows keyOrdinal+    upperCardinality = contextKeySetCardinality upperRow+    lowerCardinality = contextKeySetCardinality lowerRow++booleanPlanFromDeclaredPairs ::+  Int ->+  ContextKey ->+  ContextKey ->+  [(ContextKey, ContextKey)] ->+  Maybe ContextPlan+booleanPlanFromDeclaredPairs size topKey bottomKey@(ContextKey bottomOrdinal) declaredPairs = do+  atomCount <- booleanAtomCountFromSize size+  guardMaybe (atomCount >= 2)+  guardMaybe (contextKeysInBounds size topKey bottomKey && topKey /= bottomKey)+  topologicalOrder' <- coverTopologicalOrder size strictPairs+  let successorSets = coverSuccessorSets strictPairs+      predecessorSets = coverPredecessorSets strictPairs+      atomOrdinals =+        IntSet.toAscList+          (IntMap.findWithDefault IntSet.empty bottomOrdinal successorSets)+  guardMaybe (length atomOrdinals == atomCount)+  let atomBitByKey =+        IntMap.fromDistinctAscList+          [ (atomOrdinal, bit atomIndex)+          | (atomOrdinal, atomIndex) <- zip atomOrdinals [0 .. atomCount - 1]+          ]+      fullMask = bit atomCount - 1+  maskByKeyMap <-+    booleanMaskMapFromCover+      size+      bottomOrdinal+      atomBitByKey+      predecessorSets+      topologicalOrder'+  let keyByMaskMap =+        Map.fromList+          [ (mask, keyOrdinal)+          | (keyOrdinal, mask) <- IntMap.toAscList maskByKeyMap+          ]+  guardMaybe (IntMap.size maskByKeyMap == size)+  guardMaybe (Map.size keyByMaskMap == size)+  guardMaybe (IntMap.lookup bottomOrdinal maskByKeyMap == Just 0)+  guardMaybe (IntMap.lookup (contextKeyOrdinal topKey) maskByKeyMap == Just fullMask)+  let maskByKey =+        UVector.generate+          size+          (\keyOrdinal -> IntMap.findWithDefault maxBound keyOrdinal maskByKeyMap)+      keyByMask =+        UVector.generate+          size+          (\maskOrdinal -> Map.findWithDefault (-1) (fromIntegral maskOrdinal) keyByMaskMap)+  guardMaybe (UVector.all (/= maxBound) maskByKey)+  guardMaybe (UVector.all (>= 0) keyByMask)+  guardMaybe+    ( strictPairs+        == booleanExpectedCoverPairs atomCount fullMask keyByMask+    )+  pure+    ( MaskPlan+        ( BooleanPlan+            ContextBooleanPlan+              { cboAtomCount = atomCount,+                cboFullMask = fullMask,+                cboMaskByKey = maskByKey,+                cboKeyByMask = keyByMask+              }+        )+    )+  where+    strictPairs = declaredStrictPairOrdinals declaredPairs++booleanPlanFromRows ::+  Int ->+  ContextKey ->+  ContextKey ->+  ContextRows ->+  ContextRows ->+  Maybe ContextPlan+booleanPlanFromRows size topKey bottomKey upperRows lowerRows = do+  atomCount <- booleanAtomCountFromSize size+  guardMaybe (atomCount >= 2)+  guardMaybe (contextKeysInBounds size topKey bottomKey)+  let atomOrdinals =+        [ keyOrdinal+        | keyOrdinal <- [0 .. size - 1],+          let lowerSet = rowForRawKey lowerRows keyOrdinal,+          ContextKey keyOrdinal /= bottomKey,+          contextKeySetCardinality lowerSet == 2,+          contextKeySetMember (contextKeyOrdinal bottomKey) lowerSet,+          contextKeySetMember keyOrdinal lowerSet+        ]+  guardMaybe (length atomOrdinals == atomCount)+  let atomBitByKey =+        IntMap.fromDistinctAscList+          [ (atomOrdinal, bit atomIndex)+          | (atomOrdinal, atomIndex) <- zip atomOrdinals [0 .. atomCount - 1]+          ]+      fullMask = bit atomCount - 1+      maskByKeyMap =+        IntMap.fromDistinctAscList+          [ (keyOrdinal, booleanMaskForRows upperRows atomBitByKey keyOrdinal)+          | keyOrdinal <- [0 .. size - 1]+          ]+      keyByMaskMap =+        Map.fromList+          [ (mask, keyOrdinal)+          | (keyOrdinal, mask) <- IntMap.toAscList maskByKeyMap+          ]+  guardMaybe (Map.size keyByMaskMap == size)+  guardMaybe (IntMap.lookup (contextKeyOrdinal bottomKey) maskByKeyMap == Just 0)+  guardMaybe (IntMap.lookup (contextKeyOrdinal topKey) maskByKeyMap == Just fullMask)+  guardMaybe (booleanOrderMatchesMasks size upperRows maskByKeyMap)+  let maskByKey =+        UVector.generate+          size+          (\keyOrdinal -> IntMap.findWithDefault maxBound keyOrdinal maskByKeyMap)+      keyByMask =+        UVector.generate+          size+          (\maskOrdinal -> Map.findWithDefault (-1) (fromIntegral maskOrdinal) keyByMaskMap)+  guardMaybe (UVector.all (/= maxBound) maskByKey)+  guardMaybe (UVector.all (>= 0) keyByMask)+  pure+    ( MaskPlan+        ( BooleanPlan+            ContextBooleanPlan+              { cboAtomCount = atomCount,+                cboFullMask = fullMask,+                cboMaskByKey = maskByKey,+                cboKeyByMask = keyByMask+              }+        )+    )++booleanMaskForRows ::+  ContextRows ->+  IntMap Word64 ->+  Int ->+  Word64+booleanMaskForRows upperRows atomBitByKey keyOrdinal =+  IntMap.foldlWithKey'+    (\mask atomOrdinal atomBit ->+       if+         contextKeyRelated+           upperRows+           (ContextKey atomOrdinal)+           (ContextKey keyOrdinal)+         then mask .|. atomBit+         else mask+    )+    0+    atomBitByKey++booleanOrderMatchesMasks ::+  Int ->+  ContextRows ->+  IntMap Word64 ->+  Bool+booleanOrderMatchesMasks size upperRows maskByKeyMap =+  all relationMatches+    [ (leftOrdinal, rightOrdinal)+    | leftOrdinal <- [0 .. size - 1],+      rightOrdinal <- [0 .. size - 1]+    ]+  where+    relationMatches (leftOrdinal, rightOrdinal) =+      case+        ( IntMap.lookup leftOrdinal maskByKeyMap,+          IntMap.lookup rightOrdinal maskByKeyMap+        )+        of+        (Just leftMask, Just rightMask) ->+          contextKeyRelated+            upperRows+            (ContextKey leftOrdinal)+            (ContextKey rightOrdinal)+            == (leftMask .&. rightMask == leftMask)+        _ -> False++booleanMaskMapFromCover ::+  Int ->+  Int ->+  IntMap Word64 ->+  IntMap IntSet ->+  [Int] ->+  Maybe (IntMap Word64)+booleanMaskMapFromCover size bottomOrdinal atomBitByKey predecessorSets =+  foldM includeKey IntMap.empty+  where+    includeKey masksByKey keyOrdinal+      | keyOrdinal < 0 || keyOrdinal >= size = Nothing+      | keyOrdinal == bottomOrdinal =+          Just (IntMap.insert keyOrdinal 0 masksByKey)+      | Just atomMask <- IntMap.lookup keyOrdinal atomBitByKey =+          Just (IntMap.insert keyOrdinal atomMask masksByKey)+      | otherwise = do+          let predecessorOrdinals =+                IntSet.toAscList+                  (IntMap.findWithDefault IntSet.empty keyOrdinal predecessorSets)+          guardMaybe (not (null predecessorOrdinals))+          predecessorMasks <-+            traverse (`IntMap.lookup` masksByKey) predecessorOrdinals+          let mask = Foldable.foldl' (.|.) 0 predecessorMasks+          guardMaybe (mask /= 0)+          Just (IntMap.insert keyOrdinal mask masksByKey)++booleanExpectedCoverPairs ::+  Int ->+  Word64 ->+  UVector.Vector Int ->+  Set (Int, Int)+booleanExpectedCoverPairs atomCount fullMask keyByMask =+  Set.fromList+    [ (lowerOrdinal, upperOrdinal)+    | lowerMask <- [0 .. fullMask],+      atomIndex <- [0 .. atomCount - 1],+      lowerMask .&. bit atomIndex == 0,+      let upperMask = lowerMask .|. bit atomIndex,+      Just lowerOrdinal <- [keyOrdinalForMask keyByMask lowerMask],+      Just upperOrdinal <- [keyOrdinalForMask keyByMask upperMask]+    ]++keyOrdinalForMask :: UVector.Vector Int -> Word64 -> Maybe Int+keyOrdinalForMask keyByMask mask+  | mask > fromIntegral (maxBound :: Int) = Nothing+  | otherwise =+      case keyByMask UVector.!? fromIntegral mask of+        Just keyOrdinal+          | keyOrdinal >= 0 -> Just keyOrdinal+        _ -> Nothing++booleanAtomCountFromSize :: Int -> Maybe Int+booleanAtomCountFromSize size+  | size <= 0 = Nothing+  | size .&. (size - 1) /= 0 = Nothing+  | otherwise = Just (countTrailingZeros size)++coverTopologicalOrder :: Int -> Set (Int, Int) -> Maybe [Int]+coverTopologicalOrder size strictPairs =+  topologicalOrder size $ \sourceOrdinal step initial ->+    IntSet.foldr+      step+      initial+      (IntMap.findWithDefault IntSet.empty sourceOrdinal successorSets)+  where+    successorSets = coverSuccessorSets strictPairs++coverSuccessorSets :: Set (Int, Int) -> IntMap IntSet+coverSuccessorSets =+  Foldable.foldl'+    (\successors (sourceOrdinal, targetOrdinal) ->+       IntMap.insertWith+         IntSet.union+         sourceOrdinal+         (IntSet.singleton targetOrdinal)+         successors+    )+    IntMap.empty+    . Set.toAscList++coverPredecessorSets :: Set (Int, Int) -> IntMap IntSet+coverPredecessorSets =+  Foldable.foldl'+    (\predecessors (sourceOrdinal, targetOrdinal) ->+       IntMap.insertWith+         IntSet.union+         targetOrdinal+         (IntSet.singleton sourceOrdinal)+         predecessors+    )+    IntMap.empty+    . Set.toAscList++declaredStrictPairOrdinals ::+  [(ContextKey, ContextKey)] ->+  Set (Int, Int)+declaredStrictPairOrdinals =+  Set.fromList+    . foldMap+      (\(ContextKey sourceOrdinal, ContextKey targetOrdinal) ->+         if sourceOrdinal == targetOrdinal+           then []+           else [(sourceOrdinal, targetOrdinal)]+      )++successorPath :: Int -> IntMap Int -> Int -> [Int]+successorPath size successorBySource bottomOrdinal =+  take size (unfoldr next (Just bottomOrdinal))+  where+    next Nothing = Nothing+    next (Just sourceOrdinal) =+      Just (sourceOrdinal, IntMap.lookup sourceOrdinal successorBySource)++totalOrderRankByKey :: Int -> [Int] -> UVector.Vector Int+totalOrderRankByKey size path =+  UVector.accum+    (\_ rank -> rank)+    (UVector.replicate size (-1))+    [ (keyOrdinal, rank)+    | (keyOrdinal, rank) <- zip path [0 ..],+      keyOrdinal >= 0,+      keyOrdinal < size+    ]++totalOrderKeyRankValue :: UVector.Vector Int -> Int -> Maybe Int+totalOrderKeyRankValue rankByKey keyOrdinal =+  case rankByKey UVector.!? keyOrdinal of+    Just rank+      | rank >= 0 -> Just rank+    _ -> Nothing++allContextKeyOrdinals :: Int -> IntSet+allContextKeyOrdinals size =+  IntSet.fromDistinctAscList [0 .. size - 1]++contextKeysInBounds :: Int -> ContextKey -> ContextKey -> Bool+contextKeysInBounds size leftKey rightKey =+  contextKeyInBounds size leftKey && contextKeyInBounds size rightKey++contextKeyInBounds :: Int -> ContextKey -> Bool+contextKeyInBounds size (ContextKey keyOrdinal) =+  keyOrdinal >= 0 && keyOrdinal < size++guardMaybe :: Bool -> Maybe ()+guardMaybe condition =+  if condition then Just () else Nothing
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Relation.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Relation+  ( ContextRows,+    ContextRowIndex,+    relationRowsGenerate,+    relationRowsFromKeyPairs,+    transitiveClosureRows,+    lowerRowsFromUpperRows,+    contextRowIndexFromRows,+    contextRowIndexLookup,+    rowJoinKeyMaybe,+    rowMeetKeyMaybe,+    rowJoinCandidateKeys,+    rowMeetCandidateKeys,+    contextKeyRelated,+    rowForKey,+    rowForRawKey,+  )+where++import Control.Monad (when)+import Control.Monad.ST (ST, runST)+import Data.Bits+  ( (.&.),+    (.|.),+    bit,+    countTrailingZeros,+  )+import Data.Foldable (traverse_)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector.Unboxed qualified as UVector+import Data.Vector.Unboxed.Mutable qualified as MVector+import Data.Word (Word64)+import Moonlight.FiniteLattice.Internal.Invariant+  ( unboxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet (..),+    contextKeySetChunkCount,+    contextKeySetFilter,+    contextKeySetFoldr,+    contextKeySetIntersection,+    contextKeySetIntersectsExcept,+    contextKeySetMember,+    contextKeySetToAscList,+  )+import Moonlight.FiniteLattice.Internal.Topological+  ( topologicalOrder,+  )++data ContextRows = ContextRows+  { crSize :: !Int,+    crChunkCount :: !Int,+    crChunks :: !(UVector.Vector Word64)+  }+  deriving stock (Eq, Show)++data ContextRowSignature+  = ContextRowSignature0+  | ContextRowSignature1 !Word64+  | ContextRowSignature2 !Word64 !Word64+  | ContextRowSignatureN ![Word64]+  deriving stock (Eq, Ord, Show)++newtype ContextRowIndex = ContextRowIndex+  (Map ContextRowSignature ContextKey)++-- | Build a relation matrix while evaluating the predicate exactly once for+-- each ordered pair of keys.+relationRowsGenerate :: Int -> (Int -> Int -> Bool) -> ContextRows+relationRowsGenerate size related =+  ContextRows+    { crSize = size,+      crChunkCount = chunkCount,+      crChunks =+        UVector.generate relationWordCount $ \flatIndex ->+          let (sourceOrdinal, chunkIndex) = flatIndex `quotRem` chunkCount+              targetBase = chunkIndex * contextKeyBitsPerChunk+           in generateChunk sourceOrdinal targetBase 0 0+    }+  where+    chunkCount = contextKeySetChunkCount size+    relationWordCount = size * chunkCount++    generateChunk !sourceOrdinal !targetBase !bitIndex !chunkValue+      | bitIndex >= contextKeyBitsPerChunk = chunkValue+      | targetOrdinal >= size = chunkValue+      | otherwise =+          generateChunk+            sourceOrdinal+            targetBase+            (bitIndex + 1)+            ( if related sourceOrdinal targetOrdinal+                then chunkValue .|. bit bitIndex+                else chunkValue+            )+      where+        targetOrdinal = targetBase + bitIndex++relationRowsFromKeyPairs :: Int -> [(ContextKey, ContextKey)] -> ContextRows+relationRowsFromKeyPairs size keyPairs =+  ContextRows+    { crSize = size,+      crChunkCount = chunkCount,+      crChunks =+        UVector.accum+          (.|.)+          (UVector.replicate (size * chunkCount) 0)+          rowBits+    }+  where+    chunkCount = contextKeySetChunkCount size++    rowBits =+      [ ( contextRowsChunkOffset chunkCount sourceOrdinal targetChunk,+          contextKeyBitMask targetOrdinal+        )+      | (ContextKey sourceOrdinal, ContextKey targetOrdinal) <- keyPairs,+        sourceOrdinal >= 0,+        sourceOrdinal < size,+        targetOrdinal >= 0,+        targetOrdinal < size,+        let targetChunk = contextKeyChunkIndex targetOrdinal+      ]++transitiveClosureRows :: ContextRows -> ContextRows+transitiveClosureRows initialRows =+  case topologicalKeyOrder initialRows of+    Just order -> dagTransitiveClosureRows initialRows order+    Nothing -> warshallTransitiveClosureRows initialRows++warshallTransitiveClosureRows :: ContextRows -> ContextRows+warshallTransitiveClosureRows rows =+  rows+    { crChunks =+        runST $ do+          mutableChunks <- UVector.thaw (crChunks rows)+          closeThrough mutableChunks 0+          UVector.unsafeFreeze mutableChunks+    }+  where+    size = crSize rows+    chunkCount = crChunkCount rows++    closeThrough :: MVector.MVector s Word64 -> Int -> ST s ()+    closeThrough mutableChunks !throughOrdinal+      | throughOrdinal >= size =+          pure ()+      | otherwise = do+          closeSource mutableChunks throughOrdinal 0+          closeThrough mutableChunks (throughOrdinal + 1)++    closeSource :: MVector.MVector s Word64 -> Int -> Int -> ST s ()+    closeSource mutableChunks !throughOrdinal !sourceOrdinal+      | sourceOrdinal >= size =+          pure ()+      | otherwise = do+          let throughChunkIndex =+                contextKeyChunkIndex throughOrdinal+              throughMask =+                contextKeyBitMask throughOrdinal+              reachabilityOffset =+                contextRowsChunkOffset+                  chunkCount+                  sourceOrdinal+                  throughChunkIndex++          sourceReachesThrough <-+            MVector.unsafeRead mutableChunks reachabilityOffset++          when+            (sourceReachesThrough .&. throughMask /= 0)+            (orMutableRow mutableChunks sourceOrdinal throughOrdinal)++          closeSource+            mutableChunks+            throughOrdinal+            (sourceOrdinal + 1)++    orMutableRow :: MVector.MVector s Word64 -> Int -> Int -> ST s ()+    orMutableRow mutableChunks !destinationOrdinal !sourceOrdinal =+      sequence_+        [ do+            let destinationOffset =+                  contextRowsChunkOffset+                    chunkCount+                    destinationOrdinal+                    chunkIndex+                sourceOffset =+                  contextRowsChunkOffset+                    chunkCount+                    sourceOrdinal+                    chunkIndex+            destinationChunk <-+              MVector.unsafeRead mutableChunks destinationOffset+            sourceChunk <-+              MVector.unsafeRead mutableChunks sourceOffset+            MVector.unsafeWrite+              mutableChunks+              destinationOffset+              (destinationChunk .|. sourceChunk)+        | chunkIndex <- [0 .. chunkCount - 1]+        ]++-- | For a DAG, reverse topological propagation computes every principal upper+-- set by joining already-computed successor rows.+dagTransitiveClosureRows :: ContextRows -> [Int] -> ContextRows+dagTransitiveClosureRows rows keyOrder =+  rows+    { crChunks =+        runST $ do+          mutableChunks <- UVector.thaw (crChunks rows)+          traverse_ (closeSource mutableChunks) (reverse keyOrder)+          UVector.unsafeFreeze mutableChunks+    }+  where+    chunkCount = crChunkCount rows++    closeSource :: MVector.MVector s Word64 -> Int -> ST s ()+    closeSource mutableChunks sourceOrdinal =+      forEachRelatedTarget rows sourceOrdinal $ \targetOrdinal ->+        when+          (targetOrdinal /= sourceOrdinal)+          (orMutableRow mutableChunks sourceOrdinal targetOrdinal)++    orMutableRow :: MVector.MVector s Word64 -> Int -> Int -> ST s ()+    orMutableRow mutableChunks !destinationOrdinal !sourceOrdinal =+      sequence_+        [ do+            let destinationOffset =+                  contextRowsChunkOffset+                    chunkCount+                    destinationOrdinal+                    chunkIndex+                sourceOffset =+                  contextRowsChunkOffset+                    chunkCount+                    sourceOrdinal+                    chunkIndex+            destinationChunk <-+              MVector.unsafeRead mutableChunks destinationOffset+            sourceChunk <-+              MVector.unsafeRead mutableChunks sourceOffset+            MVector.unsafeWrite+              mutableChunks+              destinationOffset+              (destinationChunk .|. sourceChunk)+        | chunkIndex <- [0 .. chunkCount - 1]+        ]++forEachRelatedTarget ::+  Monad m =>+  ContextRows ->+  Int ->+  (Int -> m ()) ->+  m ()+forEachRelatedTarget rows sourceOrdinal action =+  traverse_ visitChunk [0 .. crChunkCount rows - 1]+  where+    visitChunk chunkIndex =+      visitWord+        (chunkIndex * contextKeyBitsPerChunk)+        (contextRowsChunkAt rows sourceOrdinal chunkIndex)++    visitWord !baseOrdinal !remainingBits+      | remainingBits == 0 =+          pure ()+      | otherwise = do+          let bitIndex = countTrailingZeros remainingBits+              targetOrdinal = baseOrdinal + bitIndex+              nextBits = remainingBits .&. (remainingBits - 1)+          action targetOrdinal+          visitWord baseOrdinal nextBits+{-# INLINE forEachRelatedTarget #-}++lowerRowsFromUpperRows :: ContextRows -> ContextRows+lowerRowsFromUpperRows upperRows =+  ContextRows+    { crSize = crSize upperRows,+      crChunkCount = crChunkCount upperRows,+      crChunks =+        UVector.generate+          (crSize upperRows * crChunkCount upperRows)+          lowerChunk+    }+  where+    lowerChunk flatIndex =+      let (targetOrdinal, chunkIndex) = flatIndex `quotRem` crChunkCount upperRows+          sourceBase = chunkIndex * contextKeyBitsPerChunk+       in generateChunk targetOrdinal sourceBase 0 0++    generateChunk !targetOrdinal !sourceBase !bitIndex !chunkValue+      | bitIndex >= contextKeyBitsPerChunk = chunkValue+      | sourceOrdinal >= crSize upperRows = chunkValue+      | contextKeyRelated upperRows (ContextKey sourceOrdinal) (ContextKey targetOrdinal) =+          generateChunk targetOrdinal sourceBase (bitIndex + 1) (chunkValue .|. bit bitIndex)+      | otherwise =+          generateChunk targetOrdinal sourceBase (bitIndex + 1) chunkValue+      where+        sourceOrdinal = sourceBase + bitIndex++contextRowIndexFromRows :: ContextRows -> ContextRowIndex+contextRowIndexFromRows rows =+  ContextRowIndex+    ( Map.fromList+        [ (contextRowSignature (rowForRawKey rows keyOrdinal), ContextKey keyOrdinal)+        | keyOrdinal <- [0 .. crSize rows - 1]+        ]+    )++contextRowIndexLookup :: ContextKeySet -> ContextRowIndex -> Maybe ContextKey+contextRowIndexLookup keySet (ContextRowIndex rowIndex) =+  Map.lookup (contextRowSignature keySet) rowIndex++contextKeyRelated :: ContextRows -> ContextKey -> ContextKey -> Bool+contextKeyRelated rows leftKey (ContextKey rightOrdinal) =+  contextKeySetMember rightOrdinal (rowForKey rows leftKey)+{-# INLINE contextKeyRelated #-}++rowJoinKeyMaybe ::+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextKey ->+  ContextKey ->+  Maybe ContextKey+rowJoinKeyMaybe upperRows lowerRows upperRowIndex leftKey rightKey =+  case contextRowIndexLookup upperBounds upperRowIndex of+    Just joinKey -> Just joinKey+    Nothing -> uniqueKey (minimalRowKeys lowerRows upperBounds)+  where+    upperBounds =+      contextKeySetIntersection+        (rowForKey upperRows leftKey)+        (rowForKey upperRows rightKey)+{-# INLINE rowJoinKeyMaybe #-}++rowMeetKeyMaybe ::+  ContextRows ->+  ContextRows ->+  ContextRowIndex ->+  ContextKey ->+  ContextKey ->+  Maybe ContextKey+rowMeetKeyMaybe upperRows lowerRows lowerRowIndex leftKey rightKey =+  case contextRowIndexLookup lowerBounds lowerRowIndex of+    Just meetKey -> Just meetKey+    Nothing -> uniqueKey (maximalRowKeys upperRows lowerBounds)+  where+    lowerBounds =+      contextKeySetIntersection+        (rowForKey lowerRows leftKey)+        (rowForKey lowerRows rightKey)+{-# INLINE rowMeetKeyMaybe #-}++rowJoinCandidateKeys ::+  ContextRows ->+  ContextRows ->+  ContextKey ->+  ContextKey ->+  ContextKeySet+rowJoinCandidateKeys upperRows lowerRows leftKey rightKey =+  minimalRowKeys lowerRows upperBounds+  where+    upperBounds =+      contextKeySetIntersection+        (rowForKey upperRows leftKey)+        (rowForKey upperRows rightKey)++rowMeetCandidateKeys ::+  ContextRows ->+  ContextRows ->+  ContextKey ->+  ContextKey ->+  ContextKeySet+rowMeetCandidateKeys upperRows lowerRows leftKey rightKey =+  maximalRowKeys upperRows lowerBounds+  where+    lowerBounds =+      contextKeySetIntersection+        (rowForKey lowerRows leftKey)+        (rowForKey lowerRows rightKey)++minimalRowKeys :: ContextRows -> ContextKeySet -> ContextKeySet+minimalRowKeys lowerRows candidates =+  contextKeySetFilter+    (\candidateOrdinal ->+       not+         ( contextKeySetIntersectsExcept+             candidateOrdinal+             candidates+             (rowForRawKey lowerRows candidateOrdinal)+         )+    )+    candidates++maximalRowKeys :: ContextRows -> ContextKeySet -> ContextKeySet+maximalRowKeys upperRows candidates =+  contextKeySetFilter+    (\candidateOrdinal ->+       not+         ( contextKeySetIntersectsExcept+             candidateOrdinal+             candidates+             (rowForRawKey upperRows candidateOrdinal)+         )+    )+    candidates++uniqueKey :: ContextKeySet -> Maybe ContextKey+uniqueKey candidates =+  case contextKeySetToAscList candidates of+    [keyOrdinal] -> Just (ContextKey keyOrdinal)+    _ -> Nothing++-- | Total for keys produced by the same compiled relation.+rowForKey :: ContextRows -> ContextKey -> ContextKeySet+rowForKey rows (ContextKey keyOrdinal) =+  rowForRawKey rows keyOrdinal+{-# INLINE rowForKey #-}++-- | Total for ordinals in @[0, crSize)@. Every caller is an internal bounded+-- loop or starts from an abstract key.+rowForRawKey :: ContextRows -> Int -> ContextKeySet+rowForRawKey rows keyOrdinal =+  ContextKeySet+    ( UVector.slice+        (contextRowsChunkOffset (crChunkCount rows) keyOrdinal 0)+        (crChunkCount rows)+        (crChunks rows)+    )+{-# INLINE rowForRawKey #-}++topologicalKeyOrder :: ContextRows -> Maybe [Int]+topologicalKeyOrder rows =+  topologicalOrder (crSize rows) $ \sourceOrdinal step initial ->+    contextKeySetFoldr+      (\targetOrdinal rest -> step targetOrdinal rest)+      initial+      (rowForRawKey rows sourceOrdinal)++contextRowSignature :: ContextKeySet -> ContextRowSignature+contextRowSignature (ContextKeySet chunks) =+  case UVector.length chunks of+    0 -> ContextRowSignature0+    1 -> ContextRowSignature1 (unboxedIndexInvariant chunks 0)+    2 ->+      ContextRowSignature2+        (unboxedIndexInvariant chunks 0)+        (unboxedIndexInvariant chunks 1)+    _ -> ContextRowSignatureN (UVector.toList chunks)++contextRowsChunkAt :: ContextRows -> Int -> Int -> Word64+contextRowsChunkAt rows rowOrdinal chunkIndex =+  unboxedIndexInvariant (crChunks rows) (contextRowsChunkOffset (crChunkCount rows) rowOrdinal chunkIndex)++contextRowsChunkOffset :: Int -> Int -> Int -> Int+contextRowsChunkOffset chunkCount rowOrdinal chunkIndex =+  rowOrdinal * chunkCount + chunkIndex+{-# INLINE contextRowsChunkOffset #-}++contextKeyChunkIndex :: Int -> Int+contextKeyChunkIndex keyOrdinal =+  keyOrdinal `quot` contextKeyBitsPerChunk+{-# INLINE contextKeyChunkIndex #-}++contextKeyBitMask :: Int -> Word64+contextKeyBitMask keyOrdinal =+  bit (keyOrdinal .&. (contextKeyBitsPerChunk - 1))+{-# INLINE contextKeyBitMask #-}++contextKeyBitsPerChunk :: Int+contextKeyBitsPerChunk = 64
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Topological.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RankNTypes #-}++module Moonlight.FiniteLattice.Internal.Topological+  ( SuccessorFold,+    topologicalOrder,+  )+where++import Data.Foldable qualified as Foldable+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet++-- | A non-allocating fold over the successors of a key.+type SuccessorFold =+  forall result.+  Int ->+  (Int -> result -> result) ->+  result ->+  result++-- | Deterministic Kahn topological sorting over dense integer keys.+topologicalOrder :: Int -> SuccessorFold -> Maybe [Int]+topologicalOrder size successors+  | size < 0 = Nothing+  | otherwise = consume initialInDegrees initialReady [] size+  where+    sources =+      [0 .. size - 1]++    successorList source =+      successors source (:) []++    validNonSelfTarget source target =+      target /= source && target >= 0 && target < size++    initialInDegrees :: IntMap.IntMap Int+    initialInDegrees =+      Foldable.foldl'+        ( \inDegrees source ->+            Foldable.foldl'+              (\counts target -> IntMap.insertWith (+) target 1 counts)+              inDegrees+              (filter (validNonSelfTarget source) (successorList source))+        )+        IntMap.empty+        sources++    initialReady =+      IntSet.fromAscList+        [ source+        | source <- sources,+          IntMap.findWithDefault 0 source initialInDegrees == 0+        ]++    consume inDegrees ready reverseOrder remaining+      | remaining == 0 = Just (reverse reverseOrder)+      | otherwise =+          case IntSet.minView ready of+            Nothing -> Nothing+            Just (source, readyWithoutSource) ->+              let (nextInDegrees, nextReady) =+                    releaseTargets+                      source+                      inDegrees+                      readyWithoutSource+                      (successorList source)+               in consume+                    nextInDegrees+                    nextReady+                    (source : reverseOrder)+                    (remaining - 1)++    releaseTargets source inDegrees ready =+      Foldable.foldl'+        ( \(currentInDegrees, currentReady) target ->+            if validNonSelfTarget source target+              then+                let nextDegree =+                      IntMap.findWithDefault 0 target currentInDegrees - 1+                    nextInDegrees =+                      IntMap.insert target nextDegree currentInDegrees+                 in ( nextInDegrees,+                      if nextDegree == 0+                        then IntSet.insert target currentReady+                        else currentReady+                    )+              else (currentInDegrees, currentReady)+        )+        (inDegrees, ready)
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Types.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextOrderDecl (..),+    ContextCompileLimits (..),+    defaultContextCompileLimits,+    unlimitedContextCompileLimits,+    ContextRepresentation (..),+    ContextLatticeCompileError (..),+    ContextLatticeLookupError (..),+    ResidentContext (..),+    ResidentContextKey (..),+    ResidentContextKeySet (..),+    ResidentContextElement (..),+    contextKeyForMaybe,+    contextValueForKey,+    residentKeyFromContextKey,+    contextKeyFromResidentKey,+    residentContextElementForKey,+  )+where++import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Vector qualified as Vector+import Moonlight.FiniteLattice.Internal.Invariant+  ( boxedIndexInvariant,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+  )+import Moonlight.FiniteLattice.Internal.Plan (ContextPlan)+import Numeric.Natural (Natural)++type ContextLattice :: Type -> Type+data ContextLattice c = ContextLattice+  { clTop :: !c,+    clBottom :: !c,+    clTopKey :: !ContextKey,+    clBottomKey :: !ContextKey,+    clContextsByKey :: !(Vector.Vector c),+    clKeyByContext :: !(Map c ContextKey),+    clPlan :: !ContextPlan,+    clSize :: !Int+  }++type role ContextLattice nominal++type ContextOrderDecl :: Type -> Type+data ContextOrderDecl c = ContextOrderDecl+  { codTop :: !c,+    codBottom :: !c,+    -- | Generating pairs @(lower, upper)@. Reflexive and transitive pairs may+    -- be omitted; compilation takes the reflexive-transitive closure.+    codGeneratingPairs :: !(Set (c, c))+  }+  deriving stock (Eq, Ord, Show, Read)++type role ContextOrderDecl nominal++type ContextCompileLimits :: Type+data ContextCompileLimits = ContextCompileLimits+  { cclMaximumRelationBytes :: !(Maybe Natural),+    cclMaximumBinaryTableBytes :: !(Maybe Natural)+  }+  deriving stock (Eq, Ord, Show, Read)++defaultContextCompileLimits :: ContextCompileLimits+defaultContextCompileLimits =+  ContextCompileLimits+    { cclMaximumRelationBytes = Just (mebibytes 512),+      cclMaximumBinaryTableBytes = Just (mebibytes 1024)+    }++unlimitedContextCompileLimits :: ContextCompileLimits+unlimitedContextCompileLimits =+  ContextCompileLimits+    { cclMaximumRelationBytes = Nothing,+      cclMaximumBinaryTableBytes = Nothing+    }++mebibytes :: Natural -> Natural+mebibytes count =+  count * 1024 * 1024++type ContextRepresentation :: Type+data ContextRepresentation+  = ContextRelationWords+  deriving stock (Eq, Ord, Show, Read)++type ContextLatticeCompileError :: Type -> Type+data ContextLatticeCompileError c+  = ContextLatticeEmptyUniverse+  | ContextLatticeDuplicateElement !c+  | ContextLatticeUnknownTop !c+  | ContextLatticeUnknownBottom !c+  | ContextLatticeUnknownRelationEndpoint !(c, c)+  | ContextLatticeAntisymmetryViolation !c !c+  | ContextLatticeTopNotGreatest !c+  | ContextLatticeBottomNotLeast !c+  | ContextLatticeJoinDoesNotExist !c !c !(Set c)+  | ContextLatticeMeetDoesNotExist !c !c !(Set c)+  | ContextLatticeNotReflexive !c+  | ContextLatticeNotTransitive !c !c !c+  | ContextLatticeJoinOutsideUniverse !c !c !c+  | ContextLatticeMeetOutsideUniverse !c !c !c+  | ContextLatticeInvalidJoin !c !c !c+  | ContextLatticeInvalidMeet !c !c !c+  | ContextLatticeRepresentationOverflow !ContextRepresentation !Integer+  | ContextLatticeRepresentationLimitExceeded+      !ContextRepresentation+      !Integer+      !Natural+  deriving stock (Eq, Ord, Show, Read)++type role ContextLatticeCompileError nominal++type ContextLatticeLookupError :: Type -> Type+data ContextLatticeLookupError c+  = ContextLatticeUnknownContext !c+  deriving stock (Eq, Ord, Show, Read)++type role ContextLatticeLookupError nominal++type ResidentContext :: Type -> Type -> Type+newtype ResidentContext s c = ResidentContext+  { residentContextLattice :: ContextLattice c+  }++type role ResidentContext nominal nominal++type ResidentContextKey :: Type -> Type+newtype ResidentContextKey s = ResidentContextKey+  { residentContextKeyOrdinal :: Int+  }+  deriving stock (Eq, Ord, Show)++type role ResidentContextKey nominal++type ResidentContextKeySet :: Type -> Type+newtype ResidentContextKeySet s = ResidentContextKeySet ContextKeySet+  deriving stock (Eq, Show)++type role ResidentContextKeySet nominal++type ResidentContextElement :: Type -> Type -> Type+data ResidentContextElement s c = ResidentContextElement+  { residentContextElementKey :: !(ResidentContextKey s),+    residentContextElementValue :: !c+  }+  deriving stock (Eq, Ord, Show)++type role ResidentContextElement nominal nominal++contextKeyForMaybe :: Ord c => ContextLattice c -> c -> Maybe ContextKey+contextKeyForMaybe lattice contextValue =+  Map.lookup contextValue (clKeyByContext lattice)++-- | Total for internal keys produced by this lattice. The constructor of+-- 'ContextKey' is never exported by a public module.+contextValueForKey :: ContextLattice c -> ContextKey -> c+contextValueForKey lattice (ContextKey keyOrdinal) =+  contextValueAtOrdinal lattice keyOrdinal+{-# INLINE contextValueForKey #-}++residentKeyFromContextKey :: ContextKey -> ResidentContextKey s+residentKeyFromContextKey (ContextKey keyOrdinal) =+  ResidentContextKey keyOrdinal+{-# INLINE residentKeyFromContextKey #-}++contextKeyFromResidentKey :: ResidentContextKey s -> ContextKey+contextKeyFromResidentKey (ResidentContextKey keyOrdinal) =+  ContextKey keyOrdinal+{-# INLINE contextKeyFromResidentKey #-}++residentContextElementForKey ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextElement s c+residentContextElementForKey (ResidentContext lattice) residentKey =+  ResidentContextElement+    { residentContextElementKey = residentKey,+      residentContextElementValue =+        contextValueForKey lattice (contextKeyFromResidentKey residentKey)+    }++contextValueAtOrdinal :: ContextLattice c -> Int -> c+contextValueAtOrdinal lattice =+  boxedIndexInvariant (clContextsByKey lattice)+{-# INLINE contextValueAtOrdinal #-}
+ src-finite-lattice/Moonlight/FiniteLattice/Internal/Validate.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GHC2024 #-}++module Moonlight.FiniteLattice.Internal.Validate+  ( validateDeclaredUniverse,+    validateClosedOrderRows,+    validateAntisymmetryRows,+    validateTopGreatestRows,+    validateBottomLeastRows,+    validateSuppliedOperations,+  )+where++import Control.Monad (unless, when)+import Data.Foldable qualified as Foldable+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.FiniteLattice.Internal.Index+  ( ContextIndex (..),+    contextIndexValueForKey,+  )+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    contextKeySetFind,+    contextKeySetFindDifference,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( ContextPlan,+    contextPlanJoinKey,+    contextPlanMeetKey,+  )+import Moonlight.FiniteLattice.Internal.Relation+  ( ContextRows,+    contextKeyRelated,+    rowForRawKey,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLatticeCompileError (..),+    ContextOrderDecl (..),+  )++validateDeclaredUniverse ::+  Ord c =>+  Set c ->+  ContextOrderDecl c ->+  Either (ContextLatticeCompileError c) ()+validateDeclaredUniverse universe declaration = do+  when (Set.null universe) (Left ContextLatticeEmptyUniverse)+  unless+    (Set.member (codTop declaration) universe)+    (Left (ContextLatticeUnknownTop (codTop declaration)))+  unless+    (Set.member (codBottom declaration) universe)+    (Left (ContextLatticeUnknownBottom (codBottom declaration)))+  case+    Foldable.find+      (\(lower, upper) ->+         not (Set.member lower universe && Set.member upper universe)+      )+      (codGeneratingPairs declaration)+    of+    Nothing -> Right ()+    Just pair -> Left (ContextLatticeUnknownRelationEndpoint pair)++validateClosedOrderRows ::+  ContextIndex c ->+  ContextRows ->+  ContextKey ->+  ContextKey ->+  Either (ContextLatticeCompileError c) ()+validateClosedOrderRows index upperRows topKey bottomKey = do+  validateReflexivityRows index upperRows+  validateAntisymmetryRows index upperRows+  validateTransitivityRows index upperRows+  validateTopGreatestRows index upperRows topKey+  validateBottomLeastRows index upperRows bottomKey++validateReflexivityRows ::+  ContextIndex c ->+  ContextRows ->+  Either (ContextLatticeCompileError c) ()+validateReflexivityRows index upperRows =+  case+    firstOrdinal+      (ciSize index)+      (\keyOrdinal ->+         not+           ( contextKeyRelated+               upperRows+               (ContextKey keyOrdinal)+               (ContextKey keyOrdinal)+           )+      )+    of+    Nothing -> Right ()+    Just keyOrdinal ->+      Left+        (ContextLatticeNotReflexive (contextIndexValueForKey index (ContextKey keyOrdinal)))++validateAntisymmetryRows ::+  ContextIndex c ->+  ContextRows ->+  Either (ContextLatticeCompileError c) ()+validateAntisymmetryRows index upperRows =+  checkLeft 0+  where+    size = ciSize index++    checkLeft !leftOrdinal+      | leftOrdinal >= size = Right ()+      | otherwise = checkRight leftOrdinal (leftOrdinal + 1)++    checkRight !leftOrdinal !rightOrdinal+      | rightOrdinal >= size = checkLeft (leftOrdinal + 1)+      | otherwise =+          let leftKey = ContextKey leftOrdinal+              rightKey = ContextKey rightOrdinal+           in if+                contextKeyRelated upperRows leftKey rightKey+                  && contextKeyRelated upperRows rightKey leftKey+                then+                  Left+                    ( ContextLatticeAntisymmetryViolation+                        (contextIndexValueForKey index leftKey)+                        (contextIndexValueForKey index rightKey)+                    )+                else checkRight leftOrdinal (rightOrdinal + 1)++validateTransitivityRows ::+  ContextIndex c ->+  ContextRows ->+  Either (ContextLatticeCompileError c) ()+validateTransitivityRows index upperRows =+  checkLeft 0+  where+    size = ciSize index++    checkLeft !leftOrdinal+      | leftOrdinal >= size = Right ()+      | otherwise =+          case+            contextKeySetFind+              (hasMissingSuccessor leftOrdinal)+              (rowForRawKey upperRows leftOrdinal)+            of+            Nothing -> checkLeft (leftOrdinal + 1)+            Just middleOrdinal ->+              case+                contextKeySetFindDifference+                  (rowForRawKey upperRows middleOrdinal)+                  (rowForRawKey upperRows leftOrdinal)+                of+                Nothing -> checkLeft (leftOrdinal + 1)+                Just rightOrdinal ->+                  Left+                    ( ContextLatticeNotTransitive+                        (contextIndexValueForKey index (ContextKey leftOrdinal))+                        (contextIndexValueForKey index (ContextKey middleOrdinal))+                        (contextIndexValueForKey index (ContextKey rightOrdinal))+                    )++    hasMissingSuccessor leftOrdinal middleOrdinal =+      case+        contextKeySetFindDifference+          (rowForRawKey upperRows middleOrdinal)+          (rowForRawKey upperRows leftOrdinal)+        of+        Nothing -> False+        Just _ -> True++validateTopGreatestRows ::+  ContextIndex c ->+  ContextRows ->+  ContextKey ->+  Either (ContextLatticeCompileError c) ()+validateTopGreatestRows index upperRows topKey =+  case+    firstOrdinal+      (ciSize index)+      (\keyOrdinal ->+         not (contextKeyRelated upperRows (ContextKey keyOrdinal) topKey)+      )+    of+    Nothing -> Right ()+    Just keyOrdinal ->+      Left+        ( ContextLatticeTopNotGreatest+            (contextIndexValueForKey index (ContextKey keyOrdinal))+        )++validateBottomLeastRows ::+  ContextIndex c ->+  ContextRows ->+  ContextKey ->+  Either (ContextLatticeCompileError c) ()+validateBottomLeastRows index upperRows bottomKey =+  case+    firstOrdinal+      (ciSize index)+      (\keyOrdinal ->+         not (contextKeyRelated upperRows bottomKey (ContextKey keyOrdinal))+      )+    of+    Nothing -> Right ()+    Just keyOrdinal ->+      Left+        ( ContextLatticeBottomNotLeast+            (contextIndexValueForKey index (ContextKey keyOrdinal))+        )++validateSuppliedOperations ::+  Ord c =>+  ContextIndex c ->+  ContextPlan ->+  (c -> c -> c) ->+  (c -> c -> c) ->+  Either (ContextLatticeCompileError c) ()+validateSuppliedOperations index plan joinFn meetFn =+  checkLeft 0+  where+    size = ciSize index++    checkLeft !leftOrdinal+      | leftOrdinal >= size = Right ()+      | otherwise = checkRight leftOrdinal 0++    checkRight !leftOrdinal !rightOrdinal+      | rightOrdinal >= size = checkLeft (leftOrdinal + 1)+      | otherwise = do+          let leftKey = ContextKey leftOrdinal+              rightKey = ContextKey rightOrdinal+              leftContext = contextIndexValueForKey index leftKey+              rightContext = contextIndexValueForKey index rightKey+              joined = joinFn leftContext rightContext+              met = meetFn leftContext rightContext+          joinedKey <-+            maybe+              (Left (ContextLatticeJoinOutsideUniverse leftContext rightContext joined))+              Right+              (Map.lookup joined (ciKeyByContext index))+          metKey <-+            maybe+              (Left (ContextLatticeMeetOutsideUniverse leftContext rightContext met))+              Right+              (Map.lookup met (ciKeyByContext index))+          let planJoinedKey = contextPlanJoinKey plan leftKey rightKey+              planMetKey = contextPlanMeetKey plan leftKey rightKey+          unless+            (joinedKey == planJoinedKey)+            (Left (ContextLatticeInvalidJoin leftContext rightContext joined))+          unless+            (metKey == planMetKey)+            (Left (ContextLatticeInvalidMeet leftContext rightContext met))+          checkRight leftOrdinal (rightOrdinal + 1)++firstOrdinal :: Int -> (Int -> Bool) -> Maybe Int+firstOrdinal size predicate =+  go 0+  where+    go !ordinal+      | ordinal >= size = Nothing+      | predicate ordinal = Just ordinal+      | otherwise = go (ordinal + 1)
+ src-finite-lattice/Moonlight/FiniteLattice/Presentation.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE DerivingStrategies #-}++-- | A monadic, name-binding builder for finite lattices that reads as mathematics+-- and compiles to a runtime-validated 'ContextLattice'.+--+-- You declare elements and an order (@a \`below\` b@ for @a ≤ b@); the runner infers+-- the universe and the (unique) top and bottom, then hands the order to+-- 'compileContextLattice', which transitively closes it, /derives/ join and meet, and+-- proves lattice-hood. The builder adds only the ergonomic frontend — every lattice+-- obligation (missing/ambiguous join or meet, antisymmetry, top-greatest,+-- bottom-least) stays with 'compileContextLattice' and surfaces as 'InvalidLattice'.+module Moonlight.FiniteLattice.Presentation+  ( LatticeBuilder,+    ElemRef,+    LatticeBuildError (..),+    LatticeBuilderPatternFailure (..),+    element,+    elements,+    below,+    belowAll,+    latticeOf,+    boundedLatticeOf,+  )+where++import Data.Bifunctor (first)+import Data.Coerce (coerce)+import Data.Kind (Type)+import Data.List qualified as List+import Data.Set (Set)+import qualified Data.Set as Set+import Moonlight.FiniteLattice.Core+  ( ContextLattice,+    ContextLatticeCompileError,+    compileContextLattice,+    contextOrderDecl,+  )++-- | An opaque reference to a declared element, carrying its value. Obtained from+-- 'element'; never constructed directly, so an order edge can only mention elements+-- the presentation declared.+type ElemRef :: Type -> Type+newtype ElemRef c = ElemRef c+  deriving stock (Eq, Show)++type LatticeBuildError :: Type -> Type+data LatticeBuildError c+  = DuplicateElement c+  | EmptyLattice+  | NoTop+  | AmbiguousTop [c]+  | NoBottom+  | AmbiguousBottom [c]+  | BuilderPatternFailure LatticeBuilderPatternFailure+  | InvalidLattice (ContextLatticeCompileError c)+  deriving stock (Eq, Show)++-- | Refutable do-pattern failure emitted by the 'MonadFail' instance.+type LatticeBuilderPatternFailure :: Type+newtype LatticeBuilderPatternFailure = LatticeBuilderPatternFailure+  { lbpfMessage :: String+  }+  deriving stock (Eq, Show)++type DeclarationList :: Type -> Type+type DeclarationList value = [value] -> [value]++type BuilderState :: Type -> Type+data BuilderState c = BuilderState+  { bsElements :: !(DeclarationList c),+    bsElementCount :: !Int,+    bsElementSet :: !(Set c),+    bsEdges :: !(DeclarationList (c, c)),+    bsStrictSources :: !(Set c),+    bsStrictTargets :: !(Set c),+    bsTrackBounds :: !Bool,+    bsErrors :: !(DeclarationList (LatticeBuildError c))+  }+++emptyDeclarationList :: DeclarationList value+emptyDeclarationList =+  id++appendDeclaredValues :: DeclarationList value -> [value] -> DeclarationList value+appendDeclaredValues declaredValuesToDate newValues =+  declaredValuesToDate . (newValues <>)++declaredValues :: DeclarationList value -> [value]+declaredValues values =+  values []++initialState :: BuilderState c+initialState =+  BuilderState+    { bsElements = emptyDeclarationList,+      bsElementCount = 0,+      bsElementSet = Set.empty,+      bsEdges = emptyDeclarationList,+      bsStrictSources = Set.empty,+      bsStrictTargets = Set.empty,+      bsTrackBounds = True,+      bsErrors = emptyDeclarationList+    }++-- | A pure lattice-presentation builder. The 'Maybe' lets refutable @do@-patterns+-- (e.g. @[a, b, c] <- elements [..]@) short-circuit via 'fail' while preserving the+-- declarations accumulated so far for error reporting.+type LatticeBuilder :: Type -> Type -> Type+newtype LatticeBuilder c a = LatticeBuilder+  {unLatticeBuilder :: BuilderState c -> (Maybe a, BuilderState c)}++instance Functor (LatticeBuilder c) where+  fmap f (LatticeBuilder run) =+    LatticeBuilder (\state -> let (result, state') = run state in (fmap f result, state'))++instance Applicative (LatticeBuilder c) where+  pure value = LatticeBuilder (\state -> (Just value, state))+  LatticeBuilder runF <*> LatticeBuilder runA =+    LatticeBuilder+      ( \state ->+          case runF state of+            (Nothing, state') -> (Nothing, state')+            (Just f, state') ->+              let (result, state'') = runA state'+               in (fmap f result, state'')+      )++instance Monad (LatticeBuilder c) where+  LatticeBuilder run >>= k =+    LatticeBuilder+      ( \state ->+          case run state of+            (Nothing, state') -> (Nothing, state')+            (Just value, state') -> unLatticeBuilder (k value) state'+      )++instance MonadFail (LatticeBuilder c) where+  fail message =+    LatticeBuilder (\state -> (Nothing, recordError (BuilderPatternFailure (LatticeBuilderPatternFailure message)) state))++recordError :: LatticeBuildError c -> BuilderState c -> BuilderState c+recordError buildError state =+  state {bsErrors = appendDeclaredValues (bsErrors state) [buildError]}++element :: Ord c => c -> LatticeBuilder c (ElemRef c)+element value =+  LatticeBuilder+    ( \state ->+        if Set.member value (bsElementSet state)+          then (Just (ElemRef value), recordError (DuplicateElement value) state)+          else+            ( Just (ElemRef value),+              recordNewElement value state+            )+    )++elements :: Ord c => [c] -> LatticeBuilder c [ElemRef c]+elements values =+  LatticeBuilder+    ( \state ->+        let valueCount = length values+            valueSet = elementValueSet values+         in if Set.size valueSet == valueCount && elementBatchDisjoint state valueSet+              then+                ( Just (coerce values),+                  recordNewElements values valueCount valueSet state+                )+              else+                let batch = classifyElementBatch (bsElementSet state) values+                    newValues = reverse (ebNewValues batch)+                 in ( Just (coerce values),+                      state+                        { bsElements = appendElementDeclarations state newValues,+                          bsElementCount = bsElementCount state + ebNewCount batch,+                          bsElementSet = ebSeen batch,+                          bsErrors = appendDeclaredValues (bsErrors state) (fmap DuplicateElement (reverse (ebDuplicateValues batch)))+                        }+                    )+    )++-- | Declare that the first element is below the second in the order (@a ≤ b@).+below :: Ord c => ElemRef c -> ElemRef c -> LatticeBuilder c ()+below (ElemRef lowerValue) (ElemRef upperValue) =+  LatticeBuilder+    ( \state ->+        ( Just (),+          state+            { bsEdges = appendDeclaredValues (bsEdges state) [(lowerValue, upperValue)],+              bsStrictSources =+                if not (bsTrackBounds state) || lowerValue == upperValue+                  then bsStrictSources state+                  else Set.insert lowerValue (bsStrictSources state),+              bsStrictTargets =+                if not (bsTrackBounds state) || lowerValue == upperValue+                  then bsStrictTargets state+                  else Set.insert upperValue (bsStrictTargets state)+            }+        )+    )++belowAll :: Ord c => [(ElemRef c, ElemRef c)] -> LatticeBuilder c ()+belowAll edgeRefs =+  LatticeBuilder+    ( \state ->+        let edgeValues = coerce edgeRefs+            stateWithEdges = state {bsEdges = appendDeclaredValues (bsEdges state) edgeValues}+         in ( Just (),+              if bsTrackBounds state+                then+                  stateWithEdges+                    { bsStrictSources = Set.union (strictSources edgeValues) (bsStrictSources state),+                      bsStrictTargets = Set.union (strictTargets edgeValues) (bsStrictTargets state)+                    }+                else stateWithEdges+            )+    )++-- | Run a presentation, inferring the universe and the unique top and bottom, then+-- compiling and proving lattice-hood, or returning the first fault.+latticeOf :: Ord c => LatticeBuilder c a -> Either (LatticeBuildError c) (ContextLattice c)+latticeOf builder =+  let (_, state) = unLatticeBuilder builder initialState+   in case declaredValues (bsErrors state) of+        (firstError : _) -> Left firstError+        [] -> compilePresentation state++-- | Run a presentation with declared top and bottom, skipping top/bottom+-- inference while preserving the same compile-time lattice proof.+boundedLatticeOf :: Ord c => c -> c -> LatticeBuilder c a -> Either (LatticeBuildError c) (ContextLattice c)+boundedLatticeOf topValue bottomValue builder =+  let (_, state) = unLatticeBuilder builder (initialState {bsTrackBounds = False})+   in case declaredValues (bsErrors state) of+        (firstError : _) -> Left firstError+        [] -> compileBoundedPresentation topValue bottomValue state++compilePresentation :: Ord c => BuilderState c -> Either (LatticeBuildError c) (ContextLattice c)+compilePresentation state =+  case declaredValues (bsElements state) of+    [] -> Left EmptyLattice+    universeList ->+      do+        let edgeList = declaredValues (bsEdges state)+        topValue <- inferTop universeList (bsStrictSources state)+        bottomValue <- inferBottom universeList (bsStrictTargets state)+        first+          InvalidLattice+          (compileContextLattice (bsElementSet state) (contextOrderDecl topValue bottomValue edgeList))++compileBoundedPresentation :: Ord c => c -> c -> BuilderState c -> Either (LatticeBuildError c) (ContextLattice c)+compileBoundedPresentation topValue bottomValue state =+  if bsElementCount state == 0+    then Left EmptyLattice+    else+      first+        InvalidLattice+        (compileContextLattice (bsElementSet state) (contextOrderDecl topValue bottomValue (declaredValues (bsEdges state))))++-- | The unique maximal element (one with no strictly-outgoing edge). In a finite+-- poset a unique maximal element is the greatest, so this is the top.+inferTop :: Ord c => [c] -> Set c -> Either (LatticeBuildError c) c+inferTop universeList strictSourceSet =+  case filter (`Set.notMember` strictSourceSet) universeList of+    [topValue] -> Right topValue+    [] -> Left NoTop+    candidates -> Left (AmbiguousTop candidates)++-- | The unique minimal element (one with no strictly-incoming edge).+inferBottom :: Ord c => [c] -> Set c -> Either (LatticeBuildError c) c+inferBottom universeList strictTargetSet =+  case filter (`Set.notMember` strictTargetSet) universeList of+    [bottomValue] -> Right bottomValue+    [] -> Left NoBottom+    candidates -> Left (AmbiguousBottom candidates)++type ElementBatch :: Type -> Type+data ElementBatch c = ElementBatch+  { ebSeen :: !(Set c),+    ebNewCount :: !Int,+    ebNewValues :: ![c],+    ebDuplicateValues :: ![c]+  }++classifyElementBatch :: Ord c => Set c -> [c] -> ElementBatch c+classifyElementBatch initialSeen =+  List.foldl' classifyElement (ElementBatch initialSeen 0 [] [])++classifyElement :: Ord c => ElementBatch c -> c -> ElementBatch c+classifyElement batch value+  | Set.member value (ebSeen batch) =+      batch {ebDuplicateValues = value : ebDuplicateValues batch}+  | otherwise =+      batch+        { ebSeen = Set.insert value (ebSeen batch),+          ebNewCount = ebNewCount batch + 1,+          ebNewValues = value : ebNewValues batch+        }++recordNewElement :: Ord c => c -> BuilderState c -> BuilderState c+recordNewElement value state =+  state+    { bsElements =+        if bsTrackBounds state+          then appendDeclaredValues (bsElements state) [value]+          else bsElements state,+      bsElementCount = bsElementCount state + 1,+      bsElementSet = Set.insert value (bsElementSet state)+    }++recordNewElements :: Ord c => [c] -> Int -> Set c -> BuilderState c -> BuilderState c+recordNewElements values valueCount valueSet state =+  state+    { bsElements = appendElementDeclarations state values,+      bsElementCount = bsElementCount state + valueCount,+      bsElementSet =+        if Set.null (bsElementSet state)+          then valueSet+          else Set.union valueSet (bsElementSet state)+    }++elementBatchDisjoint :: Ord c => BuilderState c -> Set c -> Bool+elementBatchDisjoint state valueSet =+  Set.null (bsElementSet state) || Set.null (Set.intersection (bsElementSet state) valueSet)++appendElementDeclarations :: BuilderState c -> [c] -> DeclarationList c+appendElementDeclarations state values =+  if bsTrackBounds state+    then appendDeclaredValues (bsElements state) values+    else bsElements state++elementValueSet :: Ord c => [c] -> Set c+elementValueSet values+  | strictlyAscending values = Set.fromDistinctAscList values+  | otherwise = Set.fromList values++strictlyAscending :: Ord c => [c] -> Bool+strictlyAscending values =+  and [leftValue < rightValue | (leftValue, rightValue) <- zip values (drop 1 values)]++strictSources :: Ord c => [(c, c)] -> Set c+strictSources edgeValues =+  Set.fromList [lowerValue | (lowerValue, upperValue) <- edgeValues, lowerValue /= upperValue]++strictTargets :: Ord c => [(c, c)] -> Set c+strictTargets edgeValues =+  Set.fromList [upperValue | (lowerValue, upperValue) <- edgeValues, lowerValue /= upperValue]
+ src-finite-lattice/Moonlight/FiniteLattice/Resident.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE GHC2024 #-}++-- | Resident context keys: brand-parameterised handles that tie compiled-lattice+-- keys to the plan that issued them. The brand's nominal role is the safety+-- guarantee (see @negative-finite-lattice/@ for the must-not-compile fixture).+module Moonlight.FiniteLattice.Resident+  ( ResidentContext,+    ResidentContextKey,+    residentContextKeyOrdinal,+    ResidentContextKeySet,+    residentContextKeySetNull,+    residentContextKeySetCardinality,+    residentContextKeySetFoldr,+    residentContextKeySetToAscList,+    residentContextKeySetMember,+    ResidentContextElement,+    residentContextElementKey,+    residentContextElementValue,+    withResidentContext,+    residentContextSize,+    residentContextKeys,+    residentContextElements,+    residentContextKeyFromOrdinal,+    checkResidentContext,+    residentContextElementForKey,+    residentContextUpperKeys,+    residentContextLowerKeys,+    residentContextKeyLeq,+    residentJoinKey,+    residentMeetKey,+    residentJoinMeetKeys,+    residentJoin,+    residentMeet,+  )+where++import Data.Map.Strict qualified as Map+import Moonlight.FiniteLattice.Internal.Key+  ( contextKeySetCardinality,+    contextKeySetFoldr,+    contextKeySetMember,+    contextKeySetNull,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( contextPlanJoinKey,+    contextPlanJoinMeetKeys,+    contextPlanLeq,+    contextPlanLowerKeys,+    contextPlanMeetKey,+    contextPlanUpperKeys,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ContextLatticeLookupError (..),+    ResidentContext (..),+    ResidentContextElement (..),+    ResidentContextKey (..),+    ResidentContextKeySet (..),+    contextKeyFromResidentKey,+    residentContextElementForKey,+    residentKeyFromContextKey,+  )++withResidentContext ::+  ContextLattice c ->+  (forall s. ResidentContext s c -> result) ->+  result+withResidentContext lattice continuation =+  continuation (ResidentContext lattice)+{-# INLINE withResidentContext #-}++residentContextSize :: ResidentContext s c -> Int+residentContextSize (ResidentContext lattice) =+  clSize lattice+{-# INLINE residentContextSize #-}++residentContextKeys :: ResidentContext s c -> [ResidentContextKey s]+residentContextKeys (ResidentContext lattice) =+  fmap ResidentContextKey [0 .. clSize lattice - 1]+{-# INLINE residentContextKeys #-}++residentContextElements :: ResidentContext s c -> [ResidentContextElement s c]+residentContextElements context =+  residentContextElementForKey context <$> residentContextKeys context++residentContextKeyFromOrdinal ::+  ResidentContext s c ->+  Int ->+  Maybe (ResidentContextKey s)+residentContextKeyFromOrdinal (ResidentContext lattice) keyOrdinal+  | keyOrdinal >= 0 && keyOrdinal < clSize lattice =+      Just (ResidentContextKey keyOrdinal)+  | otherwise = Nothing++checkResidentContext ::+  Ord c =>+  ResidentContext s c ->+  c ->+  Either (ContextLatticeLookupError c) (ResidentContextElement s c)+checkResidentContext context@(ResidentContext lattice) contextValue =+  case Map.lookup contextValue (clKeyByContext lattice) of+    Nothing -> Left (ContextLatticeUnknownContext contextValue)+    Just contextKey ->+      Right+        ( residentContextElementForKey+            context+            (residentKeyFromContextKey contextKey)+        )++residentContextKeySetNull :: ResidentContextKeySet s -> Bool+residentContextKeySetNull (ResidentContextKeySet keySet) =+  contextKeySetNull keySet+{-# INLINE residentContextKeySetNull #-}++residentContextKeySetCardinality :: ResidentContextKeySet s -> Int+residentContextKeySetCardinality (ResidentContextKeySet keySet) =+  contextKeySetCardinality keySet+{-# INLINE residentContextKeySetCardinality #-}++residentContextKeySetFoldr ::+  (ResidentContextKey s -> result -> result) ->+  result ->+  ResidentContextKeySet s ->+  result+residentContextKeySetFoldr step initial (ResidentContextKeySet keySet) =+  contextKeySetFoldr+    (\keyOrdinal rest -> step (ResidentContextKey keyOrdinal) rest)+    initial+    keySet++residentContextKeySetToAscList ::+  ResidentContextKeySet s ->+  [ResidentContextKey s]+residentContextKeySetToAscList =+  residentContextKeySetFoldr (:) []++residentContextKeySetMember ::+  ResidentContextKey s ->+  ResidentContextKeySet s ->+  Bool+residentContextKeySetMember (ResidentContextKey keyOrdinal) (ResidentContextKeySet keySet) =+  contextKeySetMember keyOrdinal keySet++residentContextUpperKeys ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKeySet s+residentContextUpperKeys (ResidentContext lattice) residentKey =+  ResidentContextKeySet+    ( contextPlanUpperKeys+        (clPlan lattice)+        (contextKeyFromResidentKey residentKey)+    )++residentContextLowerKeys ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKeySet s+residentContextLowerKeys (ResidentContext lattice) residentKey =+  ResidentContextKeySet+    ( contextPlanLowerKeys+        (clPlan lattice)+        (contextKeyFromResidentKey residentKey)+    )++residentContextKeyLeq ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKey s ->+  Bool+residentContextKeyLeq (ResidentContext lattice) leftKey rightKey =+  contextPlanLeq+    (clPlan lattice)+    (contextKeyFromResidentKey leftKey)+    (contextKeyFromResidentKey rightKey)+{-# INLINE residentContextKeyLeq #-}++residentJoinKey ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKey s ->+  ResidentContextKey s+residentJoinKey (ResidentContext lattice) leftKey rightKey =+  residentKeyFromContextKey+    ( contextPlanJoinKey+        (clPlan lattice)+        (contextKeyFromResidentKey leftKey)+        (contextKeyFromResidentKey rightKey)+    )+{-# INLINE residentJoinKey #-}++residentMeetKey ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKey s ->+  ResidentContextKey s+residentMeetKey (ResidentContext lattice) leftKey rightKey =+  residentKeyFromContextKey+    ( contextPlanMeetKey+        (clPlan lattice)+        (contextKeyFromResidentKey leftKey)+        (contextKeyFromResidentKey rightKey)+    )+{-# INLINE residentMeetKey #-}++residentJoinMeetKeys ::+  ResidentContext s c ->+  ResidentContextKey s ->+  ResidentContextKey s ->+  (ResidentContextKey s, ResidentContextKey s)+residentJoinMeetKeys (ResidentContext lattice) leftKey rightKey =+  let (joinKey, meetKey) =+        contextPlanJoinMeetKeys+        (clPlan lattice)+        (contextKeyFromResidentKey leftKey)+        (contextKeyFromResidentKey rightKey)+   in (residentKeyFromContextKey joinKey, residentKeyFromContextKey meetKey)+{-# INLINE residentJoinMeetKeys #-}++residentJoin ::+  ResidentContext s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c+residentJoin context leftElement rightElement =+  residentContextElementForKey+    context+    ( residentJoinKey+      context+      (residentContextElementKey leftElement)+      (residentContextElementKey rightElement)+    )++residentMeet ::+  ResidentContext s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c ->+  ResidentContextElement s c+residentMeet context leftElement rightElement =+  residentContextElementForKey+    context+    ( residentMeetKey+      context+      (residentContextElementKey leftElement)+      (residentContextElementKey rightElement)+    )
+ src-finite-lattice/Moonlight/FiniteLattice/Support.hs view
@@ -0,0 +1,350 @@+-- | Generator supports over a finite 'ContextLattice': semantic value-boundary+-- supports plus resident antichain kernels over branded lattice keys.+module Moonlight.FiniteLattice.Support+  ( SupportBasis,+    supportBasis,+    supportBasisWithOrder,+    emptySupport,+    supportGenerators,+    principalSupport,+    supportContains,+    supportReachableContexts,+    supportReachableLatticeContexts,+    normalizeSupport,+    supportUnion,+    supportMeet,+    ResidentSupport,+    residentSupportFromElements,+    residentSupportFromKeys,+    residentSupportKeys,+    residentSupportWithClosure,+    residentSupportContainsKey,+    residentSupportContainsElement,+    residentSupportReachableElements,+    residentSupportUnion,+    residentSupportMeet,+  )+where++import Data.Kind (Type)+import Data.Maybe (catMaybes)+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.FiniteLattice.Internal.Key+  ( ContextKey (..),+    ContextKeySet,+    contextKeySetChunkCount,+    contextKeySetFilter,+    contextKeySetFromKeys,+    contextKeySetImage2,+    contextKeySetIntersects,+    contextKeySetIntersectsExcept,+    contextKeySetUnion,+    contextKeySetUnionImages,+  )+import Moonlight.FiniteLattice.Internal.Plan+  ( contextPlanJoinKey,+    contextPlanLowerKeys,+    contextPlanUpperKeys,+  )+import Moonlight.FiniteLattice.Internal.Types+  ( ContextLattice (..),+    ResidentContext (..),+    ResidentContextKeySet (..),+    contextKeyFromResidentKey,+  )+import Moonlight.FiniteLattice.Core+  ( ContextLatticeLookupError (..),+  )+import Moonlight.FiniteLattice.Resident+  ( ResidentContextElement,+    ResidentContextKey,+    checkResidentContext,+    residentContextElementForKey,+    residentContextElementKey,+    residentContextElementValue,+    residentContextElements,+    residentContextKeyOrdinal,+    residentContextKeySetMember,+    residentContextKeySetToAscList,+    withResidentContext,+  )++type SupportBasis :: Type -> Type+newtype SupportBasis c = SupportBasis+  { unSupportBasis :: Set c+  }+  deriving stock (Eq, Ord, Show)++type ResidentSupport :: Type -> Type -> Type+data ResidentSupport s c = ResidentSupport+  { rsMinimalKeys :: !(ResidentContextKeySet s),+    rsClosure :: !(Maybe (ResidentContextKeySet s))+  }+  deriving stock (Eq, Show)++supportBasis :: Ord c => ContextLattice c -> [c] -> Either (ContextLatticeLookupError c) (SupportBasis c)+supportBasis contextLatticeValue =+  normalizeSupport contextLatticeValue . SupportBasis . Set.fromList++supportBasisWithOrder :: Ord c => (c -> c -> Bool) -> [c] -> SupportBasis c+supportBasisWithOrder leqValue contexts =+  SupportBasis (Set.filter isMinimal candidates)+  where+    candidates =+      Set.fromList contexts+    isMinimal candidateValue =+      not+        ( any+            (\otherValue -> otherValue /= candidateValue && leqValue otherValue candidateValue)+            (Set.toAscList candidates)+        )++emptySupport :: SupportBasis c+emptySupport =+  SupportBasis Set.empty++supportGenerators :: SupportBasis c -> [c]+supportGenerators =+  Set.toAscList . unSupportBasis++principalSupport :: c -> SupportBasis c+principalSupport =+  SupportBasis . Set.singleton++supportContains :: Ord c => ContextLattice c -> SupportBasis c -> c -> Either (ContextLatticeLookupError c) Bool+supportContains contextLatticeValue supportValue contextValue =+  withResidentSupport contextLatticeValue supportValue $ \residentContext support ->+    residentSupportContainsElement residentContext support+      <$> checkResidentContext residentContext contextValue++supportReachableContexts :: Ord c => ContextLattice c -> [c] -> SupportBasis c -> Either (ContextLatticeLookupError c) [c]+supportReachableContexts contextLatticeValue candidateContexts supportValue =+  withResidentSupport contextLatticeValue supportValue $ \residentContext support ->+    let cachedSupport = residentSupportWithClosure residentContext support+     in catMaybes+          <$>+          traverse+            (reachableCandidate residentContext cachedSupport)+            candidateContexts++supportReachableLatticeContexts :: Ord c => ContextLattice c -> SupportBasis c -> Either (ContextLatticeLookupError c) [c]+supportReachableLatticeContexts contextLatticeValue supportValue =+  withResidentSupport contextLatticeValue supportValue $ \residentContext support ->+    pure+      ( residentContextElementValue+          <$> residentSupportReachableElements residentContext support+      )++normalizeSupport :: Ord c => ContextLattice c -> SupportBasis c -> Either (ContextLatticeLookupError c) (SupportBasis c)+normalizeSupport contextLatticeValue supportValue =+  withResidentSupport contextLatticeValue supportValue $ \residentContext support ->+    pure (supportFromResidentSupport residentContext support)++supportUnion :: Ord c => ContextLattice c -> SupportBasis c -> SupportBasis c -> Either (ContextLatticeLookupError c) (SupportBasis c)+supportUnion contextLatticeValue leftSupport rightSupport =+  withResidentSupports contextLatticeValue leftSupport rightSupport $ \residentContext residentLeft residentRight ->+    pure+      ( supportFromResidentSupport+          residentContext+          (residentSupportUnion residentContext residentLeft residentRight)+      )++supportMeet :: Ord c => ContextLattice c -> SupportBasis c -> SupportBasis c -> Either (ContextLatticeLookupError c) (SupportBasis c)+supportMeet contextLatticeValue leftSupport rightSupport =+  withResidentSupports contextLatticeValue leftSupport rightSupport $ \residentContext residentLeft residentRight -> do+    pure+      ( supportFromResidentSupport+          residentContext+          (residentSupportMeet residentContext residentLeft residentRight)+      )++residentSupportFromElements :: Ord c => ResidentContext s c -> [c] -> Either (ContextLatticeLookupError c) (ResidentSupport s c)+residentSupportFromElements contextValue contextValues =+  residentSupportFromKeys contextValue+    . fmap residentContextElementKey+    <$> traverse (checkResidentContext contextValue) contextValues++residentSupportFromKeys :: ResidentContext s c -> [ResidentContextKey s] -> ResidentSupport s c+residentSupportFromKeys (ResidentContext lattice) keys =+  ResidentSupport+    { rsMinimalKeys =+        ResidentContextKeySet+          ( minimalResidentKeySet+              lattice+              ( contextKeySetFromKeys+                  (contextKeySetChunkCount (clSize lattice))+                  (fmap residentContextKeyOrdinal keys)+              )+          ),+      rsClosure = Nothing+    }++residentSupportKeys :: ResidentContext s c -> ResidentSupport s c -> [ResidentContextKey s]+residentSupportKeys _ supportValue =+  residentContextKeySetToAscList (rsMinimalKeys supportValue)++residentSupportWithClosure :: ResidentContext s c -> ResidentSupport s c -> ResidentSupport s c+residentSupportWithClosure contextValue supportValue =+  case rsClosure supportValue of+    Just _ ->+      supportValue+    Nothing ->+      supportValue+        { rsClosure = Just (residentSupportClosure contextValue supportValue)+        }++residentSupportContainsKey :: ResidentContext s c -> ResidentSupport s c -> ResidentContextKey s -> Bool+residentSupportContainsKey (ResidentContext lattice) supportValue candidateKey =+  case rsClosure supportValue of+    Just closure ->+      residentContextKeySetMember candidateKey closure+    Nothing ->+      case rsMinimalKeys supportValue of+        ResidentContextKeySet minimalKeys ->+          contextKeySetIntersects+            minimalKeys+            ( contextPlanLowerKeys+                (clPlan lattice)+                (contextKeyFromResidentKey candidateKey)+            )++residentSupportContainsElement :: ResidentContext s c -> ResidentSupport s c -> ResidentContextElement s c -> Bool+residentSupportContainsElement contextValue supportValue =+  residentSupportContainsKey contextValue supportValue . residentContextElementKey++residentSupportReachableElements :: ResidentContext s c -> ResidentSupport s c -> [ResidentContextElement s c]+residentSupportReachableElements contextValue supportValue =+  let closure =+        case rsClosure supportValue of+          Just cachedClosure -> cachedClosure+          Nothing -> residentSupportClosure contextValue supportValue+   in [ contextElement+      | contextElement <- residentContextElements contextValue,+        residentContextKeySetMember (residentContextElementKey contextElement) closure+      ]++residentSupportUnion :: ResidentContext s c -> ResidentSupport s c -> ResidentSupport s c -> ResidentSupport s c+residentSupportUnion (ResidentContext lattice) leftSupport rightSupport =+  case (rsMinimalKeys leftSupport, rsMinimalKeys rightSupport) of+    (ResidentContextKeySet leftKeys, ResidentContextKeySet rightKeys) ->+      ResidentSupport+        { rsMinimalKeys =+            ResidentContextKeySet+              (minimalResidentKeySet lattice (contextKeySetUnion leftKeys rightKeys)),+          rsClosure = Nothing+        }++residentSupportMeet :: ResidentContext s c -> ResidentSupport s c -> ResidentSupport s c -> ResidentSupport s c+residentSupportMeet (ResidentContext lattice) leftSupport rightSupport =+  case (rsMinimalKeys leftSupport, rsMinimalKeys rightSupport) of+    (ResidentContextKeySet leftKeys, ResidentContextKeySet rightKeys) ->+      let chunkCount =+            contextKeySetChunkCount (clSize lattice)+          pairwiseJoins =+            contextKeySetImage2+              chunkCount+              ( \leftOrdinal rightOrdinal ->+                  contextKeyOrdinal+                    ( contextPlanJoinKey+                        (clPlan lattice)+                        (ContextKey leftOrdinal)+                        (ContextKey rightOrdinal)+                    )+              )+              leftKeys+              rightKeys+       in ResidentSupport+          { rsMinimalKeys =+              ResidentContextKeySet+                (minimalResidentKeySet lattice pairwiseJoins),+            rsClosure = Nothing+          }++withResidentSupport ::+  Ord c =>+  ContextLattice c ->+  SupportBasis c ->+  (forall s. ResidentContext s c -> ResidentSupport s c -> Either (ContextLatticeLookupError c) result) ->+  Either (ContextLatticeLookupError c) result+withResidentSupport contextLatticeValue supportValue continuation =+  withResidentContext contextLatticeValue $ \residentContext -> do+    residentSupport <-+      residentSupportFromElements+        residentContext+        (supportGenerators supportValue)+    continuation residentContext residentSupport++withResidentSupports ::+  Ord c =>+  ContextLattice c ->+  SupportBasis c ->+  SupportBasis c ->+  (forall s. ResidentContext s c -> ResidentSupport s c -> ResidentSupport s c -> Either (ContextLatticeLookupError c) result) ->+  Either (ContextLatticeLookupError c) result+withResidentSupports contextLatticeValue leftSupport rightSupport continuation =+  withResidentContext contextLatticeValue $ \residentContext -> do+    residentLeft <-+      residentSupportFromElements+        residentContext+        (supportGenerators leftSupport)+    residentRight <-+      residentSupportFromElements+        residentContext+        (supportGenerators rightSupport)+    continuation residentContext residentLeft residentRight++supportFromResidentSupport ::+  Ord c =>+  ResidentContext s c ->+  ResidentSupport s c ->+  SupportBasis c+supportFromResidentSupport residentContext supportValue =+  SupportBasis+    ( Set.fromList+        ( residentContextElementValue+            . residentContextElementForKey residentContext+            <$> residentSupportKeys residentContext supportValue+        )+    )++reachableCandidate ::+  Ord c =>+  ResidentContext s c ->+  ResidentSupport s c ->+  c ->+  Either (ContextLatticeLookupError c) (Maybe c)+reachableCandidate residentContext supportValue contextValue = do+  candidateElement <- checkResidentContext residentContext contextValue+  pure+    ( if residentSupportContainsElement residentContext supportValue candidateElement+        then Just contextValue+        else Nothing+    )++minimalResidentKeySet :: ContextLattice c -> ContextKeySet -> ContextKeySet+minimalResidentKeySet lattice candidates =+  contextKeySetFilter isMinimal candidates+  where+    isMinimal candidateOrdinal =+      not+        ( contextKeySetIntersectsExcept+            candidateOrdinal+            candidates+            (contextPlanLowerKeys (clPlan lattice) (ContextKey candidateOrdinal))+        )++residentSupportClosure :: ResidentContext s c -> ResidentSupport s c -> ResidentContextKeySet s+residentSupportClosure (ResidentContext lattice) supportValue =+  case rsMinimalKeys supportValue of+    ResidentContextKeySet minimalKeys ->+      ResidentContextKeySet+        ( contextKeySetUnionImages+            (contextKeySetChunkCount (clSize lattice))+            ( \generatorOrdinal ->+                contextPlanUpperKeys+                  (clPlan lattice)+                  (ContextKey generatorOrdinal)+            )+            minimalKeys+        )
+ src-internal/Moonlight/Algebra/Unsafe/GCDWitness.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.Algebra.Unsafe.GCDWitness+  ( NonZero,+    NonZeroModulus,+    mkNonZeroInternal,+    nonZeroValue,+    retagNonZero,+    CanonicalResidue (..),+    canonicalResidueModulus,+    canonicalResidueValue,+  )+where++import Data.Kind (Type)+import Prelude (Bool, Eq, Maybe (..), Show, not)++type NonZero :: Type -> Type -> Type+newtype NonZero witness a = NonZero a+  deriving stock (Eq, Show)++type role NonZero nominal representational++type NonZeroModulus :: Type -> Type -> Type+type NonZeroModulus modulus a = NonZero modulus a++mkNonZeroInternal :: (a -> Bool) -> a -> Maybe (NonZero witness a)+mkNonZeroInternal isZeroValue value =+  if not (isZeroValue value)+    then Just (NonZero value)+    else Nothing++nonZeroValue :: NonZero witness a -> a+nonZeroValue (NonZero value) = value++retagNonZero :: NonZero source a -> NonZero target a+retagNonZero (NonZero value) = NonZero value++type CanonicalResidue :: Type -> Type -> Type+data CanonicalResidue modulus a = CanonicalResidue !(NonZeroModulus modulus a) !a+  deriving stock (Eq, Show)++type role CanonicalResidue nominal representational++canonicalResidueModulus :: CanonicalResidue modulus a -> NonZeroModulus modulus a+canonicalResidueModulus (CanonicalResidue modulus _) = modulus++canonicalResidueValue :: CanonicalResidue modulus a -> a+canonicalResidueValue (CanonicalResidue _ value) = value
+ src-laws/Moonlight/Algebra/Effect/LawNames.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Algebra.Effect.LawNames+  ( LawName (..),+    lawName,+    CommonLawName (..),+    IsLawName (..),+    constructorLawNameWithOverrides,+  )+where++import Data.Kind (Type)+import Moonlight.Core (CommonLawName (..), IsLawName (..), constructorLawNameWithOverrides)++type LawName :: Type+data LawName+  = MonoidAssoc+  | MonoidLeftId+  | MonoidRightId+  | GroupInvLeft+  | GroupInvRight+  | AbelianComm+  | RingAddAssoc+  | RingMulComm+  | CommonLaw CommonLawName+  | ModuleDistribScalarAdd+  | ModuleDistribVectorAdd+  | HeytingImpliesSelfTop+  | HeytingMeetImplication+  | HeytingConsequentMeetImplication+  | HeytingImplicationDistributesMeet+  | HeytingNegDefault+  | HeytingEquivalenceDefault+  | GcdDividesLeft+  | GcdDividesRight+  | ExtGcdBezout+  | ModInverseCorrect+  | ModInverseAbsentNonunit+  | CrtSound+  | UnitInverseOne+  | UnitInverseCorrect+  | UnitInverseAbsent+  | FreeMonoidAssoc+  | FreeMonoidLeftId+  | FreeMonoidRightId+  | PolynomialCanonicalizationIdempotent+  | ZnGeneratorNormalized+  | PolynomialGeneratorCanonical+  | FreeAbelianGeneratorCanonical+  | SparseVecGeneratorCanonical+  | PowerSetGeneratorCanonical+  | LaneVectorSubtraction+  | OrientationGroupInvLeft+  | OrientationGroupInvRight+  | OrientationAbelianComm+  deriving stock (Eq, Ord, Show)++lawName :: LawName -> String+lawName lawNameValue =+  case lawNameValue of+    CommonLaw commonLawName -> lawNameText commonLawName+    specificLawName -> constructorLawNameWithOverrides [("PowerSetGeneratorCanonical", "powerset_generator_canonical")] (show specificLawName)++instance IsLawName LawName where+  lawNameText = lawName
+ src-laws/Moonlight/Algebra/Effect/Laws.hs view
@@ -0,0 +1,695 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}++module Moonlight.Algebra.Effect.Laws+  ( tests,+    testsWithConfig,+  )+where++import Prelude hiding (gcd)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import Data.Vector.Unboxed qualified as UVector+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import Moonlight.Algebra+import Moonlight.Algebra.Effect.LawNames (CommonLawName (..), LawName (..))+import Moonlight.Algebra.Test.Generators+  ( AlgebraGeneratorConfig,+    defaultAlgebraGeneratorConfig,+    genBatch,+    genFreeAbelianGroup,+    genIntBasis,+    genIntegerCoefficient,+    genIntegerLawValue,+    genLaneVector,+    genModulus,+    genOrientation,+    genPolynomial,+    genPowerSet,+    genSparseVec,+    genZn,+  )+import Data.Maybe (fromMaybe)+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+    sub,+  )+import Moonlight.Core qualified as Core+import qualified Moonlight.Pale.Test.Laws.Algebraic as Algebraic+import Moonlight.Pale.Test.LawSuite+  ( LawBundle,+    hedgehogLawDefinition,+    lawBundleHedgehog,+    lawSuiteGroup,+    renderLawBundles,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++type Atom :: Type+data Atom = Alpha | Beta | Gamma+  deriving stock (Eq, Ord, Show, Enum, Bounded)++instance FiniteUniverse Atom where+  finiteUniverse =+    boundedEnumUniverse++type NonZeroGcdContext :: Type+data NonZeroGcdContext = NonZeroGcdContext+  { nonZeroGcdLeft :: Integer,+    nonZeroGcdRight :: Integer+  }+  deriving stock (Show)++type ModInverseContext :: Type+data ModInverseContext = ModInverseContext+  { modInverseCandidate :: Integer,+    modInverseModulus :: Integer+  }+  deriving stock (Show)++type CrtSoundContext :: Type+data CrtSoundContext = CrtSoundContext+  { crtLeftResidue :: Integer,+    crtLeftModulus :: Integer,+    crtRightResidue :: Integer,+    crtRightModulus :: Integer+  }+  deriving stock (Show)++type SomeNonZeroModulus :: Type -> Type+data SomeNonZeroModulus a where+  SomeNonZeroModulus :: NonZeroModulus modulus a -> SomeNonZeroModulus a++type ResidueView :: Type -> Type+data ResidueView a = ResidueView+  { residueModulusValue :: a,+    residueCandidateValue :: a+  }++genAtom :: HH.Gen Atom+genAtom =+  Gen.element [Alpha, Beta, Gamma]++genPair :: HH.Gen a -> HH.Gen b -> HH.Gen (a, b)+genPair genLeft genRight =+  (,) <$> genLeft <*> genRight++genPairOf :: HH.Gen a -> HH.Gen (a, a)+genPairOf genValue =+  genPair genValue genValue++genTriple :: HH.Gen a -> HH.Gen b -> HH.Gen c -> HH.Gen (a, b, c)+genTriple genLeft genMiddle genRight =+  (,,) <$> genLeft <*> genMiddle <*> genRight++genTripleOf :: HH.Gen a -> HH.Gen (a, a, a)+genTripleOf genValue =+  genTriple genValue genValue genValue++genNonZeroGcdContext :: AlgebraGeneratorConfig -> HH.Gen NonZeroGcdContext+genNonZeroGcdContext config =+  Gen.filter ((/= 0) . nonZeroGcdDivisor) $+    NonZeroGcdContext <$> genIntegerLawValue config <*> genIntegerLawValue config++genModInverseContext :: (Integer -> Bool) -> AlgebraGeneratorConfig -> HH.Gen ModInverseContext+genModInverseContext divisorPredicate config =+  Gen.filter (divisorPredicate . modInverseDivisor) $+    ModInverseContext <$> genIntegerLawValue config <*> genModulus config++genCrtSoundContext :: AlgebraGeneratorConfig -> HH.Gen CrtSoundContext+genCrtSoundContext config =+  CrtSoundContext+    <$> genIntegerLawValue config+    <*> genModulus config+    <*> genIntegerLawValue config+    <*> genModulus config++genIntegerUnit :: HH.Gen Integer+genIntegerUnit =+  Gen.element [1, -1]++genIntegerNonUnit :: AlgebraGeneratorConfig -> HH.Gen Integer+genIntegerNonUnit config =+  Gen.filter (not . isUnit) (genIntegerLawValue config)++applyPair :: (a -> b -> result) -> (a, b) -> result+applyPair propertyValue (leftValue, rightValue) =+  propertyValue leftValue rightValue++applyTriple :: (a -> b -> c -> result) -> (a, b, c) -> result+applyTriple propertyValue (leftValue, middleValue, rightValue) =+  propertyValue leftValue middleValue rightValue++nonZeroGcdDivisor :: NonZeroGcdContext -> Integer+nonZeroGcdDivisor context =+  gcd (nonZeroGcdLeft context) (nonZeroGcdRight context)++modInverseDivisor :: ModInverseContext -> Integer+modInverseDivisor context =+  gcd (modInverseCandidate context) (modInverseModulus context)++mkSomeNonZeroModulus :: IntegralDomain a => a -> Maybe (SomeNonZeroModulus a)+mkSomeNonZeroModulus value =+  withNonZeroModulus value SomeNonZeroModulus++canonicalResidueView :: CanonicalResidue modulus a -> ResidueView a+canonicalResidueView residue =+  withCanonicalResidue residue $ \modulus candidate ->+    withNonZeroModulusValue modulus $ \modulusValue ->+      ResidueView modulusValue candidate++monoidAssoc :: Additive (FreeAbelianGroup Int) -> Additive (FreeAbelianGroup Int) -> Additive (FreeAbelianGroup Int) -> Bool+monoidAssoc = Algebraic.monoidAssociativity (<>)++monoidLeftId :: Additive (FreeAbelianGroup Int) -> Bool+monoidLeftId = Algebraic.monoidLeftIdentity (<>) mempty++monoidRightId :: Additive (FreeAbelianGroup Int) -> Bool+monoidRightId = Algebraic.monoidRightIdentity (<>) mempty++groupInvLeft :: Additive (FreeAbelianGroup Int) -> Bool+groupInvLeft = Algebraic.groupLeftInverse (<>) groupInverse mempty++groupInvRight :: Additive (FreeAbelianGroup Int) -> Bool+groupInvRight = Algebraic.groupRightInverse (<>) groupInverse mempty++abelianGroupCommutativity :: (Eq group, AbelianGroup group) => group -> group -> Bool+abelianGroupCommutativity = Algebraic.abelianCommutativity (<>)++abelianComm :: Additive (FreeAbelianGroup Int) -> Additive (FreeAbelianGroup Int) -> Bool+abelianComm = abelianGroupCommutativity++laneVectorMonoidAssoc :: Additive LaneVector -> Additive LaneVector -> Additive LaneVector -> Bool+laneVectorMonoidAssoc = Algebraic.monoidAssociativity (<>)++laneVectorMonoidLeftId :: Additive LaneVector -> Bool+laneVectorMonoidLeftId = Algebraic.monoidLeftIdentity (<>) mempty++laneVectorMonoidRightId :: Additive LaneVector -> Bool+laneVectorMonoidRightId = Algebraic.monoidRightIdentity (<>) mempty++laneVectorGroupInvLeft :: Additive LaneVector -> Bool+laneVectorGroupInvLeft = Algebraic.groupLeftInverse (<>) groupInverse mempty++laneVectorGroupInvRight :: Additive LaneVector -> Bool+laneVectorGroupInvRight = Algebraic.groupRightInverse (<>) groupInverse mempty++laneVectorAbelianComm :: Additive LaneVector -> Additive LaneVector -> Bool+laneVectorAbelianComm = abelianGroupCommutativity++laneVectorSubtraction :: LaneVector -> LaneVector -> Bool+laneVectorSubtraction left right =+  sub left right == add left (Core.neg right)++freeMonoidAssoc :: Batch Int -> Batch Int -> Batch Int -> Bool+freeMonoidAssoc = Algebraic.monoidAssociativity (<>)++freeMonoidLeftId :: Batch Int -> Bool+freeMonoidLeftId = Algebraic.monoidLeftIdentity (<>) mempty++freeMonoidRightId :: Batch Int -> Bool+freeMonoidRightId = Algebraic.monoidRightIdentity (<>) mempty++ringMulComm :: Zn 7 -> Zn 7 -> Bool+ringMulComm = Algebraic.ringMultiplicativeCommutativity++ringAddAssoc :: Zn 7 -> Zn 7 -> Zn 7 -> Bool+ringAddAssoc = Algebraic.ringAdditiveAssociativity++latticeAbsorptionJoin :: PowerSet Atom -> PowerSet Atom -> Bool+latticeAbsorptionJoin = Algebraic.latticeAbsorptionJoin join meet++latticeAbsorptionMeet :: PowerSet Atom -> PowerSet Atom -> Bool+latticeAbsorptionMeet = Algebraic.latticeAbsorptionMeet join meet++heytingImpliesSelfTop :: PowerSet Atom -> Bool+heytingImpliesSelfTop value =+  implies value value == top++heytingMeetImplication :: PowerSet Atom -> PowerSet Atom -> Bool+heytingMeetImplication left right =+  meet left (implies left right) == meet left right++heytingConsequentMeetImplication :: PowerSet Atom -> PowerSet Atom -> Bool+heytingConsequentMeetImplication left right =+  meet right (implies left right) == right++heytingImplicationDistributesMeet :: PowerSet Atom -> PowerSet Atom -> PowerSet Atom -> Bool+heytingImplicationDistributesMeet left middle right =+  implies left (meet middle right) == meet (implies left middle) (implies left right)++heytingNegDefault :: PowerSet Atom -> Bool+heytingNegDefault value =+  neg value == implies value bottom++heytingEquivalenceDefault :: PowerSet Atom -> PowerSet Atom -> Bool+heytingEquivalenceDefault left right =+  (left <=> right) == meet (implies left right) (implies right left)++moduleDistribScalarAdd :: Integer -> Integer -> Polynomial Integer -> Bool+moduleDistribScalarAdd = Algebraic.moduleDistributivityScalar add add scale++moduleDistribVectorAdd :: Integer -> Polynomial Integer -> Polynomial Integer -> Bool+moduleDistribVectorAdd = Algebraic.moduleDistributivityVector add scale++polynomialCanonicalizationIdempotent :: Polynomial Integer -> Bool+polynomialCanonicalizationIdempotent = Algebraic.idempotentLaw normalizePolynomial++polynomialViewsCoherent :: Polynomial Integer -> Bool+polynomialViewsCoherent polynomialValue =+  all denseCoefficientMatches denseCoefficients+    && all supportCoefficientMatches (support @Integer polynomialValue)+  where+    denseCoefficients = zip [0 ..] (toCoefficients polynomialValue)+    coefficientsByDegree = Map.fromList denseCoefficients++    denseCoefficientMatches (degreeValue, coefficientValue) =+      coefficient @Integer degreeValue polynomialValue == coefficientValue++    supportCoefficientMatches degreeValue =+      Map.lookup degreeValue coefficientsByDegree+        == Just (coefficient @Integer degreeValue polynomialValue)++unitInverseOne :: () -> Bool+unitInverseOne () = isUnit (one :: Integer)++unitInverseCorrect :: Integer -> Bool+unitInverseCorrect value =+  case unitInverse value of+    Nothing -> False+    Just inverseValue -> mul value inverseValue == one && mul inverseValue value == one++unitInverseAbsent :: Integer -> Bool+unitInverseAbsent value =+  unitInverse value == Nothing++dividesInteger :: Integer -> Integer -> Bool+dividesInteger divisor value+  | divisor == 0 = value == 0+  | otherwise =+      maybe False ((== 0) . snd) $ do+        divisorRefined <- mkNonZeroDivisor divisor+        pure (divideWithRemainder value divisorRefined)++normalizeInteger :: Integer -> Integer -> Maybe Integer+normalizeInteger modulus value = do+  modulusRefined <- mkNonZeroDivisor modulus+  pure (snd (divideWithRemainder value modulusRefined))++gcdDividesLeft :: NonZeroGcdContext -> Bool+gcdDividesLeft context =+  dividesInteger (nonZeroGcdDivisor context) (nonZeroGcdLeft context)++gcdDividesRight :: NonZeroGcdContext -> Bool+gcdDividesRight context =+  dividesInteger (nonZeroGcdDivisor context) (nonZeroGcdRight context)++extGcdBezout :: Integer -> Integer -> Bool+extGcdBezout left right =+  let (gcdValue, coefficientLeft, coefficientRight) = extGcd left right+   in add (mul coefficientLeft left) (mul coefficientRight right) == gcdValue++modInverseCorrect :: ModInverseContext -> Bool+modInverseCorrect context =+  fromMaybe False $+    withNonZeroModulus (modInverseModulus context) $ \modulusRefined ->+      case modInverse (modInverseCandidate context) modulusRefined of+        Nothing -> False+        Just inverseValue ->+          dividesInteger+            (modInverseModulus context)+            (sub (mul (modInverseCandidate context) inverseValue) one)++modInverseAbsentNonunit :: ModInverseContext -> Bool+modInverseAbsentNonunit context =+  fromMaybe False $+    withNonZeroModulus (modInverseModulus context) $ \modulusRefined ->+      modInverse (modInverseCandidate context) modulusRefined == Nothing++crtSound :: CrtSoundContext -> Bool+crtSound =+  fromMaybe False . crtSoundResult++crtSoundResult :: CrtSoundContext -> Maybe Bool+crtSoundResult context = do+  let leftModulus = crtLeftModulus context+      rightModulus = crtRightModulus context+      divisor = gcd leftModulus rightModulus+  normalizedLeftResidue <- normalizeInteger leftModulus (crtLeftResidue context)+  normalizedRightResidue <- normalizeInteger rightModulus (crtRightResidue context)+  divisorRefined <- mkNonZeroDivisor divisor+  let (reducedRightModulus, _) = divideWithRemainder rightModulus divisorRefined+      congruencesCompatible = dividesInteger divisor (sub normalizedRightResidue normalizedLeftResidue)+      combinedModulusExpected = mul leftModulus reducedRightModulus+  SomeNonZeroModulus leftModulusRefined <- mkSomeNonZeroModulus leftModulus+  SomeNonZeroModulus rightModulusRefined <- mkSomeNonZeroModulus rightModulus+  pure $+    case+      crt+        (mkCanonicalResidue leftModulusRefined normalizedLeftResidue)+        (mkCanonicalResidue rightModulusRefined normalizedRightResidue) of+      Nothing -> not congruencesCompatible+      Just combinedResidue ->+        combinedResidueSound+          leftModulus+          normalizedLeftResidue+          rightModulus+          normalizedRightResidue+          combinedModulusExpected+          combinedResidue++combinedResidueSound :: Integer -> Integer -> Integer -> Integer -> Integer -> CanonicalResidue modulus Integer -> Bool+combinedResidueSound leftModulus normalizedLeftResidue rightModulus normalizedRightResidue combinedModulusExpected combinedResidue =+  let residueView = canonicalResidueView combinedResidue+      candidate = residueCandidateValue residueView+   in dividesInteger leftModulus (sub candidate normalizedLeftResidue)+        && dividesInteger rightModulus (sub candidate normalizedRightResidue)+        && residueModulusValue residueView == combinedModulusExpected++znGeneratorNormalized :: Zn 7 -> Bool+znGeneratorNormalized value =+  let modulus = znModulus (Proxy @7)+      residue = unZn value+   in residue >= 0 && residue < modulus++polynomialGeneratorCanonical :: Polynomial Integer -> Bool+polynomialGeneratorCanonical polynomialValue =+  normalizePolynomial polynomialValue == polynomialValue++freeAbelianGeneratorCanonical :: FreeAbelianGroup Int -> Bool+freeAbelianGeneratorCanonical groupValue =+  normalizeFreeAbelianGroup groupValue == groupValue++sparseVecGeneratorCanonical :: SparseVec Integer Int -> Bool+sparseVecGeneratorCanonical sparseVector =+  normalize sparseVector == sparseVector++powerSetGeneratorCanonical :: PowerSet Atom -> Bool+powerSetGeneratorCanonical powerSet =+  normalizePowerSet powerSet == powerSet++orientationGroupInvLeft :: Orientation -> Bool+orientationGroupInvLeft = Algebraic.groupLeftInverse (<>) groupInverse mempty++orientationGroupInvRight :: Orientation -> Bool+orientationGroupInvRight = Algebraic.groupRightInverse (<>) groupInverse mempty++orientationAbelianComm :: Orientation -> Orientation -> Bool+orientationAbelianComm = Algebraic.abelianCommutativity (<>)++tests :: TestTree+tests =+  testsWithConfig defaultAlgebraGeneratorConfig++testsWithConfig :: AlgebraGeneratorConfig -> TestTree+testsWithConfig config =+  testGroup+    "moonlight-algebra"+    [ lawSuiteGroup+        "laws"+        (renderLawBundles id (algebraLawBundles config)),+      representationBoundaryTests config,+      boolSemiringTests,+      latticeImplementationTests+    ]++algebraLawBundles :: AlgebraGeneratorConfig -> [LawBundle String]+algebraLawBundles config =+  let genFreeAbelianInt = genFreeAbelianGroup config (genIntBasis config)+      genAdditiveFreeAbelianInt = Additive <$> genFreeAbelianInt+      genAdditiveLaneVector = Additive <$> genLaneVector+      genFreeMonoidInt = genBatch config (genIntBasis config)+      genZn7 = genZn @7 config+      genCoefficient = genIntegerCoefficient config+      genInteger = genIntegerLawValue config+      genPolynomialInteger = genPolynomial config genCoefficient+      genPowerSetAtom = genPowerSet config genAtom+      genSparseVecIntegerInt = genSparseVec config (genIntBasis config) genCoefficient+   in [ lawBundleHedgehog+          "additive-wrapper"+          [ hedgehogLawDefinition MonoidAssoc (genTripleOf genAdditiveFreeAbelianInt) (applyTriple monoidAssoc),+            hedgehogLawDefinition MonoidLeftId genAdditiveFreeAbelianInt monoidLeftId,+            hedgehogLawDefinition MonoidRightId genAdditiveFreeAbelianInt monoidRightId,+            hedgehogLawDefinition GroupInvLeft genAdditiveFreeAbelianInt groupInvLeft,+            hedgehogLawDefinition GroupInvRight genAdditiveFreeAbelianInt groupInvRight,+            hedgehogLawDefinition AbelianComm (genPairOf genAdditiveFreeAbelianInt) (applyPair abelianComm)+          ],+        lawBundleHedgehog+          "lane-vector-additive"+          [ hedgehogLawDefinition MonoidAssoc (genTripleOf genAdditiveLaneVector) (applyTriple laneVectorMonoidAssoc),+            hedgehogLawDefinition MonoidLeftId genAdditiveLaneVector laneVectorMonoidLeftId,+            hedgehogLawDefinition MonoidRightId genAdditiveLaneVector laneVectorMonoidRightId,+            hedgehogLawDefinition GroupInvLeft genAdditiveLaneVector laneVectorGroupInvLeft,+            hedgehogLawDefinition GroupInvRight genAdditiveLaneVector laneVectorGroupInvRight,+            hedgehogLawDefinition AbelianComm (genPairOf genAdditiveLaneVector) (applyPair laneVectorAbelianComm),+            hedgehogLawDefinition LaneVectorSubtraction (genPairOf genLaneVector) (applyPair laneVectorSubtraction)+          ],+        lawBundleHedgehog+          "free-monoid"+          [ hedgehogLawDefinition FreeMonoidAssoc (genTripleOf genFreeMonoidInt) (applyTriple freeMonoidAssoc),+            hedgehogLawDefinition FreeMonoidLeftId genFreeMonoidInt freeMonoidLeftId,+            hedgehogLawDefinition FreeMonoidRightId genFreeMonoidInt freeMonoidRightId+          ],+        lawBundleHedgehog+          "ring"+          [ hedgehogLawDefinition RingAddAssoc (genTripleOf genZn7) (applyTriple ringAddAssoc),+            hedgehogLawDefinition RingMulComm (genPairOf genZn7) (applyPair ringMulComm)+          ],+        lawBundleHedgehog+          "lattice"+          [ hedgehogLawDefinition (CommonLaw LatticeAbsorptionJoin) (genPairOf genPowerSetAtom) (applyPair latticeAbsorptionJoin),+            hedgehogLawDefinition (CommonLaw LatticeAbsorptionMeet) (genPairOf genPowerSetAtom) (applyPair latticeAbsorptionMeet)+          ],+        lawBundleHedgehog+          "heyting"+          [ hedgehogLawDefinition HeytingImpliesSelfTop genPowerSetAtom heytingImpliesSelfTop,+            hedgehogLawDefinition HeytingMeetImplication (genPairOf genPowerSetAtom) (applyPair heytingMeetImplication),+            hedgehogLawDefinition HeytingConsequentMeetImplication (genPairOf genPowerSetAtom) (applyPair heytingConsequentMeetImplication),+            hedgehogLawDefinition HeytingImplicationDistributesMeet (genTripleOf genPowerSetAtom) (applyTriple heytingImplicationDistributesMeet),+            hedgehogLawDefinition HeytingNegDefault genPowerSetAtom heytingNegDefault,+            hedgehogLawDefinition HeytingEquivalenceDefault (genPairOf genPowerSetAtom) (applyPair heytingEquivalenceDefault)+          ],+        lawBundleHedgehog+          "module"+          [ hedgehogLawDefinition ModuleDistribScalarAdd (genTriple genCoefficient genCoefficient genPolynomialInteger) (applyTriple moduleDistribScalarAdd),+            hedgehogLawDefinition ModuleDistribVectorAdd (genTriple genCoefficient genPolynomialInteger genPolynomialInteger) (applyTriple moduleDistribVectorAdd)+          ],+        lawBundleHedgehog+          "unit"+          [ hedgehogLawDefinition UnitInverseOne (pure ()) unitInverseOne,+            hedgehogLawDefinition UnitInverseCorrect genIntegerUnit unitInverseCorrect,+            hedgehogLawDefinition UnitInverseAbsent (genIntegerNonUnit config) unitInverseAbsent+          ],+        lawBundleHedgehog+          "gcd"+          [ hedgehogLawDefinition GcdDividesLeft (genNonZeroGcdContext config) gcdDividesLeft,+            hedgehogLawDefinition GcdDividesRight (genNonZeroGcdContext config) gcdDividesRight,+            hedgehogLawDefinition ExtGcdBezout (genPairOf genInteger) (applyPair extGcdBezout),+            hedgehogLawDefinition ModInverseCorrect (genModInverseContext isUnit config) modInverseCorrect,+            hedgehogLawDefinition ModInverseAbsentNonunit (genModInverseContext (not . isUnit) config) modInverseAbsentNonunit,+            hedgehogLawDefinition CrtSound (genCrtSoundContext config) crtSound+          ],+        lawBundleHedgehog+          "canonicalization"+          [ hedgehogLawDefinition PolynomialCanonicalizationIdempotent genPolynomialInteger polynomialCanonicalizationIdempotent+          ],+        lawBundleHedgehog+          "hedgehog-generators"+          [ hedgehogLawDefinition ZnGeneratorNormalized genZn7 znGeneratorNormalized,+            hedgehogLawDefinition PolynomialGeneratorCanonical genPolynomialInteger polynomialGeneratorCanonical,+            hedgehogLawDefinition FreeAbelianGeneratorCanonical genFreeAbelianInt freeAbelianGeneratorCanonical,+            hedgehogLawDefinition SparseVecGeneratorCanonical genSparseVecIntegerInt sparseVecGeneratorCanonical,+            hedgehogLawDefinition PowerSetGeneratorCanonical genPowerSetAtom powerSetGeneratorCanonical+          ],+        lawBundleHedgehog+          "orientation"+          [ hedgehogLawDefinition OrientationGroupInvLeft genOrientation orientationGroupInvLeft,+            hedgehogLawDefinition OrientationGroupInvRight genOrientation orientationGroupInvRight,+            hedgehogLawDefinition OrientationAbelianComm (genPairOf genOrientation) (applyPair orientationAbelianComm)+          ]+      ]++representationBoundaryTests :: AlgebraGeneratorConfig -> TestTree+representationBoundaryTests config =+  testGroup+    "representation-boundaries"+    [ testCase "huge polynomial degree keeps sparse and dense observations coherent" $ do+        let hugeDegree = fromIntegral (maxBound :: Int) + 1+            hugePolynomial = monomial hugeDegree (1 :: Integer)+        coefficient @Integer hugeDegree hugePolynomial @?= 1+        take 1 (toCoefficients hugePolynomial) @?= [0]+        assertBool+          "a huge monomial is not the constant polynomial"+          (hugePolynomial /= fromCoefficients [1]),+      testProperty "ordinary polynomial sparse and dense views agree" $ HH.property $ do+        polynomialValue <- HH.forAll (genPolynomial config (genIntegerCoefficient config))+        HH.assert (polynomialViewsCoherent polynomialValue),+      testCase "lane vector construction pads short inputs" $+        laneVectorLanes (laneVectorFromLanes (UVector.fromList [1, 2]))+          @?= UVector.fromList (1 : 2 : replicate (laneCount - 2) 0),+      testCase "lane vector construction truncates long inputs" $+        laneVectorLanes (laneVectorFromLanes (UVector.generate (laneCount + 1) fromIntegral))+          @?= UVector.generate laneCount fromIntegral,+      testCase "product arity remains a Natural until list construction" $ do+        mkProductAlgebra @18446744073709551616 ([] :: [Int]) @?= Nothing+        take 1+          (toProductList (pure 7 :: ProductAlgebra 18446744073709551616 Int))+          @?= [7],+      testCase "Euclidean division rejects a zero divisor at construction" $+        assertBool+          "zero must not construct a NonZeroDivisor"+          (case mkNonZeroDivisor (0 :: Integer) of+             Nothing -> True+             Just _ -> False)+    ]++boolSemiringTests :: TestTree+boolSemiringTests =+  testGroup+    "bool-semiring"+    [ testCase "zero is additive identity and absorbing for multiplication" $+        assertBool+          "bool semiring zero laws"+          (all+             (\value ->+                add zero value == value+                  && add value zero == value+                  && mul zero value == zero+                  && mul value zero == zero+             )+             [False, True]+          ),+      testCase "one is multiplicative identity" $+        assertBool+          "bool semiring one laws"+          (all+             (\value ->+                mul one value == value+                  && mul value one == value+             )+             [False, True]+          ),+      testCase "multiplication distributes over addition" $+        assertBool+          "bool semiring distributivity"+          (all+             (\(leftValue, middleValue, rightValue) ->+                mul leftValue (add middleValue rightValue)+                  == add+                    (mul leftValue middleValue)+                    (mul leftValue rightValue)+                  && mul (add middleValue rightValue) leftValue+                    == add+                      (mul middleValue leftValue)+                      (mul rightValue leftValue)+             )+             [ (leftValue, middleValue, rightValue)+             | leftValue <- [False, True],+               middleValue <- [False, True],+               rightValue <- [False, True]+             ]+          )+    ]++latticeImplementationTests :: TestTree+latticeImplementationTests =+  testGroup+    "lattice-implementation"+    [ testCase "bounded and non-empty folds use the local semilattice tower" $ do+        joins ([] :: [Bool]) @?= False+        joins [False, True, False] @?= True+        joins1 (False :| [True, False]) @?= True+        meets ([] :: [Bool]) @?= True+        meets [True, False, True] @?= False+        meets1 (True :| [False, True]) @?= False,+      testCase "Join and Meet wrappers expose semilattice folds" $ do+        foldMap Join [False, True, False] @?= Join True+        foldMap Meet [True, False, True] @?= Meet False,+      testCase "joinLeq and meetLeq induce the Bool lattice order" $ do+        joinLeq False True @?= True+        joinLeq True False @?= False+        meetLeq False True @?= True+        meetLeq True False @?= False+        fromBool True @?= True+        fromBool False @?= False,+      testCase "true lattice fixpoints iterate the endomap with an explicit budget" $ do+        leastFixpoint 4 growPowerSet+          @?= Right (fromList [Alpha, Beta, Gamma] :: PowerSet Atom)+        greatestFixpoint 4 shrinkPowerSet+          @?= Right (fromList [] :: PowerSet Atom)+        iterateFixpointFrom 4 (fromList [Alpha, Beta] :: PowerSet Atom) shrinkPowerSet+          @?= Right (fromList [] :: PowerSet Atom),+      testCase "pre/post lattice closures are distinct from true fixpoints" $ do+        leastFixpoint 2 not @?= Left (FixpointDivergence 2 False)+        leastPreFixpoint 2 not @?= Right True+        greatestFixpoint 2 not @?= Left (FixpointDivergence 2 True)+        greatestPostFixpoint 2 not @?= Right False,+      testCase "seeded pre/post closures keep the old closure law under explicit names" $ do+        leastPreFixpointFrom 3 (fromList [Beta] :: PowerSet Atom) growPowerSet+          @?= Right (fromList [Alpha, Beta, Gamma] :: PowerSet Atom)+        greatestPostFixpointFrom 4 (fromList [Alpha, Beta] :: PowerSet Atom) shrinkPowerSet+          @?= Right (fromList [] :: PowerSet Atom),+      testCase "bounded lattice fixpoints report typed divergence" $+        leastFixpoint 2 growPowerSet+          @?= Left (FixpointDivergence 2 (fromList [Alpha, Beta] :: PowerSet Atom)),+      testCase "containers inherit finite-support lattice operations" $ do+        join (Set.fromList [1, 2 :: Int]) (Set.fromList [2, 3])+          @?= Set.fromList [1, 2, 3]+        meet (Set.fromList [1, 2 :: Int]) (Set.fromList [2, 3])+          @?= Set.fromList [2]+        join (IntSet.fromList [1, 2]) (IntSet.fromList [2, 3])+          @?= IntSet.fromList [1, 2, 3]+        meet (IntSet.fromList [1, 2]) (IntSet.fromList [2, 3])+          @?= IntSet.fromList [2]+        join+          (Map.fromList [("a", False), ("b", True)])+          (Map.fromList [("a", True), ("c", True)])+          @?= Map.fromList [("a", True), ("b", True), ("c", True)]+        meet+          (Map.fromList [("a", False), ("b", True)])+          (Map.fromList [("a", True), ("c", True)])+          @?= Map.fromList [("a", False)]+        join+          (IntMap.fromList [(1, False), (2, True)])+          (IntMap.fromList [(1, True), (3, True)])+          @?= IntMap.fromList [(1, True), (2, True), (3, True)]+        meet+          (IntMap.fromList [(1, False), (2, True)])+          (IntMap.fromList [(1, True), (3, True)])+          @?= IntMap.fromList [(1, False)],+      testCase "product algebras inherit componentwise lattice operations" $+        case+          ( mkProductAlgebra @3 [False, True, False],+            mkProductAlgebra @3 [True, False, False]+          ) of+          (Just left, Just right) -> do+            toProductList (join left right) @?= [True, True, False]+            toProductList (meet left right) @?= [False, False, False]+            toProductList (implies left right) @?= [True, False, True]+            toProductList (complement left) @?= [True, False, True]+          _ ->+            assertBool "test product arity is fixed at the type level" False+    ]++growPowerSet :: PowerSet Atom -> PowerSet Atom+growPowerSet current+  | member Gamma current = current+  | member Beta current = fromList [Alpha, Beta, Gamma]+  | member Alpha current = fromList [Alpha, Beta]+  | otherwise = fromList [Alpha]++shrinkPowerSet :: PowerSet Atom -> PowerSet Atom+shrinkPowerSet current+  | member Alpha current = fromList [Beta, Gamma]+  | member Beta current = fromList [Gamma]+  | otherwise = fromList []
+ src-laws/Moonlight/Algebra/Test/Generators.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Algebra.Test.Generators+  ( AlgebraGeneratorConfig (..),+    defaultAlgebraGeneratorConfig,+    genBatch,+    genFreeAbelianGroup,+    genIntBasis,+    genIntegerCoefficient,+    genIntegerLawValue,+    genIntegerWeight,+    genLaneVector,+    genModulus,+    genOrientation,+    genPolynomial,+    genPowerSet,+    genSparseVec,+    genZn,+  )+where++import GHC.TypeNats (KnownNat, type (<=))+import Data.Vector.Unboxed qualified as UVector+import qualified Hedgehog as HH+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Moonlight.Algebra++data AlgebraGeneratorConfig = AlgebraGeneratorConfig+  { collectionLengthRange :: Range.Range Int,+    integerLawRange :: Range.Range Integer,+    integerCoefficientRange :: Range.Range Integer,+    integerWeightRange :: Range.Range Integer,+    intBasisRange :: Range.Range Int,+    modulusRange :: Range.Range Integer,+    znRepresentativeRange :: Range.Range Integer+  }++defaultAlgebraGeneratorConfig :: AlgebraGeneratorConfig+defaultAlgebraGeneratorConfig =+  AlgebraGeneratorConfig+    { collectionLengthRange = Range.linear 0 16,+      integerLawRange = Range.linear (-1000) 1000,+      integerCoefficientRange = Range.linear (-100) 100,+      integerWeightRange = Range.linear (-20) 20,+      intBasisRange = Range.linear (-8) 8,+      modulusRange = Range.linear 2 100,+      znRepresentativeRange = Range.linear (-1000) 1000+    }++genBatch :: AlgebraGeneratorConfig -> HH.Gen a -> HH.Gen (Batch a)+genBatch config genElement =+  Batch <$> Gen.list (collectionLengthRange config) genElement++genFreeAbelianGroup :: Ord g => AlgebraGeneratorConfig -> HH.Gen g -> HH.Gen (FreeAbelianGroup g)+genFreeAbelianGroup config genGenerator =+  fromTerms <$> Gen.list (collectionLengthRange config) ((,) <$> genGenerator <*> genIntegerWeight config)++genIntBasis :: AlgebraGeneratorConfig -> HH.Gen Int+genIntBasis =+  Gen.int . intBasisRange++genIntegerCoefficient :: AlgebraGeneratorConfig -> HH.Gen Integer+genIntegerCoefficient =+  Gen.integral . integerCoefficientRange++genIntegerLawValue :: AlgebraGeneratorConfig -> HH.Gen Integer+genIntegerLawValue =+  Gen.integral . integerLawRange++genIntegerWeight :: AlgebraGeneratorConfig -> HH.Gen Integer+genIntegerWeight =+  Gen.integral . integerWeightRange++genLaneVector :: HH.Gen LaneVector+genLaneVector =+  laneVectorFromLanes . UVector.fromList+    <$> Gen.list+      (Range.constant laneCount laneCount)+      (Gen.word64 Range.linearBounded)++genModulus :: AlgebraGeneratorConfig -> HH.Gen Integer+genModulus =+  Gen.integral . modulusRange++genOrientation :: HH.Gen Orientation+genOrientation =+  Gen.element [Positive, Negative]++genPolynomial :: (Eq r, AdditiveGroup r) => AlgebraGeneratorConfig -> HH.Gen r -> HH.Gen (Polynomial r)+genPolynomial config genScalar =+  fromCoefficients <$> Gen.list (collectionLengthRange config) genScalar++genPowerSet :: Ord a => AlgebraGeneratorConfig -> HH.Gen a -> HH.Gen (PowerSet a)+genPowerSet config genElement =+  fromList <$> Gen.list (collectionLengthRange config) genElement++genSparseVec ::+  (Eq r, AdditiveGroup r, Ord g) =>+  AlgebraGeneratorConfig ->+  HH.Gen g ->+  HH.Gen r ->+  HH.Gen (SparseVec r g)+genSparseVec config genGenerator genScalar =+  fromEntries <$> Gen.list (collectionLengthRange config) ((,) <$> genGenerator <*> genScalar)++genZn :: forall n. (KnownNat n, 1 <= n) => AlgebraGeneratorConfig -> HH.Gen (Zn n)+genZn config =+  mkZn <$> Gen.integral (znRepresentativeRange config)
+ src-public/Moonlight/Algebra.hs view
@@ -0,0 +1,69 @@+{-|+Convenience re-export of the whole "Moonlight.Algebra.Pure" tower as a single+import. For finer-grained control, import the individual @Moonlight.Algebra.Pure.*@+modules directly.+-}+module Moonlight.Algebra+  ( -- * Standard semigroups, monoids and groups+    module Group,+    module LaneVector,+    -- * Free structures+    module FreeMonoid,+    module FreeAbelianGroup,+    module EndoPatch,+    -- * Actions+    module Action,+    -- * Lattices and orientation+    module Lattice,+    module Orientation,+    -- * Rings, modular arithmetic and number theory+    module Ring,+    module Zn,+    module NumberTheory,+    module GCD,+    -- * Modules, vector spaces and magnitude+    module Module,+    module Magnitude,+    -- * Polynomials+    module Polynomial,+    -- * Power sets, products and quotients+    module PowerSet,+    module Product,+    module Quotient,+    -- * Sparse vectors+    module SparseVec,+    -- * Selected re-exports from "Moonlight.Core"+    AdditiveGroup,+    AdditiveMonoid (..),+    Field (..),+    MultiplicativeMonoid (..),+    Ring,+  )+where++import Moonlight.Algebra.Pure.Action as Action+import Moonlight.Algebra.Pure.EndoPatch as EndoPatch+import Moonlight.Algebra.Pure.FreeAbelianGroup as FreeAbelianGroup+import Moonlight.Algebra.Pure.FreeMonoid as FreeMonoid+import Moonlight.Algebra.Pure.GCD as GCD+import Moonlight.Algebra.Pure.Group as Group+import Moonlight.Algebra.Pure.Lattice as Lattice+import Moonlight.Algebra.Pure.LaneVector as LaneVector+import Moonlight.Algebra.Pure.Magnitude as Magnitude+import Moonlight.Algebra.Pure.Module as Module+import Moonlight.Algebra.Pure.NumberTheory as NumberTheory+import Moonlight.Algebra.Pure.Orientation as Orientation+import Moonlight.Algebra.Pure.Polynomial as Polynomial+import Moonlight.Algebra.Pure.PowerSet as PowerSet+import Moonlight.Algebra.Pure.Product as Product+import Moonlight.Algebra.Pure.Quotient as Quotient+import Moonlight.Algebra.Pure.Ring as Ring+import Moonlight.Algebra.Pure.SparseVec as SparseVec+import Moonlight.Algebra.Pure.Zn as Zn+import Moonlight.Core+  ( AdditiveGroup,+    AdditiveMonoid (..),+    Field (..),+    MultiplicativeMonoid (..),+    Ring,+  )
+ test/abstract/AbstractTests.hs view
@@ -0,0 +1,21 @@+module AbstractTests+  ( tests,+  )+where++import Moonlight.Algebra.Effect.Laws qualified as EffectLaws+import OrderedLatticeSpec qualified+import SparseVecSpec qualified+import Test.Tasty+  ( TestTree,+    testGroup,+  )++tests :: TestTree+tests =+  testGroup+    "moonlight-algebra"+    [ EffectLaws.tests,+      OrderedLatticeSpec.tests,+      SparseVecSpec.tests+    ]
+ test/abstract/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import AbstractTests qualified+import Moonlight.Pale.Test.Runner (runTestTree)++main :: IO ()+main =+  runTestTree AbstractTests.tests
+ test/abstract/OrderedLatticeSpec.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++module OrderedLatticeSpec+  ( tests,+  )+where++import Control.Monad+  ( when,+  )+import Data.Foldable+  ( traverse_,+  )+import Data.List+  ( subsequences,+  )+import Data.Set qualified as Set+import Moonlight.Algebra+  ( JoinSemilattice (..),+    MeetSemilattice (..),+    OrderedLattice,+  )+import Moonlight.Algebra+  ( PowerSet,+    fromList,+  )+import Moonlight.Algebra+  ( mkProductAlgebra,+    toProductList,+  )+import Moonlight.Core+  ( FiniteUniverse (..),+    boundedEnumUniverse,+  )+import Moonlight.Core+  ( PartialOrder (..),+    comparable,+    incomparable,+  )+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( Assertion,+    assertBool,+    assertEqual,+    assertFailure,+    testCase,+    (@?=),+  )++data Atom+  = AtomA+  | AtomB+  | AtomC+  deriving stock (Eq, Ord, Show, Enum, Bounded)++instance FiniteUniverse Atom where+  finiteUniverse =+    boundedEnumUniverse++tests :: TestTree+tests =+  testGroup+    "ordered lattice"+    [ testCase "Bool join and meet are least upper and greatest lower bounds" $+        assertOrderedLatticeLaws "Bool" [False, True],+      testCase "Set Int join and meet are least upper and greatest lower bounds" $+        assertOrderedLatticeLaws "Set Int" setSamples,+      testCase "PowerSet Atom obeys ordered lattice laws" $+        assertOrderedLatticeLaws "PowerSet Atom" powerSetSamples,+      testCase "ProductAlgebra 2 Bool matches DBSP product-time join and meet shape" testProductLattice+    ]++assertOrderedLatticeLaws ::+  (OrderedLattice lattice, Show lattice) =>+  String ->+  [lattice] ->+  Assertion+assertOrderedLatticeLaws label values = do+  traverse_ (uncurry (assertJoinMeetOrderCoherence label)) (pairs values)+  traverse_ (uncurry (assertLeastUpperBound label values)) (pairs values)+  traverse_ (uncurry (assertGreatestLowerBound label values)) (pairs values)+  traverse_ (assertIdempotence label) values+  traverse_ (uncurry (assertCommutativity label)) (pairs values)+  traverse_ (assertAssociativity label) (triples values)+  traverse_ (uncurry (assertAbsorption label)) (pairs values)++assertJoinMeetOrderCoherence ::+  (OrderedLattice lattice, Show lattice) =>+  String ->+  lattice ->+  lattice ->+  Assertion+assertJoinMeetOrderCoherence label left right = do+  leq left right @?= (join left right == right)+  leq left right @?= (meet left right == left)+  assertBool+    (label <> " join is not above left at " <> show (left, right))+    (leq left (join left right))+  assertBool+    (label <> " join is not above right at " <> show (left, right))+    (leq right (join left right))+  assertBool+    (label <> " meet is not below left at " <> show (left, right))+    (leq (meet left right) left)+  assertBool+    (label <> " meet is not below right at " <> show (left, right))+    (leq (meet left right) right)++assertLeastUpperBound ::+  (OrderedLattice lattice, Show lattice) =>+  String ->+  [lattice] ->+  lattice ->+  lattice ->+  Assertion+assertLeastUpperBound label values left right =+  traverse_ checkCandidate values+  where+    leastUpperBound =+      join left right++    checkCandidate candidate =+      when (leq left candidate && leq right candidate) $+        assertBool+          ( label+              <> " join is not least at "+              <> show (left, right, candidate)+          )+          (leq leastUpperBound candidate)++assertGreatestLowerBound ::+  (OrderedLattice lattice, Show lattice) =>+  String ->+  [lattice] ->+  lattice ->+  lattice ->+  Assertion+assertGreatestLowerBound label values left right =+  traverse_ checkCandidate values+  where+    greatestLowerBound =+      meet left right++    checkCandidate candidate =+      when (leq candidate left && leq candidate right) $+        assertBool+          ( label+              <> " meet is not greatest at "+              <> show (left, right, candidate)+          )+          (leq candidate greatestLowerBound)++assertIdempotence ::+  (Eq lattice, Show lattice, JoinSemilattice lattice, MeetSemilattice lattice) =>+  String ->+  lattice ->+  Assertion+assertIdempotence label value = do+  assertEqual (label <> " join idempotence at " <> show value) value (join value value)+  assertEqual (label <> " meet idempotence at " <> show value) value (meet value value)++assertCommutativity ::+  (Eq lattice, Show lattice, JoinSemilattice lattice, MeetSemilattice lattice) =>+  String ->+  lattice ->+  lattice ->+  Assertion+assertCommutativity label left right = do+  assertEqual+    (label <> " join commutativity at " <> show (left, right))+    (join left right)+    (join right left)+  assertEqual+    (label <> " meet commutativity at " <> show (left, right))+    (meet left right)+    (meet right left)++assertAssociativity ::+  (Eq lattice, Show lattice, JoinSemilattice lattice, MeetSemilattice lattice) =>+  String ->+  (lattice, lattice, lattice) ->+  Assertion+assertAssociativity label (left, middle, right) = do+  assertEqual+    (label <> " join associativity at " <> show (left, middle, right))+    (join (join left middle) right)+    (join left (join middle right))+  assertEqual+    (label <> " meet associativity at " <> show (left, middle, right))+    (meet (meet left middle) right)+    (meet left (meet middle right))++assertAbsorption ::+  (Eq lattice, Show lattice, JoinSemilattice lattice, MeetSemilattice lattice) =>+  String ->+  lattice ->+  lattice ->+  Assertion+assertAbsorption label left right = do+  assertEqual+    (label <> " join absorption at " <> show (left, right))+    left+    (join left (meet left right))+  assertEqual+    (label <> " meet absorption at " <> show (left, right))+    left+    (meet left (join left right))++testProductLattice :: Assertion+testProductLattice =+  case+    ( traverse (mkProductAlgebra @2) [[False, True], [True, False], [True, True], [False, False]],+      traverse (mkProductAlgebra @2) productBoolCoordinateLists+    ) of+    (Just [left, right, expectedJoin, expectedMeet], Just productBoolSamples) -> do+      toProductList (join left right) @?= toProductList expectedJoin+      toProductList (meet left right) @?= toProductList expectedMeet+      leq left expectedJoin @?= True+      leq right expectedJoin @?= True+      comparable left expectedJoin @?= True+      incomparable left right @?= True+      assertOrderedLatticeLaws "ProductAlgebra 2 Bool" productBoolSamples+    _ ->+      assertFailure "test fixture declared an invalid ProductAlgebra arity"++setSamples :: [Set.Set Int]+setSamples =+  Set.fromList <$> subsequences [1, 2, 3]++powerSetSamples :: [PowerSet Atom]+powerSetSamples =+  fromList <$> subsequences [AtomA, AtomB, AtomC]++productBoolCoordinateLists :: [[Bool]]+productBoolCoordinateLists =+  traverse (const [False, True]) [(), ()]++pairs :: [a] -> [(a, a)]+pairs values =+  (,) <$> values <*> values++triples :: [a] -> [(a, a, a)]+triples values =+  (,,) <$> values <*> values <*> values
+ test/abstract/SparseVecSpec.hs view
@@ -0,0 +1,69 @@+module SparseVecSpec+  ( tests,+  )+where++import Moonlight.Algebra.Pure.SparseVec qualified as SparseVec+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( assertFailure,+    testCase,+    (@?=),+  )++tests :: TestTree+tests =+  testGroup+    "sparse vector compiled kernels"+    [ testCase "compiled linear map matches semantic extendLinear" compiledLinearMapMatchesExtendLinear,+      testCase "compiled linear map reports source indices outside the domain" compiledLinearMapRejectsOutOfBoundsSource,+      testCase "compiled linear map rejects a negative source count" compiledLinearMapRejectsNegativeSourceCount+    ]++compiledLinearMapMatchesExtendLinear :: IO ()+compiledLinearMapMatchesExtendLinear = do+  let sourceEntries = [(0, 3), (1, 4), (2, -4), (6, 5)]+      semanticResult =+        SparseVec.toEntries+          (SparseVec.extendLinear sparseBasisExpansion (SparseVec.fromEntries sourceEntries))+      compiledSource =+        SparseVec.sparseIxVecFromEntries sourceEntries+  case SparseVec.compileSparseLinearMap 8 sparseBasisExpansionEntries of+    Left failure ->+      assertFailure ("unexpected sparse-map compile failure: " <> show failure)+    Right compiledMap ->+      case SparseVec.applySparseLinearMap compiledMap compiledSource of+        Left failure ->+          assertFailure ("unexpected compiled sparse-map failure: " <> show failure)+        Right compiledResult ->+          SparseVec.sparseIxVecToEntries compiledResult @?= semanticResult++compiledLinearMapRejectsOutOfBoundsSource :: IO ()+compiledLinearMapRejectsOutOfBoundsSource =+  case SparseVec.compileSparseLinearMap 3 sparseBasisExpansionEntries of+    Left failure ->+      assertFailure ("unexpected sparse-map compile failure: " <> show failure)+    Right compiledMap ->+      SparseVec.applySparseLinearMap compiledMap compiledSource+        @?= Left (SparseVec.SparseLinearMapSourceOutOfBounds 4)+  where+    compiledSource =+      SparseVec.sparseIxVecFromEntries [(4, 1)]++compiledLinearMapRejectsNegativeSourceCount :: IO ()+compiledLinearMapRejectsNegativeSourceCount =+  SparseVec.compileSparseLinearMap (-1) sparseBasisExpansionEntries+    @?= Left (SparseVec.SparseLinearMapNegativeSourceCount (-1))++sparseBasisExpansion :: Int -> SparseVec.SparseVec Int Int+sparseBasisExpansion =+  SparseVec.fromEntries . sparseBasisExpansionEntries++sparseBasisExpansionEntries :: Int -> [(Int, Int)]+sparseBasisExpansionEntries basisValue =+  [ (basisValue, 1),+    (basisValue + 1, 2)+  ]
+ test/aggregate/Main.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import AbstractTests qualified+import FiniteLatticeTests qualified+import Moonlight.Pale.Test.Runner (runTestTreeGroup)++main :: IO ()+main =+  runTestTreeGroup+    "moonlight-algebra"+    [ AbstractTests.tests,+      FiniteLatticeTests.tests+    ]
+ test/finite-lattice/FiniteLatticeSpec.hs view
@@ -0,0 +1,1013 @@+{-# LANGUAGE GHC2024 #-}++module FiniteLatticeSpec+  ( tests,+  )+where++import Data.Bits ((.&.), (.|.))+import Data.Foldable (for_, traverse_)+import Data.Set qualified as Set+import Moonlight.FiniteLattice+  ( ContextHeyting,+    ContextHeytingCompileError (..),+    ContextCompileLimits (..),+    ContextLattice (clBottom, clTop),+    ContextLatticeCompileError (..),+    ContextLatticeLookupError (..),+    ContextMonotoneMapError (..),+    ContextOrderDecl,+    ContextRepresentation (..),+    compileContextHeyting,+    compileContextLattice,+    compileContextLatticeWith,+    contextLatticeElements,+    contextLatticeFromClosedOrder,+    contextLatticeFromClosedOrderWith,+    contextOrderDecl,+    coverPairs,+    greatestContextFixpoint,+    impliesContext,+    joinContext,+    leastContextFixpoint,+    leqContext,+    lowerCovers,+    meetContext,+    defaultContextCompileLimits,+    residentContextElementForKey,+    residentContextElementKey,+    residentContextElementValue,+    residentHeytingBaseContext,+    residentImplies,+    residentJoin,+    residentJoinMeetKeys,+    residentMeet,+    residentSupportContainsElement,+    residentSupportFromElements,+    residentSupportReachableElements,+    residentSupportWithClosure,+    singletonContextLattice,+    strictOrderPairs,+    upperCovers,+    checkResidentContext,+    withResidentContext,+    withResidentHeytingContext,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+  ( Assertion,+    assertBool,+    assertEqual,+    assertFailure,+    testCase,+    (@?=),+  )++data DiamondContext+  = DiamondBottom+  | DiamondLeft+  | DiamondRight+  | DiamondTop+  deriving stock (Eq, Ord, Show, Read)++data ChainContext+  = ChainBottom+  | ChainX+  | ChainY+  | ChainZ+  | ChainTop+  deriving stock (Eq, Ord, Show, Read)++data NonLatticeContext+  = NBottom+  | NA+  | NB+  | NL+  | NM+  | NU+  | NV+  | NTop+  deriving stock (Eq, Ord, Show, Read)++data M3+  = M3Bottom+  | M3A+  | M3B+  | M3C+  | M3Top+  deriving stock (Eq, Ord, Show, Read)++data N5+  = N5Bottom+  | N5A+  | N5B+  | N5C+  | N5Top+  deriving stock (Eq, Ord, Show, Read)++tests :: TestTree+tests =+  testGroup+    "finite context lattice declarations"+    [ testCase "diamond order compiles to the expected lattice" testDiamondLattice,+      testCase "resident context handles branded total lattice operations" testResidentContextOperations,+      testCase "resident support materializes upward closure without value lookups" testResidentSupportClosure,+      testCase "boolean cube cover graph uses Boolean lattice semantics" testBooleanCubeLattice,+      testCase "unknown context fails checked join" testUnknownJoinContext,+      testCase "unknown context fails checked meet" testUnknownMeetContext,+      testCase "unknown context fails checked order" testUnknownLeqContext,+      testCase "non-monotone endomap is rejected before fixpoint iteration" testRejectsNonMonotoneFixpoint,+      testCase "least context fixpoint ascends a finite chain" testLeastContextFixpointAscendsChain,+      testCase "greatest context fixpoint descends a finite chain" testGreatestContextFixpointDescendsChain,+      testCase "context fixpoint reports endomap closure obstruction" testContextFixpointClosureObstruction,+      testCase "checked context implication derives the finite residuum when Heyting" testImpliesContextUnique,+      testCase "M3 is a lattice but not Heyting" testRejectsM3Residual,+      testCase "Boolean implication satisfies the adjunction" testBooleanAdjunction,+      testCase "dense distributive Heyting implication satisfies the adjunction" testDenseHeytingAdjunction,+      testCase "tableless distributive lattice agrees with dense operations" testTablelessDistributiveMatchesDense,+      testCase "tableless N5 lattice matches dense operations and keeps Heyting witness" testTablelessN5MatchesDense,+      testCase "tableless 64x2 product implication handles one-word masks" testTablelessProduct64ImplicationBoundary,+      testCase "tableless 66x2 product implication handles multi-word masks" testTablelessProduct66ImplicationBoundary,+      testCase "downset-generated distributive lattices satisfy Heyting adjunction" testDownsetGeneratedHeytingAdjunction,+      testCase "dense N5 is rejected as non-Heyting by first missing residual" testRejectsDenseN5Residual,+      testCase "strict pairs and covers are lower-to-upper" testCoverOrientation,+      testCase "unknown top fails before closure" testUnknownTop,+      testCase "unknown bottom fails before closure" testUnknownBottom,+      testCase "unknown relation endpoint fails before closure" testUnknownRelationEndpoint,+      testCase "antisymmetry violation fails after closure" testAntisymmetryViolation,+      testCase "declared top must be greatest" testTopNotGreatest,+      testCase "declared bottom must be least" testBottomNotLeast,+      testCase "missing unique join is rejected" testMissingJoin,+      testCase "closed-order constructor reproduces the compiled diamond lattice" testClosedOrderReproducesDiamond,+      testCase "closed-order constructor rejects an invalid join function" testClosedOrderRejectsInvalidJoin,+      testCase "closed-order constructor rejects joins outside the universe" testClosedOrderRejectsOutsideJoin,+      testCase "closed-order constructor rejects meets outside the universe" testClosedOrderRejectsOutsideMeet,+      testCase "closed-order constructor rejects an intransitive order" testClosedOrderRejectsIntransitiveOrder,+      testCase "closed-order constructor rejects relation layouts over the byte limit" testClosedOrderRejectsRelationLimit+    ]++diamondLeq :: DiamondContext -> DiamondContext -> Bool+diamondLeq leftContext rightContext =+  leftContext == rightContext+    || leftContext == DiamondBottom+    || rightContext == DiamondTop++diamondJoin :: DiamondContext -> DiamondContext -> DiamondContext+diamondJoin leftContext rightContext+  | diamondLeq leftContext rightContext = rightContext+  | diamondLeq rightContext leftContext = leftContext+  | otherwise = DiamondTop++diamondMeet :: DiamondContext -> DiamondContext -> DiamondContext+diamondMeet leftContext rightContext+  | diamondLeq leftContext rightContext = leftContext+  | diamondLeq rightContext leftContext = rightContext+  | otherwise = DiamondBottom++testClosedOrderReproducesDiamond :: Assertion+testClosedOrderReproducesDiamond =+  case ( compileContextLattice diamondUniverse diamondDecl,+         contextLatticeFromClosedOrder+           DiamondTop+           DiamondBottom+           (Set.toAscList diamondUniverse)+           diamondLeq+           diamondJoin+           diamondMeet+       ) of+    (Right compiled, Right closed) -> do+      clTop closed @?= clTop compiled+      clBottom closed @?= clBottom compiled+      contextLatticeElements closed @?= contextLatticeElements compiled+      traverse_+        ( \(leftContext, rightContext) -> do+            leqContext closed leftContext rightContext+              @?= leqContext compiled leftContext rightContext+            joinContext closed leftContext rightContext+              @?= joinContext compiled leftContext rightContext+            meetContext closed leftContext rightContext+              @?= meetContext compiled leftContext rightContext+        )+        [ (leftContext, rightContext)+        | leftContext <- contextLatticeElements compiled,+          rightContext <- contextLatticeElements compiled+        ]+    (Left err, _) ->+      assertFailure ("expected compiled diamond lattice, got " <> show err)+    (_, Left err) ->+      assertFailure ("expected closed-order diamond lattice, got " <> show err)++testClosedOrderRejectsInvalidJoin :: Assertion+testClosedOrderRejectsInvalidJoin =+  contextLatticeFromClosedOrder+    DiamondTop+    DiamondBottom+    (Set.toAscList diamondUniverse)+    diamondLeq+    ( \leftContext rightContext ->+        if leftContext == DiamondLeft && rightContext == DiamondRight+          then DiamondBottom+          else diamondJoin leftContext rightContext+    )+    diamondMeet+    `shouldFailWith` ContextLatticeInvalidJoin DiamondLeft DiamondRight DiamondBottom++testClosedOrderRejectsRelationLimit :: Assertion+testClosedOrderRejectsRelationLimit =+  contextLatticeFromClosedOrderWith+    defaultContextCompileLimits {cclMaximumRelationBytes = Just 0}+    DiamondTop+    DiamondBottom+    (Set.toAscList diamondUniverse)+    diamondLeq+    diamondJoin+    diamondMeet+    `shouldFailWith` ContextLatticeRepresentationLimitExceeded ContextRelationWords 64 0++closedChainUniverse :: [ChainContext]+closedChainUniverse =+  [ChainBottom, ChainX, ChainY, ChainTop]++closedChainLeq :: ChainContext -> ChainContext -> Bool+closedChainLeq leftContext rightContext =+  leftContext == rightContext+    || leftContext == ChainBottom+    || rightContext == ChainTop+    || (leftContext == ChainX && rightContext == ChainY)++closedChainJoin :: ChainContext -> ChainContext -> ChainContext+closedChainJoin leftContext rightContext+  | closedChainLeq leftContext rightContext = rightContext+  | closedChainLeq rightContext leftContext = leftContext+  | otherwise = ChainTop++closedChainMeet :: ChainContext -> ChainContext -> ChainContext+closedChainMeet leftContext rightContext+  | closedChainLeq leftContext rightContext = leftContext+  | closedChainLeq rightContext leftContext = rightContext+  | otherwise = ChainBottom++testClosedOrderRejectsOutsideJoin :: Assertion+testClosedOrderRejectsOutsideJoin =+  contextLatticeFromClosedOrder+    ChainTop+    ChainBottom+    closedChainUniverse+    closedChainLeq+    ( \leftContext rightContext ->+        if leftContext == ChainX && rightContext == ChainY+          then ChainZ+          else closedChainJoin leftContext rightContext+    )+    closedChainMeet+    `shouldFailWith` ContextLatticeJoinOutsideUniverse ChainX ChainY ChainZ++testClosedOrderRejectsOutsideMeet :: Assertion+testClosedOrderRejectsOutsideMeet =+  contextLatticeFromClosedOrder+    ChainTop+    ChainBottom+    closedChainUniverse+    closedChainLeq+    closedChainJoin+    ( \leftContext rightContext ->+        if leftContext == ChainX && rightContext == ChainY+          then ChainZ+          else closedChainMeet leftContext rightContext+    )+    `shouldFailWith` ContextLatticeMeetOutsideUniverse ChainX ChainY ChainZ++testClosedOrderRejectsIntransitiveOrder :: Assertion+testClosedOrderRejectsIntransitiveOrder =+  contextLatticeFromClosedOrder+    ChainTop+    ChainBottom+    [ChainBottom, ChainX, ChainY, ChainZ, ChainTop]+    intransitiveLeq+    (\_ _ -> ChainTop)+    (\_ _ -> ChainBottom)+    `shouldFailWith` ContextLatticeNotTransitive ChainX ChainY ChainZ+  where+    intransitiveLeq leftContext rightContext =+      leftContext == rightContext+        || leftContext == ChainBottom+        || rightContext == ChainTop+        || (leftContext == ChainX && rightContext == ChainY)+        || (leftContext == ChainY && rightContext == ChainZ)++testDiamondLattice :: Assertion+testDiamondLattice =+  case compileContextLattice diamondUniverse diamondDecl of+    Left err ->+      assertFailure ("expected diamond lattice, got " <> show err)+    Right lattice -> do+      clTop lattice @?= DiamondTop+      clBottom lattice @?= DiamondBottom+      contextLatticeElements lattice @?= [DiamondBottom, DiamondLeft, DiamondRight, DiamondTop]+      joinContext lattice DiamondLeft DiamondRight @?= Right DiamondTop+      meetContext lattice DiamondLeft DiamondRight @?= Right DiamondBottom+      leqContext lattice DiamondBottom DiamondTop @?= Right True+      leqContext lattice DiamondLeft DiamondTop @?= Right True+      leqContext lattice DiamondRight DiamondTop @?= Right True+      assertBool "left and right are incomparable" $+        leqContext lattice DiamondLeft DiamondRight == Right False+          && leqContext lattice DiamondRight DiamondLeft == Right False++testResidentContextOperations :: Assertion+testResidentContextOperations =+  case compileContextLattice diamondUniverse diamondDecl of+    Left err ->+      assertFailure ("expected diamond lattice, got " <> show err)+    Right lattice ->+      case compileContextHeyting lattice of+        Left err ->+          assertFailure ("expected diamond Heyting proof, got " <> show err)+        Right heyting ->+          withResidentHeytingContext heyting $ \heytingContext -> do+            let residentContext = residentHeytingBaseContext heytingContext+            leftElement <- requireRight (checkResidentContext residentContext DiamondLeft)+            rightElement <- requireRight (checkResidentContext residentContext DiamondRight)+            bottomElement <- requireRight (checkResidentContext residentContext DiamondBottom)+            let joinResult = residentJoin residentContext leftElement rightElement+                meetResult = residentMeet residentContext leftElement rightElement+                (joinKey, meetKey) =+                  residentJoinMeetKeys+                    residentContext+                    (residentContextElementKey leftElement)+                    (residentContextElementKey rightElement)+                implicationResult = residentImplies heytingContext leftElement bottomElement+            residentContextElementValue joinResult @?= DiamondTop+            residentContextElementValue meetResult @?= DiamondBottom+            residentContextElementValue (residentContextElementForKey residentContext joinKey) @?= DiamondTop+            residentContextElementValue (residentContextElementForKey residentContext meetKey) @?= DiamondBottom+            residentContextElementValue implicationResult @?= DiamondRight++testResidentSupportClosure :: Assertion+testResidentSupportClosure =+  case compileContextLattice diamondUniverse diamondDecl of+    Left err ->+      assertFailure ("expected diamond lattice, got " <> show err)+    Right lattice ->+      withResidentContext lattice $ \residentContext -> do+        support <- requireRight (residentSupportFromElements residentContext [DiamondLeft])+        topElement <- requireRight (checkResidentContext residentContext DiamondTop)+        rightElement <- requireRight (checkResidentContext residentContext DiamondRight)+        let cachedSupport = residentSupportWithClosure residentContext support+        residentSupportContainsElement residentContext cachedSupport topElement @?= True+        residentSupportContainsElement residentContext cachedSupport rightElement @?= False+        fmap residentContextElementValue (residentSupportReachableElements residentContext support)+          @?= [DiamondLeft, DiamondTop]++testBooleanCubeLattice :: Assertion+testBooleanCubeLattice =+  case compileContextLattice booleanCubeUniverse booleanCubeDecl of+    Left err ->+      assertFailure ("expected boolean cube lattice, got " <> show err)+    Right lattice ->+      case compileContextHeyting lattice of+        Left err -> assertFailure ("expected boolean Heyting proof, got " <> show err)+        Right heyting -> do+          contextLatticeElements lattice @?= [0 .. 7]+          joinContext lattice 3 5 @?= Right 7+          meetContext lattice 3 5 @?= Right 1+          impliesContext heyting 3 1 @?= Right 5+          leqContext lattice 3 7 @?= Right True+          leqContext lattice 3 5 @?= Right False++booleanCubeUniverse :: Set.Set Int+booleanCubeUniverse =+  Set.fromAscList [0 .. 7]++booleanCubeDecl :: ContextOrderDecl Int+booleanCubeDecl =+  contextOrderDecl 7 0 booleanCubeCoverEdges++booleanCubeCoverEdges :: [(Int, Int)]+booleanCubeCoverEdges =+  [ (mask, mask + bitValue)+  | mask <- [0 .. 7],+    bitValue <- [1, 2, 4],+    mask .&. bitValue == 0+  ]++testUnknownJoinContext :: Assertion+testUnknownJoinContext =+  joinContext (singletonContextLattice DiamondBottom) DiamondBottom DiamondTop+    @?= Left (ContextLatticeUnknownContext DiamondTop)++testUnknownMeetContext :: Assertion+testUnknownMeetContext =+  meetContext (singletonContextLattice DiamondBottom) DiamondTop DiamondBottom+    @?= Left (ContextLatticeUnknownContext DiamondTop)++testUnknownLeqContext :: Assertion+testUnknownLeqContext =+  leqContext (singletonContextLattice DiamondBottom) DiamondBottom DiamondTop+    @?= Left (ContextLatticeUnknownContext DiamondTop)++testRejectsNonMonotoneFixpoint :: Assertion+testRejectsNonMonotoneFixpoint =+  case boolLattice of+    Left compileError ->+      assertFailure ("unexpected compile failure: " <> show compileError)+    Right lattice ->+      leastContextFixpoint lattice not+        @?= Left (ContextEndomapNotMonotone False True True False)++testLeastContextFixpointAscendsChain :: Assertion+testLeastContextFixpointAscendsChain =+  case chainLattice of+    Left err ->+      assertFailure ("expected chain lattice, got " <> show err)+    Right lattice ->+      leastContextFixpoint lattice advanceChain+        @?= Right ChainTop++testGreatestContextFixpointDescendsChain :: Assertion+testGreatestContextFixpointDescendsChain =+  case chainLattice of+    Left err ->+      assertFailure ("expected chain lattice, got " <> show err)+    Right lattice ->+      greatestContextFixpoint lattice retreatChain+        @?= Right ChainBottom++testContextFixpointClosureObstruction :: Assertion+testContextFixpointClosureObstruction =+  leastContextFixpoint (singletonContextLattice DiamondBottom) (const DiamondTop)+    @?= Left (ContextEndomapOutsideUniverse DiamondBottom DiamondTop)++testImpliesContextUnique :: Assertion+testImpliesContextUnique =+  case (compileContextLattice diamondUniverse diamondDecl, chainLattice) of+    (Right diamond, Right chain) -> do+      diamondHeyting <- requireRight (compileContextHeyting diamond)+      chainHeyting <- requireRight (compileContextHeyting chain)+      impliesContext diamondHeyting DiamondLeft DiamondRight @?= Right DiamondRight+      impliesContext diamondHeyting DiamondLeft DiamondBottom @?= Right DiamondRight+      impliesContext chainHeyting ChainX ChainY @?= Right ChainTop+    (Left err, _) ->+      assertFailure ("expected diamond lattice, got " <> show err)+    (_, Left err) ->+      assertFailure ("expected chain lattice, got " <> show err)++testRejectsM3Residual :: Assertion+testRejectsM3Residual =+  case m3Lattice of+    Left compileError ->+      assertFailure ("unexpected lattice failure: " <> show compileError)+    Right lattice ->+      compileContextHeyting lattice+        `shouldFailWith` ContextResidualDoesNotExist M3A M3Bottom M3Top++testBooleanAdjunction :: Assertion+testBooleanAdjunction =+  case boolean4 of+    Left compileError ->+      assertFailure ("unexpected lattice failure: " <> show compileError)+    Right lattice ->+      case compileContextHeyting lattice of+        Left heytingError ->+          assertFailure ("unexpected Heyting failure: " <> show heytingError)+        Right heyting -> do+          impliesContext heyting 1 0 @?= Right 2+          for_ [(a, b, x) | a <- [0 .. 3], b <- [0 .. 3], x <- [0 .. 3]] $+            \(a, b, x) -> assertAdjunction lattice heyting a b x++testDenseHeytingAdjunction :: Assertion+testDenseHeytingAdjunction =+  case divisor12Lattice of+    Left compileError ->+      assertFailure ("unexpected lattice failure: " <> show compileError)+    Right lattice ->+      case compileContextHeyting lattice of+        Left heytingError ->+          assertFailure ("unexpected Heyting failure: " <> show heytingError)+        Right heyting -> do+          impliesContext heyting 2 3 @?= Right 3+          impliesContext heyting 4 2 @?= Right 6+          impliesContext heyting 6 2 @?= Right 4+          traverse_+            ( \(a, b, x) ->+                assertAdjunction lattice heyting a b x+            )+            [ (a, b, x)+            | a <- divisor12Universe,+              b <- divisor12Universe,+              x <- divisor12Universe+            ]++testTablelessDistributiveMatchesDense :: Assertion+testTablelessDistributiveMatchesDense = do+  defaultLattice <- requireRight divisor12Lattice+  tablelessLattice <- requireRight divisor12TablelessLattice+  assertLatticeAgreement "divisor12" divisor12Universe defaultLattice tablelessLattice+  defaultHeyting <- requireRight (compileContextHeyting defaultLattice)+  tablelessHeyting <- requireRight (compileContextHeyting tablelessLattice)+  assertHeytingAgreement "divisor12" divisor12Universe defaultHeyting tablelessHeyting+  traverse_+    ( \(antecedent, consequent, candidate) ->+        assertAdjunction tablelessLattice tablelessHeyting antecedent consequent candidate+    )+    [ (antecedent, consequent, candidate)+    | antecedent <- divisor12Universe,+      consequent <- divisor12Universe,+      candidate <- divisor12Universe+    ]++testTablelessN5MatchesDense :: Assertion+testTablelessN5MatchesDense = do+  defaultLattice <- requireRight n5Lattice+  tablelessLattice <- requireRight n5TablelessLattice+  assertLatticeAgreement "N5" (Set.toAscList n5Universe) defaultLattice tablelessLattice+  compileContextHeyting defaultLattice+    `shouldFailWith` ContextResidualDoesNotExist N5C N5A N5Top+  compileContextHeyting tablelessLattice+    `shouldFailWith` ContextResidualDoesNotExist N5C N5A N5Top++testTablelessProduct64ImplicationBoundary :: Assertion+testTablelessProduct64ImplicationBoundary =+  assertProductTablelessImplicationBoundary+    64+    [ (productContext 63 1, productContext 61 0, productContext 61 0),+      (productContext 62 0, productContext 63 1, productContext 63 1),+      (productContext 63 0, productContext 62 1, productContext 62 1)+    ]+    [61 .. 63]++testTablelessProduct66ImplicationBoundary :: Assertion+testTablelessProduct66ImplicationBoundary =+  assertProductTablelessImplicationBoundary+    66+    [ (productContext 65 1, productContext 64 0, productContext 64 0),+      (productContext 64 0, productContext 65 1, productContext 65 1),+      (productContext 63 1, productContext 64 0, productContext 65 0)+    ]+    [63 .. 65]++testRejectsDenseN5Residual :: Assertion+testRejectsDenseN5Residual =+  case n5Lattice of+    Left compileError ->+      assertFailure ("unexpected lattice failure: " <> show compileError)+    Right lattice ->+      compileContextHeyting lattice+        `shouldFailWith` ContextResidualDoesNotExist N5C N5A N5Top++assertAdjunction :: (Ord c, Show c) => ContextLattice c -> ContextHeyting c -> c -> c -> c -> Assertion+assertAdjunction lattice heyting antecedent consequent candidate =+  case (impliesContext heyting antecedent consequent, meetContext lattice candidate antecedent) of+    (Right residual, Right candidateMeet) ->+      case (leqContext lattice candidate residual, leqContext lattice candidateMeet consequent) of+        (Right leftSide, Right rightSide) -> leftSide @?= rightSide+        (leftResult, rightResult) ->+          assertFailure ("unexpected lookup failure: " <> show (leftResult, rightResult))+    (residualResult, meetResult) ->+      assertFailure ("unexpected lookup failure: " <> show (residualResult, meetResult))++assertLatticeAgreement :: (Ord c, Show c) => String -> [c] -> ContextLattice c -> ContextLattice c -> Assertion+assertLatticeAgreement label universe expected actual = do+  assertEqual (label <> " elements") (contextLatticeElements expected) (contextLatticeElements actual)+  assertEqual (label <> " top") (clTop expected) (clTop actual)+  assertEqual (label <> " bottom") (clBottom expected) (clBottom actual)+  for_ universe $ \contextValue -> do+    assertEqual (label <> " upper covers of " <> show contextValue) (upperCovers expected contextValue) (upperCovers actual contextValue)+    assertEqual (label <> " lower covers of " <> show contextValue) (lowerCovers expected contextValue) (lowerCovers actual contextValue)+  for_ [(leftContext, rightContext) | leftContext <- universe, rightContext <- universe] $+    \(leftContext, rightContext) -> do+      assertEqual (label <> " leq " <> show (leftContext, rightContext)) (leqContext expected leftContext rightContext) (leqContext actual leftContext rightContext)+      assertEqual (label <> " join " <> show (leftContext, rightContext)) (joinContext expected leftContext rightContext) (joinContext actual leftContext rightContext)+      assertEqual (label <> " meet " <> show (leftContext, rightContext)) (meetContext expected leftContext rightContext) (meetContext actual leftContext rightContext)++assertHeytingAgreement :: (Ord c, Show c) => String -> [c] -> ContextHeyting c -> ContextHeyting c -> Assertion+assertHeytingAgreement label universe expected actual =+  for_ [(antecedent, consequent) | antecedent <- universe, consequent <- universe] $+    \(antecedent, consequent) ->+      assertEqual (label <> " implication " <> show (antecedent, consequent)) (impliesContext expected antecedent consequent) (impliesContext actual antecedent consequent)++assertProductTablelessImplicationBoundary :: Int -> [(Int, Int, Int)] -> [Int] -> Assertion+assertProductTablelessImplicationBoundary rowCount implicationExamples adjunctionRows = do+  lattice <- requireRight (productLatticeWith noBinaryOperationTablesLimits rowCount)+  heyting <- requireRight (compileContextHeyting lattice)+  for_ implicationExamples $ \(antecedent, consequent, residual) ->+    assertEqual+      ("product implication " <> show (productCoordinates antecedent, productCoordinates consequent))+      (Right residual)+      (impliesContext heyting antecedent consequent)+  traverse_+    ( \(antecedent, consequent, candidate) ->+        assertAdjunction lattice heyting antecedent consequent candidate+    )+    [ (antecedent, consequent, candidate)+    | antecedent <- targetedProductContexts adjunctionRows,+      consequent <- targetedProductContexts adjunctionRows,+      candidate <- targetedProductContexts adjunctionRows+    ]++targetedProductContexts :: [Int] -> [Int]+targetedProductContexts rows =+  [productContext row column | row <- rows, column <- [0, 1]]++productLatticeWith :: ContextCompileLimits -> Int -> Either (ContextLatticeCompileError Int) (ContextLattice Int)+productLatticeWith limits rowCount =+  contextLatticeFromClosedOrderWith+    limits+    (productContext (rowCount - 1) 1)+    (productContext 0 0)+    (productUniverse rowCount)+    productLeq+    productJoin+    productMeet++productUniverse :: Int -> [Int]+productUniverse rowCount =+  [productContext row column | row <- [0 .. rowCount - 1], column <- [0, 1]]++productContext :: Int -> Int -> Int+productContext row column =+  row * 2 + column++productCoordinates :: Int -> (Int, Int)+productCoordinates contextValue =+  (contextValue `div` 2, contextValue `mod` 2)++productLeq :: Int -> Int -> Bool+productLeq leftContext rightContext =+  leftRow <= rightRow && leftColumn <= rightColumn+  where+    (leftRow, leftColumn) = productCoordinates leftContext+    (rightRow, rightColumn) = productCoordinates rightContext++productJoin :: Int -> Int -> Int+productJoin leftContext rightContext =+  productContext (max leftRow rightRow) (max leftColumn rightColumn)+  where+    (leftRow, leftColumn) = productCoordinates leftContext+    (rightRow, rightColumn) = productCoordinates rightContext++productMeet :: Int -> Int -> Int+productMeet leftContext rightContext =+  productContext (min leftRow rightRow) (min leftColumn rightColumn)+  where+    (leftRow, leftColumn) = productCoordinates leftContext+    (rightRow, rightColumn) = productCoordinates rightContext+++type PosetLeq = Int -> Int -> Bool++type DownsetCase = (String, Int, PosetLeq, Int, [(Int, Int, Int)])++testDownsetGeneratedHeytingAdjunction :: Assertion+testDownsetGeneratedHeytingAdjunction =+  for_ downsetLatticeCases $ \(caseName, elementCount, posetLeq, expectedSize, implicationWitnesses) -> do+    let universe = downsetUniverse elementCount posetLeq+    assertEqual (caseName <> " downset count") expectedSize (length universe)+    case downsetLattice elementCount posetLeq of+      Left compileError ->+        assertFailure (caseName <> " unexpected lattice failure: " <> show compileError)+      Right lattice ->+        case compileContextHeyting lattice of+          Left heytingError ->+            assertFailure (caseName <> " unexpected Heyting failure: " <> show heytingError)+          Right heyting -> do+            for_ implicationWitnesses $ \(antecedent, consequent, residual) ->+              impliesContext heyting antecedent consequent @?= Right residual+            traverse_+              ( \(antecedent, consequent, candidate) ->+                  assertAdjunction lattice heyting antecedent consequent candidate+              )+              [ (antecedent, consequent, candidate)+              | antecedent <- universe,+                consequent <- universe,+                candidate <- universe+              ]++downsetLatticeCases :: [DownsetCase]+downsetLatticeCases =+  [ ( "two-point antichain",+      2,+      discretePosetLeq,+      4,+      [(1, 0, 2)]+    ),+    ( "two-element chain",+      2,+      chain2PlusIsolatedPosetLeq,+      3,+      [(1, 0, 0)]+    ),+    ( "vee poset",+      3,+      veePosetLeq,+      5,+      [(1, 2, 2)]+    ),+    ( "2x3 grid from a chain plus an isolated point",+      3,+      chain2PlusIsolatedPosetLeq,+      6,+      [(1, 0, 4)]+    )+  ]++downsetLattice :: Int -> PosetLeq -> Either (ContextLatticeCompileError Int) (ContextLattice Int)+downsetLattice elementCount posetLeq =+  compileContextLattice+    (Set.fromList universe)+    (contextOrderDecl (downsetTop elementCount) 0 (downsetCoverEdges universe))+  where+    universe = downsetUniverse elementCount posetLeq++downsetUniverse :: Int -> PosetLeq -> [Int]+downsetUniverse elementCount posetLeq =+  [mask | mask <- [0 .. downsetTop elementCount], isDownset mask]+  where+    elements = [0 .. elementCount - 1]+    isDownset mask =+      all+        ( \upper ->+            not (maskContains mask upper)+              || all+                ( \lower ->+                    not (posetLeq lower upper) || maskContains mask lower+                )+                elements+        )+        elements++downsetCoverEdges :: [Int] -> [(Int, Int)]+downsetCoverEdges universe =+  [ (lower, upper)+  | lower <- universe,+    upper <- universe,+    lower /= upper,+    downsetSubset lower upper,+    not (hasStrictIntermediate lower upper)+  ]+  where+    hasStrictIntermediate lower upper =+      any+        ( \candidate ->+            candidate /= lower+              && candidate /= upper+              && downsetSubset lower candidate+              && downsetSubset candidate upper+        )+        universe++downsetTop :: Int -> Int+downsetTop elementCount =+  2 ^ elementCount - 1++downsetSubset :: Int -> Int -> Bool+downsetSubset lower upper =+  lower .&. upper == lower++maskContains :: Int -> Int -> Bool+maskContains mask elementIndex =+  mask .&. (2 ^ elementIndex) /= 0++discretePosetLeq :: PosetLeq+discretePosetLeq left right =+  left == right++chain2PlusIsolatedPosetLeq :: PosetLeq+chain2PlusIsolatedPosetLeq left right =+  left == right || (left == 0 && right == 1)++veePosetLeq :: PosetLeq+veePosetLeq left right =+  left == right || (left == 0 && right == 2) || (left == 1 && right == 2)++testCoverOrientation :: Assertion+testCoverOrientation =+  case chain3 of+    Left compileError ->+      assertFailure ("unexpected lattice failure: " <> show compileError)+    Right lattice -> do+      strictOrderPairs lattice @?= [(0, 1), (0, 2), (1, 2)]+      coverPairs lattice @?= [(0, 1), (1, 2)]+      upperCovers lattice 0 @?= Right [1]+      lowerCovers lattice 2 @?= Right [1]++testUnknownTop :: Assertion+testUnknownTop =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondLeft])+    (contextOrderDecl DiamondTop DiamondBottom [])+    `shouldFailWith` ContextLatticeUnknownTop DiamondTop++testUnknownBottom :: Assertion+testUnknownBottom =+  compileContextLattice+    (Set.fromList [DiamondLeft, DiamondTop])+    (contextOrderDecl DiamondTop DiamondBottom [])+    `shouldFailWith` ContextLatticeUnknownBottom DiamondBottom++testUnknownRelationEndpoint :: Assertion+testUnknownRelationEndpoint =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondTop])+    (contextOrderDecl DiamondTop DiamondBottom [(DiamondBottom, DiamondLeft)])+    `shouldFailWith` ContextLatticeUnknownRelationEndpoint (DiamondBottom, DiamondLeft)++testAntisymmetryViolation :: Assertion+testAntisymmetryViolation =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondTop])+    ( contextOrderDecl+        DiamondTop+        DiamondBottom+        [ (DiamondBottom, DiamondTop),+          (DiamondTop, DiamondBottom)+        ]+    )+    `shouldFailWith` ContextLatticeAntisymmetryViolation DiamondBottom DiamondTop++testTopNotGreatest :: Assertion+testTopNotGreatest =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondLeft, DiamondTop])+    (contextOrderDecl DiamondTop DiamondBottom [(DiamondBottom, DiamondTop)])+    `shouldFailWith` ContextLatticeTopNotGreatest DiamondLeft++testBottomNotLeast :: Assertion+testBottomNotLeast =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondLeft, DiamondTop])+    ( contextOrderDecl+        DiamondTop+        DiamondBottom+        [ (DiamondLeft, DiamondTop),+          (DiamondBottom, DiamondTop)+        ]+    )+    `shouldFailWith` ContextLatticeBottomNotLeast DiamondLeft++testMissingJoin :: Assertion+testMissingJoin =+  compileContextLattice+    (Set.fromList [NBottom, NA, NB, NU, NV, NTop])+    ( contextOrderDecl+        NTop+        NBottom+        [ (NBottom, NA),+          (NBottom, NB),+          (NA, NU),+          (NB, NU),+          (NA, NV),+          (NB, NV),+          (NU, NTop),+          (NV, NTop)+        ]+    )+    `shouldFailWith` ContextLatticeJoinDoesNotExist NA NB (Set.fromList [NU, NV])++shouldFailWith :: (Eq errorValue, Show errorValue) => Either errorValue value -> errorValue -> Assertion+shouldFailWith result expected =+  case result of+    Left actual -> actual @?= expected+    Right _ -> assertFailure "expected lattice compile failure"++requireRight :: Show errorValue => Either errorValue value -> IO value+requireRight result =+  case result of+    Left errorValue ->+      assertFailure ("expected Right, got " <> show errorValue)+    Right value ->+      pure value++diamondUniverse :: Set.Set DiamondContext+diamondUniverse =+  Set.fromList [DiamondBottom, DiamondLeft, DiamondRight, DiamondTop]++diamondDecl :: ContextOrderDecl DiamondContext+diamondDecl =+  contextOrderDecl+    DiamondTop+    DiamondBottom+    [ (DiamondBottom, DiamondLeft),+      (DiamondBottom, DiamondRight),+      (DiamondLeft, DiamondTop),+      (DiamondRight, DiamondTop)+    ]++chainLattice :: Either (ContextLatticeCompileError ChainContext) (ContextLattice ChainContext)+chainLattice =+  contextLatticeFromClosedOrder+    ChainTop+    ChainBottom+    closedChainUniverse+    closedChainLeq+    closedChainJoin+    closedChainMeet++advanceChain :: ChainContext -> ChainContext+advanceChain contextValue =+  case contextValue of+    ChainBottom -> ChainX+    ChainX -> ChainY+    ChainY -> ChainTop+    ChainZ -> ChainTop+    ChainTop -> ChainTop++retreatChain :: ChainContext -> ChainContext+retreatChain contextValue =+  case contextValue of+    ChainTop -> ChainY+    ChainY -> ChainX+    ChainX -> ChainBottom+    ChainZ -> ChainBottom+    ChainBottom -> ChainBottom++boolLattice :: Either (ContextLatticeCompileError Bool) (ContextLattice Bool)+boolLattice =+  contextLatticeFromClosedOrder True False [False, True] (<=) (||) (&&)++noBinaryOperationTablesLimits :: ContextCompileLimits+noBinaryOperationTablesLimits =+  defaultContextCompileLimits {cclMaximumBinaryTableBytes = Just 0}++m3Lattice :: Either (ContextLatticeCompileError M3) (ContextLattice M3)+m3Lattice =+  compileContextLattice+    (Set.fromList [M3Bottom, M3A, M3B, M3C, M3Top])+    ( contextOrderDecl+        M3Top+        M3Bottom+        [ (M3Bottom, M3A),+          (M3Bottom, M3B),+          (M3Bottom, M3C),+          (M3A, M3Top),+          (M3B, M3Top),+          (M3C, M3Top)+        ]+    )++n5Universe :: Set.Set N5+n5Universe =+  Set.fromList [N5Bottom, N5A, N5B, N5C, N5Top]++n5Decl :: ContextOrderDecl N5+n5Decl =+  contextOrderDecl+    N5Top+    N5Bottom+    [ (N5Bottom, N5A),+      (N5A, N5C),+      (N5C, N5Top),+      (N5Bottom, N5B),+      (N5B, N5Top)+    ]++n5Lattice :: Either (ContextLatticeCompileError N5) (ContextLattice N5)+n5Lattice =+  compileContextLattice n5Universe n5Decl++n5TablelessLattice :: Either (ContextLatticeCompileError N5) (ContextLattice N5)+n5TablelessLattice =+  compileContextLatticeWith noBinaryOperationTablesLimits n5Universe n5Decl++boolean4 :: Either (ContextLatticeCompileError Int) (ContextLattice Int)+boolean4 =+  contextLatticeFromClosedOrder+    3+    0+    [0 .. 3]+    (\left right -> left .&. right == left)+    (.|.)+    (.&.)++divisor12Lattice :: Either (ContextLatticeCompileError Int) (ContextLattice Int)+divisor12Lattice =+  contextLatticeFromClosedOrder+    12+    1+    divisor12Universe+    divisor12Leq+    lcm+    gcd+++divisor12TablelessLattice :: Either (ContextLatticeCompileError Int) (ContextLattice Int)+divisor12TablelessLattice =+  contextLatticeFromClosedOrderWith+    noBinaryOperationTablesLimits+    12+    1+    divisor12Universe+    divisor12Leq+    lcm+    gcd++divisor12Universe :: [Int]+divisor12Universe =+  [1, 2, 3, 4, 6, 12]++divisor12Leq :: Int -> Int -> Bool+divisor12Leq left right =+  left > 0 && right `mod` left == 0++chain3 :: Either (ContextLatticeCompileError Int) (ContextLattice Int)+chain3 =+  contextLatticeFromClosedOrder 2 0 [0, 1, 2] (<=) max min
+ test/finite-lattice/FiniteLatticeTests.hs view
@@ -0,0 +1,21 @@+module FiniteLatticeTests+  ( tests,+  )+where++import FiniteLatticeSpec qualified+import LawSpec qualified+import PresentationSpec qualified+import Test.Tasty+  ( TestTree,+    testGroup,+  )++tests :: TestTree+tests =+  testGroup+    "moonlight-algebra:finite-lattice"+    [ FiniteLatticeSpec.tests,+      LawSpec.tests,+      PresentationSpec.tests+    ]
+ test/finite-lattice/LawSpec.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE GHC2024 #-}++-- | Property-based law congregation for finite context lattices.+--+-- Where 'FiniteLatticeSpec' pins named witnesses (the diamond, M3, N5,+-- divisor lattices), this module quantifies the algebraic laws over a random+-- family of lattices. The generator is Birkhoff's representation theorem made+-- operational: the downsets of any finite poset, ordered by inclusion, form a+-- finite distributive (hence Heyting) lattice, so a random poset yields a random+-- lawful lattice for free. Each law is then exhausted over every element of the+-- generated carrier — random across lattices, total within each.+module LawSpec+  ( tests,+  )+where++import Data.Bits (bit, (.&.))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Moonlight.FiniteLattice+  ( ContextHeyting,+    ContextLattice (clBottom, clTop),+    ContextLatticeCompileError,+    ContextLatticeLookupError,+    compileContextHeyting,+    compileContextLattice,+    contextLatticeElements,+    contextOrderDecl,+    coverPairs,+    greatestContextFixpoint,+    impliesContext,+    joinContext,+    leastContextFixpoint,+    leqContext,+    meetContext,+    principalSupport,+    strictOrderPairs,+    SupportBasis,+    supportBasis,+    supportReachableLatticeContexts,+    supportUnion,+    upperCovers,+  )+import Test.Tasty (TestTree, localOption, testGroup)+import Test.Tasty.QuickCheck+  ( Gen,+    Property,+    QuickCheckTests (..),+    choose,+    conjoin,+    counterexample,+    elements,+    forAll,+    frequency,+    listOf,+    oneof,+    property,+    resize,+    sublistOf,+    testProperty,+  )++-- ---------------------------------------------------------------------------+-- Generated carriers+-- ---------------------------------------------------------------------------++-- | A poset on @[0 .. prN - 1]@, represented by its (reflexive-transitively+-- closed) order relation so the generator has a legible 'Show'.+data PosetRep = PosetRep+  { prN :: Int,+    prOrder :: Set (Int, Int)+  }+  deriving stock (Show)++posetLeq :: PosetRep -> Int -> Int -> Bool+posetLeq poset lower upper =+  Set.member (lower, upper) (prOrder poset)++-- | A random finite poset: strict edges are drawn only among @i < j@, which+-- keeps the relation acyclic (hence antisymmetric); its reflexive-transitive+-- closure is then a genuine partial order.+genPosetRep :: Gen PosetRep+genPosetRep = do+  elementCount <- choose (1, 4)+  strictEdges <-+    sublistOf+      [(lower, upper) | lower <- [0 .. elementCount - 1], upper <- [0 .. elementCount - 1], lower < upper]+  pure (PosetRep elementCount (reflexiveTransitiveClosure elementCount strictEdges))++reflexiveTransitiveClosure :: Int -> [(Int, Int)] -> Set (Int, Int)+reflexiveTransitiveClosure elementCount strictEdges =+  fixpoint (Set.fromList (strictEdges <> [(index, index) | index <- [0 .. elementCount - 1]]))+  where+    fixpoint :: Set (Int, Int) -> Set (Int, Int)+    fixpoint relation =+      let grown = Set.union relation (composeOnce relation)+       in if grown == relation then relation else fixpoint grown+    composeOnce :: Set (Int, Int) -> Set (Int, Int)+    composeOnce relation =+      Set.fromList+        [ (left, right)+        | (left, mid) <- Set.toList relation,+          (mid', right) <- Set.toList relation,+          mid == mid'+        ]++-- | A carrier plus a legible description for QuickCheck counterexamples.+data LatSample = LatSample+  { lsDescription :: String,+    lsLattice :: ContextLattice Int,+    lsElements :: [Int]+  }++instance Show LatSample where+  show sample =+    lsDescription sample <> " {elements=" <> show (lsElements sample) <> "}"++mkSample :: String -> ContextLattice Int -> LatSample+mkSample description lattice =+  LatSample description lattice (contextLatticeElements lattice)++-- | The downset lattice of a poset: elements are down-closed subsets encoded as+-- bitmasks over @[0 .. n-1]@, ordered by inclusion. Always a finite+-- distributive lattice, with @0@ (empty set) least and @2^n - 1@ (full set)+-- greatest.+downsetLattice ::+  PosetRep ->+  Either (ContextLatticeCompileError Int) (ContextLattice Int)+downsetLattice poset =+  compileContextLattice+    (Set.fromList universe)+    (contextOrderDecl (fullMask (prN poset)) 0 (downsetCoverEdges universe))+  where+    universe = downsetUniverse poset++downsetUniverse :: PosetRep -> [Int]+downsetUniverse poset =+  [mask | mask <- [0 .. fullMask (prN poset)], isDownset mask]+  where+    base = [0 .. prN poset - 1]+    isDownset mask =+      all+        ( \upper ->+            not (maskContains mask upper)+              || all (\lower -> not (posetLeq poset lower upper) || maskContains mask lower) base+        )+        base++downsetCoverEdges :: [Int] -> [(Int, Int)]+downsetCoverEdges universe =+  [ (lower, upper)+  | lower <- universe,+    upper <- universe,+    lower /= upper,+    maskSubset lower upper,+    not (hasStrictIntermediate lower upper)+  ]+  where+    hasStrictIntermediate lower upper =+      any+        ( \mid ->+            mid /= lower+              && mid /= upper+              && maskSubset lower mid+              && maskSubset mid upper+        )+        universe++fullMask :: Int -> Int+fullMask elementCount = bit elementCount - 1++maskContains :: Int -> Int -> Bool+maskContains mask index = mask .&. bit index /= 0++maskSubset :: Int -> Int -> Bool+maskSubset lower upper = lower .&. upper == lower++describePoset :: PosetRep -> String+describePoset poset =+  "downset(n="+    <> show (prN poset)+    <> ", strictOrder="+    <> show [(lower, upper) | (lower, upper) <- Set.toList (prOrder poset), lower /= upper]+    <> ")"++data SampleAttempt+  = DistributiveSampleAttempt+      !PosetRep+      !(Either (ContextLatticeCompileError Int) (ContextLattice Int))+  | NamedSampleAttempt+      !String+      !(Either (ContextLatticeCompileError Int) (ContextLattice Int))++instance Show SampleAttempt where+  show attempt =+    case attempt of+      DistributiveSampleAttempt poset _ -> describePoset poset+      NamedSampleAttempt name _ -> name++genDistributiveSampleAttempt :: Gen SampleAttempt+genDistributiveSampleAttempt = do+  poset <- genPosetRep+  pure (DistributiveSampleAttempt poset (downsetLattice poset))++-- | Named non-distributive witnesses, encoded as @Int@ carriers so every sample+-- shares one element type. M3 and N5 are lattices that are not distributive;+-- they exercise the general lattice laws without claiming Heyting structure.+namedRoster :: [(String, Either (ContextLatticeCompileError Int) (ContextLattice Int))]+namedRoster =+  [ ("M3", latticeOf [0, 1, 2, 3, 4] 4 0 [(0, 1), (0, 2), (0, 3), (1, 4), (2, 4), (3, 4)]),+    ("N5", latticeOf [0, 1, 2, 3, 4] 4 0 [(0, 1), (1, 3), (3, 4), (0, 2), (2, 4)]),+    ("diamond2x2", latticeOf [0, 1, 2, 3] 3 0 [(0, 1), (0, 2), (1, 3), (2, 3)]),+    ("chain5", latticeOf [0, 1, 2, 3, 4] 4 0 [(0, 1), (1, 2), (2, 3), (3, 4)])+  ]+  where+    latticeOf :: [Int] -> Int -> Int -> [(Int, Int)] -> Either (ContextLatticeCompileError Int) (ContextLattice Int)+    latticeOf universe topValue bottomValue edges =+      compileContextLattice (Set.fromList universe) (contextOrderDecl topValue bottomValue edges)++namedSampleAttempts :: [SampleAttempt]+namedSampleAttempts =+  fmap (uncurry NamedSampleAttempt) namedRoster++genAnySampleAttempt :: Gen SampleAttempt+genAnySampleAttempt =+  frequency+    [ (3, genDistributiveSampleAttempt),+      (2, elements namedSampleAttempts)+    ]++withSampleAttempt :: (LatSample -> Property) -> SampleAttempt -> Property+withSampleAttempt law attempt =+  case attempt of+    DistributiveSampleAttempt poset compiled ->+      withCompiledSample (describePoset poset) compiled+    NamedSampleAttempt name compiled ->+      withCompiledSample name compiled+  where+    withCompiledSample description compiled =+      case compiled of+        Left compileError ->+          counterexample+            (description <> " failed to compile: " <> show compileError)+            (property False)+        Right lattice -> law (mkSample description lattice)++-- ---------------------------------------------------------------------------+-- Resolved operation tables+-- ---------------------------------------------------------------------------++-- | Total join/meet/order tables for a carrier, resolved once from the checked+-- @Either@ queries. Every lookup is over declared elements, so a 'Left' here is+-- itself a defect and fails the surrounding property.+data Tables = Tables+  { tEls :: [Int],+    tTop :: Int,+    tBot :: Int,+    tJoin :: Int -> Int -> Int,+    tMeet :: Int -> Int -> Int,+    tLeq :: Int -> Int -> Bool+  }++buildTables :: ContextLattice Int -> Either String Tables+buildTables lattice = do+  let els = contextLatticeElements lattice+  joinTable <- pairTable "join" (joinContext lattice) els+  meetTable <- pairTable "meet" (meetContext lattice) els+  leqTable <- pairTable "leq" (leqContext lattice) els+  pure+    Tables+      { tEls = els,+        tTop = clTop lattice,+        tBot = clBottom lattice,+        tJoin = \a b -> joinTable Map.! (a, b),+        tMeet = \a b -> meetTable Map.! (a, b),+        tLeq = \a b -> leqTable Map.! (a, b)+      }++pairTable ::+  Show err =>+  String ->+  (Int -> Int -> Either err result) ->+  [Int] ->+  Either String (Map (Int, Int) result)+pairTable label query els =+  Map.fromList <$> traverse resolve [(a, b) | a <- els, b <- els]+  where+    resolve (a, b) =+      case query a b of+        Left err -> Left (label <> " lookup failed @ " <> show (a, b) <> ": " <> show err)+        Right value -> Right ((a, b), value)++withTables :: LatSample -> (Tables -> Property) -> Property+withTables sample continuation =+  case buildTables (lsLattice sample) of+    Left err -> counterexample ("table build failed: " <> err) (property False)+    Right tables -> continuation tables++check :: String -> Bool -> Property+check message ok = counterexample message (property ok)++allPairs :: Tables -> [(Int, Int)]+allPairs tables = [(a, b) | a <- tEls tables, b <- tEls tables]++allTriples :: Tables -> [(Int, Int, Int)]+allTriples tables = [(a, b, c) | a <- tEls tables, b <- tEls tables, c <- tEls tables]++-- ---------------------------------------------------------------------------+-- General lattice laws (hold for every lattice, distributive or not)+-- ---------------------------------------------------------------------------++lawSemilattice :: LatSample -> Property+lawSemilattice sample =+  withTables sample $ \t ->+    conjoin $+      [check ("join idempotent @ " <> show a) (tJoin t a a == a) | a <- tEls t]+        <> [check ("meet idempotent @ " <> show a) (tMeet t a a == a) | a <- tEls t]+        <> [check ("join commutative @ " <> show (a, b)) (tJoin t a b == tJoin t b a) | (a, b) <- allPairs t]+        <> [check ("meet commutative @ " <> show (a, b)) (tMeet t a b == tMeet t b a) | (a, b) <- allPairs t]+        <> [ check ("join associative @ " <> show (a, b, c)) (tJoin t (tJoin t a b) c == tJoin t a (tJoin t b c))+           | (a, b, c) <- allTriples t+           ]+        <> [ check ("meet associative @ " <> show (a, b, c)) (tMeet t (tMeet t a b) c == tMeet t a (tMeet t b c))+           | (a, b, c) <- allTriples t+           ]++lawAbsorption :: LatSample -> Property+lawAbsorption sample =+  withTables sample $ \t ->+    conjoin $+      [check ("absorb join-of-meet @ " <> show (a, b)) (tJoin t a (tMeet t a b) == a) | (a, b) <- allPairs t]+        <> [check ("absorb meet-of-join @ " <> show (a, b)) (tMeet t a (tJoin t a b) == a) | (a, b) <- allPairs t]++lawOrderConsistency :: LatSample -> Property+lawOrderConsistency sample =+  withTables sample $ \t ->+    conjoin $+      [check ("leq iff join-absorbs @ " <> show (a, b)) (tLeq t a b == (tJoin t a b == b)) | (a, b) <- allPairs t]+        <> [check ("leq iff meet-absorbs @ " <> show (a, b)) (tLeq t a b == (tMeet t a b == a)) | (a, b) <- allPairs t]++lawPartialOrder :: LatSample -> Property+lawPartialOrder sample =+  withTables sample $ \t ->+    conjoin $+      [check ("reflexive @ " <> show a) (tLeq t a a) | a <- tEls t]+        <> [ check ("antisymmetric @ " <> show (a, b)) (not (tLeq t a b && tLeq t b a) || a == b)+           | (a, b) <- allPairs t+           ]+        <> [ check ("transitive @ " <> show (a, b, c)) (not (tLeq t a b && tLeq t b c) || tLeq t a c)+           | (a, b, c) <- allTriples t+           ]++lawBounds :: LatSample -> Property+lawBounds sample =+  withTables sample $ \t ->+    conjoin $+      [check ("bottom is least @ " <> show a) (tLeq t (tBot t) a) | a <- tEls t]+        <> [check ("top is greatest @ " <> show a) (tLeq t a (tTop t)) | a <- tEls t]+        <> [check ("join-bottom identity @ " <> show a) (tJoin t a (tBot t) == a) | a <- tEls t]+        <> [check ("meet-top identity @ " <> show a) (tMeet t a (tTop t) == a) | a <- tEls t]+        <> [check ("join-top absorbing @ " <> show a) (tJoin t a (tTop t) == tTop t) | a <- tEls t]+        <> [check ("meet-bottom absorbing @ " <> show a) (tMeet t a (tBot t) == tBot t) | a <- tEls t]++lawCoverStructure :: LatSample -> Property+lawCoverStructure sample =+  withTables sample $ \t ->+    let lattice = lsLattice sample+        strict = Set.fromList (strictOrderPairs lattice)+        expectedStrict = Set.fromList [(a, b) | (a, b) <- allPairs t, a /= b, tLeq t a b]+        covers = coverPairs lattice+     in conjoin $+          [ check "strictOrderPairs equals the strict order relation" (strict == expectedStrict),+            check "coverPairs is contained in the strict order" (Set.fromList covers `Set.isSubsetOf` strict)+          ]+            <> [ check ("cover " <> show (a, b) <> " has no strict intermediate") (null (strictIntermediates t a b))+               | (a, b) <- covers+               ]+            <> [ check ("upperCovers agrees with coverPairs @ " <> show a) (upperCoverAgrees lattice covers a)+               | a <- tEls t+               ]+  where+    strictIntermediates :: Tables -> Int -> Int -> [Int]+    strictIntermediates t a b =+      [mid | mid <- tEls t, mid /= a, mid /= b, tLeq t a mid, tLeq t mid b]+    upperCoverAgrees :: ContextLattice Int -> [(Int, Int)] -> Int -> Bool+    upperCoverAgrees lattice covers a =+      fmap Set.fromList (upperCovers lattice a) == Right (Set.fromList [upper | (lower, upper) <- covers, lower == a])++-- ---------------------------------------------------------------------------+-- Fixpoint laws (Knaster–Tarski over a monotone endomap)+-- ---------------------------------------------------------------------------++-- | A monotone endomap built as a composition of @join k@/@meet k@ steps; each+-- step is monotone, so the composite is monotone by construction.+data MonoStep+  = JoinBy Int+  | MeetBy Int+  deriving stock (Show)++genMonoSteps :: [Int] -> Gen [MonoStep]+genMonoSteps els =+  resize 5 (listOf (oneof [JoinBy <$> elements els, MeetBy <$> elements els]))++applyMonoSteps :: Tables -> [MonoStep] -> Int -> Int+applyMonoSteps t steps start =+  foldl' step start steps+  where+    step acc (JoinBy k) = tJoin t acc k+    step acc (MeetBy k) = tMeet t acc k++lawFixpoint :: LatSample -> Property+lawFixpoint sample =+  withTables sample $ \t ->+    forAll (genMonoSteps (tEls t)) $ \steps ->+      let lattice = lsLattice sample+          endomap = applyMonoSteps t steps+       in case (leastContextFixpoint lattice endomap, greatestContextFixpoint lattice endomap) of+            (Right lfp, Right gfp) ->+              conjoin $+                [ check ("least fixpoint is fixed; lfp=" <> show lfp) (endomap lfp == lfp),+                  check ("greatest fixpoint is fixed; gfp=" <> show gfp) (endomap gfp == gfp),+                  check ("lfp <= gfp; " <> show (lfp, gfp)) (tLeq t lfp gfp)+                ]+                  <> [check ("lfp <= fixed point " <> show p) (endomap p /= p || tLeq t lfp p) | p <- tEls t]+                  <> [check ("fixed point " <> show p <> " <= gfp") (endomap p /= p || tLeq t p gfp) | p <- tEls t]+            (leastResult, greatestResult) ->+              counterexample+                ("monotone endomap rejected before iteration: " <> show (leastResult, greatestResult))+                (property False)++-- ---------------------------------------------------------------------------+-- Distributive / Heyting laws (downset carriers only)+-- ---------------------------------------------------------------------------++lawDistributive :: LatSample -> Property+lawDistributive sample =+  withTables sample $ \t ->+    conjoin+      [ check+          ("meet distributes over join @ " <> show (a, b, c))+          (tMeet t a (tJoin t b c) == tJoin t (tMeet t a b) (tMeet t a c))+      | (a, b, c) <- allTriples t+      ]++lawHeyting :: LatSample -> Property+lawHeyting sample =+  withTables sample $ \t ->+    case compileContextHeyting (lsLattice sample) of+      Left err ->+        counterexample ("a distributive lattice must be Heyting, but compilation failed: " <> show err) (property False)+      Right heyting ->+        case implicationTable heyting (tEls t) of+          Left err -> counterexample err (property False)+          Right implies ->+            conjoin $+              [ check+                  ("Heyting adjunction @ " <> show (a, b, x))+                  (tLeq t x (implies a b) == tLeq t (tMeet t x a) b)+              | (a, b, x) <- allTriples t+              ]+                <> [ check+                       ("residuum is the greatest witness @ " <> show (a, b))+                       (implies a b == relativePseudocomplement t a b)+                   | (a, b) <- allPairs t+                   ]++implicationTable ::+  ContextHeyting Int ->+  [Int] ->+  Either String (Int -> Int -> Int)+implicationTable heyting els = do+  entries <- traverse resolve [(a, b) | a <- els, b <- els]+  let table = Map.fromList entries+  pure (\a b -> table Map.! (a, b))+  where+    resolve (a, b) =+      case impliesContext heyting a b of+        Left err -> Left ("implication lookup failed @ " <> show (a, b) <> ": " <> show err)+        Right value -> Right ((a, b), value)++relativePseudocomplement :: Tables -> Int -> Int -> Int+relativePseudocomplement t antecedent consequent =+  foldl' (tJoin t) (tBot t) [x | x <- tEls t, tLeq t (tMeet t x antecedent) consequent]++-- ---------------------------------------------------------------------------+-- Support laws+-- ---------------------------------------------------------------------------++lawSupport :: LatSample -> Property+lawSupport sample =+  withTables sample $ \t ->+    let lattice = lsLattice sample+     in conjoin $+          [ check+              ("principal support reaches the up-closure @ " <> show a)+              ( fmap Set.fromList (supportReachableLatticeContexts lattice (principalSupport a))+                  == Right (Set.fromList [x | x <- tEls t, tLeq t a x])+              )+          | a <- tEls t+          ]+            <> [ check ("support union commutes @ " <> show (a, b)) (unionOf lattice a b == unionOf lattice b a)+               | (a, b) <- allPairs t+               ]+  where+    unionOf :: ContextLattice Int -> Int -> Int -> Either (ContextLatticeLookupError Int) (SupportBasis Int)+    unionOf lattice a b = do+      supportA <- supportBasis lattice [a]+      supportB <- supportBasis lattice [b]+      supportUnion lattice supportA supportB++-- ---------------------------------------------------------------------------+-- Generator soundness+-- ---------------------------------------------------------------------------++prop_downsetsCompile :: Property+prop_downsetsCompile =+  forAll genPosetRep $ \poset ->+    case downsetLattice poset of+      Right _ -> property True+      Left err -> counterexample ("downset construction failed to compile: " <> show err) (property False)++prop_namedRosterCompiles :: Property+prop_namedRosterCompiles =+  conjoin (fmap (withSampleAttempt (const (property True))) namedSampleAttempts)++-- ---------------------------------------------------------------------------+-- Suite+-- ---------------------------------------------------------------------------++tests :: TestTree+tests =+  testGroup+    "finite lattice laws (property-based)"+    [ localOption (QuickCheckTests 300) $+        testGroup+          "generators are lawful"+          [ testProperty "downsets of a random poset always compile" prop_downsetsCompile,+            testProperty "named non-distributive witnesses compile" prop_namedRosterCompiles+          ],+      localOption (QuickCheckTests 120) $+        testGroup+          "order and lattice axioms"+          [ testProperty "leq is a partial order" (forAll genAnySampleAttempt (withSampleAttempt lawPartialOrder)),+            testProperty "join and meet are semilattices" (forAll genAnySampleAttempt (withSampleAttempt lawSemilattice)),+            testProperty "absorption holds" (forAll genAnySampleAttempt (withSampleAttempt lawAbsorption)),+            testProperty "order agrees with join and meet" (forAll genAnySampleAttempt (withSampleAttempt lawOrderConsistency)),+            testProperty "top and bottom are the bounds" (forAll genAnySampleAttempt (withSampleAttempt lawBounds)),+            testProperty "covers are the transitive reduction of the order" (forAll genAnySampleAttempt (withSampleAttempt lawCoverStructure)),+            testProperty "support union commutes and reaches up-closures" (forAll genAnySampleAttempt (withSampleAttempt lawSupport))+          ],+      localOption (QuickCheckTests 120) $+        testGroup+          "fixpoints"+          [testProperty "monotone endomaps have bracketing least and greatest fixpoints" (forAll genAnySampleAttempt (withSampleAttempt lawFixpoint))],+      localOption (QuickCheckTests 100) $+        testGroup+          "distributive and Heyting structure"+          [ testProperty "meet distributes over join on downset lattices" (forAll genDistributiveSampleAttempt (withSampleAttempt lawDistributive)),+            testProperty "implication is the relative pseudocomplement (adjunction)" (forAll genDistributiveSampleAttempt (withSampleAttempt lawHeyting))+          ]+    ]
+ test/finite-lattice/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import FiniteLatticeTests qualified+import Moonlight.Pale.Test.Runner (runTestTree)++main :: IO ()+main =+  runTestTree FiniteLatticeTests.tests
+ test/finite-lattice/PresentationSpec.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE DerivingStrategies #-}++module PresentationSpec+  ( tests,+  )+where++import Data.Set qualified as Set+import Moonlight.FiniteLattice+  ( ContextLattice,+    ContextLatticeCompileError (..),+    LatticeBuildError (..),+    below,+    belowAll,+    boundedLatticeOf,+    clBottom,+    clTop,+    compileContextLattice,+    contextLatticeElements,+    contextOrderDecl,+    element,+    elements,+    joinContext,+    latticeOf,+    leqContext,+    meetContext,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+  ( Assertion,+    assertFailure,+    testCase,+    (@?=),+  )++data DiamondContext+  = DiamondBottom+  | DiamondLeft+  | DiamondRight+  | DiamondTop+  deriving stock (Eq, Ord, Show, Read)++data BowtieContext+  = BowtieBottom+  | BowtieA+  | BowtieB+  | BowtieJoinLeft+  | BowtieJoinRight+  | BowtieTop+  deriving stock (Eq, Ord, Show, Read)++tests :: TestTree+tests =+  testGroup+    "finite lattice presentations"+    [ testCase "the diamond builder reproduces the hand-written declaration" testBuiltDiamondMatchesDeclaration,+      testCase "the bounded batched builder reproduces the hand-written declaration" testBoundedBatchedDiamondMatchesDeclaration,+      testCase "the builder infers top and bottom from the order" testInferredTopAndBottom,+      testCase "below a b means a is at or under b" testEdgeDirection,+      testCase "two maximal elements are an ambiguous top" testAmbiguousTop,+      testCase "a cyclic order has no maximal element" testCyclicOrderHasNoTop,+      testCase "an empty presentation is rejected" testEmptyPresentation,+      testCase "a duplicate element is rejected" testDuplicateElement,+      testCase "a non-lattice poset surfaces the compile obstruction" testNonLatticeSurfacesCompileError+    ]++-- | The centrepiece: a diamond declared by name binding produces the same lattice as+-- the hand-written 'contextOrderDecl', observed through top, bottom, the element list,+-- and the order\/join\/meet of every pair.+builtDiamond :: Either (LatticeBuildError DiamondContext) (ContextLattice DiamondContext)+builtDiamond =+  latticeOf $ do+    [bottom, left, right, top] <-+      elements [DiamondBottom, DiamondLeft, DiamondRight, DiamondTop]+    below bottom left+    below bottom right+    below left top+    below right top++boundedBatchedDiamond :: Either (LatticeBuildError DiamondContext) (ContextLattice DiamondContext)+boundedBatchedDiamond =+  boundedLatticeOf DiamondTop DiamondBottom $ do+    [bottom, left, right, top] <-+      elements [DiamondBottom, DiamondLeft, DiamondRight, DiamondTop]+    belowAll+      [ (bottom, left),+        (bottom, right),+        (left, top),+        (right, top)+      ]++declaredDiamond :: Either (ContextLatticeCompileError DiamondContext) (ContextLattice DiamondContext)+declaredDiamond =+  compileContextLattice+    (Set.fromList [DiamondBottom, DiamondLeft, DiamondRight, DiamondTop])+    ( contextOrderDecl+        DiamondTop+        DiamondBottom+        [ (DiamondBottom, DiamondLeft),+          (DiamondBottom, DiamondRight),+          (DiamondLeft, DiamondTop),+          (DiamondRight, DiamondTop)+        ]+    )++testBuiltDiamondMatchesDeclaration :: Assertion+testBuiltDiamondMatchesDeclaration =+  assertMatchesDeclaredDiamond builtDiamond++testBoundedBatchedDiamondMatchesDeclaration :: Assertion+testBoundedBatchedDiamondMatchesDeclaration =+  assertMatchesDeclaredDiamond boundedBatchedDiamond++assertMatchesDeclaredDiamond :: Either (LatticeBuildError DiamondContext) (ContextLattice DiamondContext) -> Assertion+assertMatchesDeclaredDiamond diamond =+  case (diamond, declaredDiamond) of+    (Right built, Right declared) -> do+      clTop built @?= clTop declared+      clBottom built @?= clBottom declared+      contextLatticeElements built @?= contextLatticeElements declared+      mapM_+        ( \(leftContext, rightContext) -> do+            leqContext built leftContext rightContext+              @?= leqContext declared leftContext rightContext+            joinContext built leftContext rightContext+              @?= joinContext declared leftContext rightContext+            meetContext built leftContext rightContext+              @?= meetContext declared leftContext rightContext+        )+        [ (leftContext, rightContext)+          | leftContext <- contextLatticeElements declared,+            rightContext <- contextLatticeElements declared+        ]+    (Left buildError, _) ->+      assertFailure ("expected the presentation diamond, got " <> show buildError)+    (_, Left compileError) ->+      assertFailure ("expected the declared diamond, got " <> show compileError)++testInferredTopAndBottom :: Assertion+testInferredTopAndBottom =+  case builtDiamond of+    Left buildError ->+      assertFailure ("expected the built diamond, got " <> show buildError)+    Right built -> do+      clTop built @?= DiamondTop+      clBottom built @?= DiamondBottom+      joinContext built DiamondLeft DiamondRight @?= Right DiamondTop+      meetContext built DiamondLeft DiamondRight @?= Right DiamondBottom++testEdgeDirection :: Assertion+testEdgeDirection =+  case builtDiamond of+    Left buildError ->+      assertFailure ("expected the built diamond, got " <> show buildError)+    Right built -> do+      leqContext built DiamondBottom DiamondTop @?= Right True+      leqContext built DiamondTop DiamondBottom @?= Right False++testAmbiguousTop :: Assertion+testAmbiguousTop =+  case latticeOf forkWithoutTop of+    Left (AmbiguousTop candidates) ->+      Set.fromList candidates @?= Set.fromList [DiamondLeft, DiamondRight]+    Left otherError ->+      assertFailure ("expected AmbiguousTop, got " <> show otherError)+    Right _ ->+      assertFailure "expected AmbiguousTop, got a compiled lattice"+  where+    forkWithoutTop = do+      [bottom, left, right] <- elements [DiamondBottom, DiamondLeft, DiamondRight]+      below bottom left+      below bottom right++testCyclicOrderHasNoTop :: Assertion+testCyclicOrderHasNoTop =+  latticeOf cyclicPresentation `shouldFailWith` NoTop+  where+    cyclicPresentation = do+      [a, b] <- elements [DiamondLeft, DiamondRight]+      below a b+      below b a++testEmptyPresentation :: Assertion+testEmptyPresentation =+  ( latticeOf (pure ()) ::+      Either (LatticeBuildError DiamondContext) (ContextLattice DiamondContext)+  )+    `shouldFailWith` EmptyLattice++testDuplicateElement :: Assertion+testDuplicateElement =+  latticeOf duplicatePresentation `shouldFailWith` DuplicateElement DiamondTop+  where+    duplicatePresentation = do+      _ <- element DiamondTop+      _ <- element DiamondTop+      pure ()++-- | A poset with a unique top and bottom whose incomparable pair @A@, @B@ has two+-- minimal upper bounds. Inference succeeds; @compileContextLattice@ rejects it, and the+-- builder forwards that obstruction verbatim through 'InvalidLattice'.+testNonLatticeSurfacesCompileError :: Assertion+testNonLatticeSurfacesCompileError =+  latticeOf bowtiePresentation+    `shouldFailWith` InvalidLattice+      (ContextLatticeJoinDoesNotExist BowtieA BowtieB (Set.fromList [BowtieJoinLeft, BowtieJoinRight]))+  where+    bowtiePresentation = do+      [bottom, a, b, joinLeft, joinRight, top] <-+        elements+          [ BowtieBottom,+            BowtieA,+            BowtieB,+            BowtieJoinLeft,+            BowtieJoinRight,+            BowtieTop+          ]+      below bottom a+      below bottom b+      below a joinLeft+      below b joinLeft+      below a joinRight+      below b joinRight+      below joinLeft top+      below joinRight top++-- | Assert a presentation fails with a given build error, inspecting only the 'Left'+-- so the lattice on the 'Right' (which has no 'Eq') is never compared.+shouldFailWith ::+  (Eq buildError, Show buildError) =>+  Either buildError lattice ->+  buildError ->+  Assertion+shouldFailWith result expected =+  case result of+    Left actual -> actual @?= expected+    Right _ -> assertFailure "expected a lattice presentation failure"