diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/bench/abstract/AbstractBench.hs b/bench/abstract/AbstractBench.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/AbstractBench.hs @@ -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 diff --git a/bench/abstract/Main.hs b/bench/abstract/Main.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Main.hs @@ -0,0 +1,15 @@ +module Main + ( main, + ) +where + +import AbstractBench + ( abstractBenchmarks, + ) +import Moonlight.Pale.Bench.Runner + ( runBenchmark, + ) + +main :: IO () +main = + runBenchmark abstractBenchmarks diff --git a/bench/aggregate/Main.hs b/bench/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/bench/aggregate/Main.hs @@ -0,0 +1,21 @@ +module Main + ( main, + ) +where + +import AbstractBench + ( abstractBenchmarks, + ) +import FiniteLatticeBench + ( finiteLatticeBenchmarkSuite, + ) +import Moonlight.Pale.Bench.Runner + ( runBenchmarks, + ) + +main :: IO () +main = + runBenchmarks + [ abstractBenchmarks, + finiteLatticeBenchmarkSuite + ] diff --git a/bench/finite-lattice/Atomic.hs b/bench/finite-lattice/Atomic.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Atomic.hs @@ -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 + ] diff --git a/bench/finite-lattice/Finite.hs b/bench/finite-lattice/Finite.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Finite.hs @@ -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) + ] diff --git a/bench/finite-lattice/FiniteLatticeBench.hs b/bench/finite-lattice/FiniteLatticeBench.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/FiniteLatticeBench.hs @@ -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 + ] diff --git a/bench/finite-lattice/Fixtures.hs b/bench/finite-lattice/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Fixtures.hs @@ -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 diff --git a/bench/finite-lattice/JoinMeet.hs b/bench/finite-lattice/JoinMeet.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/JoinMeet.hs @@ -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) diff --git a/bench/finite-lattice/Kernels.hs b/bench/finite-lattice/Kernels.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Kernels.hs @@ -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)) diff --git a/bench/finite-lattice/Main.hs b/bench/finite-lattice/Main.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Main.hs @@ -0,0 +1,15 @@ +module Main + ( main, + ) +where + +import FiniteLatticeBench + ( finiteLatticeBenchmarkSuite, + ) +import Moonlight.Pale.Bench.Runner + ( runBenchmark, + ) + +main :: IO () +main = + runBenchmark finiteLatticeBenchmarkSuite diff --git a/bench/finite-lattice/Rows.hs b/bench/finite-lattice/Rows.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Rows.hs @@ -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" diff --git a/bench/finite-lattice/Support.hs b/bench/finite-lattice/Support.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Support.hs @@ -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) + ) + ) diff --git a/bench/finite-lattice/Tableless.hs b/bench/finite-lattice/Tableless.hs new file mode 100644 --- /dev/null +++ b/bench/finite-lattice/Tableless.hs @@ -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) + ] diff --git a/docs/finite-lattice/BENCHMARKS-m4-pro.md b/docs/finite-lattice/BENCHMARKS-m4-pro.md new file mode 100644 --- /dev/null +++ b/docs/finite-lattice/BENCHMARKS-m4-pro.md @@ -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 | diff --git a/docs/finite-lattice/CHANGELOG.md b/docs/finite-lattice/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/docs/finite-lattice/CHANGELOG.md @@ -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. diff --git a/moonlight-algebra.cabal b/moonlight-algebra.cabal new file mode 100644 --- /dev/null +++ b/moonlight-algebra.cabal @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/Action.hs b/src-abstract/Moonlight/Algebra/Pure/Action.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Action.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/EndoPatch.hs b/src-abstract/Moonlight/Algebra/Pure/EndoPatch.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/EndoPatch.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/FreeAbelianGroup.hs b/src-abstract/Moonlight/Algebra/Pure/FreeAbelianGroup.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/FreeAbelianGroup.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/FreeMonoid.hs b/src-abstract/Moonlight/Algebra/Pure/FreeMonoid.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/FreeMonoid.hs @@ -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] diff --git a/src-abstract/Moonlight/Algebra/Pure/GCD.hs b/src-abstract/Moonlight/Algebra/Pure/GCD.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/GCD.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/Group.hs b/src-abstract/Moonlight/Algebra/Pure/Group.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Group.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/LaneVector.hs b/src-abstract/Moonlight/Algebra/Pure/LaneVector.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/LaneVector.hs @@ -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 #-} diff --git a/src-abstract/Moonlight/Algebra/Pure/Lattice.hs b/src-abstract/Moonlight/Algebra/Pure/Lattice.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Lattice.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/Magnitude.hs b/src-abstract/Moonlight/Algebra/Pure/Magnitude.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Magnitude.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/Module.hs b/src-abstract/Moonlight/Algebra/Pure/Module.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Module.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/NumberTheory.hs b/src-abstract/Moonlight/Algebra/Pure/NumberTheory.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/NumberTheory.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/Orientation.hs b/src-abstract/Moonlight/Algebra/Pure/Orientation.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Orientation.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/Polynomial.hs b/src-abstract/Moonlight/Algebra/Pure/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Polynomial.hs @@ -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) + ] diff --git a/src-abstract/Moonlight/Algebra/Pure/PowerSet.hs b/src-abstract/Moonlight/Algebra/Pure/PowerSet.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/PowerSet.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/Product.hs b/src-abstract/Moonlight/Algebra/Pure/Product.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Product.hs @@ -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 diff --git a/src-abstract/Moonlight/Algebra/Pure/Quotient.hs b/src-abstract/Moonlight/Algebra/Pure/Quotient.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Quotient.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/Ring.hs b/src-abstract/Moonlight/Algebra/Pure/Ring.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Ring.hs @@ -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) diff --git a/src-abstract/Moonlight/Algebra/Pure/SparseVec.hs b/src-abstract/Moonlight/Algebra/Pure/SparseVec.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/SparseVec.hs @@ -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)] diff --git a/src-abstract/Moonlight/Algebra/Pure/Zn.hs b/src-abstract/Moonlight/Algebra/Pure/Zn.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Algebra/Pure/Zn.hs @@ -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) diff --git a/src-finite-lattice/Moonlight/FiniteLattice.hs b/src-finite-lattice/Moonlight/FiniteLattice.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Core.hs b/src-finite-lattice/Moonlight/FiniteLattice/Core.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Core.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Cover.hs b/src-finite-lattice/Moonlight/FiniteLattice/Cover.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Cover.hs @@ -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) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Fixpoint.hs b/src-finite-lattice/Moonlight/FiniteLattice/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Fixpoint.hs @@ -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 #-} diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Heyting.hs b/src-finite-lattice/Moonlight/FiniteLattice/Heyting.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Heyting.hs @@ -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 #-} diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Compile.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Compile.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Compile.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Dense.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Dense.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Dense.hs @@ -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) + ) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Distributive.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Distributive.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Distributive.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Index.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Index.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Index.hs @@ -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 #-} diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Invariant.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Invariant.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Invariant.hs @@ -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 #-} diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Key.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Key.hs @@ -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 #-} + diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Layout.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Layout.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Layout.hs @@ -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 + ) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Plan.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Plan.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Plan.hs @@ -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) + diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Recognize.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Recognize.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Recognize.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Relation.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Relation.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Relation.hs @@ -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 diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Topological.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Topological.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Topological.hs @@ -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) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Types.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Types.hs @@ -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 #-} diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Internal/Validate.hs b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Validate.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Internal/Validate.hs @@ -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) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Presentation.hs b/src-finite-lattice/Moonlight/FiniteLattice/Presentation.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Presentation.hs @@ -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] diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Resident.hs b/src-finite-lattice/Moonlight/FiniteLattice/Resident.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Resident.hs @@ -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) + ) diff --git a/src-finite-lattice/Moonlight/FiniteLattice/Support.hs b/src-finite-lattice/Moonlight/FiniteLattice/Support.hs new file mode 100644 --- /dev/null +++ b/src-finite-lattice/Moonlight/FiniteLattice/Support.hs @@ -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 + ) diff --git a/src-internal/Moonlight/Algebra/Unsafe/GCDWitness.hs b/src-internal/Moonlight/Algebra/Unsafe/GCDWitness.hs new file mode 100644 --- /dev/null +++ b/src-internal/Moonlight/Algebra/Unsafe/GCDWitness.hs @@ -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 diff --git a/src-laws/Moonlight/Algebra/Effect/LawNames.hs b/src-laws/Moonlight/Algebra/Effect/LawNames.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Algebra/Effect/LawNames.hs @@ -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 diff --git a/src-laws/Moonlight/Algebra/Effect/Laws.hs b/src-laws/Moonlight/Algebra/Effect/Laws.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Algebra/Effect/Laws.hs @@ -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 [] diff --git a/src-laws/Moonlight/Algebra/Test/Generators.hs b/src-laws/Moonlight/Algebra/Test/Generators.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Algebra/Test/Generators.hs @@ -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) diff --git a/src-public/Moonlight/Algebra.hs b/src-public/Moonlight/Algebra.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Algebra.hs @@ -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, + ) diff --git a/test/abstract/AbstractTests.hs b/test/abstract/AbstractTests.hs new file mode 100644 --- /dev/null +++ b/test/abstract/AbstractTests.hs @@ -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 + ] diff --git a/test/abstract/Main.hs b/test/abstract/Main.hs new file mode 100644 --- /dev/null +++ b/test/abstract/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import AbstractTests qualified +import Moonlight.Pale.Test.Runner (runTestTree) + +main :: IO () +main = + runTestTree AbstractTests.tests diff --git a/test/abstract/OrderedLatticeSpec.hs b/test/abstract/OrderedLatticeSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/OrderedLatticeSpec.hs @@ -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 diff --git a/test/abstract/SparseVecSpec.hs b/test/abstract/SparseVecSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/SparseVecSpec.hs @@ -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) + ] diff --git a/test/aggregate/Main.hs b/test/aggregate/Main.hs new file mode 100644 --- /dev/null +++ b/test/aggregate/Main.hs @@ -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 + ] diff --git a/test/finite-lattice/FiniteLatticeSpec.hs b/test/finite-lattice/FiniteLatticeSpec.hs new file mode 100644 --- /dev/null +++ b/test/finite-lattice/FiniteLatticeSpec.hs @@ -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 diff --git a/test/finite-lattice/FiniteLatticeTests.hs b/test/finite-lattice/FiniteLatticeTests.hs new file mode 100644 --- /dev/null +++ b/test/finite-lattice/FiniteLatticeTests.hs @@ -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 + ] diff --git a/test/finite-lattice/LawSpec.hs b/test/finite-lattice/LawSpec.hs new file mode 100644 --- /dev/null +++ b/test/finite-lattice/LawSpec.hs @@ -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)) + ] + ] diff --git a/test/finite-lattice/Main.hs b/test/finite-lattice/Main.hs new file mode 100644 --- /dev/null +++ b/test/finite-lattice/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import FiniteLatticeTests qualified +import Moonlight.Pale.Test.Runner (runTestTree) + +main :: IO () +main = + runTestTree FiniteLatticeTests.tests diff --git a/test/finite-lattice/PresentationSpec.hs b/test/finite-lattice/PresentationSpec.hs new file mode 100644 --- /dev/null +++ b/test/finite-lattice/PresentationSpec.hs @@ -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"