diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Blue Rose + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,155 @@ +# moonlight-category + +> Part of **Moonlight**, the sheaf-theoretic computation layer beneath +> [Melusine](https://bluerose.blue) and Pale Meridian. + +`moonlight-category` is Moonlight's categorical tier. Building on +[`moonlight-core`](https://hackage.haskell.org/package/moonlight-core), it provides a totalised, +explicit-error category abstraction together with the finite, runtime-validated +categories and site/path presentations the compiler uses to model its own structure. + +## Relationship to `data-category` + +If you want general indexed category theory in Haskell, prefer Sjoerd Visscher's +[`data-category`](https://hackage.haskell.org/package/data-category). Its typed-arrow +calculus is the primary inspiration for this package's indexed layer, and several +modules under `Moonlight.Category.Indexed` are adapted from it. Thank you to Sjoerd +Visscher for the design and implementation work in `data-category`. + +Full attribution and the upstream BSD-3-Clause license are recorded in +[`THIRD_PARTY_NOTICES.md`](./THIRD_PARTY_NOTICES.md). + +## What it provides + +- **A category abstraction.** The `Category` class is totalised: objects, morphisms, + 2-morphisms, compositors and a category-specific error type are associated types, + and every operation returns `Either`. +- **Limits and colimits.** A class tower for products, coproducts, pullbacks, + pushouts, equalizers and coequalizers. +- **Higher structure.** 2-categories, bicategories, monoidal and enriched categories. +- **Finite categories.** `FinCat`: runtime-validated finite categories with handles, + bit-packed thin variants, composable chains and core/automorphism groupoid + extraction. +- **Finite-category presentations.** `Moonlight.Category.Presentation` provides a + focused authoring EDSL for finite posets and fully enumerated finite categories, + compiling down to validated `FinCat`. +- **Sites and presentations.** Site manifests with validation, reachable-closure and + import-cycle diagnostics, path categories, quotients, and compilation down to + `FinCat`. +- **Rewriting witnesses.** Adhesive and PBPO pushout-complement witnesses, structured + cospans, double categories, and decorated composition/presentation. +- **Indexed category theory.** The typed-arrow layer adapted from `data-category`. +- **Simplicial substrate.** Runtime-dimensional Δ morphisms, finite truncated + simplicial sets, standard/boundary/horn spaces, nerves, Kan interfaces, and + connected-component/core-groupoid queries over finite composable categories. + +## Public modules + +| Module | Surface | +| --- | --- | +| `Moonlight.Category` | The broad categorical surface: `Category` and composition, the limit/colimit and higher-category towers, finite and thin categories, invertibility/groupoids, adhesive & PBPO witnesses, structured cospans, double categories, decorated composition, Galois connections, polynomial functors, covering families, and the site/path layer. | +| `Moonlight.Category.Indexed` | The indexed, typed-arrow category-theory layer adapted from `data-category`: indexed categories, functors, natural transformations, adjunctions, (co)limits, Kan extensions, products/coproducts and the simplex category. | +| `Moonlight.Category.Presentation` | The finite-category authoring surface: named objects, named nonidentity morphisms, strict-order `below` declarations, identities in equations, and compilation to `FinCat`. | +| `Moonlight.Category.Notation` | Scoped query and composition helpers for already-compiled `FinCat` values. | +| `Moonlight.Category.Simplicial` | The public simplicial surface: Δ, simplicial sets, nerves, Kan interfaces, homotopy queries, and pure validation. | + +The `Moonlight.Category.Pure.*` leaves live in named implementation sublibraries: +`abstract` for generic category theory, `finite` for `FinCat`/presentation runtime, +`site` for site and path compilation, `indexed` for the adapted `data-category` +typed-arrow layer, and `simplicial` for Δ, simplicial sets, nerves and Kan +interfaces. Effectful law harnesses and cross-package test fixtures live in the +`laws` sublibrary rather than the pure production components. + +## Finite-category presentations + +Use `Moonlight.Category.Presentation` to write finite categories declaratively. +Compilation always produces the validated runtime representation `FinCat`. + +### Finite posets + +`below` declares strict generating inequalities. Compilation takes the transitive +closure, rejects cycles, and supplies identities implicitly. + +```haskell +import Moonlight.Category.Presentation + +threeChain :: Either FinCatBuildError FinCat +threeChain = + finCategory $ do + [a, b, c] <- objects ["A", "B", "C"] + below a b + below b c +``` + +### Fully enumerated finite categories + +In the general dialect, each call to `arrow` declares one actual nonidentity +morphism of the resulting category. Equations determine the nonidentity +composition table. + +```haskell +import Moonlight.Category.Presentation + +commutingTriangle :: Either FinCatBuildError FinCat +commutingTriangle = + finCategory $ do + a <- object "A" + b <- object "B" + c <- object "C" + + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow a c "h" + + equate (g `after` f) h +``` + +Identities may be named inside equations: + +```haskell +inversePair :: Either FinCatBuildError FinCat +inversePair = + finCategory $ do + a <- object "A" + b <- object "B" + + f <- arrow a b "f" + g <- arrow b a "g" + + equate (g `after` f) (identityAt a) + equate (f `after` g) (identityAt b) +``` + +Longer paths are accepted when their proper intermediate composites are determined +elsewhere in the presentation. Equation declaration order is irrelevant. + +The presentation dialect accepts declared morphisms and equations over determined +composites. An equation such as `equate f g` for distinct declared morphisms is +rejected rather than silently identifying them. + +For querying and composing morphisms after compilation, import +`Moonlight.Category.Notation` separately. + +## Acknowledgements + +The representation of finite and finitely-presented categories as concrete, +runtime-validated data structures, including `FinCat` and the site/path +presentations that compile down to it, was directly inspired by the +[AlgebraicJulia](https://www.algebraicjulia.org/) ecosystem and the work on attributed +C-sets (acsets), whose thesis is precisely that categorical objects can be realised as +performant data structures. The implementation here is independent; the conceptual +debt is real and gratefully acknowledged. + +> Evan Patterson, Owen Lynch, and James Fairbanks. +> "Categorical Data Structures for Technical Computing." arXiv:2106.04703. +> + +Thank you to Evan Patterson, Owen Lynch, James Fairbanks, and the AlgebraicJulia +community. + +## License + +Moonlight's original code is licensed under MIT; see [`LICENSE`](./LICENSE). +The indexed modules adapted from `data-category` remain BSD-3-Clause; their +copyright notice, license terms, and attribution are recorded in +[`THIRD_PARTY_NOTICES.md`](./THIRD_PARTY_NOTICES.md). diff --git a/THIRD_PARTY_NOTICES.md b/THIRD_PARTY_NOTICES.md new file mode 100644 --- /dev/null +++ b/THIRD_PARTY_NOTICES.md @@ -0,0 +1,70 @@ +# Third-party notices + +## data-category 0.11 + +Selected indexed category-theory modules under +`src-indexed/Moonlight/Category/Pure/Indexed/` are adapted from `data-category-0.11`. + +Thanks to Sjoerd Visscher for `data-category`; its indexed-arrow design is the better +starting point for general category-theory code. If you need ordinary indexed +category calculus rather than Pale Meridian's runtime finite categories, site/path +presentations, adhesive/PBPO witnesses, exact handles, diagnostics, or law harnesses, +use `data-category` instead of `moonlight-category`. + +- Original package: https://hackage.haskell.org/package/data-category-0.11 +- Original author: Sjoerd Visscher +- Original copyright: Copyright Sjoerd Visscher 2011 +- License: BSD-3-Clause + +The original BSD-3-Clause license text follows: + +```text +Copyright Sjoerd Visscher 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sjoerd Visscher nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +``` + +## Acknowledgements (inspiration, no derived code) + +The representation of finite and finitely-presented categories as concrete, +runtime-validated data structures — `FinCat` and the site/path presentations that +compile to it — was directly inspired by the AlgebraicJulia ecosystem and the work on +attributed C-sets (acsets), whose central idea is that categorical objects can be +realised as performant data structures. No code is derived from those Julia projects; +the inspiration is conceptual, but real and gratefully acknowledged. + +- Evan Patterson, Owen Lynch, and James Fairbanks. "Categorical Data Structures for + Technical Computing." arXiv:2106.04703. + (Topos Institute; Universiteit Utrecht, Mathematics Department; University of + Florida, Computer & Information Science & Engineering.) +- AlgebraicJulia: + +Thank you to Evan Patterson, Owen Lynch, James Fairbanks, and the AlgebraicJulia +community. 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,18 @@ +module AbstractBench + ( abstractBenchmarks, + ) +where + +import Adhesive.Suite (adhesiveBenchmarks) +import Algebraic.Suite (algebraicSurfaceBenchmarks) +import Covering (coveringBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +abstractBenchmarks :: Benchmark +abstractBenchmarks = + bgroup + "abstract" + [ coveringBenchmarks, + adhesiveBenchmarks, + algebraicSurfaceBenchmarks + ] diff --git a/bench/abstract/AbstractFixtures.hs b/bench/abstract/AbstractFixtures.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/AbstractFixtures.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TypeFamilies #-} + +module AbstractFixtures + ( BenchCategory (..), + BenchObject (..), + BenchMorphism (..), + benchMorphism, + benchObjectWeight, + benchMorphismWeight, + benchRuleLeg, + benchMonicMatch, + benchLeftCospanLeg, + benchLeftCospanRightLeg, + benchRightCospanLeftLeg, + benchRightCospanRightLeg, + ) +where + +import Moonlight.Category.Pure.Adhesive + ( AdhesiveCategory (..), + MonicMatchComponents (..), + PBPOAdhesiveCategory, + PushoutComplementComponents (..), + ) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Limits (HasPullbacks (..), HasPushouts (..)) + +data BenchCategory = BenchCategory + +data BenchObject + = ObjectK + | ObjectL + | ObjectD + | ObjectG + | ObjectP + | ObjectQ + deriving stock (Eq, Ord, Show) + +data BenchMorphism = BenchMorphism + { benchMorphismSource :: !BenchObject, + benchMorphismTarget :: !BenchObject + } + deriving stock (Eq, Ord, Show) + +benchMorphism :: BenchObject -> BenchObject -> BenchMorphism +benchMorphism = BenchMorphism + +benchRuleLeg :: BenchMorphism +benchRuleLeg = benchMorphism ObjectK ObjectL + +benchMonicMatch :: BenchMorphism +benchMonicMatch = benchMorphism ObjectL ObjectG + +benchLeftCospanLeg :: BenchMorphism +benchLeftCospanLeg = benchMorphism ObjectK ObjectD + +benchLeftCospanRightLeg :: BenchMorphism +benchLeftCospanRightLeg = benchMorphism ObjectL ObjectD + +benchRightCospanLeftLeg :: BenchMorphism +benchRightCospanLeftLeg = benchMorphism ObjectL ObjectG + +benchRightCospanRightLeg :: BenchMorphism +benchRightCospanRightLeg = benchMorphism ObjectQ ObjectG + +benchObjectWeight :: BenchObject -> Int +benchObjectWeight objectValue = + case objectValue of + ObjectK -> 1 + ObjectL -> 2 + ObjectD -> 3 + ObjectG -> 4 + ObjectP -> 5 + ObjectQ -> 6 + +benchMorphismWeight :: BenchMorphism -> Int +benchMorphismWeight morphism = + benchObjectWeight (benchMorphismSource morphism) + + benchObjectWeight (benchMorphismTarget morphism) + +instance Category BenchCategory where + type Ob BenchCategory = BenchObject + type Mor BenchCategory = BenchMorphism + + identity _ objectValue = + Right (benchMorphism objectValue objectValue) + + compose _ leftMorphism rightMorphism + | benchMorphismTarget rightMorphism == benchMorphismSource leftMorphism = + Right (benchMorphism (benchMorphismSource rightMorphism) (benchMorphismTarget leftMorphism), ()) + | otherwise = + Left () + + source _ = + Right . benchMorphismSource + + target _ = + Right . benchMorphismTarget + +instance HasPullbacks BenchCategory where + pullback _ leftMorphism rightMorphism + | benchMorphismTarget leftMorphism == benchMorphismTarget rightMorphism = + Just + ( ObjectP, + benchMorphism ObjectP (benchMorphismSource leftMorphism), + benchMorphism ObjectP (benchMorphismSource rightMorphism) + ) + | otherwise = + Nothing + + pullbackMediator _ leftMorphism rightMorphism coneLeft coneRight + | benchMorphismTarget leftMorphism == benchMorphismTarget rightMorphism + && benchMorphismTarget coneLeft == benchMorphismSource leftMorphism + && benchMorphismTarget coneRight == benchMorphismSource rightMorphism + && benchMorphismSource coneLeft == benchMorphismSource coneRight = + Just (benchMorphism (benchMorphismSource coneLeft) ObjectP) + | otherwise = + Nothing + +instance HasPushouts BenchCategory where + pushout _ leftMorphism rightMorphism + | benchMorphismSource leftMorphism == benchMorphismSource rightMorphism = + Just + ( ObjectQ, + benchMorphism (benchMorphismTarget leftMorphism) ObjectQ, + benchMorphism (benchMorphismTarget rightMorphism) ObjectQ + ) + | otherwise = + Nothing + +instance AdhesiveCategory BenchCategory where + monicMatchComponents _ morphism = + Just (MonicMatchComponents morphism) + + pushoutComplementComponents _ _ _ = + Just + PushoutComplementComponents + { pushoutComplementComponentObject = ObjectD, + pushoutComplementComponentBorrowedLeg = benchMorphism ObjectD ObjectG, + pushoutComplementComponentResidualLeg = benchMorphism ObjectK ObjectD + } + +instance PBPOAdhesiveCategory BenchCategory diff --git a/bench/abstract/Adhesive/Graph.hs b/bench/abstract/Adhesive/Graph.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Adhesive/Graph.hs @@ -0,0 +1,840 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Adhesive.Graph + ( finiteGraphDPOBenchmarks, + ) +where + +import BenchSupport (boolWeight) +import Control.DeepSeq (NFData (..)) +import Control.Monad (guard) +import Data.Function ((&)) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Moonlight.Category.Pure.Adhesive + ( AdhesiveCategory (..), + DenseIntSet, + MonicMatchComponents (..), + PBPOAdhesiveCategory (..), + PBPOComplementComponents (..), + PBPOComplementWitness, + PushoutComplementWitness, + PushoutComplementComponents (..), + denseIntSetDifference, + denseIntSetFoldl', + denseIntSetFromAscList, + denseIntSetFull, + denseIntSetIntersection, + denseIntSetIntersects, + denseIntSetInterval, + denseIntSetIsSubsetOf, + denseIntSetMember, + denseIntSetSize, + denseIntSetUnion, + denseIntSetUniverseSize, + denseIntSetWeight, + monicMatchArrow, + pbpoComplement, + pbpoComplementBorrowedLeg, + pbpoComplementPullbackObject, + pbpoComplementPullbackToBorrowed, + pbpoComplementPullbackToMatch, + pbpoComplementPushoutFromComplement, + pbpoComplementPushoutFromMatch, + pbpoComplementPushoutObject, + pbpoComplementResidualLeg, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pushoutComplement, + pushoutComplementBorrowedLeg, + pushoutComplementObject, + pushoutComplementResidualLeg, + pushoutComplementSquareCommutes, + witnessMonic, + ) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Limits (HasPullbacks (..), HasPushouts (..), pullback, pushout) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +newtype GraphId = GraphId {unGraphId :: Int} + deriving stock (Eq, Ord, Show) + +data GraphCategory = GraphCategory + { graphCategoryCarrier :: !GraphCarrier + } + deriving stock (Show) + +data GraphTwoMor + +data GraphCompositor = GraphCompositor + +data GraphCategoryError + = GraphBoundaryMismatch + | GraphCompositeInvalid + deriving stock (Eq, Show) + +data GraphEdge = GraphEdge + { graphEdgeSource :: !Int, + graphEdgeTarget :: !Int + } + deriving stock (Eq, Show) + +data GraphCarrier = GraphCarrier + { graphCarrierId :: !GraphId, + graphCarrierVertices :: !DenseIntSet, + graphCarrierEdgeIds :: !DenseIntSet, + graphCarrierEdges :: !(IntMap GraphEdge), + graphCarrierIncidentEdges :: !(Vector DenseIntSet) + } + deriving stock (Show) + +data GraphObject = GraphObject + { graphObjectCarrierId :: !GraphId, + graphObjectVertices :: !DenseIntSet, + graphObjectEdges :: !DenseIntSet, + graphObjectVertexCount :: !Int, + graphObjectEdgeCount :: !Int + } + deriving stock (Show) + +data GraphDeletionDelta = GraphDeletionDelta + { graphDeletionVertices :: !DenseIntSet, + graphDeletionEdges :: !DenseIntSet + } + deriving stock (Eq, Show) + +data GraphMorphism = GraphMorphism + { graphMorphismSource :: !GraphObject, + graphMorphismTarget :: !GraphObject, + graphMorphismKnownComplement :: !(Maybe GraphDeletionDelta) + } + deriving stock (Show) + +data GraphRewriteCase = GraphRewriteCase + { graphRewriteCategory :: !GraphCategory, + graphRewriteRuleLeg :: !GraphMorphism, + graphRewriteMatch :: !GraphMorphism + } + deriving stock (Show) + +data PreparedGraphRewriteCase = PreparedGraphRewriteCase + { preparedGraphRewrite :: !GraphRewriteCase, + preparedGraphComplement :: !(PushoutComplementWitness GraphCategory), + preparedGraphPBPO :: !(PBPOComplementWitness GraphCategory) + } + +data PreparedGraphRewriteBatch = PreparedGraphRewriteBatch + { preparedGraphAmbientSize :: !Int, + preparedGraphCases :: ![PreparedGraphRewriteCase] + } + +instance Eq GraphObject where + left == right = + graphObjectCarrierId left == graphObjectCarrierId right + && graphObjectVertexCount left == graphObjectVertexCount right + && graphObjectEdgeCount left == graphObjectEdgeCount right + && graphObjectVertices left == graphObjectVertices right + && graphObjectEdges left == graphObjectEdges right + +instance Eq GraphMorphism where + left == right = + graphMorphismSource left == graphMorphismSource right + && graphMorphismTarget left == graphMorphismTarget right + +instance NFData GraphId where + rnf graphId = + unGraphId graphId `seq` () + +instance NFData GraphEdge where + rnf edge = + graphEdgeSource edge + `seq` graphEdgeTarget edge + `seq` () + +instance NFData GraphCarrier where + rnf carrier = + rnf (graphCarrierId carrier) + `seq` denseIntSetSize (graphCarrierVertices carrier) + `seq` denseIntSetSize (graphCarrierEdgeIds carrier) + `seq` rnf (graphCarrierEdges carrier) + `seq` Vector.foldl' (\forced incidentEdges -> denseIntSetSize incidentEdges `seq` forced) () (graphCarrierIncidentEdges carrier) + +instance NFData GraphCategory where + rnf categoryValue = + rnf (graphCategoryCarrier categoryValue) + +instance NFData GraphObject where + rnf graph = + rnf (graphObjectCarrierId graph) + `seq` denseIntSetSize (graphObjectVertices graph) + `seq` denseIntSetSize (graphObjectEdges graph) + `seq` graphObjectVertexCount graph + `seq` graphObjectEdgeCount graph + `seq` () + +instance NFData GraphDeletionDelta where + rnf delta = + denseIntSetSize (graphDeletionVertices delta) + `seq` denseIntSetSize (graphDeletionEdges delta) + `seq` () + +instance NFData GraphMorphism where + rnf morphism = + rnf (graphMorphismSource morphism) + `seq` rnf (graphMorphismTarget morphism) + `seq` rnf (graphMorphismKnownComplement morphism) + +instance NFData GraphRewriteCase where + rnf rewriteCase = + rnf (graphRewriteCategory rewriteCase) + `seq` rnf (graphRewriteRuleLeg rewriteCase) + `seq` rnf (graphRewriteMatch rewriteCase) + +instance NFData (PushoutComplementWitness GraphCategory) where + rnf witness = + graphPushoutComplementWitnessWeight witness `seq` () + +instance NFData (PBPOComplementWitness GraphCategory) where + rnf witness = + graphPBPOComplementWitnessWeight witness `seq` () + +instance NFData PreparedGraphRewriteCase where + rnf prepared = + rnf (preparedGraphRewrite prepared) + `seq` rnf (preparedGraphComplement prepared) + `seq` rnf (preparedGraphPBPO prepared) + +instance NFData PreparedGraphRewriteBatch where + rnf prepared = + preparedGraphAmbientSize prepared + `seq` rnf (preparedGraphCases prepared) + +instance Category GraphCategory where + type Ob GraphCategory = GraphObject + type Mor GraphCategory = GraphMorphism + type TwoMor GraphCategory = GraphTwoMor + type Compositor GraphCategory = GraphCompositor + type CategoryError GraphCategory = GraphCategoryError + + identity categoryValue graph + | graphObjectCarrierId graph == graphCarrierId (graphCategoryCarrier categoryValue) = + Right (graphTrustedInclusion graph graph) + | otherwise = + Left GraphBoundaryMismatch + + compose categoryValue leftMorphism rightMorphism + | not (graphMorphismValidIn categoryValue leftMorphism) + || not (graphMorphismValidIn categoryValue rightMorphism) = + Left GraphBoundaryMismatch + | graphMorphismTarget rightMorphism /= graphMorphismSource leftMorphism = + Left GraphBoundaryMismatch + | otherwise = + Right (graphTrustedInclusion (graphMorphismSource rightMorphism) (graphMorphismTarget leftMorphism), GraphCompositor) + + source categoryValue morphism + | graphMorphismValidIn categoryValue morphism = + Right (graphMorphismSource morphism) + | otherwise = + Left GraphBoundaryMismatch + + target categoryValue morphism + | graphMorphismValidIn categoryValue morphism = + Right (graphMorphismTarget morphism) + | otherwise = + Left GraphBoundaryMismatch + +instance HasPullbacks GraphCategory where + pullback categoryValue leftMorphism rightMorphism + | graphMorphismValidIn categoryValue leftMorphism + && graphMorphismValidIn categoryValue rightMorphism + && graphMorphismTarget leftMorphism == graphMorphismTarget rightMorphism = do + pullbackObjectValue <- + graphIntersectionObject + (graphMorphismSource leftMorphism) + (graphMorphismSource rightMorphism) + pure + ( pullbackObjectValue, + graphTrustedInclusion pullbackObjectValue (graphMorphismSource leftMorphism), + graphTrustedInclusion pullbackObjectValue (graphMorphismSource rightMorphism) + ) + | otherwise = + Nothing + + pullbackMediator categoryValue leftMorphism rightMorphism coneLeft coneRight + | graphMorphismValidIn categoryValue leftMorphism + && graphMorphismValidIn categoryValue rightMorphism + && graphMorphismValidIn categoryValue coneLeft + && graphMorphismValidIn categoryValue coneRight + && graphMorphismTarget leftMorphism == graphMorphismTarget rightMorphism + && graphMorphismTarget coneLeft == graphMorphismSource leftMorphism + && graphMorphismTarget coneRight == graphMorphismSource rightMorphism + && graphMorphismSource coneLeft == graphMorphismSource coneRight = do + pullbackObjectValue <- + graphIntersectionObject + (graphMorphismSource leftMorphism) + (graphMorphismSource rightMorphism) + pure (graphTrustedInclusion (graphMorphismSource coneLeft) pullbackObjectValue) + | otherwise = + Nothing + +instance HasPushouts GraphCategory where + pushout categoryValue leftMorphism rightMorphism + | graphMorphismValidIn categoryValue leftMorphism + && graphMorphismValidIn categoryValue rightMorphism + && graphMorphismSource leftMorphism == graphMorphismSource rightMorphism = do + pushoutObjectValue <- + graphCompatibleUnion + (graphMorphismTarget leftMorphism) + (graphMorphismTarget rightMorphism) + pure + ( pushoutObjectValue, + graphTrustedInclusion (graphMorphismTarget leftMorphism) pushoutObjectValue, + graphTrustedInclusion (graphMorphismTarget rightMorphism) pushoutObjectValue + ) + | otherwise = + Nothing + +instance AdhesiveCategory GraphCategory where + monicMatchComponents categoryValue morphism + | graphMorphismValidIn categoryValue morphism = + Just (MonicMatchComponents morphism) + | otherwise = + Nothing + + pushoutComplementComponents categoryValue ruleLeg monicMatch = do + let carrier = graphCategoryCarrier categoryValue + matchArrow = monicMatchArrow monicMatch + kernelObject = graphMorphismSource ruleLeg + hostObject = graphMorphismTarget matchArrow + guard (graphMorphismValidIn categoryValue ruleLeg) + guard (graphMorphismValidIn categoryValue matchArrow) + guard (graphMorphismTarget ruleLeg == graphMorphismSource matchArrow) + guard (graphObjectCarrierId hostObject == graphCarrierId carrier) + deletionDelta <- graphMorphismDeletionDelta ruleLeg + let deletedGraphVertices = graphDeletionVertices deletionDelta + deletedGraphEdges = graphDeletionEdges deletionDelta + danglingEdges <- graphHasDanglingEdges carrier hostObject deletedGraphVertices deletedGraphEdges + guard (not danglingEdges) + complementObjectValue <- + graphObjectRemoveAfterDanglingCheck deletedGraphVertices deletedGraphEdges hostObject + pure + PushoutComplementComponents + { pushoutComplementComponentObject = complementObjectValue, + pushoutComplementComponentBorrowedLeg = graphTrustedInclusion complementObjectValue hostObject, + pushoutComplementComponentResidualLeg = graphTrustedInclusion kernelObject complementObjectValue + } + +instance PBPOAdhesiveCategory GraphCategory where + pbpoComplementComponents categoryValue ruleLeg monicMatch = do + pushoutComplementComponentsValue <- pushoutComplementComponents categoryValue ruleLeg monicMatch + let matchArrow = monicMatchArrow monicMatch + pullbackObjectValue = graphMorphismSource ruleLeg + pullbackToBorrowed = pushoutComplementComponentResidualLeg pushoutComplementComponentsValue + pullbackToMatch = ruleLeg + pushoutObjectValue = graphMorphismTarget matchArrow + pushoutFromComplement = pushoutComplementComponentBorrowedLeg pushoutComplementComponentsValue + pushoutFromMatch = matchArrow + pure + PBPOComplementComponents + { pbpoComplementComponentPullbackObject = pullbackObjectValue, + pbpoComplementComponentPullbackToBorrowed = pullbackToBorrowed, + pbpoComplementComponentPullbackToMatch = pullbackToMatch, + pbpoComplementComponentPushoutObject = pushoutObjectValue, + pbpoComplementComponentPushoutFromComplement = pushoutFromComplement, + pbpoComplementComponentPushoutFromMatch = pushoutFromMatch, + pbpoComplementComponentBorrowedLeg = pushoutComplementComponentBorrowedLeg pushoutComplementComponentsValue, + pbpoComplementComponentResidualLeg = pushoutComplementComponentResidualLeg pushoutComplementComponentsValue + } + +finiteGraphDPOBenchmarks :: Benchmark +finiteGraphDPOBenchmarks = + bgroup + "pre-matched indexed-subgraph DPO/PBPO workload" + (fmap finiteGraphDPOBenchmark [32, 128, 512]) + +finiteGraphDPOBenchmark :: Int -> Benchmark +finiteGraphDPOBenchmark ambientSize = + env (prepareGraphRewriteBatch ambientSize) $ \prepared -> + bgroup + ("ambient vertices=" <> show ambientSize <> ", cases=64") + [ bench "pullback graph intersections" (nf graphPullbackBatchWeight prepared), + bench "pushout graph unions" (nf graphPushoutBatchWeight prepared), + bench "monic match validation" (nf graphMonicBatchWeight prepared), + bench "DPO indexed witness construction shape" (nf graphPushoutComplementShapeBatchWeight prepared), + bench "DPO indexed witness full projection" (nf graphPushoutComplementBatchWeight prepared), + bench "DPO square commute checks" (nf graphPushoutComplementCommuteBatchWeight prepared), + bench "PBPO specialized witness construction shape" (nf graphPBPOComplementShapeBatchWeight prepared), + bench "PBPO specialized witness full projection" (nf graphPBPOComplementBatchWeight prepared), + bench "PBPO pullback+pushout commute checks" (nf graphPBPOCommuteBatchWeight prepared) + ] + +prepareGraphRewriteBatch :: Int -> IO PreparedGraphRewriteBatch +prepareGraphRewriteBatch ambientSize = + case traverse (preparedGraphRewriteCase ambientSize) [0 .. 63] of + Nothing -> + ioError (userError ("failed to prepare finite graph DPO benchmark for ambient size " <> show ambientSize)) + Just rewriteCases -> + let prepared = + PreparedGraphRewriteBatch + { preparedGraphAmbientSize = ambientSize, + preparedGraphCases = rewriteCases + } + in rnf prepared `seq` pure prepared + +preparedGraphRewriteCase :: Int -> Int -> Maybe PreparedGraphRewriteCase +preparedGraphRewriteCase ambientSize seed = do + rewriteCase <- graphRewriteCase ambientSize seed + complement <- graphComplementWitness rewriteCase + pbpo <- graphPBPOWitness rewriteCase + pure + PreparedGraphRewriteCase + { preparedGraphRewrite = rewriteCase, + preparedGraphComplement = complement, + preparedGraphPBPO = pbpo + } + +graphRewriteCase :: Int -> Int -> Maybe GraphRewriteCase +graphRewriteCase ambientSize seed = do + kernelVertices <- graphRangeSet normalizedSize 0 kernelCount + deletedVertices <- graphRangeSet normalizedSize kernelCount deletedCount + ambientVertices <- denseIntSetFull normalizedSize + let kernelEdgePairs = + graphPathEdgePairs (graphRangeList 0 kernelCount) + deletedEdgePairs = + graphPathEdgePairs (graphRangeList kernelCount deletedCount) + contextEdgePairs = + graphPathEdgePairs (graphRangeList (kernelCount + deletedCount) contextCount) + kernelEdgeCount = + length kernelEdgePairs + deletedEdgeCount = + length deletedEdgePairs + contextEdgeCount = + length contextEdgePairs + edgeUniverse = + kernelEdgeCount + deletedEdgeCount + contextEdgeCount + ambientEdges = + graphEdgesFromPairs (kernelEdgePairs <> deletedEdgePairs <> contextEdgePairs) + kernelEdges <- graphRangeSet edgeUniverse 0 kernelEdgeCount + deletedEdges <- graphRangeSet edgeUniverse kernelEdgeCount deletedEdgeCount + ruleVertices <- denseIntSetUnion kernelVertices deletedVertices + ruleEdges <- denseIntSetUnion kernelEdges deletedEdges + ambientEdgeIds <- denseIntSetFull edgeUniverse + ambientCarrier <- graphCarrierFromEdges graphId ambientVertices ambientEdges + kernelGraph <- graphObjectFromParts ambientCarrier kernelVertices kernelEdges + ruleGraph <- graphObjectFromParts ambientCarrier ruleVertices ruleEdges + ambientGraph <- graphObjectFromParts ambientCarrier ambientVertices ambientEdgeIds + ruleLeg <- graphSubobjectInclusion kernelGraph ruleGraph + matchArrow <- graphSubobjectInclusion ruleGraph ambientGraph + pure + GraphRewriteCase + { graphRewriteCategory = GraphCategory ambientCarrier, + graphRewriteRuleLeg = ruleLeg, + graphRewriteMatch = matchArrow + } + where + normalizedSize = + max 8 ambientSize + kernelCount = + max 2 (normalizedSize `div` 4) + deletedCount = + max 2 (normalizedSize `div` 4) + contextCount = + max 2 (normalizedSize - kernelCount - deletedCount) + graphId = + GraphId (ambientSize * 1024 + seed) + +graphCarrierFromEdges :: GraphId -> DenseIntSet -> IntMap GraphEdge -> Maybe GraphCarrier +graphCarrierFromEdges graphId vertices edges = do + let edgeUniverseSize = IntMap.size edges + edgeIds <- denseIntSetFull edgeUniverseSize + guard (IntMap.keys edges == [0 .. edgeUniverseSize - 1]) + guard (graphEdgesClosedOver vertices edges) + incidentEdges <- graphIncidentIndex (denseIntSetUniverseSize vertices) edgeUniverseSize edges + pure + GraphCarrier + { graphCarrierId = graphId, + graphCarrierVertices = vertices, + graphCarrierEdgeIds = edgeIds, + graphCarrierEdges = edges, + graphCarrierIncidentEdges = incidentEdges + } + +graphObjectFromParts :: GraphCarrier -> DenseIntSet -> DenseIntSet -> Maybe GraphObject +graphObjectFromParts carrier vertices edgeIds = do + let objectValue = + GraphObject + { graphObjectCarrierId = graphCarrierId carrier, + graphObjectVertices = vertices, + graphObjectEdges = edgeIds, + graphObjectVertexCount = denseIntSetSize vertices, + graphObjectEdgeCount = denseIntSetSize edgeIds + } + guard (denseIntSetIsSubsetOf vertices (graphCarrierVertices carrier) == Just True) + guard (denseIntSetIsSubsetOf edgeIds (graphCarrierEdgeIds carrier) == Just True) + guard (graphObjectClosed carrier objectValue) + pure objectValue + +graphRangeSet :: Int -> Int -> Int -> Maybe DenseIntSet +graphRangeSet = + denseIntSetInterval + +graphRangeList :: Int -> Int -> [Int] +graphRangeList start count = + [start .. start + count - 1] + +graphPathEdgePairs :: [Int] -> [(Int, Int)] +graphPathEdgePairs vertices = + zip vertices (drop 1 vertices) + +graphEdgesFromPairs :: [(Int, Int)] -> IntMap GraphEdge +graphEdgesFromPairs pairs = + zip [0 ..] pairs + & fmap (\(edgeId, (sourceVertex, targetVertex)) -> (edgeId, GraphEdge sourceVertex targetVertex)) + & IntMap.fromAscList + +graphIncidentIndex :: Int -> Int -> IntMap GraphEdge -> Maybe (Vector DenseIntSet) +graphIncidentIndex vertexUniverseSize edgeUniverseSize edges = + traverse + (denseIntSetFromAscList edgeUniverseSize . graphIncidentEdgeIds edges) + (Vector.generate vertexUniverseSize id) + +graphIncidentEdgeIds :: IntMap GraphEdge -> Int -> [Int] +graphIncidentEdgeIds edges vertex = + [ edgeId + | (edgeId, edge) <- IntMap.toAscList edges, + graphEdgeSource edge == vertex || graphEdgeTarget edge == vertex + ] + +graphObjectVertexSet :: GraphObject -> DenseIntSet +graphObjectVertexSet = + graphObjectVertices + +graphObjectEdgeSet :: GraphObject -> DenseIntSet +graphObjectEdgeSet = + graphObjectEdges + +graphEdgesClosedOver :: DenseIntSet -> IntMap GraphEdge -> Bool +graphEdgesClosedOver vertices edges = + edges + & IntMap.elems + & all + ( \edge -> + denseIntSetMember (graphEdgeSource edge) vertices + && denseIntSetMember (graphEdgeTarget edge) vertices + ) + +graphObjectClosed :: GraphCarrier -> GraphObject -> Bool +graphObjectClosed carrier graph = + denseIntSetFoldl' + (\closed edgeId -> closed && graphObjectContainsEdgeEndpoints carrier graph edgeId) + True + (graphObjectEdgeSet graph) + +graphObjectContainsEdgeEndpoints :: GraphCarrier -> GraphObject -> Int -> Bool +graphObjectContainsEdgeEndpoints carrier graph edgeId = + case IntMap.lookup edgeId (graphCarrierEdges carrier) of + Just edge -> + denseIntSetMember (graphEdgeSource edge) (graphObjectVertices graph) + && denseIntSetMember (graphEdgeTarget edge) (graphObjectVertices graph) + Nothing -> + False + +graphObjectInCategory :: GraphCategory -> GraphObject -> Bool +graphObjectInCategory categoryValue graph = + graphObjectCarrierId graph == graphCarrierId (graphCategoryCarrier categoryValue) + +graphMorphismValidIn :: GraphCategory -> GraphMorphism -> Bool +graphMorphismValidIn categoryValue morphism = + graphObjectInCategory categoryValue (graphMorphismSource morphism) + && graphObjectInCategory categoryValue (graphMorphismTarget morphism) + && graphMorphismIsInclusion morphism + +graphMorphismIsInclusion :: GraphMorphism -> Bool +graphMorphismIsInclusion morphism = + graphObjectCarrierId (graphMorphismSource morphism) == graphObjectCarrierId (graphMorphismTarget morphism) + +graphObjectIsSubobjectOf :: GraphObject -> GraphObject -> Bool +graphObjectIsSubobjectOf sourceGraph targetGraph = + graphObjectCarrierId sourceGraph == graphObjectCarrierId targetGraph + && denseIntSetIsSubsetOf (graphObjectVertices sourceGraph) (graphObjectVertices targetGraph) == Just True + && denseIntSetIsSubsetOf (graphObjectEdges sourceGraph) (graphObjectEdges targetGraph) == Just True + +graphSubobjectInclusion :: GraphObject -> GraphObject -> Maybe GraphMorphism +graphSubobjectInclusion sourceGraph targetGraph = do + guard (graphObjectIsSubobjectOf sourceGraph targetGraph) + deletionDelta <- graphDeletionDelta sourceGraph targetGraph + pure (graphTrustedInclusionWithDelta sourceGraph targetGraph (Just deletionDelta)) + +graphTrustedInclusion :: GraphObject -> GraphObject -> GraphMorphism +graphTrustedInclusion sourceGraph targetGraph = + graphTrustedInclusionWithDelta sourceGraph targetGraph Nothing + +graphTrustedInclusionWithDelta :: GraphObject -> GraphObject -> Maybe GraphDeletionDelta -> GraphMorphism +graphTrustedInclusionWithDelta sourceGraph targetGraph complementDelta = + GraphMorphism + { graphMorphismSource = sourceGraph, + graphMorphismTarget = targetGraph, + graphMorphismKnownComplement = complementDelta + } + +graphMorphismDeletionDelta :: GraphMorphism -> Maybe GraphDeletionDelta +graphMorphismDeletionDelta morphism = + case graphMorphismKnownComplement morphism of + Just deletionDelta -> + Just deletionDelta + Nothing -> + graphDeletionDelta (graphMorphismSource morphism) (graphMorphismTarget morphism) + +graphDeletionDelta :: GraphObject -> GraphObject -> Maybe GraphDeletionDelta +graphDeletionDelta sourceGraph targetGraph = do + deletedVertices <- denseIntSetDifference (graphObjectVertexSet targetGraph) (graphObjectVertexSet sourceGraph) + deletedEdges <- denseIntSetDifference (graphObjectEdgeSet targetGraph) (graphObjectEdgeSet sourceGraph) + pure + GraphDeletionDelta + { graphDeletionVertices = deletedVertices, + graphDeletionEdges = deletedEdges + } + +graphIntersectionObject :: GraphObject -> GraphObject -> Maybe GraphObject +graphIntersectionObject leftGraph rightGraph = do + guard (graphObjectCarrierId leftGraph == graphObjectCarrierId rightGraph) + intersectionVertices <- denseIntSetIntersection (graphObjectVertexSet leftGraph) (graphObjectVertexSet rightGraph) + intersectionEdges <- denseIntSetIntersection (graphObjectEdgeSet leftGraph) (graphObjectEdgeSet rightGraph) + pure + GraphObject + { graphObjectCarrierId = graphObjectCarrierId leftGraph, + graphObjectVertices = intersectionVertices, + graphObjectEdges = intersectionEdges, + graphObjectVertexCount = denseIntSetSize intersectionVertices, + graphObjectEdgeCount = denseIntSetSize intersectionEdges + } + +graphCompatibleUnion :: GraphObject -> GraphObject -> Maybe GraphObject +graphCompatibleUnion leftGraph rightGraph = do + guard (graphObjectCarrierId leftGraph == graphObjectCarrierId rightGraph) + unionVertices <- denseIntSetUnion (graphObjectVertexSet leftGraph) (graphObjectVertexSet rightGraph) + unionEdges <- denseIntSetUnion (graphObjectEdgeSet leftGraph) (graphObjectEdgeSet rightGraph) + pure + GraphObject + { graphObjectCarrierId = graphObjectCarrierId leftGraph, + graphObjectVertices = unionVertices, + graphObjectEdges = unionEdges, + graphObjectVertexCount = denseIntSetSize unionVertices, + graphObjectEdgeCount = denseIntSetSize unionEdges + } + +graphObjectRemoveAfterDanglingCheck :: DenseIntSet -> DenseIntSet -> GraphObject -> Maybe GraphObject +graphObjectRemoveAfterDanglingCheck deletedVertices deletedEdges graph = + do + remainingVertices <- denseIntSetDifference (graphObjectVertices graph) deletedVertices + remainingEdges <- denseIntSetDifference (graphObjectEdges graph) deletedEdges + pure + GraphObject + { graphObjectCarrierId = graphObjectCarrierId graph, + graphObjectVertices = remainingVertices, + graphObjectEdges = remainingEdges, + graphObjectVertexCount = denseIntSetSize remainingVertices, + graphObjectEdgeCount = denseIntSetSize remainingEdges + } + +graphHasDanglingEdges :: GraphCarrier -> GraphObject -> DenseIntSet -> DenseIntSet -> Maybe Bool +graphHasDanglingEdges carrier hostGraph deletedVertices deletedEdges = + do + hostEdgesAfterDeletion <- denseIntSetDifference (graphObjectEdges hostGraph) deletedEdges + denseIntSetFoldl' (detectDanglingEdge hostEdgesAfterDeletion) (Just False) deletedVertices + where + detectDanglingEdge hostEdgesAfterDeletion danglingFound vertex = + case danglingFound of + Nothing -> + Nothing + Just True -> + Just True + Just False -> + vertexHasDanglingEdge hostEdgesAfterDeletion vertex + + vertexHasDanglingEdge hostEdgesAfterDeletion vertex = + case graphCarrierIncidentEdges carrier Vector.!? vertex of + Nothing -> + Nothing + Just incidentEdges -> + denseIntSetIntersects hostEdgesAfterDeletion incidentEdges + +graphPullbackBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPullbackBatchWeight = + graphBatchWeight graphPullbackWeight + +graphPushoutBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPushoutBatchWeight = + graphBatchWeight graphPushoutWeight + +graphMonicBatchWeight :: PreparedGraphRewriteBatch -> Int +graphMonicBatchWeight = + graphBatchWeight graphMonicWeight + +graphPushoutComplementBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPushoutComplementBatchWeight = + graphBatchWeight graphPushoutComplementWeight + +graphPushoutComplementShapeBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPushoutComplementShapeBatchWeight = + graphBatchWeight graphPushoutComplementShapeWeight + +graphPushoutComplementCommuteBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPushoutComplementCommuteBatchWeight = + graphBatchWeight graphPushoutComplementCommuteWeight + +graphPBPOComplementBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPBPOComplementBatchWeight = + graphBatchWeight graphPBPOComplementWeight + +graphPBPOComplementShapeBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPBPOComplementShapeBatchWeight = + graphBatchWeight graphPBPOComplementShapeWeight + +graphPBPOCommuteBatchWeight :: PreparedGraphRewriteBatch -> Int +graphPBPOCommuteBatchWeight = + graphBatchWeight graphPBPOCommuteWeight + +graphBatchWeight :: (PreparedGraphRewriteCase -> Int) -> PreparedGraphRewriteBatch -> Int +graphBatchWeight weight prepared = + preparedGraphCases prepared + & fmap weight + & sum + +graphPullbackWeight :: PreparedGraphRewriteCase -> Int +graphPullbackWeight prepared = + maybe + 0 + graphPullbackTripleWeight + (pullback (graphPreparedCategory prepared) (pushoutComplementBorrowedLeg (preparedGraphComplement prepared)) (graphRewriteMatch (preparedGraphRewrite prepared))) + +graphPushoutWeight :: PreparedGraphRewriteCase -> Int +graphPushoutWeight prepared = + maybe + 0 + graphPushoutTripleWeight + (pushout (graphPreparedCategory prepared) (pushoutComplementResidualLeg (preparedGraphComplement prepared)) (graphRewriteRuleLeg (preparedGraphRewrite prepared))) + +graphMonicWeight :: PreparedGraphRewriteCase -> Int +graphMonicWeight prepared = + let rewriteCase = preparedGraphRewrite prepared + in maybe 0 (graphMorphismWeight . monicMatchArrow) (witnessMonic (graphRewriteCategory rewriteCase) (graphRewriteMatch rewriteCase)) + +graphPushoutComplementWeight :: PreparedGraphRewriteCase -> Int +graphPushoutComplementWeight prepared = + let rewriteCase = preparedGraphRewrite prepared + in maybe 0 graphPushoutComplementWitnessWeight (graphComplementWitness rewriteCase) + +graphPushoutComplementShapeWeight :: PreparedGraphRewriteCase -> Int +graphPushoutComplementShapeWeight prepared = + let rewriteCase = preparedGraphRewrite prepared + in maybe 0 graphPushoutComplementWitnessShapeWeight (graphComplementWitness rewriteCase) + +graphPushoutComplementCommuteWeight :: PreparedGraphRewriteCase -> Int +graphPushoutComplementCommuteWeight prepared = + boolWeight (pushoutComplementSquareCommutes (graphPreparedCategory prepared) (preparedGraphComplement prepared)) + +graphPBPOComplementWeight :: PreparedGraphRewriteCase -> Int +graphPBPOComplementWeight prepared = + let rewriteCase = preparedGraphRewrite prepared + in maybe 0 graphPBPOComplementWitnessWeight (graphPBPOWitness rewriteCase) + +graphPBPOComplementShapeWeight :: PreparedGraphRewriteCase -> Int +graphPBPOComplementShapeWeight prepared = + let rewriteCase = preparedGraphRewrite prepared + in maybe 0 graphPBPOComplementWitnessShapeWeight (graphPBPOWitness rewriteCase) + +graphPBPOCommuteWeight :: PreparedGraphRewriteCase -> Int +graphPBPOCommuteWeight prepared = + let witness = preparedGraphPBPO prepared + categoryValue = graphPreparedCategory prepared + in boolWeight (pbpoPullbackSquareCommutes categoryValue witness) + + boolWeight (pbpoPushoutSquareCommutes categoryValue witness) + +graphPreparedCategory :: PreparedGraphRewriteCase -> GraphCategory +graphPreparedCategory = + graphRewriteCategory . preparedGraphRewrite + +graphComplementWitness :: GraphRewriteCase -> Maybe (PushoutComplementWitness GraphCategory) +graphComplementWitness rewriteCase = do + monicWitness <- witnessMonic (graphRewriteCategory rewriteCase) (graphRewriteMatch rewriteCase) + pushoutComplement (graphRewriteCategory rewriteCase) (graphRewriteRuleLeg rewriteCase) monicWitness + +graphPBPOWitness :: GraphRewriteCase -> Maybe (PBPOComplementWitness GraphCategory) +graphPBPOWitness rewriteCase = do + monicWitness <- witnessMonic (graphRewriteCategory rewriteCase) (graphRewriteMatch rewriteCase) + pbpoComplement (graphRewriteCategory rewriteCase) (graphRewriteRuleLeg rewriteCase) monicWitness + +graphPullbackTripleWeight :: (GraphObject, GraphMorphism, GraphMorphism) -> Int +graphPullbackTripleWeight (objectValue, leftLeg, rightLeg) = + graphObjectWeight objectValue + + graphMorphismWeight leftLeg + + graphMorphismWeight rightLeg + +graphPushoutTripleWeight :: (GraphObject, GraphMorphism, GraphMorphism) -> Int +graphPushoutTripleWeight = + graphPullbackTripleWeight + +graphPushoutComplementWitnessWeight :: PushoutComplementWitness GraphCategory -> Int +graphPushoutComplementWitnessWeight witness = + graphObjectWeight (pushoutComplementObject witness) + + graphMorphismWeight (pushoutComplementBorrowedLeg witness) + + graphMorphismWeight (pushoutComplementResidualLeg witness) + +graphPushoutComplementWitnessShapeWeight :: PushoutComplementWitness GraphCategory -> Int +graphPushoutComplementWitnessShapeWeight witness = + graphObjectShapeWeight (pushoutComplementObject witness) + + graphMorphismShapeWeight (pushoutComplementBorrowedLeg witness) + + graphMorphismShapeWeight (pushoutComplementResidualLeg witness) + +graphPBPOComplementWitnessWeight :: PBPOComplementWitness GraphCategory -> Int +graphPBPOComplementWitnessWeight witness = + graphObjectWeight (pbpoComplementPullbackObject witness) + + graphMorphismWeight (pbpoComplementPullbackToBorrowed witness) + + graphMorphismWeight (pbpoComplementPullbackToMatch witness) + + graphObjectWeight (pbpoComplementPushoutObject witness) + + graphMorphismWeight (pbpoComplementPushoutFromComplement witness) + + graphMorphismWeight (pbpoComplementPushoutFromMatch witness) + + graphMorphismWeight (pbpoComplementBorrowedLeg witness) + + graphMorphismWeight (pbpoComplementResidualLeg witness) + +graphPBPOComplementWitnessShapeWeight :: PBPOComplementWitness GraphCategory -> Int +graphPBPOComplementWitnessShapeWeight witness = + graphObjectShapeWeight (pbpoComplementPullbackObject witness) + + graphMorphismShapeWeight (pbpoComplementPullbackToBorrowed witness) + + graphMorphismShapeWeight (pbpoComplementPullbackToMatch witness) + + graphObjectShapeWeight (pbpoComplementPushoutObject witness) + + graphMorphismShapeWeight (pbpoComplementPushoutFromComplement witness) + + graphMorphismShapeWeight (pbpoComplementPushoutFromMatch witness) + + graphMorphismShapeWeight (pbpoComplementBorrowedLeg witness) + + graphMorphismShapeWeight (pbpoComplementResidualLeg witness) + +graphObjectShapeWeight :: GraphObject -> Int +graphObjectShapeWeight graph = + graphIdWeight (graphObjectCarrierId graph) + + graphObjectVertexCount graph + + graphObjectEdgeCount graph + +graphMorphismShapeWeight :: GraphMorphism -> Int +graphMorphismShapeWeight morphism = + graphObjectShapeWeight (graphMorphismSource morphism) + + graphObjectShapeWeight (graphMorphismTarget morphism) + +graphObjectWeight :: GraphObject -> Int +graphObjectWeight graph = + graphIdWeight (graphObjectCarrierId graph) + + denseIntSetWeight (graphObjectVertexSet graph) + + denseIntSetWeight (graphObjectEdgeSet graph) + +graphMorphismWeight :: GraphMorphism -> Int +graphMorphismWeight morphism = + graphObjectWeight (graphMorphismSource morphism) + + graphObjectWeight (graphMorphismTarget morphism) + +graphIdWeight :: GraphId -> Int +graphIdWeight = + unGraphId diff --git a/bench/abstract/Adhesive/Subset.hs b/bench/abstract/Adhesive/Subset.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Adhesive/Subset.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} + +module Adhesive.Subset + ( finiteSubsetDPOBenchmarks, + ) +where + +import BenchSupport (boolWeight) +import Control.DeepSeq (NFData (..)) +import Data.Function ((&)) +import Data.List qualified as List +import Moonlight.Category.Pure.Adhesive + ( AdhesiveCategory (..), + DenseIntSet, + MonicMatchComponents (..), + PBPOAdhesiveCategory, + PBPOComplementWitness, + PushoutComplementWitness, + PushoutComplementComponents (..), + denseIntSetDifference, + denseIntSetFromAscList, + denseIntSetIntersection, + denseIntSetIsSubsetOf, + denseIntSetSize, + denseIntSetUnion, + denseIntSetWeight, + monicMatchArrow, + pbpoComplement, + pbpoComplementBorrowedLeg, + pbpoComplementPullbackObject, + pbpoComplementPullbackToBorrowed, + pbpoComplementPullbackToMatch, + pbpoComplementPushoutFromComplement, + pbpoComplementPushoutFromMatch, + pbpoComplementPushoutObject, + pbpoComplementResidualLeg, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pushoutComplement, + pushoutComplementBorrowedLeg, + pushoutComplementObject, + pushoutComplementResidualLeg, + pushoutComplementSquareCommutes, + witnessMonic, + ) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Limits (HasPullbacks (..), HasPushouts (..), pullback, pushout) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +data SubsetCategory = SubsetCategory + +data SubsetTwoMor + +data SubsetCompositor = SubsetCompositor + +newtype SubsetObject = SubsetObject + { subsetObjectElements :: DenseIntSet + } + deriving stock (Eq, Ord, Show) + +data SubsetMorphism = SubsetMorphism + { subsetMorphismSource :: !SubsetObject, + subsetMorphismTarget :: !SubsetObject + } + deriving stock (Eq, Ord, Show) + +data SubsetRewriteCase = SubsetRewriteCase + { subsetRewriteRuleLeg :: !SubsetMorphism, + subsetRewriteMatch :: !SubsetMorphism + } + deriving stock (Eq, Ord, Show) + +data PreparedSubsetRewriteBatch = PreparedSubsetRewriteBatch + { preparedSubsetObjectSize :: !Int, + preparedSubsetCases :: ![SubsetRewriteCase] + } + deriving stock (Eq, Show) + +instance NFData SubsetObject where + rnf (SubsetObject elements) = + denseIntSetSize elements `seq` () + +instance NFData SubsetMorphism where + rnf morphism = + rnf (subsetMorphismSource morphism) + `seq` rnf (subsetMorphismTarget morphism) + +instance NFData SubsetRewriteCase where + rnf rewriteCase = + rnf (subsetRewriteRuleLeg rewriteCase) + `seq` rnf (subsetRewriteMatch rewriteCase) + +instance NFData PreparedSubsetRewriteBatch where + rnf prepared = + preparedSubsetObjectSize prepared + `seq` rnf (preparedSubsetCases prepared) + +instance Category SubsetCategory where + type Ob SubsetCategory = SubsetObject + type Mor SubsetCategory = SubsetMorphism + type TwoMor SubsetCategory = SubsetTwoMor + type Compositor SubsetCategory = SubsetCompositor + + identity _ objectValue = + Right (SubsetMorphism objectValue objectValue) + + compose _ leftMorphism rightMorphism + | subsetMorphismTarget rightMorphism == subsetMorphismSource leftMorphism = + Right + ( SubsetMorphism + (subsetMorphismSource rightMorphism) + (subsetMorphismTarget leftMorphism), + SubsetCompositor + ) + | otherwise = + Left () + + source _ = + Right . subsetMorphismSource + + target _ = + Right . subsetMorphismTarget + +instance HasPullbacks SubsetCategory where + pullback _ leftMorphism rightMorphism + | subsetMorphismTarget leftMorphism == subsetMorphismTarget rightMorphism = do + pullbackElements <- + denseIntSetIntersection + (subsetObjectElements (subsetMorphismSource leftMorphism)) + (subsetObjectElements (subsetMorphismSource rightMorphism)) + let pullbackObjectValue = SubsetObject pullbackElements + pure + ( pullbackObjectValue, + SubsetMorphism pullbackObjectValue (subsetMorphismSource leftMorphism), + SubsetMorphism pullbackObjectValue (subsetMorphismSource rightMorphism) + ) + | otherwise = + Nothing + + pullbackMediator _ leftMorphism rightMorphism coneLeft coneRight + | subsetMorphismTarget leftMorphism == subsetMorphismTarget rightMorphism + && subsetMorphismTarget coneLeft == subsetMorphismSource leftMorphism + && subsetMorphismTarget coneRight == subsetMorphismSource rightMorphism + && subsetMorphismSource coneLeft == subsetMorphismSource coneRight = do + pullbackElements <- + denseIntSetIntersection + (subsetObjectElements (subsetMorphismSource leftMorphism)) + (subsetObjectElements (subsetMorphismSource rightMorphism)) + sourceContained <- + denseIntSetIsSubsetOf + (subsetObjectElements (subsetMorphismSource coneLeft)) + pullbackElements + if sourceContained + then Just (SubsetMorphism (subsetMorphismSource coneLeft) (SubsetObject pullbackElements)) + else Nothing + | otherwise = + Nothing + +instance HasPushouts SubsetCategory where + pushout _ leftMorphism rightMorphism + | subsetMorphismSource leftMorphism == subsetMorphismSource rightMorphism = do + pushoutElements <- + denseIntSetUnion + (subsetObjectElements (subsetMorphismTarget leftMorphism)) + (subsetObjectElements (subsetMorphismTarget rightMorphism)) + let pushoutObjectValue = SubsetObject pushoutElements + pure + ( pushoutObjectValue, + SubsetMorphism (subsetMorphismTarget leftMorphism) pushoutObjectValue, + SubsetMorphism (subsetMorphismTarget rightMorphism) pushoutObjectValue + ) + | otherwise = + Nothing + +instance AdhesiveCategory SubsetCategory where + monicMatchComponents _ morphism + | subsetMorphismIsInclusion morphism = + Just (MonicMatchComponents morphism) + | otherwise = + Nothing + + pushoutComplementComponents _ ruleLeg monicMatch + | subsetMorphismIsInclusion ruleLeg + && subsetMorphismIsInclusion matchArrow + && subsetMorphismTarget ruleLeg == subsetMorphismSource matchArrow = do + let kernelObject = subsetMorphismSource ruleLeg + ruleObject = subsetMorphismTarget ruleLeg + ambientObject = subsetMorphismTarget matchArrow + ambientRemainder <- denseIntSetDifference (subsetObjectElements ambientObject) (subsetObjectElements ruleObject) + complementElements <- denseIntSetUnion (subsetObjectElements kernelObject) ambientRemainder + let complementObject = SubsetObject complementElements + pure + PushoutComplementComponents + { pushoutComplementComponentObject = complementObject, + pushoutComplementComponentBorrowedLeg = SubsetMorphism complementObject ambientObject, + pushoutComplementComponentResidualLeg = SubsetMorphism kernelObject complementObject + } + | otherwise = + Nothing + where + matchArrow = + monicMatchArrow monicMatch + +instance PBPOAdhesiveCategory SubsetCategory + +finiteSubsetDPOBenchmarks :: Benchmark +finiteSubsetDPOBenchmarks = + bgroup + "finite-subset DPO/PBPO size curves" + (fmap finiteSubsetDPOBenchmark [32, 128, 512]) + +finiteSubsetDPOBenchmark :: Int -> Benchmark +finiteSubsetDPOBenchmark objectSize = + env (prepareSubsetRewriteBatch objectSize) $ \prepared -> + bgroup + ("ambient=" <> show objectSize <> ", cases=64") + [ bench "pullback intersection witnesses" (nf subsetPullbackBatchWeight prepared), + bench "pushout union witnesses" (nf subsetPushoutBatchWeight prepared), + bench "DPO pushoutComplement witnesses" (nf subsetPushoutComplementBatchWeight prepared), + bench "DPO square commute checks" (nf subsetPushoutComplementCommuteBatchWeight prepared), + bench "PBPO default complement witnesses" (nf subsetPBPOComplementBatchWeight prepared), + bench "PBPO pullback+pushout commute checks" (nf subsetPBPOCommuteBatchWeight prepared) + ] + +prepareSubsetRewriteBatch :: Int -> IO PreparedSubsetRewriteBatch +prepareSubsetRewriteBatch objectSize = + case traverse (subsetRewriteCase objectSize) [0 .. 63] of + Nothing -> + ioError (userError ("failed to prepare finite subset DPO benchmark for ambient size " <> show objectSize)) + Just rewriteCases -> + let prepared = + PreparedSubsetRewriteBatch + { preparedSubsetObjectSize = objectSize, + preparedSubsetCases = rewriteCases + } + in rnf prepared `seq` pure prepared + +subsetRewriteCase :: Int -> Int -> Maybe SubsetRewriteCase +subsetRewriteCase objectSize seed = do + kernelObject <- subsetIntervalObject normalizedSize offset 0 kernelSize + deletedObject <- subsetIntervalObject normalizedSize offset kernelSize deletedSize + retainedObject <- subsetIntervalObject normalizedSize offset (kernelSize + deletedSize) retainedSize + ruleObject <- subsetObjectUnion kernelObject deletedObject + ambientObject <- subsetObjectUnion ruleObject retainedObject + pure + SubsetRewriteCase + { subsetRewriteRuleLeg = SubsetMorphism kernelObject ruleObject, + subsetRewriteMatch = SubsetMorphism ruleObject ambientObject + } + where + normalizedSize = + max 4 objectSize + kernelSize = + normalizedSize `div` 4 + deletedSize = + normalizedSize `div` 4 + retainedSize = + normalizedSize - kernelSize - deletedSize + offset = + (seed * 7) `mod` normalizedSize + +subsetIntervalObject :: Int -> Int -> Int -> Int -> Maybe SubsetObject +subsetIntervalObject universeSize offset start count = + SubsetObject <$> denseIntSetFromAscList universeSize values + where + values = + List.sort (fmap (\value -> (offset + value) `mod` universeSize) [start .. start + count - 1]) + +subsetObjectUnion :: SubsetObject -> SubsetObject -> Maybe SubsetObject +subsetObjectUnion leftObject rightObject = + SubsetObject <$> denseIntSetUnion (subsetObjectElements leftObject) (subsetObjectElements rightObject) + +subsetMorphismIsInclusion :: SubsetMorphism -> Bool +subsetMorphismIsInclusion morphism = + denseIntSetIsSubsetOf + (subsetObjectElements (subsetMorphismSource morphism)) + (subsetObjectElements (subsetMorphismTarget morphism)) + == Just True + +subsetPullbackBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPullbackBatchWeight prepared = + subsetBatchWeight subsetPullbackWeight prepared + +subsetPushoutBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPushoutBatchWeight prepared = + subsetBatchWeight subsetPushoutWeight prepared + +subsetPushoutComplementBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPushoutComplementBatchWeight prepared = + subsetBatchWeight subsetPushoutComplementWeight prepared + +subsetPushoutComplementCommuteBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPushoutComplementCommuteBatchWeight prepared = + subsetBatchWeight subsetPushoutComplementCommuteWeight prepared + +subsetPBPOComplementBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPBPOComplementBatchWeight prepared = + subsetBatchWeight subsetPBPOComplementWeight prepared + +subsetPBPOCommuteBatchWeight :: PreparedSubsetRewriteBatch -> Int +subsetPBPOCommuteBatchWeight prepared = + subsetBatchWeight subsetPBPOCommuteWeight prepared + +subsetBatchWeight :: (SubsetRewriteCase -> Int) -> PreparedSubsetRewriteBatch -> Int +subsetBatchWeight weight prepared = + preparedSubsetCases prepared + & fmap weight + & sum + +subsetPullbackWeight :: SubsetRewriteCase -> Int +subsetPullbackWeight rewriteCase = + case complementWitness rewriteCase of + Nothing -> 0 + Just witness -> + maybe + 0 + subsetPullbackTripleWeight + (pullback SubsetCategory (pushoutComplementBorrowedLeg witness) (subsetRewriteMatch rewriteCase)) + +subsetPushoutWeight :: SubsetRewriteCase -> Int +subsetPushoutWeight rewriteCase = + case complementWitness rewriteCase of + Nothing -> 0 + Just witness -> + maybe + 0 + subsetPushoutTripleWeight + (pushout SubsetCategory (pushoutComplementResidualLeg witness) (subsetRewriteRuleLeg rewriteCase)) + +subsetPushoutComplementWeight :: SubsetRewriteCase -> Int +subsetPushoutComplementWeight rewriteCase = + maybe 0 subsetPushoutComplementWitnessWeight (complementWitness rewriteCase) + +subsetPushoutComplementCommuteWeight :: SubsetRewriteCase -> Int +subsetPushoutComplementCommuteWeight rewriteCase = + maybe 0 (boolWeight . pushoutComplementSquareCommutes SubsetCategory) (complementWitness rewriteCase) + +subsetPBPOComplementWeight :: SubsetRewriteCase -> Int +subsetPBPOComplementWeight rewriteCase = + maybe 0 subsetPBPOComplementWitnessWeight (pbpoWitness rewriteCase) + +subsetPBPOCommuteWeight :: SubsetRewriteCase -> Int +subsetPBPOCommuteWeight rewriteCase = + maybe + 0 + ( \witness -> + boolWeight (pbpoPullbackSquareCommutes SubsetCategory witness) + + boolWeight (pbpoPushoutSquareCommutes SubsetCategory witness) + ) + (pbpoWitness rewriteCase) + +complementWitness :: SubsetRewriteCase -> Maybe (PushoutComplementWitness SubsetCategory) +complementWitness rewriteCase = do + monicWitness <- witnessMonic SubsetCategory (subsetRewriteMatch rewriteCase) + pushoutComplement SubsetCategory (subsetRewriteRuleLeg rewriteCase) monicWitness + +pbpoWitness :: SubsetRewriteCase -> Maybe (PBPOComplementWitness SubsetCategory) +pbpoWitness rewriteCase = do + monicWitness <- witnessMonic SubsetCategory (subsetRewriteMatch rewriteCase) + pbpoComplement SubsetCategory (subsetRewriteRuleLeg rewriteCase) monicWitness + +subsetPullbackTripleWeight :: (SubsetObject, SubsetMorphism, SubsetMorphism) -> Int +subsetPullbackTripleWeight (objectValue, leftLeg, rightLeg) = + subsetObjectWeight objectValue + + subsetMorphismWeight leftLeg + + subsetMorphismWeight rightLeg + +subsetPushoutTripleWeight :: (SubsetObject, SubsetMorphism, SubsetMorphism) -> Int +subsetPushoutTripleWeight = + subsetPullbackTripleWeight + +subsetPushoutComplementWitnessWeight :: PushoutComplementWitness SubsetCategory -> Int +subsetPushoutComplementWitnessWeight witness = + subsetObjectWeight (pushoutComplementObject witness) + + subsetMorphismWeight (pushoutComplementBorrowedLeg witness) + + subsetMorphismWeight (pushoutComplementResidualLeg witness) + +subsetPBPOComplementWitnessWeight :: PBPOComplementWitness SubsetCategory -> Int +subsetPBPOComplementWitnessWeight witness = + subsetObjectWeight (pbpoComplementPullbackObject witness) + + subsetMorphismWeight (pbpoComplementPullbackToBorrowed witness) + + subsetMorphismWeight (pbpoComplementPullbackToMatch witness) + + subsetObjectWeight (pbpoComplementPushoutObject witness) + + subsetMorphismWeight (pbpoComplementPushoutFromComplement witness) + + subsetMorphismWeight (pbpoComplementPushoutFromMatch witness) + + subsetMorphismWeight (pbpoComplementBorrowedLeg witness) + + subsetMorphismWeight (pbpoComplementResidualLeg witness) + +subsetObjectWeight :: SubsetObject -> Int +subsetObjectWeight (SubsetObject elements) = + denseIntSetSize elements + denseIntSetWeight elements + +subsetMorphismWeight :: SubsetMorphism -> Int +subsetMorphismWeight morphism = + subsetObjectWeight (subsetMorphismSource morphism) + + subsetObjectWeight (subsetMorphismTarget morphism) diff --git a/bench/abstract/Adhesive/Suite.hs b/bench/abstract/Adhesive/Suite.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Adhesive/Suite.hs @@ -0,0 +1,18 @@ +module Adhesive.Suite + ( adhesiveBenchmarks, + ) +where + +import Adhesive.Graph (finiteGraphDPOBenchmarks) +import Adhesive.Subset (finiteSubsetDPOBenchmarks) +import Adhesive.Symbolic (symbolicFixtureBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +adhesiveBenchmarks :: Benchmark +adhesiveBenchmarks = + bgroup + "limits / adhesive / PBPO witnesses" + [ symbolicFixtureBenchmarks, + finiteGraphDPOBenchmarks, + finiteSubsetDPOBenchmarks + ] diff --git a/bench/abstract/Adhesive/Symbolic.hs b/bench/abstract/Adhesive/Symbolic.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Adhesive/Symbolic.hs @@ -0,0 +1,150 @@ +module Adhesive.Symbolic + ( symbolicFixtureBenchmarks, + ) +where + +import AbstractFixtures + ( BenchCategory (..), + BenchMorphism (..), + benchLeftCospanLeg, + benchMorphism, + benchMorphismWeight, + benchMonicMatch, + benchObjectWeight, + benchRuleLeg, + ) +import BenchSupport (batchWeight, boolWeight, sampleBatch512) +import Moonlight.Category.Pure.Adhesive + ( PBPOComplementWitness, + PushoutComplementWitness, + monicMatchArrow, + pbpoComplement, + pbpoComplementBorrowedLeg, + pbpoComplementPullbackObject, + pbpoComplementPullbackToBorrowed, + pbpoComplementPullbackToMatch, + pbpoComplementPushoutFromComplement, + pbpoComplementPushoutFromMatch, + pbpoComplementPushoutObject, + pbpoComplementResidualLeg, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pushoutComplement, + pushoutComplementBorrowedLeg, + pushoutComplementObject, + pushoutComplementResidualLeg, + pushoutComplementSquareCommutes, + witnessMonic, + ) +import Moonlight.Category.Pure.Limits (pullback, pullbackMediator, pushout) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +symbolicFixtureBenchmarks :: Benchmark +symbolicFixtureBenchmarks = + bgroup + "symbolic constant fixture" + [ symbolicLimitBenchmarks, + symbolicAdhesiveBenchmarks, + symbolicPBPObenchmarks + ] + +symbolicLimitBenchmarks :: Benchmark +symbolicLimitBenchmarks = + bgroup + "limits" + [ bench "pullback witness batch x512" (nf (batchWeight pullbackWeight) sampleBatch512), + bench "pullback mediator batch x512" (nf (batchWeight pullbackMediatorWeight) sampleBatch512), + bench "pushout witness batch x512" (nf (batchWeight pushoutWeight) sampleBatch512) + ] + +symbolicAdhesiveBenchmarks :: Benchmark +symbolicAdhesiveBenchmarks = + bgroup + "adhesive" + [ bench "witnessMonic batch x512" (nf (batchWeight monicWitnessWeight) sampleBatch512), + bench "pushoutComplement witness batch x512" (nf (batchWeight pushoutComplementWeight) sampleBatch512), + bench "pushoutComplement square commute check batch x512" (nf (batchWeight pushoutComplementCommuteWeight) sampleBatch512) + ] + +symbolicPBPObenchmarks :: Benchmark +symbolicPBPObenchmarks = + bgroup + "PBPO" + [ bench "pbpoComplement witness batch x512" (nf (batchWeight pbpoComplementWeight) sampleBatch512), + bench "pbpo pullback square commute check batch x512" (nf (batchWeight pbpoPullbackCommuteWeight) sampleBatch512), + bench "pbpo pushout square commute check batch x512" (nf (batchWeight pbpoPushoutCommuteWeight) sampleBatch512) + ] + +pullbackWeight :: Int -> Int +pullbackWeight seed = + seed + maybe 0 pullbackTripleWeight (pullback BenchCategory benchMonicMatch borrowedLeg) + +pullbackMediatorWeight :: Int -> Int +pullbackMediatorWeight seed = + seed + maybe 0 benchMorphismWeight (pullbackMediator BenchCategory benchMonicMatch borrowedLeg benchRuleLeg benchLeftCospanLeg) + +pushoutWeight :: Int -> Int +pushoutWeight seed = + seed + maybe 0 pushoutTripleWeight (pushout BenchCategory benchRuleLeg benchLeftCospanLeg) + +monicWitnessWeight :: Int -> Int +monicWitnessWeight seed = + seed + maybe 0 (benchMorphismWeight . monicMatchArrow) (witnessMonic BenchCategory benchMonicMatch) + +pushoutComplementWeight :: Int -> Int +pushoutComplementWeight seed = + seed + maybe 0 pushoutComplementWitnessWeight pushoutComplementWitnessValue + +pushoutComplementCommuteWeight :: Int -> Int +pushoutComplementCommuteWeight seed = + seed + maybe 0 (boolWeight . pushoutComplementSquareCommutes BenchCategory) pushoutComplementWitnessValue + +pbpoComplementWeight :: Int -> Int +pbpoComplementWeight seed = + seed + maybe 0 pbpoComplementWitnessWeight pbpoComplementWitnessValue + +pbpoPullbackCommuteWeight :: Int -> Int +pbpoPullbackCommuteWeight seed = + seed + maybe 0 (boolWeight . pbpoPullbackSquareCommutes BenchCategory) pbpoComplementWitnessValue + +pbpoPushoutCommuteWeight :: Int -> Int +pbpoPushoutCommuteWeight seed = + seed + maybe 0 (boolWeight . pbpoPushoutSquareCommutes BenchCategory) pbpoComplementWitnessValue + +borrowedLeg :: BenchMorphism +borrowedLeg = benchMorphism (benchMorphismTarget benchLeftCospanLeg) (benchMorphismTarget benchMonicMatch) + +pushoutComplementWitnessValue :: Maybe (PushoutComplementWitness BenchCategory) +pushoutComplementWitnessValue = do + monicWitness <- witnessMonic BenchCategory benchMonicMatch + pushoutComplement BenchCategory benchRuleLeg monicWitness + +pbpoComplementWitnessValue :: Maybe (PBPOComplementWitness BenchCategory) +pbpoComplementWitnessValue = do + monicWitness <- witnessMonic BenchCategory benchMonicMatch + pbpoComplement BenchCategory benchRuleLeg monicWitness + +pullbackTripleWeight :: (a, BenchMorphism, BenchMorphism) -> Int +pullbackTripleWeight (_, leftLeg, rightLeg) = + benchMorphismWeight leftLeg + benchMorphismWeight rightLeg + +pushoutTripleWeight :: (a, BenchMorphism, BenchMorphism) -> Int +pushoutTripleWeight (_, leftLeg, rightLeg) = + benchMorphismWeight leftLeg + benchMorphismWeight rightLeg + +pushoutComplementWitnessWeight :: PushoutComplementWitness BenchCategory -> Int +pushoutComplementWitnessWeight witness = + benchObjectWeight (pushoutComplementObject witness) + + benchMorphismWeight (pushoutComplementBorrowedLeg witness) + + benchMorphismWeight (pushoutComplementResidualLeg witness) + +pbpoComplementWitnessWeight :: PBPOComplementWitness BenchCategory -> Int +pbpoComplementWitnessWeight witness = + benchObjectWeight (pbpoComplementPullbackObject witness) + + benchMorphismWeight (pbpoComplementPullbackToBorrowed witness) + + benchMorphismWeight (pbpoComplementPullbackToMatch witness) + + benchObjectWeight (pbpoComplementPushoutObject witness) + + benchMorphismWeight (pbpoComplementPushoutFromComplement witness) + + benchMorphismWeight (pbpoComplementPushoutFromMatch witness) + + benchMorphismWeight (pbpoComplementBorrowedLeg witness) + + benchMorphismWeight (pbpoComplementResidualLeg witness) diff --git a/bench/abstract/Algebraic/Decorated.hs b/bench/abstract/Algebraic/Decorated.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/Decorated.hs @@ -0,0 +1,131 @@ +module Algebraic.Decorated + ( decoratedBenchmarks, + ) +where + +import Data.Foldable (toList) +import Data.Function ((&)) +import Data.List qualified as List +import AbstractFixtures + ( BenchCategory (..), + benchLeftCospanLeg, + benchLeftCospanRightLeg, + benchRightCospanLeftLeg, + benchRightCospanRightLeg, + ) +import Algebraic.StructuredCospan (structuredCospanWeight) +import BenchSupport (batchWeight, sampleBatch512) +import Moonlight.Category.Pure.DecoratedComposition + ( CompositionResult (..), + StructuredCompositionAlgebra (..), + composeDecorated, + composeDecoratedStructured, + reconcileCompositionObligations, + ) +import Moonlight.Category.Pure.DecoratedPresentation + ( DecoratedPresentation, + compileDecoratedPresentation, + foldDecoratedPresentation, + presentationGlue, + presentationLeaf, + ) +import Moonlight.Category.Pure.StructuredCospan (mkStructuredCospan) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +decoratedBenchmarks :: Benchmark +decoratedBenchmarks = + bgroup + "DecoratedPresentation / DecoratedComposition" + [ bench "composeDecorated batch x512" (nf (batchWeight decoratedComposeWeight) sampleBatch512), + bench "compileDecoratedPresentation batch x512" (nf decoratedPresentationCompileBatchWeight sampleBatch512), + bench "compile left-skew obligations=512" (nf decoratedPresentationCompileWeight (leftSkewPresentation 512)), + bench "compile left-skew obligations=2048" (nf decoratedPresentationCompileWeight (leftSkewPresentation 2048)), + bench "foldDecoratedPresentation batch x512" (nf decoratedPresentationFoldBatchWeight sampleBatch512), + bench "composeDecoratedStructured batch x512" (nf (batchWeight decoratedStructuredComposeWeight) sampleBatch512), + bench "reconcileCompositionObligations batch x512" (nf reconcileBatchWeight sampleBatch512), + bench "reconcile failing obligations=100000 budget=4" (nf reconcileDecisionWeight largeObligations) + ] +decoratedComposeWeight :: Int -> Int +decoratedComposeWeight seed = + composeDecorated (+) decoratedGlue seed (seed + 11, seed + 2) (seed + 17, seed + 3) + & compositionResultWeight + +decoratedPresentationCompileBatchWeight :: [Int] -> Int +decoratedPresentationCompileBatchWeight = + sum . fmap (\seed -> decoratedPresentationCompileWeight (demoPresentation seed)) + +decoratedPresentationCompileWeight :: DecoratedPresentation Int Int Int -> Int +decoratedPresentationCompileWeight presentationValue = + compileDecoratedPresentation (+) decoratedGlue presentationValue + & compositionResultWeight + +decoratedPresentationFoldBatchWeight :: [Int] -> Int +decoratedPresentationFoldBatchWeight = + sum . fmap (\seed -> decoratedPresentationFoldWeight (demoPresentation seed)) + +decoratedPresentationFoldWeight :: DecoratedPresentation Int Int Int -> Int +decoratedPresentationFoldWeight presentationValue = + foldDecoratedPresentation (\ir decoration -> ir + decoration) (\boundary left right -> boundary + left + right) presentationValue + +decoratedStructuredComposeWeight :: Int -> Int +decoratedStructuredComposeWeight seed = + composeDecoratedStructured BenchCategory structuredDecoratedAlgebra (+) seed (1, seed + 13) (2, seed + 17) + & either (const 0) compositionResultWeight + +reconcileBatchWeight :: [Int] -> Int +reconcileBatchWeight = + sum . fmap (\seed -> seed + reconcileWeight [seed, seed + 1, seed + 2]) + +reconcileWeight :: [Int] -> Int +reconcileWeight obligations = + reconcileCompositionObligations obligations 4 + & either (sum . toList) (const 1) + +reconcileDecisionWeight :: [Int] -> Int +reconcileDecisionWeight obligations = + reconcileCompositionObligations obligations 4 + & either (const 1) (const 0) + +demoPresentation :: Int -> DecoratedPresentation Int Int Int +demoPresentation seed = + presentationGlue + (seed + 7) + (presentationGlue (seed + 3) (presentationLeaf (seed + 11) (seed + 2)) (presentationLeaf (seed + 13) (seed + 5))) + (presentationLeaf (seed + 17) (seed + 19)) + +leftSkewPresentation :: Int -> DecoratedPresentation Int Int Int +leftSkewPresentation obligationCount = + [1 .. obligationCount] + & List.foldl' + ( \presentationValue obligation -> + presentationGlue + obligation + presentationValue + (presentationLeaf obligation obligation) + ) + (presentationLeaf 0 0) + +decoratedGlue :: Int -> (Int, Int) -> (Int, Int) -> (Int, [Int]) +decoratedGlue boundaryValue (leftIR, leftDecoration) (rightIR, rightDecoration) = + (boundaryValue + leftIR + rightIR, [leftDecoration + rightDecoration]) + +structuredDecoratedAlgebra :: StructuredCompositionAlgebra Int BenchCategory Int Int Int +structuredDecoratedAlgebra = + StructuredCompositionAlgebra + { toStructuredBoundary = \_ (irValue, decoration) -> + case irValue of + 1 -> either (const Nothing) Just (mkStructuredCospan BenchCategory benchLeftCospanLeg benchLeftCospanRightLeg decoration) + 2 -> either (const Nothing) Just (mkStructuredCospan BenchCategory benchRightCospanLeftLeg benchRightCospanRightLeg decoration) + _ -> Nothing, + fromStructuredComposition = \boundaryValue (leftIR, _) (rightIR, _) composedBoundary -> + (leftIR + rightIR + boundaryValue, [structuredCospanWeight composedBoundary]) + } + +compositionResultWeight :: CompositionResult Int Int Int -> Int +compositionResultWeight resultValue = + composedIR resultValue + + composedDecoration resultValue + + sum (composedObligations resultValue) + +largeObligations :: [Int] +largeObligations = [0 .. 99999] diff --git a/bench/abstract/Algebraic/Double.hs b/bench/abstract/Algebraic/Double.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/Double.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Algebraic.Double + ( doubleCategoryBenchmarks, + ) +where + +import BenchSupport (batchWeight, boolWeight, sampleBatch512) +import Data.Proxy (Proxy (..)) +import Moonlight.Category.Pure.DoubleCategory (DoubleCategory (..), interchangeLaw) +import Moonlight.Category.Test.DoubleFixture + ( SymbolicDouble, + SymbolicHorizontal (..), + SymbolicObject (..), + SymbolicSquare (..), + SymbolicVertical (..), + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +doubleCategoryBenchmarks :: Benchmark +doubleCategoryBenchmarks = + bgroup + "DoubleCategory" + [ bench "interchangeLaw symbolic 2x2 grid batch x512" (nf (batchWeight doubleInterchangeWeight) sampleBatch512), + bench "typed horizontal identity compose batch x512" (nf (batchWeight doubleHorizontalIdentityWeight) sampleBatch512), + bench "typed vertical identity compose batch x512" (nf (batchWeight doubleVerticalIdentityWeight) sampleBatch512) + ] + +doubleInterchangeWeight :: Int -> Int +doubleInterchangeWeight seed = + seed + maybe 0 boolWeight (interchangeLaw @SymbolicObject @(SymbolicDouble Int) (northWestSquare seed) (northEastSquare seed) (southWestSquare seed) (southEastSquare seed)) + +doubleHorizontalIdentityWeight :: Int -> Int +doubleHorizontalIdentityWeight seed = + seed + maybe 0 horizontalWeight (composeHorizontal @SymbolicObject @(SymbolicDouble Int) (horizontalIdentity @SymbolicObject @(SymbolicDouble Int) (Proxy @'ObjectB)) (horizontalArrow seed :: SymbolicHorizontal Int 'ObjectA 'ObjectB)) + +doubleVerticalIdentityWeight :: Int -> Int +doubleVerticalIdentityWeight seed = + seed + maybe 0 verticalWeight (composeVertical @SymbolicObject @(SymbolicDouble Int) (verticalIdentity @SymbolicObject @(SymbolicDouble Int) (Proxy @'ObjectB)) (verticalArrow seed :: SymbolicVertical Int 'ObjectA 'ObjectB)) + +horizontalArrow :: Int -> SymbolicHorizontal Int source target +horizontalArrow labelValue = SymbolicHorizontal [labelValue] + +verticalArrow :: Int -> SymbolicVertical Int source target +verticalArrow labelValue = SymbolicVertical [labelValue] + +northWestSquare :: Int -> SymbolicSquare Int 'ObjectA 'ObjectB 'ObjectD 'ObjectE +northWestSquare seed = + SymbolicSquare + { symbolicSquareTop = horizontalArrow (seed + 1), + symbolicSquareBottom = horizontalArrow (seed + 4), + symbolicSquareLeft = verticalArrow (seed + 7), + symbolicSquareRight = verticalArrow (seed + 8) + } + +northEastSquare :: Int -> SymbolicSquare Int 'ObjectB 'ObjectC 'ObjectE 'ObjectF +northEastSquare seed = + SymbolicSquare + { symbolicSquareTop = horizontalArrow (seed + 2), + symbolicSquareBottom = horizontalArrow (seed + 5), + symbolicSquareLeft = verticalArrow (seed + 8), + symbolicSquareRight = verticalArrow (seed + 9) + } + +southWestSquare :: Int -> SymbolicSquare Int 'ObjectD 'ObjectE 'ObjectG 'ObjectH +southWestSquare seed = + SymbolicSquare + { symbolicSquareTop = horizontalArrow (seed + 4), + symbolicSquareBottom = horizontalArrow (seed + 6), + symbolicSquareLeft = verticalArrow (seed + 10), + symbolicSquareRight = verticalArrow (seed + 11) + } + +southEastSquare :: Int -> SymbolicSquare Int 'ObjectE 'ObjectF 'ObjectH 'ObjectI +southEastSquare seed = + SymbolicSquare + { symbolicSquareTop = horizontalArrow (seed + 5), + symbolicSquareBottom = horizontalArrow (seed + 7), + symbolicSquareLeft = verticalArrow (seed + 11), + symbolicSquareRight = verticalArrow (seed + 12) + } + +horizontalWeight :: SymbolicHorizontal Int source target -> Int +horizontalWeight (SymbolicHorizontal traceValue) = sum traceValue + +verticalWeight :: SymbolicVertical Int source target -> Int +verticalWeight (SymbolicVertical traceValue) = sum traceValue diff --git a/bench/abstract/Algebraic/Galois.hs b/bench/abstract/Algebraic/Galois.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/Galois.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TypeApplications #-} + +module Algebraic.Galois + ( galoisBenchmarks, + ) +where + +import BenchSupport (batchWeight, sampleBatch512) +import Data.Function ((&)) +import Moonlight.Category.Pure.Galois (GaloisConnection (..), OrdinalGalois (..)) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +galoisBenchmarks :: Benchmark +galoisBenchmarks = + bgroup + "Galois" + [ bench "alpha/gamma round trip batch x512" (nf galoisRoundTripBatchWeight sampleBatch512), + bench "threshold enumeration batch x512" (nf (batchWeight galoisThresholdWeight) sampleBatch512) + ] + +newtype FineLevel = FineLevel {unFineLevel :: Int} + deriving stock (Eq, Ord, Show) + +newtype CoarseLevel = CoarseLevel {unCoarseLevel :: Int} + deriving stock (Eq, Ord, Show) + +instance GaloisConnection FineLevel CoarseLevel where + alpha (FineLevel value) = CoarseLevel (value `div` 4) + gamma (CoarseLevel value) = FineLevel (value * 4) + +instance OrdinalGalois FineLevel CoarseLevel where + thresholds = + [ (FineLevel 0, CoarseLevel 0), + (FineLevel 4, CoarseLevel 1), + (FineLevel 8, CoarseLevel 2), + (FineLevel 16, CoarseLevel 4) + ] + +galoisRoundTripBatchWeight :: [Int] -> Int +galoisRoundTripBatchWeight = + sum . fmap (galoisRoundTripWeight . FineLevel) + +galoisRoundTripWeight :: FineLevel -> Int +galoisRoundTripWeight fineValue = + let coarseValue = alpha fineValue + returnedFine = gamma coarseValue + in unFineLevel fineValue + unCoarseLevel coarseValue + unFineLevel returnedFine + +galoisThresholdWeight :: Int -> Int +galoisThresholdWeight seed = + seed + + ( thresholds @FineLevel @CoarseLevel + & fmap (\(FineLevel fineValue, CoarseLevel coarseValue) -> fineValue + coarseValue + seed `mod` 3) + & sum + ) diff --git a/bench/abstract/Algebraic/Polynomial.hs b/bench/abstract/Algebraic/Polynomial.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/Polynomial.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Algebraic.Polynomial + ( polynomialBenchmarks, + ) +where + +import BenchSupport (batchWeight, boolWeight, sampleBatch512) +import Data.Function ((&)) +import Moonlight.Category.Pure.CoveringFamily (Exists (..)) +import Moonlight.Category.Pure.PolynomialFunctor + ( Direction, + ParameterizedDirection, + ParameterizedPolynomialFunctor (..), + PolynomialFunctor (..), + ) +import Moonlight.Category.Test.PolynomialFixture + ( BranchPosition, + DemoParameterizedPolynomial, + DemoPolynomial, + FullSliceBranchPosition, + FullSliceRootPosition, + ParameterizedPosition + ( FullSliceBranchWitness, + FullSliceRootWitness, + TrimmedSliceRootWitness + ), + Position (BranchWitness, RootWitness), + RootPosition, + TrimmedSliceRootPosition, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +polynomialBenchmarks :: Benchmark +polynomialBenchmarks = + bgroup + "PolynomialFunctor" + [ bench "allPositions batch x512" (nf (batchWeight polynomialPositionsWeight) sampleBatch512), + bench "positionsAt full/trimmed alternation batch x512" (nf parameterizedPolynomialPositionsBatchWeight sampleBatch512), + bench "direction witnesses batch x512" (nf (batchWeight polynomialDirectionWeight) sampleBatch512) + ] +polynomialPositionsWeight :: Int -> Int +polynomialPositionsWeight seed = + seed + sum (fmap polynomialPositionWeight (allPositions @DemoPolynomial)) + +parameterizedPolynomialPositionsBatchWeight :: [Int] -> Int +parameterizedPolynomialPositionsBatchWeight = + sum . fmap (\seed -> seed + parameterizedPolynomialPositionsWeight (even seed)) + +parameterizedPolynomialPositionsWeight :: Bool -> Int +parameterizedPolynomialPositionsWeight includeBranch = + positionsAt @DemoParameterizedPolynomial includeBranch + & fmap parameterizedPolynomialPositionWeight + & sum + +polynomialDirectionWeight :: Int -> Int +polynomialDirectionWeight seed = + seed + boolWeight rootDirectionWitness + maybe 0 boolWeight (branchDirectionWitness seed) + boolWeight fullSliceRootDirectionWitness + maybe 0 boolWeight (fullSliceBranchDirectionWitness seed) + trimmedSliceRootDirectionWeight trimmedSliceRootDirectionWitness + +rootDirectionWitness :: Direction DemoPolynomial RootPosition +rootDirectionWitness = True + +branchDirectionWitness :: Int -> Direction DemoPolynomial BranchPosition +branchDirectionWitness seed = Just (even seed) + +fullSliceRootDirectionWitness :: ParameterizedDirection DemoParameterizedPolynomial FullSliceRootPosition +fullSliceRootDirectionWitness = True + +fullSliceBranchDirectionWitness :: Int -> ParameterizedDirection DemoParameterizedPolynomial FullSliceBranchPosition +fullSliceBranchDirectionWitness seed = Just (odd seed) + +trimmedSliceRootDirectionWitness :: ParameterizedDirection DemoParameterizedPolynomial TrimmedSliceRootPosition +trimmedSliceRootDirectionWitness = () + +polynomialPositionWeight :: Exists (Position DemoPolynomial) -> Int +polynomialPositionWeight (Exists witness) = + case witness of + RootWitness -> 1 + BranchWitness -> 2 + +parameterizedPolynomialPositionWeight :: Exists (ParameterizedPosition DemoParameterizedPolynomial) -> Int +parameterizedPolynomialPositionWeight (Exists witness) = + case witness of + FullSliceRootWitness -> 3 + FullSliceBranchWitness -> 5 + TrimmedSliceRootWitness -> 7 + +trimmedSliceRootDirectionWeight :: () -> Int +trimmedSliceRootDirectionWeight () = 1 diff --git a/bench/abstract/Algebraic/StructuredCospan.hs b/bench/abstract/Algebraic/StructuredCospan.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/StructuredCospan.hs @@ -0,0 +1,64 @@ +module Algebraic.StructuredCospan + ( structuredCospanBenchmarks, + structuredCospanWeight, + ) +where + +import BenchSupport (batchWeight, sampleBatch512) +import Data.Function ((&)) +import AbstractFixtures + ( BenchCategory (..), + benchLeftCospanLeg, + benchLeftCospanRightLeg, + benchMorphismWeight, + benchObjectWeight, + benchRightCospanLeftLeg, + benchRightCospanRightLeg, + ) +import Moonlight.Category.Pure.StructuredCospan + ( StructuredCospan, + composeStructuredCospan, + mkStructuredCospan, + structuredApex, + structuredDecoration, + structuredLeftLeg, + structuredRightLeg, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +structuredCospanBenchmarks :: Benchmark +structuredCospanBenchmarks = + bgroup + "StructuredCospan" + [ bench "mkStructuredCospan left batch x512" (nf (batchWeight structuredCospanBuildWeight) sampleBatch512), + bench "composeStructuredCospan batch x512" (nf (batchWeight structuredCospanComposeWeight) sampleBatch512) + ] +structuredCospanBuildWeight :: Int -> Int +structuredCospanBuildWeight seed = + mkStructuredCospan BenchCategory benchLeftCospanLeg benchLeftCospanRightLeg seed + & either (const 0) structuredCospanWeight + +structuredCospanComposeWeight :: Int -> Int +structuredCospanComposeWeight seed = + case (demoLeftStructuredCospan seed, demoRightStructuredCospan (seed + 1)) of + (Right leftValue, Right rightValue) -> + composeStructuredCospan BenchCategory (+) leftValue rightValue + & either (const 0) structuredCospanWeight + _ -> 0 + +demoLeftStructuredCospan :: Int -> Either () (StructuredCospan BenchCategory Int) +demoLeftStructuredCospan seed = + mkStructuredCospan BenchCategory benchLeftCospanLeg benchLeftCospanRightLeg seed + & either (const (Left ())) Right + +demoRightStructuredCospan :: Int -> Either () (StructuredCospan BenchCategory Int) +demoRightStructuredCospan seed = + mkStructuredCospan BenchCategory benchRightCospanLeftLeg benchRightCospanRightLeg seed + & either (const (Left ())) Right + +structuredCospanWeight :: StructuredCospan BenchCategory Int -> Int +structuredCospanWeight cospanValue = + benchMorphismWeight (structuredLeftLeg cospanValue) + + benchMorphismWeight (structuredRightLeg cospanValue) + + benchObjectWeight (structuredApex cospanValue) + + structuredDecoration cospanValue diff --git a/bench/abstract/Algebraic/Suite.hs b/bench/abstract/Algebraic/Suite.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Algebraic/Suite.hs @@ -0,0 +1,22 @@ +module Algebraic.Suite + ( algebraicSurfaceBenchmarks, + ) +where + +import Algebraic.Decorated (decoratedBenchmarks) +import Algebraic.Double (doubleCategoryBenchmarks) +import Algebraic.Galois (galoisBenchmarks) +import Algebraic.Polynomial (polynomialBenchmarks) +import Algebraic.StructuredCospan (structuredCospanBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +algebraicSurfaceBenchmarks :: Benchmark +algebraicSurfaceBenchmarks = + bgroup + "algebraic category surfaces" + [ galoisBenchmarks, + polynomialBenchmarks, + structuredCospanBenchmarks, + decoratedBenchmarks, + doubleCategoryBenchmarks + ] diff --git a/bench/abstract/Covering.hs b/bench/abstract/Covering.hs new file mode 100644 --- /dev/null +++ b/bench/abstract/Covering.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Covering + ( coveringBenchmarks, + ) +where + +import BenchSupport (sampleBatch512) +import Data.Function ((&)) +import Data.Kind (Type) +import Data.Monoid (Sum (..)) +import Moonlight.Category.Pure.CoveringProduct + ( CoveringProduct, + adjustCoveringProduct, + foldMapCoveringProductWithWitness, + indexCoveringProduct, + mapCoveringProductWithWitness, + replaceCoveringProduct, + restrictCoveringProduct, + tabulateCoveringProduct, + ) +import Moonlight.Category.Test.CoveringFixture + ( DemoField, + DemoFieldWitness (..), + DemoSubsetWitness (..), + embedDemoSubsetWitness, + sameDemoFieldWitness, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +type DemoValue :: DemoField -> Type +newtype DemoValue (field :: DemoField) = DemoValue + { unDemoValue :: Int + } + deriving stock (Eq, Show) + +coveringBenchmarks :: Benchmark +coveringBenchmarks = + bgroup + "CoveringProduct / CoveringFamily" + [ bench "index full product batch x512" (nf fullProductIndexBatchWeight sampleBatch512), + bench "restrict subset then index batch x512" (nf restrictSubsetBatchWeight sampleBatch512), + bench "adjust one witness then fold batch x512" (nf adjustProductBatchWeight sampleBatch512), + bench "replace one witness then fold batch x512" (nf replaceProductBatchWeight sampleBatch512), + bench "map with witness then fold batch x512" (nf mapWithWitnessBatchWeight sampleBatch512), + bench "foldMap with existential witnesses batch x512" (nf coveringProductBatchWeight sampleBatch512) + ] + +demoProduct :: CoveringProduct DemoFieldWitness DemoValue +demoProduct = + tabulateCoveringProduct + ( \witness -> + case witness of + AlphaFieldWitness -> DemoValue 11 + BetaFieldWitness -> DemoValue 17 + GammaFieldWitness -> DemoValue 23 + ) + +fullProductIndexBatchWeight :: [Int] -> Int +fullProductIndexBatchWeight = + sum . fmap (\seed -> seed + fullProductIndexWeight demoProduct) + +restrictSubsetBatchWeight :: [Int] -> Int +restrictSubsetBatchWeight = + sum . fmap (\seed -> seed + restrictSubsetWeight demoProduct) + +adjustProductBatchWeight :: [Int] -> Int +adjustProductBatchWeight = + sum . fmap (\seed -> adjustProductWeight seed demoProduct) + +replaceProductBatchWeight :: [Int] -> Int +replaceProductBatchWeight = + sum . fmap (\seed -> replaceProductWeight seed demoProduct) + +mapWithWitnessBatchWeight :: [Int] -> Int +mapWithWitnessBatchWeight = + sum . fmap (\seed -> seed + mapWithWitnessWeight demoProduct) + +coveringProductBatchWeight :: [Int] -> Int +coveringProductBatchWeight = + sum . fmap (\seed -> seed + coveringProductWeight demoProduct) + +fullProductIndexWeight :: CoveringProduct DemoFieldWitness DemoValue -> Int +fullProductIndexWeight productValue = + demoValueWeight (indexCoveringProduct productValue AlphaFieldWitness) + + demoValueWeight (indexCoveringProduct productValue BetaFieldWitness) + + demoValueWeight (indexCoveringProduct productValue GammaFieldWitness) + +restrictSubsetWeight :: CoveringProduct DemoFieldWitness DemoValue -> Int +restrictSubsetWeight productValue = + let restrictedProduct = restrictCoveringProduct embedDemoSubsetWitness productValue + in demoValueWeight (indexCoveringProduct restrictedProduct AlphaSubsetWitness) + + demoValueWeight (indexCoveringProduct restrictedProduct GammaSubsetWitness) + +adjustProductWeight :: Int -> CoveringProduct DemoFieldWitness DemoValue -> Int +adjustProductWeight seed productValue = + adjustCoveringProduct sameDemoFieldWitness BetaFieldWitness (\(DemoValue value) -> DemoValue (value + seed)) productValue + & coveringProductWeight + +replaceProductWeight :: Int -> CoveringProduct DemoFieldWitness DemoValue -> Int +replaceProductWeight seed productValue = + replaceCoveringProduct sameDemoFieldWitness GammaFieldWitness (DemoValue seed) productValue + & coveringProductWeight + +mapWithWitnessWeight :: CoveringProduct DemoFieldWitness DemoValue -> Int +mapWithWitnessWeight productValue = + mapCoveringProductWithWitness (\witness (DemoValue value) -> DemoValue (value + demoWitnessWeight witness)) productValue + & coveringProductWeight + +coveringProductWeight :: CoveringProduct DemoFieldWitness DemoValue -> Int +coveringProductWeight productValue = + getSum + ( foldMapCoveringProductWithWitness + (\witness value -> Sum (demoWitnessWeight witness + demoValueWeight value)) + productValue + ) + +demoWitnessWeight :: DemoFieldWitness field -> Int +demoWitnessWeight witness = + case witness of + AlphaFieldWitness -> 1 + BetaFieldWitness -> 2 + GammaFieldWitness -> 3 + +demoValueWeight :: DemoValue field -> Int +demoValueWeight (DemoValue value) = value 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,11 @@ +module Main + ( main, + ) +where + +import AbstractBench (abstractBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [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 FiniteBench (finiteBenchmarks) +import IndexedBench (indexedBenchmarks) +import SimplicialBench (simplicialBenchmarks) +import SiteBench (siteBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain + [ abstractBenchmarks, + finiteBenchmarks, + siteBenchmarks, + indexedBenchmarks, + simplicialBenchmarks + ] diff --git a/bench/finite/FinCat.hs b/bench/finite/FinCat.hs new file mode 100644 --- /dev/null +++ b/bench/finite/FinCat.hs @@ -0,0 +1,520 @@ +module FinCat + ( compositionMapWeight, + finCatBenchmarks, + finCatExplicitCompositionMapViewWeight, + finCatExplicitMorphismMapViewWeight, + finCatWeight, + finMorphismIdWeight, + finMorphismWeight, + finObjectIdWeight, + morphismMapWeight, + objectKeys, + objectSetWeight, + representativeCompositionPair, + rnfFinCat, + rnfMaybeFinMorphismPair, + ) +where + +import BenchSupport (BenchSetup (..), prepareBenchValue) +import Control.DeepSeq (NFData (..)) +import Control.Monad (foldM) +import Data.Bifunctor (first) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.Kind (Type) +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Pure.Category (composeMor) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatValidationError, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + FinMor, + allMorphisms, + allMorphismsFrom, + allObjects, + finCatExplicitCompositionMapView, + finCatExplicitMorphismMapView, + finCatHandle, + finCatMorphismCount, + finCatNonIdentityMorphismCount, + objectCount, + finCatObjects, + finMorCategoryHandle, + finMorId, + finMorSourceId, + finMorTargetId, + finObjId, + finObjectIdentityMor, + mkFinCat, + mkFinMorphism, + mkFinObject, + ) +import Moonlight.Category.Pure.FiniteComposable + ( SizedComposableChain, + appendComposableMorphism, + chainDimension, + chainMorphisms, + enumerateComposableChains, + sizedChainDimension, + sizedChainValue, + singletonComposableChain, + ) +import qualified Moonlight.Category.Presentation as Presentation +import Numeric.Natural (Natural) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +finCatBenchmarks :: Benchmark +finCatBenchmarks = + bgroup + "FinCat API" + [ bgroup + "FinPresentation strict-chain compilation" + (finPresentationObjectCounts & fmap finPresentationBenchmark), + bgroup + "us-vs-world thin-total-order construction" + (thinOrderCases & fmap thinOrderWorldBenchmark), + bgroup + "mkFinCat thin-total-order" + (thinOrderCases & fmap mkFinCatBenchmark), + bgroup + "mkFinCat generic non-thin validation stress" + (nonThinCases & fmap mkNonThinFinCatBenchmark), + bgroup + "prepared FinCat operations" + (thinOrderCases & fmap preparedFinCatBenchmark), + bench "appendComposableMorphism identity x1024" (nf repeatedChainAppendWeight 1024) + ] +type ThinOrderCase :: Type +data ThinOrderCase = ThinOrderCase + { thinOrderObjectCount :: !Int, + thinOrderChainBound :: !Natural + } + deriving stock (Eq, Ord, Show) + +thinOrderCases :: [ThinOrderCase] +thinOrderCases = + [ ThinOrderCase 8 3, + ThinOrderCase 16 3, + ThinOrderCase 32 2 + ] + +finPresentationObjectCounts :: [Int] +finPresentationObjectCounts = + [8, 32, 128] + +finPresentationBenchmark :: Int -> Benchmark +finPresentationBenchmark objectTotal = + bench + ("objects=" <> show objectTotal) + (nf finPresentationCategoryWeight objectTotal) + +finPresentationCategoryWeight :: Int -> Int +finPresentationCategoryWeight objectTotal = + either + (length . show) + finCatWeight + (strictChainPresentation objectTotal) + +strictChainPresentation :: + Int -> + Either Presentation.FinCatBuildError FinCat +strictChainPresentation objectTotal = + Presentation.finCategory $ do + declaredObjects <- + Presentation.objects + ( fmap + (\objectKey -> "x" <> show objectKey) + (objectKeys objectTotal) + ) + + traverse_ + (uncurry Presentation.below) + (zip declaredObjects (drop 1 declaredObjects)) + +thinOrderCaseLabel :: ThinOrderCase -> String +thinOrderCaseLabel benchCase = + "objects=" + <> show (thinOrderObjectCount benchCase) + <> " chain-bound=" + <> show (thinOrderChainBound benchCase) + +type NonThinCase :: Type +data NonThinCase = NonThinCase + { nonThinObjectCount :: !Int, + nonThinParallelCount :: !Int + } + deriving stock (Eq, Ord, Show) + +nonThinCases :: [NonThinCase] +nonThinCases = + [ NonThinCase 6 2, + NonThinCase 8 2 + ] + +nonThinCaseLabel :: NonThinCase -> String +nonThinCaseLabel benchCase = + "objects=" + <> show (nonThinObjectCount benchCase) + <> " parallel=" + <> show (nonThinParallelCount benchCase) + +mkFinCatBenchmark :: ThinOrderCase -> Benchmark +mkFinCatBenchmark benchCase = + bench (thinOrderCaseLabel benchCase) (nf mkThinOrderCategoryWeight benchCase) + +thinOrderWorldBenchmark :: ThinOrderCase -> Benchmark +thinOrderWorldBenchmark benchCase = + bgroup + (thinOrderCaseLabel benchCase) + [ bench "moonlight: mkFinCat validated finite category" (nf mkThinOrderCategoryWeight benchCase), + bench "world: containers relation+composition maps" (nf rawThinOrderMapWeight (thinOrderObjectCount benchCase)) + ] + +mkNonThinFinCatBenchmark :: NonThinCase -> Benchmark +mkNonThinFinCatBenchmark benchCase = + bench (nonThinCaseLabel benchCase) (nf mkNonThinCategoryWeight benchCase) + +preparedFinCatBenchmark :: ThinOrderCase -> Benchmark +preparedFinCatBenchmark benchCase = + env (prepareBenchValue (preparedThinOrderCase benchCase)) $ \prepared -> + bgroup + (thinOrderCaseLabel benchCase) + [ bench "allObjects/allMorphisms" (nf preparedFinCatCarrierWeight prepared), + bench "compose generator triples" (nf preparedFinCatCompositionWeight prepared), + bench "enumerateComposableChains" (nf preparedFinCatChainWeight prepared) + ] + +type PreparedFinCatCase :: Type +data PreparedFinCatCase = PreparedFinCatCase + { preparedFinCatChainBound :: !Natural, + preparedFinCatCategory :: !FinCat, + preparedFinCatCompositions :: ![(FinMor, FinMor)] + } + +instance NFData PreparedFinCatCase where + rnf prepared = + preparedFinCatChainBound prepared + `seq` rnfFinCat (preparedFinCatCategory prepared) + `seq` rnfFinMorphismPairs (preparedFinCatCompositions prepared) + `seq` () + +preparedThinOrderCase :: ThinOrderCase -> BenchSetup PreparedFinCatCase +preparedThinOrderCase benchCase = + BenchSetup $ do + categoryValue <- first (show . NonEmpty.toList) (thinTotalOrderCategory (thinOrderObjectCount benchCase)) + compositionPairs <- thinOrderCompositionPairs categoryValue (thinOrderObjectCount benchCase) + pure + PreparedFinCatCase + { preparedFinCatChainBound = thinOrderChainBound benchCase, + preparedFinCatCategory = categoryValue, + preparedFinCatCompositions = compositionPairs + } + +mkThinOrderCategoryWeight :: ThinOrderCase -> Int +mkThinOrderCategoryWeight benchCase = + either + (length . NonEmpty.toList) + finCatWeight + (thinTotalOrderCategory (thinOrderObjectCount benchCase)) + +mkNonThinCategoryWeight :: NonThinCase -> Int +mkNonThinCategoryWeight benchCase = + either + (length . NonEmpty.toList) + finCatWeight + (nonThinTotalOrderCategory (nonThinObjectCount benchCase) (nonThinParallelCount benchCase)) + +rawThinOrderMapWeight :: Int -> Int +rawThinOrderMapWeight objectTotal = + objectSetWeight (Set.fromAscList (FinObjectId <$> objectKeys objectTotal)) + + morphismMapWeight (Map.fromList (morphismBuckets objectTotal)) + + compositionMapWeight (Map.fromList (compositionEntries objectTotal)) + +preparedFinCatCarrierWeight :: PreparedFinCatCase -> Int +preparedFinCatCarrierWeight prepared = + finCatWeight (preparedFinCatCategory prepared) + + length (allObjects (preparedFinCatCategory prepared)) + + length (allMorphisms (preparedFinCatCategory prepared)) + + sourceBucketWeight (preparedFinCatCategory prepared) + +preparedFinCatCompositionWeight :: PreparedFinCatCase -> Int +preparedFinCatCompositionWeight prepared = + preparedFinCatCompositions prepared + & List.foldl' + ( \accumulated (leftMorphism, rightMorphism) -> + accumulated + + either + (const 0) + finMorphismWeight + (composeMor (preparedFinCatCategory prepared) leftMorphism rightMorphism) + ) + 0 + +preparedFinCatChainWeight :: PreparedFinCatCase -> Int +preparedFinCatChainWeight prepared = + enumerateComposableChains (preparedFinCatCategory prepared) (preparedFinCatChainBound prepared) + & fmap sizedComposableChainWeight + & sum + +repeatedChainAppendWeight :: Int -> Int +repeatedChainAppendWeight appendCount = + case mkFinObject sampleFinCat (FinObjectId 0) of + Left _ -> 0 + Right startObject -> + let identityMorphism = finObjectIdentityMor startObject + in foldM + (appendComposableMorphism sampleFinCat) + (singletonComposableChain startObject) + (replicate appendCount identityMorphism) + & either + (const 0) + ( \chainValue -> + fromIntegral (chainDimension chainValue) + + sum (finMorphismWeight <$> chainMorphisms chainValue) + ) + +sourceBucketWeight :: FinCat -> Int +sourceBucketWeight categoryValue = + allObjects categoryValue + & fmap + ( \objectValue -> + finObjectIdWeight (finObjId objectValue) + + sum (finMorphismWeight <$> allMorphismsFrom categoryValue objectValue) + ) + & sum + +finCatWeight :: FinCat -> Int +finCatWeight categoryValue = + finCatHandle categoryValue + `seq` finCatCarrierWeight categoryValue + +finCatCarrierWeight :: FinCat -> Int +finCatCarrierWeight categoryValue = + objectSetWeight (finCatObjects categoryValue) + + objectCount categoryValue + + finCatMorphismCount categoryValue + + finCatNonIdentityMorphismCount categoryValue + +finCatExplicitMorphismMapViewWeight :: FinCat -> Int +finCatExplicitMorphismMapViewWeight = + morphismMapWeight . finCatExplicitMorphismMapView + +finCatExplicitCompositionMapViewWeight :: FinCat -> Int +finCatExplicitCompositionMapViewWeight = + compositionMapWeight . finCatExplicitCompositionMapView + +morphismMapWeight :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Int +morphismMapWeight = + Map.foldlWithKey' + ( \accumulated (sourceId, targetId) morphismIds -> + accumulated + + finObjectIdWeight sourceId + + finObjectIdWeight targetId + + sum (finMorphismIdWeight <$> morphismIds) + ) + 0 + +compositionMapWeight :: Map (FinMorphismId, FinMorphismId) FinMorphismId -> Int +compositionMapWeight = + Map.foldlWithKey' + ( \accumulated (leftId, rightId) resultId -> + accumulated + + finMorphismIdWeight leftId + + finMorphismIdWeight rightId + + finMorphismIdWeight resultId + ) + 0 + +sizedComposableChainWeight :: SizedComposableChain FinCat -> Int +sizedComposableChainWeight sizedChain = + fromIntegral (sizedChainDimension sizedChain) + + sum (finMorphismIdWeight . finMorId <$> chainMorphisms (sizedChainValue sizedChain)) + +thinTotalOrderCategory :: Int -> Either (NonEmpty FinCatValidationError) FinCat +thinTotalOrderCategory objectTotal = + mkFinCat + (Set.fromAscList (FinObjectId <$> objectKeys objectTotal)) + (Map.fromList (morphismBuckets objectTotal)) + (Map.fromList (compositionEntries objectTotal)) + +nonThinTotalOrderCategory :: Int -> Int -> Either (NonEmpty FinCatValidationError) FinCat +nonThinTotalOrderCategory objectTotal parallelCount = + mkFinCat + (Set.fromAscList (FinObjectId <$> objectKeys objectTotal)) + (Map.fromList (parallelMorphismBuckets objectTotal parallelCount)) + (Map.fromList (parallelCompositionEntries objectTotal parallelCount)) + +objectKeys :: Int -> [Int] +objectKeys objectTotal = + [0 .. objectTotal - 1] + +strictObjectPairs :: Int -> [(Int, Int)] +strictObjectPairs objectTotal = + objectKeys objectTotal + >>= (\sourceKey -> fmap (\targetKey -> (sourceKey, targetKey)) [sourceKey + 1 .. objectTotal - 1]) + +strictObjectTriples :: Int -> [(Int, Int, Int)] +strictObjectTriples objectTotal = + objectKeys objectTotal + >>= (\sourceKey -> [sourceKey + 1 .. objectTotal - 1] >>= middleEntries sourceKey) + where + middleEntries sourceKey middleKey = + [middleKey + 1 .. objectTotal - 1] + & fmap (\targetKey -> (sourceKey, middleKey, targetKey)) + +morphismBuckets :: Int -> [((FinObjectId, FinObjectId), [FinMorphismId])] +morphismBuckets objectTotal = + strictObjectPairs objectTotal + & fmap + ( \(sourceKey, targetKey) -> + ( (FinObjectId sourceKey, FinObjectId targetKey), + [thinMorphismId sourceKey targetKey] + ) + ) + +compositionEntries :: Int -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +compositionEntries objectTotal = + strictObjectTriples objectTotal + & fmap + ( \(sourceKey, middleKey, targetKey) -> + ( (thinMorphismId middleKey targetKey, thinMorphismId sourceKey middleKey), + thinMorphismId sourceKey targetKey + ) + ) + +parallelMorphismBuckets :: Int -> Int -> [((FinObjectId, FinObjectId), [FinMorphismId])] +parallelMorphismBuckets objectTotal parallelCount = + strictObjectPairs objectTotal + & fmap + ( \(sourceKey, targetKey) -> + ( (FinObjectId sourceKey, FinObjectId targetKey), + parallelMorphismId objectTotal parallelCount sourceKey targetKey <$> [0 .. parallelCount - 1] + ) + ) + +parallelCompositionEntries :: Int -> Int -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +parallelCompositionEntries objectTotal parallelCount = + strictObjectTriples objectTotal + >>= ( \(sourceKey, middleKey, targetKey) -> + [ ( ( parallelMorphismId objectTotal parallelCount middleKey targetKey leftVariant, + parallelMorphismId objectTotal parallelCount sourceKey middleKey rightVariant + ), + parallelMorphismId objectTotal parallelCount sourceKey targetKey 0 + ) + | leftVariant <- [0 .. parallelCount - 1], + rightVariant <- [0 .. parallelCount - 1] + ] + ) + +parallelMorphismId :: Int -> Int -> Int -> Int -> Int -> FinMorphismId +parallelMorphismId objectTotal parallelCount sourceKey targetKey variantKey = + FinGeneratorMorphismId (FinGeneratorId ((((sourceKey * objectTotal) + targetKey) * parallelCount) + variantKey)) + +thinOrderCompositionPairs :: FinCat -> Int -> Either String [(FinMor, FinMor)] +thinOrderCompositionPairs categoryValue objectTotal = + strictObjectTriples objectTotal + & traverse + ( \(sourceKey, middleKey, targetKey) -> + (,) + <$> finMorphismByKeys categoryValue middleKey targetKey + <*> finMorphismByKeys categoryValue sourceKey middleKey + ) + +finMorphismByKeys :: FinCat -> Int -> Int -> Either String FinMor +finMorphismByKeys categoryValue sourceKey targetKey = + first + show + (mkFinMorphism categoryValue (thinMorphismId sourceKey targetKey)) + +thinMorphismId :: Int -> Int -> FinMorphismId +thinMorphismId sourceKey targetKey = + FinGeneratorMorphismId (FinGeneratorId (sourceKey * 4096 + targetKey)) + +finMorphismWeight :: FinMor -> Int +finMorphismWeight morphism = + finMorCategoryHandle morphism + `seq` finMorphismIdWeight (finMorId morphism) + + finObjectIdWeight (finMorSourceId morphism) + + finObjectIdWeight (finMorTargetId morphism) + +finObjectIdWeight :: FinObjectId -> Int +finObjectIdWeight (FinObjectId objectKey) = + objectKey + +finMorphismIdWeight :: FinMorphismId -> Int +finMorphismIdWeight morphismId = + case morphismId of + FinIdentityId (FinObjectId objectKey) -> objectKey + FinGeneratorMorphismId (FinGeneratorId generatorKey) -> generatorKey + +objectSetWeight :: Set FinObjectId -> Int +objectSetWeight = + sum . fmap finObjectIdWeight . Set.toAscList + +rnfFinCat :: FinCat -> () +rnfFinCat categoryValue = + finCatWeight categoryValue + `seq` sourceBucketWeight categoryValue + `seq` allMorphismsWeight categoryValue + `seq` () + +allMorphismsWeight :: FinCat -> Int +allMorphismsWeight categoryValue = + allMorphisms categoryValue + & fmap finMorphismWeight + & sum + +rnfFinMorphismPairs :: [(FinMor, FinMor)] -> () +rnfFinMorphismPairs morphismPairs = + morphismPairs + & List.foldl' + ( \accumulated (leftMorphism, rightMorphism) -> + accumulated + finMorphismWeight leftMorphism + finMorphismWeight rightMorphism + ) + 0 + & (`seq` ()) + +rnfMaybeFinMorphismPair :: Maybe (FinMor, FinMor) -> () +rnfMaybeFinMorphismPair maybePair = + case maybePair of + Nothing -> () + Just (leftMorphism, rightMorphism) -> + finMorphismWeight leftMorphism + `seq` finMorphismWeight rightMorphism + `seq` () + +representativeCompositionPair :: FinCat -> Maybe (FinMor, FinMor) +representativeCompositionPair categoryValue = + allMorphisms categoryValue + >>= ( \rightMorphism -> + case mkFinObject categoryValue (finMorTargetId rightMorphism) of + Left _ -> [] + Right middleObject -> + allMorphismsFrom categoryValue middleObject + & filter nonIdentityMorphism + & fmap (,rightMorphism) + ) + & filter (nonIdentityMorphism . snd) + & firstMaybe + +nonIdentityMorphism :: FinMor -> Bool +nonIdentityMorphism morphism = + case finMorId morphism of + FinIdentityId _ -> False + FinGeneratorMorphismId _ -> True + +firstMaybe :: [value] -> Maybe value +firstMaybe values = + case values of + [] -> Nothing + firstValue : _ -> Just firstValue diff --git a/bench/finite/FiniteBench.hs b/bench/finite/FiniteBench.hs new file mode 100644 --- /dev/null +++ b/bench/finite/FiniteBench.hs @@ -0,0 +1,16 @@ +module FiniteBench + ( finiteBenchmarks, + ) +where + +import FinCat (finCatBenchmarks) +import Invertibility (invertibilityBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +finiteBenchmarks :: Benchmark +finiteBenchmarks = + bgroup + "finite" + [ finCatBenchmarks, + invertibilityBenchmarks + ] diff --git a/bench/finite/Invertibility.hs b/bench/finite/Invertibility.hs new file mode 100644 --- /dev/null +++ b/bench/finite/Invertibility.hs @@ -0,0 +1,274 @@ +module Invertibility + ( invertibilityBenchmarks, + ) +where + +import Control.DeepSeq (NFData (..)) +import Data.Function ((&)) +import Data.Map.Strict qualified as Map +import Data.Monoid (Sum (..)) +import Data.Set qualified as Set +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + FinMor, + allObjects, + finCatMorphismCount, + objectCount, + finMorId, + finMorSourceId, + finMorTargetId, + finObjId, + foldMapFinMorphisms, + mkFinCat, + ) +import Moonlight.Category.Pure.Invertibility + ( AutomorphismGroupoid, + CoreGroupoid, + InvertibilityIndex, + automorphismGroupAt, + automorphismGroupoid, + automorphismGroupoidFromIndex, + automorphismGroupoidObjects, + coreGroupoid, + coreGroupoidFromIndex, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + coreGroupoidObjects, + forgetAutomorphismGroupoidMorphism, + forgetAutomorphismGroupoidObject, + forgetCoreGroupoidMorphism, + forgetCoreGroupoidObject, + invertibilityIndex, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +data PreparedInvertibilityCase = PreparedInvertibilityCase + { preparedObjectCount :: !Int, + preparedCategory :: !FinCat + } + +data PreparedIndexedInvertibilityCase = PreparedIndexedInvertibilityCase + { preparedIndexedObjectCount :: !Int, + preparedIndexedCategory :: !FinCat, + preparedIndex :: InvertibilityIndex FinCat + } + +instance NFData PreparedInvertibilityCase where + rnf prepared = + preparedObjectCount prepared + `seq` finCatDeepWeight (preparedCategory prepared) + `seq` () + +instance NFData PreparedIndexedInvertibilityCase where + rnf prepared = + preparedIndexedObjectCount prepared + `seq` invertibilityIndexWeight (preparedIndexedCategory prepared) (preparedIndex prepared) + `seq` () + +invertibilityBenchmarks :: Benchmark +invertibilityBenchmarks = + bgroup + "invertibility / core groupoid" + [ bgroup + "complete pair-groupoid construction" + (fmap completePairGroupoidBenchmark [4, 8, 12]), + bgroup + "index construction by size" + (fmap preparedInvertibilityIndexBenchmark [4, 8, 12]), + preparedIndexedViewBenchmarks 12 + ] + +completePairGroupoidBenchmark :: Int -> Benchmark +completePairGroupoidBenchmark categoryObjectCount = + bench ("n=" <> show categoryObjectCount) (nf completePairGroupoidWeight categoryObjectCount) + +preparedInvertibilityIndexBenchmark :: Int -> Benchmark +preparedInvertibilityIndexBenchmark categoryObjectCount = + env (prepareCompletePairGroupoid categoryObjectCount) $ \prepared -> + bench ("n=" <> show categoryObjectCount) (nf preparedInvertibilityIndexWeight prepared) + +preparedIndexedViewBenchmarks :: Int -> Benchmark +preparedIndexedViewBenchmarks categoryObjectCount = + env (prepareIndexedInvertibilityCase categoryObjectCount) $ \prepared -> + bgroup + ("precomputed index views n=" <> show categoryObjectCount) + [ bench "coreGroupoidFromIndex" (nf preparedCoreFromIndexWeight prepared), + bench "automorphismGroupoidFromIndex" (nf preparedAutomorphismFromIndexWeight prepared), + bench "coreGroupoidMorphismsBetween all object pairs" (nf preparedCoreBetweenWeight prepared), + bench "automorphismGroupAt all objects" (nf preparedAutomorphismAtWeight prepared), + bench "direct coreGroupoid rebuilds index" (nf preparedDirectCoreGroupoidWeight prepared), + bench "direct automorphismGroupoid rebuilds index" (nf preparedDirectAutomorphismGroupoidWeight prepared) + ] + +prepareCompletePairGroupoid :: Int -> IO PreparedInvertibilityCase +prepareCompletePairGroupoid categoryObjectCount = + case completePairGroupoid categoryObjectCount of + Left failure -> ioError (userError failure) + Right categoryValue -> + finCatDeepWeight categoryValue `seq` pure (PreparedInvertibilityCase categoryObjectCount categoryValue) + +prepareIndexedInvertibilityCase :: Int -> IO PreparedIndexedInvertibilityCase +prepareIndexedInvertibilityCase categoryObjectCount = do + PreparedInvertibilityCase _ categoryValue <- prepareCompletePairGroupoid categoryObjectCount + let indexValue = invertibilityIndex categoryValue + forcedWeight = invertibilityIndexWeight categoryValue indexValue + forcedWeight `seq` pure (PreparedIndexedInvertibilityCase categoryObjectCount categoryValue indexValue) + +completePairGroupoidWeight :: Int -> Int +completePairGroupoidWeight categoryObjectCount = + completePairGroupoid categoryObjectCount + & either length finCatDeepWeight + +preparedInvertibilityIndexWeight :: PreparedInvertibilityCase -> Int +preparedInvertibilityIndexWeight prepared = + let categoryValue = preparedCategory prepared + in invertibilityIndexWeight categoryValue (invertibilityIndex categoryValue) + +preparedCoreFromIndexWeight :: PreparedIndexedInvertibilityCase -> Int +preparedCoreFromIndexWeight prepared = + let categoryValue = preparedIndexedCategory prepared + indexValue = preparedIndex prepared + in coreGroupoidWeight (coreGroupoidFromIndex categoryValue indexValue) + +preparedAutomorphismFromIndexWeight :: PreparedIndexedInvertibilityCase -> Int +preparedAutomorphismFromIndexWeight prepared = + let categoryValue = preparedIndexedCategory prepared + indexValue = preparedIndex prepared + in automorphismGroupoidWeight (automorphismGroupoidFromIndex categoryValue indexValue) + +preparedCoreBetweenWeight :: PreparedIndexedInvertibilityCase -> Int +preparedCoreBetweenWeight prepared = + let categoryValue = preparedIndexedCategory prepared + indexValue = preparedIndex prepared + groupoidValue = coreGroupoidFromIndex categoryValue indexValue + objects = coreGroupoidObjects groupoidValue + in objects + & fmap + ( \sourceObject -> + objects + & fmap + ( \targetObject -> + coreGroupoidMorphismsBetween groupoidValue sourceObject targetObject + & fmap (finMorphismWeight . forgetCoreGroupoidMorphism) + & sum + ) + & sum + ) + & sum + +preparedAutomorphismAtWeight :: PreparedIndexedInvertibilityCase -> Int +preparedAutomorphismAtWeight prepared = + let categoryValue = preparedIndexedCategory prepared + indexValue = preparedIndex prepared + groupoidValue = automorphismGroupoidFromIndex categoryValue indexValue + in automorphismGroupoidObjects groupoidValue + & fmap + ( \objectValue -> + automorphismGroupAt groupoidValue objectValue + & fmap (finMorphismWeight . forgetAutomorphismGroupoidMorphism) + & sum + ) + & sum + +preparedDirectCoreGroupoidWeight :: PreparedIndexedInvertibilityCase -> Int +preparedDirectCoreGroupoidWeight prepared = + let categoryValue = preparedIndexedCategory prepared + in coreGroupoidWeight (coreGroupoid categoryValue) + +preparedDirectAutomorphismGroupoidWeight :: PreparedIndexedInvertibilityCase -> Int +preparedDirectAutomorphismGroupoidWeight prepared = + let categoryValue = preparedIndexedCategory prepared + in automorphismGroupoidWeight (automorphismGroupoid categoryValue) + +invertibilityIndexWeight :: FinCat -> InvertibilityIndex FinCat -> Int +invertibilityIndexWeight categoryValue indexValue = + coreGroupoidWeight (coreGroupoidFromIndex categoryValue indexValue) + + automorphismGroupoidWeight (automorphismGroupoidFromIndex categoryValue indexValue) + +coreGroupoidWeight :: CoreGroupoid FinCat -> Int +coreGroupoidWeight groupoidValue = + sum (fmap (finObjectWeight . finObjId . forgetCoreGroupoidObject) (coreGroupoidObjects groupoidValue)) + + sum (fmap (finMorphismWeight . forgetCoreGroupoidMorphism) (coreGroupoidMorphisms groupoidValue)) + +automorphismGroupoidWeight :: AutomorphismGroupoid FinCat -> Int +automorphismGroupoidWeight groupoidValue = + sum (fmap (finObjectWeight . finObjId . forgetAutomorphismGroupoidObject) (automorphismGroupoidObjects groupoidValue)) + + automorphismWeight + where + automorphismWeight = + automorphismGroupoidObjects groupoidValue + & fmap + ( \objectValue -> + automorphismGroupAt groupoidValue objectValue + & fmap (finMorphismWeight . forgetAutomorphismGroupoidMorphism) + & sum + ) + & sum + +finCatDeepWeight :: FinCat -> Int +finCatDeepWeight categoryValue = + finCatShapeWeight categoryValue + + getSum (foldMapFinMorphisms (Sum . finMorphismWeight) categoryValue) + +finCatShapeWeight :: FinCat -> Int +finCatShapeWeight categoryValue = + objectCount categoryValue + + finCatMorphismCount categoryValue + + sum (fmap (finObjectWeight . finObjId) (allObjects categoryValue)) + +completePairGroupoid :: Int -> Either String FinCat +completePairGroupoid categoryObjectCount = + mkFinCat objects morphismMap compositionMap + & either (Left . show) Right + where + objectIds = fmap FinObjectId [0 .. categoryObjectCount - 1] + objects = Set.fromList objectIds + nonIdentityEndpoints = + [ (sourceId, targetId) + | sourceId <- objectIds, + targetId <- objectIds, + sourceId /= targetId + ] + morphismMap = + nonIdentityEndpoints + & fmap (\(sourceId, targetId) -> ((sourceId, targetId), [generatorMorphismId categoryObjectCount sourceId targetId])) + & Map.fromList + compositionMap = + [ ( (generatorMorphismId categoryObjectCount middleId targetId, generatorMorphismId categoryObjectCount sourceId middleId), + resultMorphismId categoryObjectCount sourceId targetId + ) + | sourceId <- objectIds, + middleId <- objectIds, + targetId <- objectIds, + sourceId /= middleId, + middleId /= targetId + ] + & Map.fromList + +generatorMorphismId :: Int -> FinObjectId -> FinObjectId -> FinMorphismId +generatorMorphismId categoryObjectCount (FinObjectId sourceId) (FinObjectId targetId) = + FinGeneratorMorphismId (FinGeneratorId (sourceId * categoryObjectCount + targetId)) + +resultMorphismId :: Int -> FinObjectId -> FinObjectId -> FinMorphismId +resultMorphismId categoryObjectCount sourceId targetId = + if sourceId == targetId + then FinIdentityId sourceId + else generatorMorphismId categoryObjectCount sourceId targetId + +finObjectWeight :: FinObjectId -> Int +finObjectWeight (FinObjectId objectId) = objectId + +finMorphismWeight :: FinMor -> Int +finMorphismWeight morphismValue = + finMorphismIdWeight (finMorId morphismValue) + + finObjectWeight (finMorSourceId morphismValue) + + finObjectWeight (finMorTargetId morphismValue) + +finMorphismIdWeight :: FinMorphismId -> Int +finMorphismIdWeight morphismId = + case morphismId of + FinIdentityId objectId -> finObjectWeight objectId + FinGeneratorMorphismId (FinGeneratorId generatorId) -> generatorId diff --git a/bench/finite/Main.hs b/bench/finite/Main.hs new file mode 100644 --- /dev/null +++ b/bench/finite/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import FiniteBench (finiteBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [finiteBenchmarks] diff --git a/bench/indexed/IndexedBench.hs b/bench/indexed/IndexedBench.hs new file mode 100644 --- /dev/null +++ b/bench/indexed/IndexedBench.hs @@ -0,0 +1,13 @@ +module IndexedBench + ( indexedBenchmarks, + ) +where + +import Simplex (indexedSimplexBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +indexedBenchmarks :: Benchmark +indexedBenchmarks = + bgroup + "indexed" + [indexedSimplexBenchmarks] diff --git a/bench/indexed/Main.hs b/bench/indexed/Main.hs new file mode 100644 --- /dev/null +++ b/bench/indexed/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import IndexedBench (indexedBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [indexedBenchmarks] diff --git a/bench/indexed/Simplex.hs b/bench/indexed/Simplex.hs new file mode 100644 --- /dev/null +++ b/bench/indexed/Simplex.hs @@ -0,0 +1,99 @@ +module Simplex + ( indexedSimplexBenchmarks, + ) +where + +import BenchSupport (sampleBatch512) +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Indexed.Category qualified as Indexed +import Moonlight.Category.Pure.Indexed.Simplex + ( S, + Simplex, + Z, + codegeneracyFirst, + codegeneracyLast, + codegeneracySucc, + cofaceFirst, + cofaceLast, + cofaceSucc, + simplexSucc, + simplexValues, + simplexZero, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +type N0 = Z +type N1 = S N0 +type N2 = S N1 +type N3 = S N2 +type N4 = S N3 +type N5 = S N4 +type N6 = S N5 + +indexedSimplexBenchmarks :: Benchmark +indexedSimplexBenchmarks = + bgroup + "simplex Δ" + [ bench "identity decode Δ6 batch x512" (nf simplexIdentityBatchWeight sampleBatch512), + bench "coface/codegeneracy decode batch x512" (nf simplexGeneratorBatchWeight sampleBatch512), + bench "compose and decode generators batch x512" (nf simplexComposeDecodeBatchWeight sampleBatch512) + ] + +simplexIdentityBatchWeight :: [Int] -> Int +simplexIdentityBatchWeight = + sum . fmap (\seed -> seed + simplexValuesWeight (simplexValues simplex6)) + +simplexGeneratorBatchWeight :: [Int] -> Int +simplexGeneratorBatchWeight = + sum . fmap simplexGeneratorWeight + +simplexGeneratorWeight :: Int -> Int +simplexGeneratorWeight seed = + seed + + case seed `mod` 6 of + 0 -> simplexValuesWeight (simplexValues (cofaceFirst simplex5)) + 1 -> simplexValuesWeight (simplexValues (cofaceLast simplex5)) + 2 -> simplexValuesWeight (simplexValues (cofaceSucc (cofaceFirst simplex4))) + 3 -> simplexValuesWeight (simplexValues (codegeneracyFirst simplex5)) + 4 -> simplexValuesWeight (simplexValues (codegeneracyLast simplex5)) + _ -> simplexValuesWeight (simplexValues (codegeneracySucc (codegeneracyFirst simplex4))) + +simplexComposeDecodeBatchWeight :: [Int] -> Int +simplexComposeDecodeBatchWeight = + sum . fmap simplexComposeDecodeWeight + +simplexComposeDecodeWeight :: Int -> Int +simplexComposeDecodeWeight seed = + let left = codegeneracyFirst simplex5 :: Simplex N6 N5 + right = cofaceFirst simplex5 :: Simplex N5 N6 + identityLike = left Indexed.. right + shifted = cofaceSucc (cofaceSucc (cofaceFirst simplex3)) + collapsed = codegeneracySucc (codegeneracySucc (codegeneracyFirst simplex3)) + in seed + + simplexValuesWeight (simplexValues identityLike) + + simplexValuesWeight (simplexValues (collapsed Indexed.. shifted)) + +simplexValuesWeight :: [Natural] -> Int +simplexValuesWeight = + sum . fmap fromIntegral + +simplex0 :: Simplex N0 N0 +simplex0 = simplexZero + +simplex1 :: Simplex N1 N1 +simplex1 = simplexSucc simplex0 + +simplex2 :: Simplex N2 N2 +simplex2 = simplexSucc simplex1 + +simplex3 :: Simplex N3 N3 +simplex3 = simplexSucc simplex2 + +simplex4 :: Simplex N4 N4 +simplex4 = simplexSucc simplex3 + +simplex5 :: Simplex N5 N5 +simplex5 = simplexSucc simplex4 + +simplex6 :: Simplex N6 N6 +simplex6 = simplexSucc simplex5 diff --git a/bench/simplicial/Main.hs b/bench/simplicial/Main.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import SimplicialBench (simplicialBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [simplicialBenchmarks] diff --git a/bench/simplicial/SimplicialBench.hs b/bench/simplicial/SimplicialBench.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/SimplicialBench.hs @@ -0,0 +1,18 @@ +module SimplicialBench + ( simplicialBenchmarks, + ) +where + +import SimplicialDelta (deltaBenchmarks) +import SimplicialNerve (nerveBenchmarks) +import SimplicialSpaces (generatedSpaceBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +simplicialBenchmarks :: Benchmark +simplicialBenchmarks = + bgroup + "simplicial" + [ deltaBenchmarks, + generatedSpaceBenchmarks, + nerveBenchmarks + ] diff --git a/bench/simplicial/SimplicialDelta.hs b/bench/simplicial/SimplicialDelta.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/SimplicialDelta.hs @@ -0,0 +1,84 @@ +module SimplicialDelta + ( deltaBenchmarks, + ) +where + +import Data.Function ((&)) +import Moonlight.Category.Simplicial + ( DeltaMorphism, + allDeltaMorphisms, + deltaCodomainDimension, + deltaDomainDimension, + deltaIdentity, + deltaMapValues, + normalInjection, + normalSurjection, + normalizeDeltaMorphism, + ) +import Numeric.Natural (Natural) +import SimplicialWeight (naturalListWeight, naturalWeight) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +deltaBenchmarks :: Benchmark +deltaBenchmarks = + bgroup + "operational Delta API" + [ bgroup + "allDeltaMorphisms" + (dimensionPairs & fmap (\dimensions -> bench (dimensionPairLabel dimensions) (nf deltaEnumerationWeight dimensions))), + bgroup + "normalizeDeltaMorphism over allDeltaMorphisms" + (dimensionPairs & fmap (\dimensions -> bench (dimensionPairLabel dimensions) (nf deltaNormalizationWeight dimensions))), + bgroup + "normalize identity" + (identityDimensions & fmap (\dimension -> bench ("dimension=" <> show dimension) (nf normalizeIdentityWeight dimension))) + ] + +type DimensionPair = (Natural, Natural) + +dimensionPairs :: [DimensionPair] +dimensionPairs = + [ (3, 3), + (4, 4), + (5, 5), + (6, 4) + ] + +identityDimensions :: [Natural] +identityDimensions = + [ 128, + 512, + 2048 + ] + +dimensionPairLabel :: DimensionPair -> String +dimensionPairLabel (domainDimension, codomainDimension) = + "domain=" <> show domainDimension <> " codomain=" <> show codomainDimension + +deltaEnumerationWeight :: DimensionPair -> Int +deltaEnumerationWeight (domainDimension, codomainDimension) = + allDeltaMorphisms domainDimension codomainDimension + & fmap deltaMorphismWeight + & sum + +deltaNormalizationWeight :: DimensionPair -> Int +deltaNormalizationWeight (domainDimension, codomainDimension) = + allDeltaMorphisms domainDimension codomainDimension + & fmap normalizedDeltaWeight + & sum + +normalizeIdentityWeight :: Natural -> Int +normalizeIdentityWeight = + normalizedDeltaWeight . deltaIdentity + +deltaMorphismWeight :: DeltaMorphism -> Int +deltaMorphismWeight morphism = + naturalWeight (deltaDomainDimension morphism) + + naturalWeight (deltaCodomainDimension morphism) + + naturalListWeight (deltaMapValues morphism) + +normalizedDeltaWeight :: DeltaMorphism -> Int +normalizedDeltaWeight morphism = + maybe 0 + (\normalForm -> naturalListWeight (normalSurjection normalForm) + naturalListWeight (normalInjection normalForm)) + (normalizeDeltaMorphism morphism) diff --git a/bench/simplicial/SimplicialNerve.hs b/bench/simplicial/SimplicialNerve.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/SimplicialNerve.hs @@ -0,0 +1,177 @@ +module SimplicialNerve + ( nerveBenchmarks, + ) +where + +import Control.DeepSeq (NFData (..)) +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Moonlight.Category + ( ComposableChain, + FinCat, + FinCatValidationError, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + allMorphisms, + allObjects, + chainMorphisms, + finMorId, + mkFinCat, + ) +import Moonlight.Category.Simplicial + ( NerveSimplex, + TruncatedNormalizedSSet, + nerve, + nerveSimplexChain, + nerveSimplexDimension, + simplicesAtDimension, + truncationBound, + ) +import Numeric.Natural (Natural) +import SimplicialWeight (naturalWeight) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +nerveBenchmarks :: Benchmark +nerveBenchmarks = + bgroup + "nerve API" + (nerveCases & fmap nerveBenchmark) + +nerveBenchmark :: NerveCase -> Benchmark +nerveBenchmark nerveCase = + env (prepareNerveCategory nerveCase) $ \categoryValue -> + bench (nerveCaseLabel nerveCase) (nf preparedNerveWeight categoryValue) + +data NerveCase = NerveCase + { nerveCaseObjectCount :: !Int, + nerveCaseTruncationBound :: !Natural + } + deriving stock (Eq, Ord, Show) + +nerveCases :: [NerveCase] +nerveCases = + [ NerveCase 4 2, + NerveCase 5 2, + NerveCase 5 3, + NerveCase 6 3 + ] + +data PreparedNerveCategory = PreparedNerveCategory + { preparedNerveTruncationBound :: !Natural, + preparedNerveCategory :: !FinCat + } + +instance NFData PreparedNerveCategory where + rnf prepared = + preparedNerveCategoryWeight prepared `seq` () + +nerveCaseLabel :: NerveCase -> String +nerveCaseLabel nerveCase = + "nerve FinCat thin-total-order objects=" + <> show (nerveCaseObjectCount nerveCase) + <> " bound=" + <> show (nerveCaseTruncationBound nerveCase) + +prepareNerveCategory :: NerveCase -> IO PreparedNerveCategory +prepareNerveCategory nerveCase = + case first NonEmpty.toList (thinTotalOrderCategory (nerveCaseObjectCount nerveCase)) of + Left errors -> fail ("invalid nerve benchmark category: " <> show errors) + Right categoryValue -> + pure + PreparedNerveCategory + { preparedNerveTruncationBound = nerveCaseTruncationBound nerveCase, + preparedNerveCategory = categoryValue + } + +thinTotalOrderCategory :: Int -> Either (NonEmpty FinCatValidationError) FinCat +thinTotalOrderCategory objectCount = + mkFinCat + (Set.fromAscList (FinObjectId <$> objectKeys objectCount)) + (Map.fromList (morphismBuckets objectCount)) + (Map.fromList (compositionEntries objectCount)) + +objectKeys :: Int -> [Int] +objectKeys objectCount = + [0 .. objectCount - 1] + +strictObjectPairs :: Int -> [(Int, Int)] +strictObjectPairs objectCount = + objectKeys objectCount + >>= (\sourceKey -> fmap (\targetKey -> (sourceKey, targetKey)) [sourceKey + 1 .. objectCount - 1]) + +morphismBuckets :: Int -> [((FinObjectId, FinObjectId), [FinMorphismId])] +morphismBuckets objectCount = + strictObjectPairs objectCount + & fmap + ( \(sourceKey, targetKey) -> + ( (FinObjectId sourceKey, FinObjectId targetKey), + [thinMorphismId sourceKey targetKey] + ) + ) + +compositionEntries :: Int -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +compositionEntries objectCount = + objectKeys objectCount + >>= (\sourceKey -> [sourceKey + 1 .. objectCount - 1] >>= middleEntries sourceKey) + where + middleEntries sourceKey middleKey = + [middleKey + 1 .. objectCount - 1] + & fmap + ( \targetKey -> + ( (thinMorphismId middleKey targetKey, thinMorphismId sourceKey middleKey), + thinMorphismId sourceKey targetKey + ) + ) + +thinMorphismId :: Int -> Int -> FinMorphismId +thinMorphismId sourceKey targetKey = + FinGeneratorMorphismId (FinGeneratorId (sourceKey * 1024 + targetKey)) + +nerveWeight :: Natural -> FinCat -> Int +nerveWeight upperBound categoryValue = + nerve categoryValue upperBound + & nerveSSetWeight + +preparedNerveWeight :: PreparedNerveCategory -> Int +preparedNerveWeight prepared = + nerveWeight + (preparedNerveTruncationBound prepared) + (preparedNerveCategory prepared) + +preparedNerveCategoryWeight :: PreparedNerveCategory -> Int +preparedNerveCategoryWeight prepared = + length (allObjects (preparedNerveCategory prepared)) + + length (allMorphisms (preparedNerveCategory prepared)) + + naturalWeight (preparedNerveTruncationBound prepared) + +nerveSSetWeight :: TruncatedNormalizedSSet (NerveSimplex FinCat) -> Int +nerveSSetWeight simplicialSet = + [0 .. truncationBound simplicialSet] + & fmap (nerveSimplicesWeight . simplicesAtDimension simplicialSet) + & sum + +nerveSimplicesWeight :: [NerveSimplex FinCat] -> Int +nerveSimplicesWeight = + sum . fmap nerveSimplexWeight + +nerveSimplexWeight :: NerveSimplex FinCat -> Int +nerveSimplexWeight simplexValue = + naturalWeight (nerveSimplexDimension simplexValue) + + composableChainWeight (nerveSimplexChain simplexValue) + +composableChainWeight :: ComposableChain FinCat -> Int +composableChainWeight chainValue = + chainMorphisms chainValue + & fmap (finMorphismWeight . finMorId) + & sum + +finMorphismWeight :: FinMorphismId -> Int +finMorphismWeight morphismId = + case morphismId of + FinIdentityId (FinObjectId objectKey) -> objectKey + FinGeneratorMorphismId (FinGeneratorId generatorKey) -> generatorKey diff --git a/bench/simplicial/SimplicialSpaces.hs b/bench/simplicial/SimplicialSpaces.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/SimplicialSpaces.hs @@ -0,0 +1,199 @@ +module SimplicialSpaces + ( generatedSpaceBenchmarks, + ) +where + +import Data.Function ((&)) +import Moonlight.Category.Simplicial + ( GeneratedSSet, + boundarySimplex, + boundarySimplexGenerated, + generatedSimplicesAtDimension, + hornSimplex, + hornSimplexGenerated, + normalizeGeneratedSSet, + standardSimplex, + standardSimplexGenerated, + validateGeneratedSSet, + ) +import Numeric.Natural (Natural) +import SimplicialWeight + ( naturalSSetWeight, + naturalSimplicesWeight, + obstructionWeight, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf) + +generatedSpaceBenchmarks :: Benchmark +generatedSpaceBenchmarks = + bgroup + "simplicial space API" + [ bgroup + "normalized constructors" + [ bgroup + "standardSimplex" + (spaceCases & fmap (\spaceCase -> bench (spaceCaseLabel spaceCase) (nf standardSimplexWeight spaceCase))), + bgroup + "boundarySimplex" + (spaceCases & fmap (\spaceCase -> bench (spaceCaseLabel spaceCase) (nf boundarySimplexWeight spaceCase))), + bgroup + "hornSimplex" + (hornSpaceCases & fmap (\spaceCase -> bench (hornSpaceCaseLabel spaceCase) (nf hornSimplexWeight spaceCase))) + ], + bgroup + "normalizeGeneratedSSet . standardSimplexGenerated" + (spaceCases & fmap (\spaceCase -> bench (spaceCaseLabel spaceCase) (nf standardNormalizationWeight spaceCase))), + bgroup + "normalizeGeneratedSSet . boundarySimplexGenerated" + (spaceCases & fmap (\spaceCase -> bench (spaceCaseLabel spaceCase) (nf boundaryNormalizationWeight spaceCase))), + bgroup + "validateGeneratedSSet" + (generatedValidationCases & fmap validationBenchmark) + ] + +validationBenchmark :: GeneratedValidationCase -> Benchmark +validationBenchmark validationCase = + bench (generatedValidationCaseLabel validationCase) (nf generatedValidationWeight validationCase) + +data SpaceCase = SpaceCase + { spaceCaseSimplexDimension :: !Natural, + spaceCaseTruncationBound :: !Natural + } + deriving stock (Eq, Ord, Show) + +spaceCases :: [SpaceCase] +spaceCases = + [ SpaceCase 3 3, + SpaceCase 4 4, + SpaceCase 5 4, + SpaceCase 6 4 + ] + +spaceCaseLabel :: SpaceCase -> String +spaceCaseLabel spaceCase = + "simplex=" <> show (spaceCaseSimplexDimension spaceCase) <> " bound=" <> show (spaceCaseTruncationBound spaceCase) + +standardSimplexWeight :: SpaceCase -> Int +standardSimplexWeight spaceCase = + standardSimplex (spaceCaseSimplexDimension spaceCase) (spaceCaseTruncationBound spaceCase) + & naturalSSetWeight + +boundarySimplexWeight :: SpaceCase -> Int +boundarySimplexWeight spaceCase = + boundarySimplex (spaceCaseSimplexDimension spaceCase) (spaceCaseTruncationBound spaceCase) + & naturalSSetWeight + +standardNormalizationWeight :: SpaceCase -> Int +standardNormalizationWeight spaceCase = + standardSimplexGenerated (spaceCaseSimplexDimension spaceCase) (spaceCaseTruncationBound spaceCase) + & normalizeGeneratedSSet + & naturalSSetWeight + +boundaryNormalizationWeight :: SpaceCase -> Int +boundaryNormalizationWeight spaceCase = + boundarySimplexGenerated (spaceCaseSimplexDimension spaceCase) (spaceCaseTruncationBound spaceCase) + & normalizeGeneratedSSet + & naturalSSetWeight + +data HornSpaceCase = HornSpaceCase + { hornSpaceCaseSimplexDimension :: !Natural, + hornSpaceCaseMissingFaceIndex :: !Natural, + hornSpaceCaseTruncationBound :: !Natural + } + deriving stock (Eq, Ord, Show) + +hornSpaceCases :: [HornSpaceCase] +hornSpaceCases = + [ HornSpaceCase 3 1 3, + HornSpaceCase 4 1 4, + HornSpaceCase 5 2 4, + HornSpaceCase 6 2 4 + ] + +hornSpaceCaseLabel :: HornSpaceCase -> String +hornSpaceCaseLabel spaceCase = + "simplex=" + <> show (hornSpaceCaseSimplexDimension spaceCase) + <> " missing=" + <> show (hornSpaceCaseMissingFaceIndex spaceCase) + <> " bound=" + <> show (hornSpaceCaseTruncationBound spaceCase) + +hornSimplexWeight :: HornSpaceCase -> Int +hornSimplexWeight spaceCase = + maybe + 0 + naturalSSetWeight + ( hornSimplex + (hornSpaceCaseSimplexDimension spaceCase) + (hornSpaceCaseMissingFaceIndex spaceCase) + (hornSpaceCaseTruncationBound spaceCase) + ) + +data GeneratedValidationKind + = ValidateStandard + | ValidateBoundary + | ValidateHorn !Natural + deriving stock (Eq, Ord, Show) + +data GeneratedValidationCase = GeneratedValidationCase + { generatedValidationKind :: !GeneratedValidationKind, + generatedValidationSimplexDimension :: !Natural, + generatedValidationTruncationBound :: !Natural + } + deriving stock (Eq, Ord, Show) + +generatedValidationCases :: [GeneratedValidationCase] +generatedValidationCases = + [ GeneratedValidationCase ValidateStandard 4 4, + GeneratedValidationCase ValidateBoundary 4 4, + GeneratedValidationCase (ValidateHorn 1) 4 4, + GeneratedValidationCase (ValidateHorn 2) 5 4 + ] + +generatedValidationCaseLabel :: GeneratedValidationCase -> String +generatedValidationCaseLabel validationCase = + case generatedValidationKind validationCase of + ValidateStandard -> baseLabel "standardSimplexGenerated" + ValidateBoundary -> baseLabel "boundarySimplexGenerated" + ValidateHorn missingFace -> baseLabel ("hornSimplexGenerated missing=" <> show missingFace) + where + baseLabel prefix = + prefix + <> " simplex=" + <> show (generatedValidationSimplexDimension validationCase) + <> " bound=" + <> show (generatedValidationTruncationBound validationCase) + +generatedFromValidationCase :: GeneratedValidationCase -> Maybe (GeneratedSSet [Natural]) +generatedFromValidationCase validationCase = + case generatedValidationKind validationCase of + ValidateStandard -> Just (standardGenerated validationCase) + ValidateBoundary -> Just (boundaryGenerated validationCase) + ValidateHorn missingFace -> + hornSimplexGenerated (generatedValidationSimplexDimension validationCase) missingFace (generatedValidationTruncationBound validationCase) + +standardGenerated :: GeneratedValidationCase -> GeneratedSSet [Natural] +standardGenerated validationCase = + standardSimplexGenerated + (generatedValidationSimplexDimension validationCase) + (generatedValidationTruncationBound validationCase) + +boundaryGenerated :: GeneratedValidationCase -> GeneratedSSet [Natural] +boundaryGenerated validationCase = + boundarySimplexGenerated + (generatedValidationSimplexDimension validationCase) + (generatedValidationTruncationBound validationCase) + +validateGeneratedWeight :: GeneratedSSet [Natural] -> Int +validateGeneratedWeight generatedSet = + case validateGeneratedSSet generatedSet of + Left obstructions -> obstructionWeight obstructions + Right () -> + [0 .. 4] + & fmap (naturalSimplicesWeight . generatedSimplicesAtDimension generatedSet) + & sum + +generatedValidationWeight :: GeneratedValidationCase -> Int +generatedValidationWeight validationCase = + maybe 0 validateGeneratedWeight (generatedFromValidationCase validationCase) diff --git a/bench/simplicial/SimplicialWeight.hs b/bench/simplicial/SimplicialWeight.hs new file mode 100644 --- /dev/null +++ b/bench/simplicial/SimplicialWeight.hs @@ -0,0 +1,44 @@ +module SimplicialWeight + ( naturalListWeight, + naturalSSetWeight, + naturalSimplicesWeight, + naturalWeight, + obstructionWeight, + ) +where + +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Category.Simplicial + ( TruncatedNormalizedSSet, + simplicesAtDimension, + truncationBound, + ) +import Numeric.Natural (Natural) + +naturalSSetWeight :: TruncatedNormalizedSSet [Natural] -> Int +naturalSSetWeight simplicialSet = + [0 .. truncationBound simplicialSet] + & fmap (naturalSimplicesWeight . simplicesAtDimension simplicialSet) + & sum + +naturalSimplicesWeight :: [[Natural]] -> Int +naturalSimplicesWeight = + sum . fmap naturalSimplexWeight + +naturalSimplexWeight :: [Natural] -> Int +naturalSimplexWeight values = + length values + naturalListWeight values + +naturalListWeight :: [Natural] -> Int +naturalListWeight = + sum . fmap naturalWeight + +naturalWeight :: Natural -> Int +naturalWeight = + fromIntegral + +obstructionWeight :: NonEmpty obstruction -> Int +obstructionWeight = + length . NonEmpty.toList diff --git a/bench/site/Main.hs b/bench/site/Main.hs new file mode 100644 --- /dev/null +++ b/bench/site/Main.hs @@ -0,0 +1,11 @@ +module Main + ( main, + ) +where + +import SiteBench (siteBenchmarks) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = + defaultMain [siteBenchmarks] diff --git a/bench/site/SiteBench.hs b/bench/site/SiteBench.hs new file mode 100644 --- /dev/null +++ b/bench/site/SiteBench.hs @@ -0,0 +1,19 @@ +module SiteBench + ( siteBenchmarks, + ) +where + +import SiteManifest (siteManifestBenchmarks) +import SitePathQuotient (sitePathQuotientBenchmarks) +import Test.Tasty.Bench (Benchmark, bgroup) + +siteBenchmarks :: Benchmark +siteBenchmarks = + bgroup + "site" + [ bgroup + "Site API" + [ siteManifestBenchmarks, + sitePathQuotientBenchmarks + ] + ] diff --git a/bench/site/SiteCases.hs b/bench/site/SiteCases.hs new file mode 100644 --- /dev/null +++ b/bench/site/SiteCases.hs @@ -0,0 +1,135 @@ +module SiteCases + ( SiteCase (..), + pathSiteCases, + siteCaseLabel, + siteCases, + siteEndpointObjectIds, + siteEndpoints, + siteManifestFromCase, + ) +where + +import Data.Function ((&)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import FinCat (objectKeys) +import Moonlight.Category.Pure.FinCat (FinObjectId (..)) +import Moonlight.Category.Pure.Site.Core (SiteManifest (..)) +import Moonlight.Category.Pure.Site.Graph (reachableClosure) + +data SiteCase + = LinearSite !Int + | LayeredSite !Int !Int + deriving stock (Eq, Ord, Show) + +siteCases :: [SiteCase] +siteCases = + [ LinearSite 16, + LinearSite 64, + LayeredSite 3 5, + LayeredSite 4 5 + ] + +pathSiteCases :: [SiteCase] +pathSiteCases = + [ LinearSite 16, + LayeredSite 2 8, + LayeredSite 3 6 + ] + +siteCaseLabel :: SiteCase -> String +siteCaseLabel siteCase = + case siteCase of + LinearSite objectCount -> "linear objects=" <> show objectCount + LayeredSite width depth -> "layered width=" <> show width <> " depth=" <> show depth + +siteManifestFromCase :: SiteCase -> SiteManifest Int +siteManifestFromCase siteCase = + case siteCase of + LinearSite objectCount -> linearSiteManifest objectCount + LayeredSite width depth -> layeredSiteManifest width depth + +siteEndpoints :: SiteCase -> (Int, Int) +siteEndpoints siteCase = + case siteCase of + LinearSite objectCount -> (0, objectCount - 1) + LayeredSite width depth -> (layeredNode width 0 0, layeredNode width depth 0) + +siteEndpointObjectIds :: SiteCase -> SiteManifest Int -> Either String (FinObjectId, FinObjectId) +siteEndpointObjectIds siteCase manifest = + case (Map.lookup sourceValue objectIds, Map.lookup targetValue objectIds) of + (Just sourceId, Just targetId) -> Right (sourceId, targetId) + _ -> Left ("site endpoint missing from manifest: " <> show (sourceValue, targetValue)) + where + (sourceValue, targetValue) = siteEndpoints siteCase + objectIds = + siteObjects manifest + & Set.toAscList + & zip (FinObjectId <$> [0 ..]) + & fmap (\(objectId, objectValue) -> (objectValue, objectId)) + & Map.fromList + +linearSiteManifest :: Int -> SiteManifest Int +linearSiteManifest objectCount = + validSiteManifest objects imports + where + objects = Set.fromAscList (objectKeys objectCount) + imports = + objectKeys objectCount + & fmap + ( \objectKey -> + ( objectKey, + if objectKey + 1 < objectCount + then Set.singleton (objectKey + 1) + else Set.empty + ) + ) + & Map.fromAscList + +layeredSiteManifest :: Int -> Int -> SiteManifest Int +layeredSiteManifest width depth = + validSiteManifest objects imports + where + layers = [0 .. depth] + objects = + layers + >>= (\layer -> layeredSlots width depth layer & fmap (layeredNode width layer)) + & Set.fromList + imports = + layers + >>= (\layer -> layeredSlots width depth layer & fmap (layerImports layer)) + & Map.fromList + layerImports layer slot = + let sourceNode = layeredNode width layer slot + importedNodes = + if layer < depth + then layeredSlots width depth (layer + 1) & fmap (layeredNode width (layer + 1)) & Set.fromList + else Set.empty + in (sourceNode, importedNodes) + +layeredSlots :: Int -> Int -> Int -> [Int] +layeredSlots width depth layer + | layer == 0 = [0] + | layer == depth = [0] + | otherwise = [0 .. width - 1] + +layeredNode :: Int -> Int -> Int -> Int +layeredNode width layer slot = + layer * width + slot + +validSiteManifest :: Set Int -> Map Int (Set Int) -> SiteManifest Int +validSiteManifest objects imports = + SiteManifest + { siteObjects = objects, + siteImports = imports, + siteCovers = closureCovers objects imports + } + +closureCovers :: Set Int -> Map Int (Set Int) -> Map Int (Set Int) +closureCovers objects imports = + let closureMap = reachableClosure imports + in Map.fromSet + (\objectValue -> Map.findWithDefault Set.empty objectValue closureMap) + objects diff --git a/bench/site/SiteManifest.hs b/bench/site/SiteManifest.hs new file mode 100644 --- /dev/null +++ b/bench/site/SiteManifest.hs @@ -0,0 +1,216 @@ +module SiteManifest + ( siteManifestBenchmarks, + ) +where + +import BenchSupport (BenchSetup (..), prepareBenchValue) +import Control.DeepSeq (NFData (..)) +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Monoid (Sum (..)) +import Data.Set (Set) +import Data.Set qualified as Set +import FinCat + ( compositionMapWeight, + finCatExplicitCompositionMapViewWeight, + finCatExplicitMorphismMapViewWeight, + finMorphismIdWeight, + finMorphismWeight, + finObjectIdWeight, + morphismMapWeight, + objectSetWeight, + representativeCompositionPair, + rnfFinCat, + rnfMaybeFinMorphismPair, + ) +import Moonlight.Category.Pure.Category (composeMor) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinMorphismId, + FinObjectId, + FinMor, + finCatHandle, + finCatMorphismCountFrom, + finCatMorphismCountTo, + finCatMorphismIdByEndpoints, + foldMapFinMorphisms, + ) +import Moonlight.Category.Pure.Site.Compile + ( ThinSitePresentation (..), + siteImportsAsFinCat, + thinSiteKernel, + thinSitePresentation, + ) +import Moonlight.Category.Pure.Site.Core + ( SiteFinCatError, + SiteManifest (..), + SiteViolation, + ) +import Moonlight.Category.Pure.Site.Graph + ( importCycles, + reachableClosure, + ) +import Moonlight.Category.Pure.Site.Manifest (validateSiteManifest) +import SiteCases + ( SiteCase, + siteCaseLabel, + siteCases, + siteEndpointObjectIds, + siteManifestFromCase, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +siteManifestBenchmarks :: Benchmark +siteManifestBenchmarks = + bgroup + "manifest graph and compilation" + (siteCases & fmap siteManifestBenchmark) + +siteManifestBenchmark :: SiteCase -> Benchmark +siteManifestBenchmark siteCase = + let manifest = siteManifestFromCase siteCase + in bgroup + (siteCaseLabel siteCase) + [ bench "validateSiteManifest" (nf validateSiteManifestWeight manifest), + bench "reachableClosure" (nf reachableClosureWeight (siteImports manifest)), + bench "importCycles" (nf importCyclesWeight manifest), + bench "thinSiteKernel + explicit presentation" (nf thinSitePresentationWeight manifest), + bench "siteImportsAsFinCat constructor" (nf siteImportsAsFinCatConstructorWeight manifest), + env (prepareBenchValue (preparedSiteFinCatCase siteCase manifest)) $ \prepared -> + bgroup + "prepared siteImportsAsFinCat" + [ bench "resident endpoint lookup" (nf preparedSiteFinCatEndpointLookupWeight prepared), + bench "resident source incident count" (nf preparedSiteFinCatSourceIncidentCountWeight prepared), + bench "resident target incident count" (nf preparedSiteFinCatTargetIncidentCountWeight prepared), + bench "resident composition" (nf preparedSiteFinCatCompositionWeight prepared), + bench "full morphism enumeration" (nf preparedSiteFinCatFullMorphismEnumerationWeight prepared), + bench "explicit morphism map view" (nf preparedSiteFinCatExplicitMorphismMapViewWeight prepared), + bench "explicit composition map view" (nf preparedSiteFinCatExplicitCompositionMapViewWeight prepared) + ] + ] + +data PreparedSiteFinCatCase = PreparedSiteFinCatCase + { preparedSiteFinCatCategory :: !FinCat, + preparedSiteFinCatSourceId :: !FinObjectId, + preparedSiteFinCatTargetId :: !FinObjectId, + preparedSiteFinCatCompositionPair :: Maybe (FinMor, FinMor) + } + +instance NFData PreparedSiteFinCatCase where + rnf prepared = + rnfFinCat (preparedSiteFinCatCategory prepared) + `seq` finObjectIdWeight (preparedSiteFinCatSourceId prepared) + `seq` finObjectIdWeight (preparedSiteFinCatTargetId prepared) + `seq` rnfMaybeFinMorphismPair (preparedSiteFinCatCompositionPair prepared) + `seq` () + +preparedSiteFinCatCase :: SiteCase -> SiteManifest Int -> BenchSetup PreparedSiteFinCatCase +preparedSiteFinCatCase siteCase manifest = + BenchSetup $ do + categoryValue <- first show (siteImportsAsFinCat manifest) + (sourceId, targetId) <- siteEndpointObjectIds siteCase manifest + pure + PreparedSiteFinCatCase + { preparedSiteFinCatCategory = categoryValue, + preparedSiteFinCatSourceId = sourceId, + preparedSiteFinCatTargetId = targetId, + preparedSiteFinCatCompositionPair = representativeCompositionPair categoryValue + } + +preparedSiteFinCatEndpointLookupWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatEndpointLookupWeight prepared = + finCatMorphismIdByEndpoints + (preparedSiteFinCatCategory prepared) + (preparedSiteFinCatSourceId prepared) + (preparedSiteFinCatTargetId prepared) + & maybe 0 finMorphismIdWeight + +preparedSiteFinCatSourceIncidentCountWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatSourceIncidentCountWeight prepared = + finCatMorphismCountFrom + (preparedSiteFinCatCategory prepared) + (preparedSiteFinCatSourceId prepared) + +preparedSiteFinCatTargetIncidentCountWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatTargetIncidentCountWeight prepared = + finCatMorphismCountTo + (preparedSiteFinCatCategory prepared) + (preparedSiteFinCatTargetId prepared) + +preparedSiteFinCatCompositionWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatCompositionWeight prepared = + case preparedSiteFinCatCompositionPair prepared of + Nothing -> 0 + Just (leftMorphism, rightMorphism) -> + composeMor (preparedSiteFinCatCategory prepared) leftMorphism rightMorphism + & either (const 0) finMorphismWeight + +preparedSiteFinCatFullMorphismEnumerationWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatFullMorphismEnumerationWeight prepared = + foldMapFinMorphisms (Sum . finMorphismWeight) (preparedSiteFinCatCategory prepared) + & getSum + +preparedSiteFinCatExplicitMorphismMapViewWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatExplicitMorphismMapViewWeight = + finCatExplicitMorphismMapViewWeight . preparedSiteFinCatCategory + +preparedSiteFinCatExplicitCompositionMapViewWeight :: PreparedSiteFinCatCase -> Int +preparedSiteFinCatExplicitCompositionMapViewWeight = + finCatExplicitCompositionMapViewWeight . preparedSiteFinCatCategory + +objectIdMapWeight :: Map Int FinObjectId -> Int +objectIdMapWeight = + Map.foldlWithKey' + ( \accumulated objectValue objectId -> + accumulated + objectValue + finObjectIdWeight objectId + ) + 0 + +pairIdMapWeight :: Map (Int, Int) FinMorphismId -> Int +pairIdMapWeight = + Map.foldlWithKey' + ( \accumulated (sourceValue, targetValue) morphismId -> + accumulated + sourceValue + targetValue + finMorphismIdWeight morphismId + ) + 0 + +validateSiteManifestWeight :: SiteManifest Int -> Int +validateSiteManifestWeight = + sum . fmap siteViolationWeight . validateSiteManifest + +reachableClosureWeight :: Map Int (Set Int) -> Int +reachableClosureWeight = + sum . fmap Set.size . Map.elems . reachableClosure + +importCyclesWeight :: SiteManifest Int -> Int +importCyclesWeight manifest = + importCycles manifest + & fmap (length . NonEmpty.toList) + & sum + +thinSitePresentationWeight :: SiteManifest Int -> Int +thinSitePresentationWeight manifest = + case thinSiteKernel manifest of + Left siteError -> siteFinCatErrorWeight siteError + Right kernel -> + let presentation = thinSitePresentation kernel + in objectIdMapWeight (thinPresentationObjectIds presentation) + + pairIdMapWeight (thinPresentationPairIds presentation) + + objectSetWeight (thinPresentationObjects presentation) + + morphismMapWeight (thinPresentationMorphisms presentation) + + compositionMapWeight (thinPresentationComposition presentation) + +siteImportsAsFinCatConstructorWeight :: SiteManifest Int -> Int +siteImportsAsFinCatConstructorWeight manifest = + either siteFinCatErrorWeight (\categoryValue -> finCatHandle categoryValue `seq` 1) (siteImportsAsFinCat manifest) + +siteViolationWeight :: SiteViolation Int -> Int +siteViolationWeight = + length . show + +siteFinCatErrorWeight :: SiteFinCatError Int -> Int +siteFinCatErrorWeight = + length . show diff --git a/bench/site/SitePathQuotient.hs b/bench/site/SitePathQuotient.hs new file mode 100644 --- /dev/null +++ b/bench/site/SitePathQuotient.hs @@ -0,0 +1,170 @@ +module SitePathQuotient + ( sitePathQuotientBenchmarks, + ) +where + +import BenchSupport (BenchSetup (..), prepareBenchValue) +import Control.DeepSeq (NFData (..)) +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import FinCat + ( finCatWeight, + finMorphismWeight, + finObjectIdWeight, + ) +import Moonlight.Category.Pure.FinCat (FinObjectId) +import Moonlight.Category.Pure.Site.Category + ( SitePathCategory, + SitePathMorphism, + sitePathCategory, + sitePathCategoryCodomain, + sitePathCategoryObjectIds, + sitePathManifest, + sitePathMorphismCodomain, + sitePathMorphismNodes, + sitePathMorphismsBetween, + ) +import Moonlight.Category.Pure.Site.Compile (thinSiteKernel) +import Moonlight.Category.Pure.Site.Core (SiteManifest (..)) +import Moonlight.Category.Pure.Site.Quotient + ( SitePathQuotient, + quotientMapMorphism, + sitePathQuotient, + sitePathQuotientCodomain, + sitePathQuotientDomain, + sitePathQuotientObjectIds, + ) +import SiteCases + ( SiteCase, + pathSiteCases, + siteCaseLabel, + siteEndpoints, + siteManifestFromCase, + ) +import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf) + +sitePathQuotientBenchmarks :: Benchmark +sitePathQuotientBenchmarks = + bgroup + "path category and quotient" + (pathSiteCases & fmap sitePathBenchmark) + +sitePathBenchmark :: SiteCase -> Benchmark +sitePathBenchmark siteCase = + env (prepareBenchValue (preparedPathSiteCase siteCase)) $ \prepared -> + bgroup + (siteCaseLabel siteCase) + [ bench "sitePathMorphismsBetween" (nf preparedPathEnumerationWeight prepared), + bench "sitePathQuotient map morphisms" (nf preparedPathQuotientWeight prepared) + ] + +data PreparedPathSiteCase = PreparedPathSiteCase + { preparedPathCategory :: !(SitePathCategory Int), + preparedPathQuotient :: !(SitePathQuotient Int), + preparedPathSource :: !Int, + preparedPathTarget :: !Int + } + +instance NFData PreparedPathSiteCase where + rnf prepared = + rnfSitePathCategory (preparedPathCategory prepared) + `seq` rnfSitePathQuotient (preparedPathQuotient prepared) + `seq` preparedPathSource prepared + `seq` preparedPathTarget prepared + `seq` () + +preparedPathSiteCase :: SiteCase -> BenchSetup PreparedPathSiteCase +preparedPathSiteCase siteCase = + BenchSetup $ do + kernel <- first show (thinSiteKernel manifest) + let categoryValue = sitePathCategory kernel + quotientValue = sitePathQuotient categoryValue + pure + PreparedPathSiteCase + { preparedPathCategory = categoryValue, + preparedPathQuotient = quotientValue, + preparedPathSource = sourceValue, + preparedPathTarget = targetValue + } + where + manifest = siteManifestFromCase siteCase + (sourceValue, targetValue) = siteEndpoints siteCase + +preparedPathEnumerationWeight :: PreparedPathSiteCase -> Int +preparedPathEnumerationWeight prepared = + sitePathMorphismsBetween + (preparedPathCategory prepared) + (preparedPathSource prepared) + (preparedPathTarget prepared) + & fmap sitePathMorphismWeight + & sum + +preparedPathQuotientWeight :: PreparedPathSiteCase -> Int +preparedPathQuotientWeight prepared = + sitePathMorphismsBetween + (preparedPathCategory prepared) + (preparedPathSource prepared) + (preparedPathTarget prepared) + & fmap + ( \morphism -> + either + (const 0) + finMorphismWeight + (quotientMapMorphism (preparedPathQuotient prepared) morphism) + ) + & sum + +rnfSitePathCategory :: SitePathCategory Int -> () +rnfSitePathCategory categoryValue = + sitePathCategoryDeepWeight categoryValue `seq` () + +rnfSitePathQuotient :: SitePathQuotient Int -> () +rnfSitePathQuotient quotientValue = + sitePathQuotientDeepWeight quotientValue `seq` () + +sitePathCategoryDeepWeight :: SitePathCategory Int -> Int +sitePathCategoryDeepWeight categoryValue = + siteManifestWeight (sitePathManifest categoryValue) + + finCatWeight (sitePathCategoryCodomain categoryValue) + + objectIdMapWeight (sitePathCategoryObjectIds categoryValue) + +sitePathQuotientDeepWeight :: SitePathQuotient Int -> Int +sitePathQuotientDeepWeight quotientValue = + sitePathCategoryDeepWeight (sitePathQuotientDomain quotientValue) + + finCatWeight (sitePathQuotientCodomain quotientValue) + + objectIdMapWeight (sitePathQuotientObjectIds quotientValue) + +siteManifestWeight :: SiteManifest Int -> Int +siteManifestWeight manifest = + intSetWeight (siteObjects manifest) + + intSetMapWeight (siteImports manifest) + + intSetMapWeight (siteCovers manifest) + +intSetWeight :: Set Int -> Int +intSetWeight = + sum . Set.toAscList + +intSetMapWeight :: Map Int (Set Int) -> Int +intSetMapWeight = + Map.foldlWithKey' + ( \accumulated objectValue coveredValues -> + accumulated + objectValue + intSetWeight coveredValues + ) + 0 + +objectIdMapWeight :: Map Int FinObjectId -> Int +objectIdMapWeight = + Map.foldlWithKey' + ( \accumulated objectValue objectId -> + accumulated + objectValue + finObjectIdWeight objectId + ) + 0 + +sitePathMorphismWeight :: SitePathMorphism Int -> Int +sitePathMorphismWeight morphism = + length (sitePathMorphismNodes morphism) + + finMorphismWeight (sitePathMorphismCodomain morphism) diff --git a/bench/support/BenchSupport.hs b/bench/support/BenchSupport.hs new file mode 100644 --- /dev/null +++ b/bench/support/BenchSupport.hs @@ -0,0 +1,32 @@ +module BenchSupport + ( BenchSetup (..), + batchWeight, + boolWeight, + prepareBenchValue, + sampleBatch512, + ) +where + +import Data.Kind (Type) + +type BenchSetup :: Type -> Type +newtype BenchSetup value = BenchSetup + { runBenchSetup :: Either String value + } + +prepareBenchValue :: BenchSetup value -> IO value +prepareBenchValue = + either (ioError . userError) pure . runBenchSetup + +sampleBatch512 :: [Int] +sampleBatch512 = [0 .. 511] + +batchWeight :: (Int -> Int) -> [Int] -> Int +batchWeight weight = + sum . fmap weight +{-# INLINE batchWeight #-} + +boolWeight :: Bool -> Int +boolWeight value = + if value then 1 else 0 +{-# INLINE boolWeight #-} diff --git a/moonlight-category.cabal b/moonlight-category.cabal new file mode 100644 --- /dev/null +++ b/moonlight-category.cabal @@ -0,0 +1,528 @@ +cabal-version: 3.4 +name: moonlight-category +version: 0.1.0.0 +homepage: https://github.com/PaleRoses/moonlight +bug-reports: https://github.com/PaleRoses/moonlight/issues +synopsis: Categorical layer for Pale Meridian. +description: + A totalised, explicit-error category abstraction: limits and colimits, a + higher-category class tower, runtime-validated finite categories (@FinCat@), + site and path presentations, adhesive and PBPO rewriting witnesses, structured + cospans and double categories, an indexed typed-arrow layer, and a simplicial + sublibrary for Δ, finite simplicial sets, nerves, and Kan interfaces. + . + For general indexed category theory, prefer Sjoerd Visscher's @data-category@ + package: its typed-arrow calculus is the primary inspiration for this package's + indexed modules, and several modules under "Moonlight.Category.Indexed" are adapted + from it. Thank you to Sjoerd Visscher for the design and implementation work in + @data-category@. See THIRD_PARTY_NOTICES.md. +license: MIT AND BSD-3-Clause +license-files: + LICENSE + THIRD_PARTY_NOTICES.md +copyright: (c) 2026 Blue Rose +author: Blue Rose +maintainer: rosaliafialkova@gmail.com +category: Math +build-type: Simple +tested-with: GHC == 9.14.1 +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/PaleRoses/moonlight.git + subdir: moonlight-category + +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 + FunctionalDependencies + +library abstract + import: shared-properties + visibility: public + hs-source-dirs: src-abstract + exposed-modules: + Moonlight.Category.Pure.CoveringFamily + Moonlight.Category.Pure.CoveringProduct + Moonlight.Category.Pure.Thin + Moonlight.Category.Pure.Category + Moonlight.Category.Pure.DecoratedPresentation + Moonlight.Category.Pure.Limits + Moonlight.Category.Pure.DecoratedComposition + Moonlight.Category.Pure.Adhesive + Moonlight.Category.Pure.StructuredCospan + Moonlight.Category.Pure.DoubleCategory + Moonlight.Category.Pure.PolynomialFunctor + Moonlight.Category.Pure.Higher + Moonlight.Category.Pure.Galois + Moonlight.Category.Pure.FiniteComposable + Moonlight.Category.Pure.Poset + Moonlight.Category.Pure.Unit + build-depends: + base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + +library finite + import: shared-properties + visibility: public + hs-source-dirs: src-finite + exposed-modules: + Moonlight.Category.Pure.FinCat + Moonlight.Category.Pure.FinCat.Functor + Moonlight.Category.Pure.FinPresentation + Moonlight.Category.Pure.Invertibility + Moonlight.Category.Pure.FinCat.Opposite + Moonlight.Category.Pure.Finite.DenseReachability + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , containers >= 0.6 && < 0.9 + , vector >= 0.13 && < 0.14 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-category:abstract + +library site + import: shared-properties + visibility: public + hs-source-dirs: src-site + exposed-modules: + Moonlight.Category.Pure.Site + Moonlight.Category.Pure.Site.Core + Moonlight.Category.Pure.Site.Graph + Moonlight.Category.Pure.Site.Manifest + Moonlight.Category.Pure.Site.Compile + Moonlight.Category.Pure.Site.Category + Moonlight.Category.Pure.Site.Quotient + build-depends: + base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + , vector >= 0.13 && < 0.14 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-category:abstract + , moonlight-category:finite + +library indexed + import: shared-properties + visibility: public + hs-source-dirs: src-indexed + exposed-modules: + Moonlight.Category.Pure.Indexed.Category + Moonlight.Category.Pure.Indexed.Product + Moonlight.Category.Pure.Indexed.Functor + Moonlight.Category.Pure.Indexed.NaturalTransformation + Moonlight.Category.Pure.Indexed.Unit + Moonlight.Category.Pure.Indexed.Void + Moonlight.Category.Pure.Indexed.Coproduct + Moonlight.Category.Pure.Indexed.Adjunction + Moonlight.Category.Pure.Indexed.Limit + Moonlight.Category.Pure.Indexed.KanExtension + Moonlight.Category.Pure.Indexed.Simplex + build-depends: + base >= 4.22 && < 5 + +library simplicial + import: shared-properties + visibility: public + hs-source-dirs: src-simplicial + exposed-modules: + Moonlight.Category.Simplicial + Moonlight.Category.Pure.Simplicial.CategoricalSimplex + Moonlight.Category.Pure.Simplicial.TypeLevel + Moonlight.Category.Pure.Simplicial.Ordinal + Moonlight.Category.Pure.Simplicial.Delta + Moonlight.Category.Pure.Simplicial.Set + Moonlight.Category.Pure.Simplicial.Kan + Moonlight.Category.Pure.Simplicial.Validation + Moonlight.Category.Pure.Simplicial.Presheaf + Moonlight.Category.Pure.Simplicial.Spaces + Moonlight.Category.Pure.Simplicial.Homotopy + Moonlight.Category.Pure.Simplicial.Nerve + other-modules: + Moonlight.Category.Pure.Simplicial.Delta.Types + Moonlight.Category.Pure.Simplicial.Validation.Internal + Moonlight.Category.Pure.Simplicial.Set.Internal + build-depends: + algebraic-graphs >= 0.8 && < 0.9 + , base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:indexed + +library + import: shared-properties + hs-source-dirs: src-public + exposed-modules: + Moonlight.Category + Moonlight.Category.Indexed + Moonlight.Category.Notation + Moonlight.Category.Presentation + build-depends: + base >= 4.22 && < 5 + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:site + , moonlight-category:indexed + +library laws + import: shared-properties + visibility: public + hs-source-dirs: src-laws + exposed-modules: + Moonlight.Category.Effect.Fixture.FinCat + Moonlight.Category.Effect.Harness + Moonlight.Category.Effect.Harness.Adhesive + Moonlight.Category.Effect.Harness.Algebra + Moonlight.Category.Effect.Harness.Category + Moonlight.Category.Effect.Harness.Core + Moonlight.Category.Effect.Harness.Higher + Moonlight.Category.Effect.Harness.Limits + Moonlight.Category.Effect.Harness.Site + Moonlight.Category.Effect.LawNames + Moonlight.Category.Effect.Laws + Moonlight.Category.Effect.PathQuotientHarness + Moonlight.Category.Effect.SiteGen + other-modules: + Moonlight.Category.Effect.Laws.Adhesive + Moonlight.Category.Effect.Laws.Algebra + Moonlight.Category.Effect.Laws.Category + Moonlight.Category.Effect.Laws.Generators + Moonlight.Category.Effect.Laws.Higher + Moonlight.Category.Effect.Laws.Limits + Moonlight.Category.Effect.Laws.Site + Moonlight.Category.Effect.SitePathEnumeration + build-depends: + base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + , tasty >= 1.4 && < 1.6 + , tasty-quickcheck >= 0.10 && < 0.12 + , hedgehog >= 1.2 && < 1.8 + , moonlight-core >= 0.1 && < 0.2 + , moonlight-pale:test-laws >= 0.1 && < 0.2 + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:site + +common category-test-properties + import: shared-properties + build-depends: + base >= 4.22 && < 5 + , tasty >= 1.4 && < 1.6 + +common category-abstract-fixture-slice + other-modules: + Moonlight.Category.Test.CoveringFixture + Moonlight.Category.Test.DoubleFixture + Moonlight.Category.Test.PolynomialFixture + build-depends: + moonlight-category:abstract + +common category-abstract-test-slice + other-modules: + AbstractTests + AdhesiveSpec + CoveringProductSpec + DecoratedPresentationSpec + DoubleCategorySpec + FiniteComposableSpec + PolynomialFunctorWitnessSpec + build-depends: + moonlight-category + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:laws + , moonlight-pale:test >= 0.1 && < 0.2 + , tasty-hunit >= 0.10 && < 0.11 + +common category-finite-test-slice + other-modules: + DenseReachabilitySpec + FiniteTests + FinPresentationSpec + FinThinFunctorSpec + InvertibilitySpec + build-depends: + containers >= 0.6 && < 0.9 + , moonlight-category + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:laws + , moonlight-pale:test >= 0.1 && < 0.2 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.10 && < 0.12 + , QuickCheck >= 2.14 && < 2.19 + , vector >= 0.13 && < 0.14 + +common category-site-test-slice + other-modules: + PathQuotientSpec + SiteSpec + SiteTests + build-depends: + containers >= 0.6 && < 0.9 + , moonlight-category + , moonlight-category:laws + , moonlight-category:site + , tasty-hunit >= 0.10 && < 0.11 + +common category-indexed-test-slice + other-modules: + IndexedSpec + IndexedTests + SimplexSpec + build-depends: + moonlight-category + , moonlight-category:indexed + , tasty-hunit >= 0.10 && < 0.11 + +common category-simplex-test-fixture-slice + other-modules: + Moonlight.Category.Test.IndexedSimplexFixture + build-depends: + moonlight-category + +common category-simplicial-test-slice + other-modules: + CategoricalSimplexSpec + DeltaSpec + HomotopySpec + KanSpec + Laws.Registry + Laws.Suite + NerveSpec + OrdinalSpec + PresheafSpec + SimplicialTests + SpacesSpec + build-depends: + containers >= 0.6 && < 0.9 + , moonlight-category + , moonlight-category:indexed + , moonlight-category:laws + , moonlight-category:simplicial + , moonlight-pale:test-laws >= 0.1 && < 0.2 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.10 && < 0.12 + , QuickCheck >= 2.14 && < 2.19 + +common category-facade-test-slice + other-modules: + FacadeTests + NotationSpec + build-depends: + moonlight-category + , moonlight-pale:test >= 0.1 && < 0.2 + , tasty-hunit >= 0.10 && < 0.11 + +common category-laws-test-slice + build-depends: + moonlight-category:laws + +test-suite moonlight-category-abstract-test + import: category-test-properties, category-abstract-fixture-slice, category-abstract-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + test/abstract + test/support + main-is: Main.hs + +test-suite moonlight-category-finite-test + import: category-test-properties, category-finite-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: test/finite + main-is: Main.hs + +test-suite moonlight-category-site-test + import: category-test-properties, category-site-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: test/site + main-is: Main.hs + +test-suite moonlight-category-indexed-test + import: category-test-properties, category-indexed-test-slice, category-simplex-test-fixture-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + test/indexed + test/support + main-is: Main.hs + +test-suite moonlight-category-simplicial-test + import: category-test-properties, category-simplex-test-fixture-slice, category-simplicial-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + test/simplicial + test/support + main-is: Main.hs + +test-suite moonlight-category-facade-test + import: category-test-properties, category-facade-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: test/facade + main-is: Main.hs + +test-suite moonlight-category-laws-test + import: category-test-properties, category-laws-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: test/laws + main-is: Main.hs + +-- The focused suites own behavior. This component owns only the union of their +-- module, instance, and dependency surfaces, compiled at the shared test O0. +test-suite moonlight-category-coherence-test + import: category-test-properties, category-abstract-fixture-slice, category-abstract-test-slice, category-finite-test-slice, category-site-test-slice, category-indexed-test-slice, category-simplex-test-fixture-slice, category-simplicial-test-slice, category-facade-test-slice, category-laws-test-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + test/coherence + test/abstract + test/finite + test/site + test/indexed + test/simplicial + test/facade + test/support + main-is: Main.hs + +common category-benchmark-properties + import: shared-properties + ghc-options: -O2 -rtsopts + build-depends: + base >= 4.22 && < 5 + , tasty-bench >= 0.3 && < 0.6 + +common category-benchmark-support-slice + other-modules: + BenchSupport + +common category-abstract-benchmark-slice + other-modules: + AbstractBench + AbstractFixtures + Adhesive.Graph + Adhesive.Subset + Adhesive.Suite + Adhesive.Symbolic + Algebraic.Decorated + Algebraic.Double + Algebraic.Galois + Algebraic.Polynomial + Algebraic.StructuredCospan + Algebraic.Suite + Covering + build-depends: + containers >= 0.6 && < 0.9 + , deepseq >= 1.4 && < 1.6 + , moonlight-category:abstract + , vector >= 0.13 && < 0.14 + +common category-fincat-benchmark-slice + other-modules: + FinCat + build-depends: + containers >= 0.6 && < 0.9 + , deepseq >= 1.4 && < 1.6 + , moonlight-category + , moonlight-category:abstract + , moonlight-category:finite + , moonlight-category:laws + +common category-finite-benchmark-slice + other-modules: + FiniteBench + Invertibility + +common category-site-benchmark-slice + other-modules: + SiteBench + SiteCases + SiteManifest + SitePathQuotient + build-depends: + moonlight-category:site + +common category-indexed-benchmark-slice + other-modules: + IndexedBench + Simplex + build-depends: + moonlight-category:indexed + +common category-simplicial-benchmark-slice + other-modules: + SimplicialBench + SimplicialDelta + SimplicialNerve + SimplicialSpaces + SimplicialWeight + build-depends: + containers >= 0.6 && < 0.9 + , deepseq >= 1.4 && < 1.6 + , moonlight-category + , moonlight-category:simplicial + +benchmark moonlight-category-abstract-bench + import: category-benchmark-properties, category-benchmark-support-slice, category-abstract-fixture-slice, category-abstract-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/abstract + bench/support + test/support + main-is: Main.hs + +benchmark moonlight-category-finite-bench + import: category-benchmark-properties, category-benchmark-support-slice, category-fincat-benchmark-slice, category-finite-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/finite + bench/support + main-is: Main.hs + +benchmark moonlight-category-site-bench + import: category-benchmark-properties, category-benchmark-support-slice, category-fincat-benchmark-slice, category-site-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/site + bench/finite + bench/support + main-is: Main.hs + +benchmark moonlight-category-indexed-bench + import: category-benchmark-properties, category-benchmark-support-slice, category-indexed-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/indexed + bench/support + main-is: Main.hs + +benchmark moonlight-category-simplicial-bench + import: category-benchmark-properties, category-simplicial-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: bench/simplicial + main-is: Main.hs + +benchmark moonlight-category-bench + import: category-benchmark-properties, category-benchmark-support-slice, category-abstract-fixture-slice, category-abstract-benchmark-slice, category-fincat-benchmark-slice, category-finite-benchmark-slice, category-site-benchmark-slice, category-indexed-benchmark-slice, category-simplicial-benchmark-slice + type: exitcode-stdio-1.0 + hs-source-dirs: + bench/aggregate + bench/abstract + bench/finite + bench/site + bench/indexed + bench/simplicial + bench/support + test/support + main-is: Main.hs diff --git a/src-abstract/Moonlight/Category/Pure/Adhesive.hs b/src-abstract/Moonlight/Category/Pure/Adhesive.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Adhesive.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Adhesive and PBPO categories with pushout-complement and PBPO complement +-- witnesses for double-pushout rewriting, plus monic-match and square-commutativity +-- checks. +module Moonlight.Category.Pure.Adhesive + ( DenseIntSet, + denseIntSetUniverseSize, + denseIntSetEmpty, + denseIntSetFull, + denseIntSetInterval, + denseIntSetFromAscList, + denseIntSetMember, + denseIntSetIsSubsetOf, + denseIntSetUnion, + denseIntSetUnions, + denseIntSetIntersection, + denseIntSetDifference, + denseIntSetIntersects, + denseIntSetSize, + denseIntSetWeight, + denseIntSetFoldl', + AdhesiveCategory (..), + PBPOAdhesiveCategory (..), + MonicMatchComponents (..), + PushoutComplementComponents (..), + PBPOComplementComponents (..), + MonicMatchWitness, + monicMatchArrow, + PushoutComplementWitness, + pushoutComplementRuleLeg, + pushoutComplementMonicMatch, + pushoutComplementObject, + pushoutComplementBorrowedLeg, + pushoutComplementResidualLeg, + PBPOComplementWitness, + pbpoComplementRuleLeg, + pbpoComplementMonicMatch, + pbpoComplementPullbackObject, + pbpoComplementPullbackToBorrowed, + pbpoComplementPullbackToMatch, + pbpoComplementPushoutObject, + pbpoComplementPushoutFromComplement, + pbpoComplementPushoutFromMatch, + pbpoComplementBorrowedLeg, + pbpoComplementResidualLeg, + witnessMonic, + pushoutComplement, + pbpoComplement, + pushoutComplementSquareCommutes, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + ) +where + +import Control.Monad (foldM, guard) +import Data.Bits (Bits (complement, popCount, shiftL, shiftR, testBit, (.&.), (.|.)), countTrailingZeros) +import Data.Kind (Constraint, Type) +import Data.Word (Word64) +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.Limits (HasPullbacks (..), HasPushouts (..)) + +type DenseIntSet :: Type +-- | An immutable integer set over a fixed universe of at most 512 elements. +data DenseIntSet = DenseIntSet !Int !Int !Int !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 + deriving stock (Eq, Ord, Show) + +-- | The exclusive upper bound of admissible members. +denseIntSetUniverseSize :: DenseIntSet -> Int +denseIntSetUniverseSize (DenseIntSet universeSize _ _ _ _ _ _ _ _ _ _) = + universeSize +{-# INLINE denseIntSetUniverseSize #-} + +-- | Construct the empty set when the universe bound is supported. +denseIntSetEmpty :: Int -> Maybe DenseIntSet +denseIntSetEmpty universeSize = do + guard (denseUniverseSizeValid universeSize) + pure (DenseIntSet universeSize 0 0 0 0 0 0 0 0 0 0) +{-# INLINE denseIntSetEmpty #-} + +-- | Construct the set containing its entire supported universe. +denseIntSetFull :: Int -> Maybe DenseIntSet +denseIntSetFull universeSize = do + guard (denseUniverseSizeValid universeSize) + pure + ( denseIntSetFromWords + universeSize + (denseMaskForWord universeSize 0) + (denseMaskForWord universeSize 1) + (denseMaskForWord universeSize 2) + (denseMaskForWord universeSize 3) + (denseMaskForWord universeSize 4) + (denseMaskForWord universeSize 5) + (denseMaskForWord universeSize 6) + (denseMaskForWord universeSize 7) + ) +{-# INLINE denseIntSetFull #-} + +-- | Construct a bounded contiguous interval. +denseIntSetInterval :: Int -> Int -> Int -> Maybe DenseIntSet +denseIntSetInterval universeSize start count = do + guard (denseUniverseSizeValid universeSize) + guard (count >= 0 && count <= universeSize) + guard (start >= 0 && start <= universeSize - count) + denseIntSetFromAscList universeSize [start .. start + count - 1] +{-# INLINE denseIntSetInterval #-} + +-- | Construct from strictly ascending, in-bounds members. +denseIntSetFromAscList :: Int -> [Int] -> Maybe DenseIntSet +denseIntSetFromAscList universeSize values = do + guard (denseUniverseSizeValid universeSize) + guard (denseAscValuesInBounds universeSize values) + pure (foldl' denseIntSetInsertTrusted (DenseIntSet universeSize 0 0 0 0 0 0 0 0 0 0) values) +{-# INLINE denseIntSetFromAscList #-} + +-- | Test membership; out-of-universe values are absent. +denseIntSetMember :: Int -> DenseIntSet -> Bool +denseIntSetMember value set@(DenseIntSet universeSize _ _ _ _ _ _ _ _ _ _) = + value >= 0 + && value < universeSize + && testBit (denseWordAt (denseWordIndex value) set) (denseBitOffset value) +{-# INLINE denseIntSetMember #-} + +-- | Test inclusion when both sets share a universe. +denseIntSetIsSubsetOf :: DenseIntSet -> DenseIntSet -> Maybe Bool +denseIntSetIsSubsetOf = + denseIntSetCompareWords + (\leftWord rightWord -> leftWord .&. complement rightWord == 0) +{-# INLINE denseIntSetIsSubsetOf #-} + +-- | Union sets with the same universe. +denseIntSetUnion :: DenseIntSet -> DenseIntSet -> Maybe DenseIntSet +denseIntSetUnion = + denseIntSetZipWords (.|.) +{-# INLINE denseIntSetUnion #-} + +-- | Union a family of sets in one declared universe. +denseIntSetUnions :: Int -> [DenseIntSet] -> Maybe DenseIntSet +denseIntSetUnions universeSize sets = do + emptySet <- denseIntSetEmpty universeSize + foldM denseIntSetUnion emptySet sets +{-# INLINE denseIntSetUnions #-} + +-- | Intersect sets with the same universe. +denseIntSetIntersection :: DenseIntSet -> DenseIntSet -> Maybe DenseIntSet +denseIntSetIntersection = + denseIntSetZipWords (.&.) +{-# INLINE denseIntSetIntersection #-} + +-- | Subtract the right set when universes agree. +denseIntSetDifference :: DenseIntSet -> DenseIntSet -> Maybe DenseIntSet +denseIntSetDifference = + denseIntSetZipWords (\leftWord rightWord -> leftWord .&. complement rightWord) +{-# INLINE denseIntSetDifference #-} + +-- | Test whether same-universe sets overlap. +denseIntSetIntersects :: DenseIntSet -> DenseIntSet -> Maybe Bool +denseIntSetIntersects left right = + denseIntSetCompareWords (\leftWord rightWord -> leftWord .&. rightWord == 0) left right + >>= pure . not +{-# INLINE denseIntSetIntersects #-} + +-- | The set cardinality. +denseIntSetSize :: DenseIntSet -> Int +denseIntSetSize (DenseIntSet _ size _ _ _ _ _ _ _ _ _) = + size +{-# INLINE denseIntSetSize #-} + +-- | The sum of member indices. +denseIntSetWeight :: DenseIntSet -> Int +denseIntSetWeight (DenseIntSet _ _ weight _ _ _ _ _ _ _ _) = + weight +{-# INLINE denseIntSetWeight #-} + +-- | Strictly fold members in ascending order. +denseIntSetFoldl' :: (value -> Int -> value) -> value -> DenseIntSet -> value +denseIntSetFoldl' step initialValue (DenseIntSet _ _ _ word0 word1 word2 word3 word4 word5 word6 word7) = + denseWordFoldl' step (7 * denseWordBits) word7 + ( denseWordFoldl' step (6 * denseWordBits) word6 + ( denseWordFoldl' step (5 * denseWordBits) word5 + ( denseWordFoldl' step (4 * denseWordBits) word4 + ( denseWordFoldl' step (3 * denseWordBits) word3 + ( denseWordFoldl' step (2 * denseWordBits) word2 + (denseWordFoldl' step denseWordBits word1 (denseWordFoldl' step 0 word0 initialValue)) + ) + ) + ) + ) + ) +{-# INLINE denseIntSetFoldl' #-} + +denseIntSetZipWords :: (Word64 -> Word64 -> Word64) -> DenseIntSet -> DenseIntSet -> Maybe DenseIntSet +denseIntSetZipWords combine (DenseIntSet leftUniverse _ _ left0 left1 left2 left3 left4 left5 left6 left7) (DenseIntSet rightUniverse _ _ right0 right1 right2 right3 right4 right5 right6 right7) = do + guard (leftUniverse == rightUniverse) + pure + ( denseIntSetFromWords + leftUniverse + (combine left0 right0) + (combine left1 right1) + (combine left2 right2) + (combine left3 right3) + (combine left4 right4) + (combine left5 right5) + (combine left6 right6) + (combine left7 right7) + ) +{-# INLINE denseIntSetZipWords #-} + +denseIntSetCompareWords :: (Word64 -> Word64 -> Bool) -> DenseIntSet -> DenseIntSet -> Maybe Bool +denseIntSetCompareWords compareWords (DenseIntSet leftUniverse _ _ left0 left1 left2 left3 left4 left5 left6 left7) (DenseIntSet rightUniverse _ _ right0 right1 right2 right3 right4 right5 right6 right7) = do + guard (leftUniverse == rightUniverse) + pure + ( compareWords left0 right0 + && compareWords left1 right1 + && compareWords left2 right2 + && compareWords left3 right3 + && compareWords left4 right4 + && compareWords left5 right5 + && compareWords left6 right6 + && compareWords left7 right7 + ) +{-# INLINE denseIntSetCompareWords #-} + +denseIntSetInsertTrusted :: DenseIntSet -> Int -> DenseIntSet +denseIntSetInsertTrusted (DenseIntSet universeSize size weight word0 word1 word2 word3 word4 word5 word6 word7) value = + case denseWordIndex value of + 0 -> DenseIntSet universeSize nextSize nextWeight (inserted word0) word1 word2 word3 word4 word5 word6 word7 + 1 -> DenseIntSet universeSize nextSize nextWeight word0 (inserted word1) word2 word3 word4 word5 word6 word7 + 2 -> DenseIntSet universeSize nextSize nextWeight word0 word1 (inserted word2) word3 word4 word5 word6 word7 + 3 -> DenseIntSet universeSize nextSize nextWeight word0 word1 word2 (inserted word3) word4 word5 word6 word7 + 4 -> DenseIntSet universeSize nextSize nextWeight word0 word1 word2 word3 (inserted word4) word5 word6 word7 + 5 -> DenseIntSet universeSize nextSize nextWeight word0 word1 word2 word3 word4 (inserted word5) word6 word7 + 6 -> DenseIntSet universeSize nextSize nextWeight word0 word1 word2 word3 word4 word5 (inserted word6) word7 + _ -> DenseIntSet universeSize nextSize nextWeight word0 word1 word2 word3 word4 word5 word6 (inserted word7) + where + nextSize = + size + 1 + nextWeight = + weight + value + inserted word = + word .|. shiftL 1 (denseBitOffset value) +{-# INLINE denseIntSetInsertTrusted #-} + +denseWordAt :: Int -> DenseIntSet -> Word64 +denseWordAt wordIndex (DenseIntSet _ _ _ word0 word1 word2 word3 word4 word5 word6 word7) = + case wordIndex of + 0 -> word0 + 1 -> word1 + 2 -> word2 + 3 -> word3 + 4 -> word4 + 5 -> word5 + 6 -> word6 + _ -> word7 +{-# INLINE denseWordAt #-} + +denseIntSetFromWords :: Int -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> DenseIntSet +denseIntSetFromWords universeSize word0 word1 word2 word3 word4 word5 word6 word7 = + DenseIntSet + universeSize + ( denseWordSize word0 + + denseWordSize word1 + + denseWordSize word2 + + denseWordSize word3 + + denseWordSize word4 + + denseWordSize word5 + + denseWordSize word6 + + denseWordSize word7 + ) + ( denseWordWeight 0 word0 + + denseWordWeight denseWordBits word1 + + denseWordWeight (2 * denseWordBits) word2 + + denseWordWeight (3 * denseWordBits) word3 + + denseWordWeight (4 * denseWordBits) word4 + + denseWordWeight (5 * denseWordBits) word5 + + denseWordWeight (6 * denseWordBits) word6 + + denseWordWeight (7 * denseWordBits) word7 + ) + word0 + word1 + word2 + word3 + word4 + word5 + word6 + word7 +{-# INLINE denseIntSetFromWords #-} + +denseWordSize :: Word64 -> Int +denseWordSize = + popCount +{-# INLINE denseWordSize #-} + +denseWordWeight :: Int -> Word64 -> Int +denseWordWeight base word = + denseWordFoldl' (\total value -> total + value) base word 0 +{-# INLINE denseWordWeight #-} + +denseWordFoldl' :: (value -> Int -> value) -> Int -> Word64 -> value -> value +denseWordFoldl' step base word initialValue = + foldBits initialValue word + where + foldBits !current currentWord + | currentWord == 0 = + current + | otherwise = + let bitOffset = countTrailingZeros currentWord + nextWord = currentWord .&. (currentWord - 1) + in foldBits (step current (base + bitOffset)) nextWord +{-# INLINE denseWordFoldl' #-} + +denseAscValuesInBounds :: Int -> [Int] -> Bool +denseAscValuesInBounds universeSize values = + case values of + [] -> + True + firstValue : remainingValues -> + firstValue >= 0 + && firstValue < universeSize + && snd + ( foldl' + ( \(previousValue, valid) value -> + (value, valid && value > previousValue && value < universeSize) + ) + (firstValue, True) + remainingValues + ) +{-# INLINE denseAscValuesInBounds #-} + + +denseMaskForWord :: Int -> Int -> Word64 +denseMaskForWord universeSize wordIndex + | remainingBits >= denseWordBits = + complement 0 + | remainingBits <= 0 = + 0 + | otherwise = + shiftR (complement 0) (denseWordBits - remainingBits) + where + remainingBits = + universeSize - wordIndex * denseWordBits +{-# INLINE denseMaskForWord #-} + +denseUniverseSizeValid :: Int -> Bool +denseUniverseSizeValid universeSize = + universeSize >= 0 && universeSize <= denseMaxUniverseSize +{-# INLINE denseUniverseSizeValid #-} + +denseWordIndex :: Int -> Int +denseWordIndex value = + value `div` denseWordBits +{-# INLINE denseWordIndex #-} + +denseBitOffset :: Int -> Int +denseBitOffset value = + value `mod` denseWordBits +{-# INLINE denseBitOffset #-} + +denseWordBits :: Int +denseWordBits = + 64 +{-# INLINE denseWordBits #-} + +denseMaxUniverseSize :: Int +denseMaxUniverseSize = + 512 +{-# INLINE denseMaxUniverseSize #-} + +type MonicMatchComponents :: Type -> Type +-- | Raw evidence supplied by an adhesive-category interpreter for a monic match. +data MonicMatchComponents c = MonicMatchComponents + { monicMatchComponentArrow :: Mor c + } + +type PushoutComplementComponents :: Type -> Type +-- | The object and legs produced by a pushout-complement construction. +data PushoutComplementComponents c = PushoutComplementComponents + { pushoutComplementComponentObject :: Ob c, + pushoutComplementComponentBorrowedLeg :: Mor c, + pushoutComplementComponentResidualLeg :: Mor c + } + +type PBPOComplementComponents :: Type -> Type +-- | The pullback and pushout sections produced by a PBPO complement. +data PBPOComplementComponents c = PBPOComplementComponents + { pbpoComplementComponentPullbackObject :: Ob c, + pbpoComplementComponentPullbackToBorrowed :: Mor c, + pbpoComplementComponentPullbackToMatch :: Mor c, + pbpoComplementComponentPushoutObject :: Ob c, + pbpoComplementComponentPushoutFromComplement :: Mor c, + pbpoComplementComponentPushoutFromMatch :: Mor c, + pbpoComplementComponentBorrowedLeg :: Mor c, + pbpoComplementComponentResidualLeg :: Mor c + } + +type MonicMatchWitness :: Type -> Type +-- | Opaque, admitted evidence that a match is monic. +data MonicMatchWitness c = MonicMatchWitness !(MonicMatchComponents c) + +type PushoutComplementWitness :: Type -> Type +-- | Opaque pushout-complement evidence bound to its rule leg and monic match. +data PushoutComplementWitness c = PushoutComplementWitness !(Mor c) !(MonicMatchWitness c) !(PushoutComplementComponents c) + +type PBPOComplementWitness :: Type -> Type +-- | Opaque PBPO-complement evidence bound to its rule leg and monic match. +data PBPOComplementWitness c = PBPOComplementWitness !(Mor c) !(MonicMatchWitness c) !(PBPOComplementComponents c) + +type AdhesiveCategory :: Type -> Constraint +-- | A category that can admit monic matches and construct pushout complements. +class (HasPushouts c, HasPullbacks c) => AdhesiveCategory c where + monicMatchComponents :: c -> Mor c -> Maybe (MonicMatchComponents c) + + pushoutComplementComponents :: + c -> + Mor c -> + MonicMatchWitness c -> + Maybe (PushoutComplementComponents c) + +type PBPOAdhesiveCategory :: Type -> Constraint +-- | An adhesive category that can construct PBPO complements. +class AdhesiveCategory c => PBPOAdhesiveCategory c where + pbpoComplementComponents :: + c -> + Mor c -> + MonicMatchWitness c -> + Maybe (PBPOComplementComponents c) + pbpoComplementComponents categoryValue ruleLeg monicMatch = do + pushoutComplementComponentsValue <- pushoutComplementComponents categoryValue ruleLeg monicMatch + (pullbackObject, pullbackToBorrowed, pullbackToMatch) <- + pullback + categoryValue + (pushoutComplementComponentBorrowedLeg pushoutComplementComponentsValue) + (monicMatchArrow monicMatch) + (pushoutObject, pushoutFromComplement, pushoutFromMatch) <- + pushout + categoryValue + (pushoutComplementComponentResidualLeg pushoutComplementComponentsValue) + ruleLeg + pure + PBPOComplementComponents + { pbpoComplementComponentPullbackObject = pullbackObject, + pbpoComplementComponentPullbackToBorrowed = pullbackToBorrowed, + pbpoComplementComponentPullbackToMatch = pullbackToMatch, + pbpoComplementComponentPushoutObject = pushoutObject, + pbpoComplementComponentPushoutFromComplement = pushoutFromComplement, + pbpoComplementComponentPushoutFromMatch = pushoutFromMatch, + pbpoComplementComponentBorrowedLeg = pushoutComplementComponentBorrowedLeg pushoutComplementComponentsValue, + pbpoComplementComponentResidualLeg = pushoutComplementComponentResidualLeg pushoutComplementComponentsValue + } + +-- | Admit an opaque monic-match witness. +witnessMonic :: AdhesiveCategory c => c -> Mor c -> Maybe (MonicMatchWitness c) +witnessMonic categoryValue morphism = + MonicMatchWitness <$> monicMatchComponents categoryValue morphism + +-- | Bind admitted complement components into an opaque witness. +pushoutComplement :: + AdhesiveCategory c => + c -> + Mor c -> + MonicMatchWitness c -> + Maybe (PushoutComplementWitness c) +pushoutComplement categoryValue ruleLeg monicMatch = + PushoutComplementWitness ruleLeg monicMatch <$> pushoutComplementComponents categoryValue ruleLeg monicMatch + +-- | Bind admitted PBPO components into an opaque witness. +pbpoComplement :: + PBPOAdhesiveCategory c => + c -> + Mor c -> + MonicMatchWitness c -> + Maybe (PBPOComplementWitness c) +pbpoComplement categoryValue ruleLeg monicMatch = + PBPOComplementWitness ruleLeg monicMatch <$> pbpoComplementComponents categoryValue ruleLeg monicMatch + +monicMatchArrow :: MonicMatchWitness c -> Mor c +monicMatchArrow (MonicMatchWitness components) = + monicMatchComponentArrow components + +pushoutComplementRuleLeg :: PushoutComplementWitness c -> Mor c +pushoutComplementRuleLeg (PushoutComplementWitness ruleLeg _ _) = + ruleLeg + +pushoutComplementMonicMatch :: PushoutComplementWitness c -> MonicMatchWitness c +pushoutComplementMonicMatch (PushoutComplementWitness _ monicMatch _) = + monicMatch + +pushoutComplementObject :: PushoutComplementWitness c -> Ob c +pushoutComplementObject (PushoutComplementWitness _ _ components) = + pushoutComplementComponentObject components + +pushoutComplementBorrowedLeg :: PushoutComplementWitness c -> Mor c +pushoutComplementBorrowedLeg (PushoutComplementWitness _ _ components) = + pushoutComplementComponentBorrowedLeg components + +pushoutComplementResidualLeg :: PushoutComplementWitness c -> Mor c +pushoutComplementResidualLeg (PushoutComplementWitness _ _ components) = + pushoutComplementComponentResidualLeg components + +pbpoComplementRuleLeg :: PBPOComplementWitness c -> Mor c +pbpoComplementRuleLeg (PBPOComplementWitness ruleLeg _ _) = + ruleLeg + +pbpoComplementMonicMatch :: PBPOComplementWitness c -> MonicMatchWitness c +pbpoComplementMonicMatch (PBPOComplementWitness _ monicMatch _) = + monicMatch + +pbpoComplementPullbackObject :: PBPOComplementWitness c -> Ob c +pbpoComplementPullbackObject (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPullbackObject components + +pbpoComplementPullbackToBorrowed :: PBPOComplementWitness c -> Mor c +pbpoComplementPullbackToBorrowed (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPullbackToBorrowed components + +pbpoComplementPullbackToMatch :: PBPOComplementWitness c -> Mor c +pbpoComplementPullbackToMatch (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPullbackToMatch components + +pbpoComplementPushoutObject :: PBPOComplementWitness c -> Ob c +pbpoComplementPushoutObject (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPushoutObject components + +pbpoComplementPushoutFromComplement :: PBPOComplementWitness c -> Mor c +pbpoComplementPushoutFromComplement (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPushoutFromComplement components + +pbpoComplementPushoutFromMatch :: PBPOComplementWitness c -> Mor c +pbpoComplementPushoutFromMatch (PBPOComplementWitness _ _ components) = + pbpoComplementComponentPushoutFromMatch components + +pbpoComplementBorrowedLeg :: PBPOComplementWitness c -> Mor c +pbpoComplementBorrowedLeg (PBPOComplementWitness _ _ components) = + pbpoComplementComponentBorrowedLeg components + +pbpoComplementResidualLeg :: PBPOComplementWitness c -> Mor c +pbpoComplementResidualLeg (PBPOComplementWitness _ _ components) = + pbpoComplementComponentResidualLeg components + +-- | Check the square carried by a pushout-complement witness. +pushoutComplementSquareCommutes :: (Category c, Eq (Mor c)) => c -> PushoutComplementWitness c -> Bool +pushoutComplementSquareCommutes categoryValue witness = + case + ( composeMor categoryValue (pushoutComplementBorrowedLeg witness) (pushoutComplementResidualLeg witness), + composeMor categoryValue (monicMatchArrow (pushoutComplementMonicMatch witness)) (pushoutComplementRuleLeg witness) + ) + of + (Right leftMorphism, Right rightMorphism) -> leftMorphism == rightMorphism + _ -> False + +-- | Check the pullback square carried by a PBPO witness. +pbpoPullbackSquareCommutes :: (Category c, Eq (Mor c)) => c -> PBPOComplementWitness c -> Bool +pbpoPullbackSquareCommutes categoryValue witness = + case + ( composeMor categoryValue (pbpoComplementBorrowedLeg witness) (pbpoComplementPullbackToBorrowed witness), + composeMor categoryValue (monicMatchArrow (pbpoComplementMonicMatch witness)) (pbpoComplementPullbackToMatch witness) + ) + of + (Right leftMorphism, Right rightMorphism) -> leftMorphism == rightMorphism + _ -> False + +-- | Check the pushout square carried by a PBPO witness. +pbpoPushoutSquareCommutes :: (Category c, Eq (Mor c)) => c -> PBPOComplementWitness c -> Bool +pbpoPushoutSquareCommutes categoryValue witness = + case + ( composeMor categoryValue (pbpoComplementPushoutFromComplement witness) (pbpoComplementResidualLeg witness), + composeMor categoryValue (pbpoComplementPushoutFromMatch witness) (pbpoComplementRuleLeg witness) + ) + of + (Right leftMorphism, Right rightMorphism) -> leftMorphism == rightMorphism + _ -> False diff --git a/src-abstract/Moonlight/Category/Pure/Category.hs b/src-abstract/Moonlight/Category/Pure/Category.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Category.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | The totalised, explicit-error 'Category' class: objects, morphisms, 2-morphisms, +-- compositors and errors as associated types, with 'Either'-returning operations. +module Moonlight.Category.Pure.Category + ( Category (..), + composeMor, + ) +where + +import Data.Kind (Constraint, Type) + +type Category :: Type -> Constraint +-- | A category whose primitive operations totalise structural failure through +-- its associated 'CategoryError'. +class Category c where + type Ob c = (ob :: Type) | ob -> c + type Mor c = (mor :: Type) | mor -> c + type TwoMor c = (twomor :: Type) | twomor -> c + type TwoMor c = () + type Compositor c = (compositor :: Type) | compositor -> c + type Compositor c = () + type CategoryError c :: Type + type CategoryError c = () + + identity :: c -> Ob c -> Either (CategoryError c) (Mor c) + compose :: c -> Mor c -> Mor c -> Either (CategoryError c) (Mor c, Compositor c) + source :: c -> Mor c -> Either (CategoryError c) (Ob c) + target :: c -> Mor c -> Either (CategoryError c) (Ob c) + +-- | Compose two morphisms while discarding compositor evidence. +composeMor :: forall c. Category c => c -> Mor c -> Mor c -> Either (CategoryError c) (Mor c) +composeMor categoryValue left right = fmap fst (compose @c categoryValue left right) +{-# INLINE composeMor #-} diff --git a/src-abstract/Moonlight/Category/Pure/CoveringFamily.hs b/src-abstract/Moonlight/Category/Pure/CoveringFamily.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/CoveringFamily.hs @@ -0,0 +1,69 @@ + +-- | Type-indexed covering families: the t'Exists', t'Dict' and +-- 'CoveringFamily'/'CoveringConstraints' machinery for enumerating and constraining +-- the members of a kind. +module Moonlight.Category.Pure.CoveringFamily + ( CoveringFamily (..), + Exists (..), + Dict (..), + CoveringConstraints (..), + withMember, + traverseMembers, + traverseMembers_, + ) +where + +import Data.Kind (Constraint, Type) + +type Dict :: Constraint -> Type +-- | Evidence that a constraint holds. +data Dict (c :: Constraint) where + Dict :: c => Dict c + +type Exists :: forall k. (k -> Type) -> Type +-- | A covering-family member with its index hidden. +data Exists (w :: k -> Type) where + Exists :: w member -> Exists w + +type CoveringFamily :: forall k. (k -> Type) -> Constraint +-- | A finite enumeration of every witness in an indexed family. +class CoveringFamily (w :: k -> Type) where + allMembers :: [Exists w] + +type CoveringConstraints :: forall k. (k -> Type) -> (k -> Constraint) -> Constraint +-- | Evidence that every covering member satisfies a constraint family. +class CoveringFamily w => CoveringConstraints (w :: k -> Type) (c :: k -> Constraint) where + constraintDict :: w member -> Dict (c member) + +-- | Eliminate an existential member under its recovered constraint. +withMember :: + forall k (w :: k -> Type) (c :: k -> Constraint) r. + CoveringConstraints w c => + Exists w -> + (forall (member :: k). c member => w member -> r) -> + r +withMember (Exists witness) continuation = + case constraintDict @k @w @c witness of + Dict -> continuation witness + +-- | Evaluate a constrained function at every covering member. +traverseMembers :: + forall k (w :: k -> Type) (c :: k -> Constraint) r. + CoveringConstraints w c => + (forall (member :: k). c member => w member -> r) -> + [r] +traverseMembers continuation = + fmap (\existential -> withMember @k @w @c existential continuation) (allMembers @k @w) + +-- | Sequence one applicative action for every constrained member. +traverseMembers_ :: + forall k (w :: k -> Type) (c :: k -> Constraint) m. + (CoveringConstraints w c, Applicative m) => + (forall (member :: k). c member => w member -> m ()) -> + m () +traverseMembers_ continuation = + sequenceAll (fmap (\existential -> withMember @k @w @c existential continuation) (allMembers @k @w)) + where + sequenceAll :: Applicative f => [f ()] -> f () + sequenceAll [] = pure () + sequenceAll (x : xs) = x *> sequenceAll xs diff --git a/src-abstract/Moonlight/Category/Pure/CoveringProduct.hs b/src-abstract/Moonlight/Category/Pure/CoveringProduct.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/CoveringProduct.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- | Dependent products over a covering family: a total function from each family +-- member to its fibre, with tabulation, indexing, restriction and mapping. +module Moonlight.Category.Pure.CoveringProduct + ( CoveringProduct, + tabulateCoveringProduct, + indexCoveringProduct, + restrictCoveringProduct, + adjustCoveringProduct, + replaceCoveringProduct, + mapCoveringProduct, + mapCoveringProductWithWitness, + foldMapCoveringProductWithWitness, + ) +where + +import Data.Kind (Type) +import Data.Type.Equality ((:~:) (Refl)) +import Moonlight.Category.Pure.CoveringFamily + ( CoveringFamily (..), + Exists (..), + ) + +type CoveringProduct :: forall k. (k -> Type) -> (k -> Type) -> Type +-- | A total dependent product indexed by the members of a covering family. +newtype CoveringProduct (w :: k -> Type) (f :: k -> Type) = CoveringProduct + { -- | Project the fibre selected by a witness. + indexCoveringProduct :: forall member. w member -> f member + } + +-- | Build a dependent product from its total projection. +tabulateCoveringProduct :: + (forall member. w member -> f member) -> + CoveringProduct w f +tabulateCoveringProduct = CoveringProduct + +-- | Reindex a product along a witness embedding. +restrictCoveringProduct :: + (forall member. subset member -> superset member) -> + CoveringProduct superset f -> + CoveringProduct subset f +restrictCoveringProduct embedWitness coveringProduct = + tabulateCoveringProduct + (\witness -> indexCoveringProduct coveringProduct (embedWitness witness)) + +-- | Modify the fibre at one witness selected by decidable witness equality. +adjustCoveringProduct :: + (forall left right. w left -> w right -> Maybe (left :~: right)) -> + w member -> + (f member -> f member) -> + CoveringProduct w f -> + CoveringProduct w f +adjustCoveringProduct sameWitness targetWitness adjustValue coveringProduct = + tabulateCoveringProduct + ( \witness -> + case sameWitness witness targetWitness of + Just Refl -> adjustValue (indexCoveringProduct coveringProduct witness) + Nothing -> indexCoveringProduct coveringProduct witness + ) + +-- | Replace the fibre at one witness. +replaceCoveringProduct :: + (forall left right. w left -> w right -> Maybe (left :~: right)) -> + w member -> + f member -> + CoveringProduct w f -> + CoveringProduct w f +replaceCoveringProduct sameWitness targetWitness replacement = + adjustCoveringProduct sameWitness targetWitness (const replacement) + +-- | Apply a natural transformation to every fibre. +mapCoveringProduct :: + (forall member. f member -> g member) -> + CoveringProduct w f -> + CoveringProduct w g +mapCoveringProduct transform = + mapCoveringProductWithWitness (\_ -> transform) + +-- | Apply a witness-aware natural transformation to every fibre. +mapCoveringProductWithWitness :: + (forall member. w member -> f member -> g member) -> + CoveringProduct w f -> + CoveringProduct w g +mapCoveringProductWithWitness transform (CoveringProduct productAt) = + CoveringProduct (\witness -> transform witness (productAt witness)) + +-- | Fold all fibres in covering order with their witnesses. +foldMapCoveringProductWithWitness :: + forall k (w :: k -> Type) (f :: k -> Type) monoidValue. + (CoveringFamily w, Monoid monoidValue) => + (forall member. w member -> f member -> monoidValue) -> + CoveringProduct w f -> + monoidValue +foldMapCoveringProductWithWitness foldValue coveringProduct = + foldMap + (\(Exists witness) -> foldValue witness (indexCoveringProduct coveringProduct witness)) + (allMembers @k @w) diff --git a/src-abstract/Moonlight/Category/Pure/DecoratedComposition.hs b/src-abstract/Moonlight/Category/Pure/DecoratedComposition.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/DecoratedComposition.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Composition of decorated cospans: the t'StructuredCompositionAlgebra', composition +-- results carrying obligations, and obligation reconciliation. +module Moonlight.Category.Pure.DecoratedComposition + ( CompositionResult (..), + DecoratedCompositionError (..), + StructuredCompositionAlgebra (..), + composeDecorated, + composeDecoratedStructured, + composeStructuredDecoratedCospan, + reconcileCompositionObligations, + ) +where + +import Data.Bifunctor (first) +import Data.Kind (Type) +import Data.List (genericDrop) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Category (Ob) +import Moonlight.Category.Pure.Limits (HasPushouts) +import Moonlight.Category.Pure.StructuredCospan (StructuredCospan, StructuredCospanError, composeStructuredCospan, structuredDecoration) + +type CompositionResult :: Type -> Type -> Type -> Type +-- | A composed value together with its unresolved obligations and decoration. +data CompositionResult ir obligation decoration = CompositionResult + { composedIR :: ir, + composedObligations :: [obligation], + composedDecoration :: decoration + } + deriving stock (Eq, Show) + +type DecoratedCompositionError :: Type -> Type +-- | A missing structured boundary or a failure while composing it. +data DecoratedCompositionError category + = DecoratedCompositionLeftBoundaryMissing + | DecoratedCompositionRightBoundaryMissing + | DecoratedCompositionStructuredError (StructuredCospanError category) + +type StructuredCompositionAlgebra :: + Type -> Type -> Type -> Type -> Type -> Type +-- | The two domain-specific maps required to lower composition through +-- structured cospans and raise the result again. +data StructuredCompositionAlgebra boundary category ir decoration obligation = StructuredCompositionAlgebra + { toStructuredBoundary :: + boundary -> + (ir, decoration) -> + Maybe (StructuredCospan category decoration), + fromStructuredComposition :: + boundary -> + (ir, decoration) -> + (ir, decoration) -> + StructuredCospan category decoration -> + (ir, [obligation]) + } + +-- | Compose two decorated values with a supplied pure gluing algebra. +composeDecorated :: + (decoration -> decoration -> decoration) -> + (boundary -> (ir, decoration) -> (ir, decoration) -> (ir, [obligation])) -> + boundary -> + (ir, decoration) -> + (ir, decoration) -> + CompositionResult ir obligation decoration +composeDecorated combineDecorations glue boundaryValue leftValue rightValue = + let (composedValue, obligations) = glue boundaryValue leftValue rightValue + in CompositionResult + { composedIR = composedValue, + composedObligations = obligations, + composedDecoration = combineDecorations (snd leftValue) (snd rightValue) + } +{-# INLINE composeDecorated #-} + +-- | Compose through validated structured boundaries and a categorical pushout. +composeDecoratedStructured :: + (HasPushouts category, Eq (Ob category)) => + category -> + StructuredCompositionAlgebra boundary category ir decoration obligation -> + (decoration -> decoration -> decoration) -> + boundary -> + (ir, decoration) -> + (ir, decoration) -> + Either (DecoratedCompositionError category) (CompositionResult ir obligation decoration) +composeDecoratedStructured categoryValue compositionAlgebra combineDecorations boundaryValue leftValue rightValue = do + leftBoundaryValue <- + maybe + (Left DecoratedCompositionLeftBoundaryMissing) + Right + (toStructuredBoundary compositionAlgebra boundaryValue leftValue) + rightBoundaryValue <- + maybe + (Left DecoratedCompositionRightBoundaryMissing) + Right + (toStructuredBoundary compositionAlgebra boundaryValue rightValue) + composedBoundary <- + first + DecoratedCompositionStructuredError + ( composeStructuredDecoratedCospan + categoryValue + combineDecorations + leftBoundaryValue + rightBoundaryValue + ) + let (composedValue, obligations) = + fromStructuredComposition compositionAlgebra boundaryValue leftValue rightValue composedBoundary + in Right + CompositionResult + { composedIR = composedValue, + composedObligations = obligations, + composedDecoration = structuredDecoration composedBoundary + } +{-# INLINE composeDecoratedStructured #-} + +-- | The structured-cospan composition specialized to decorated boundaries. +composeStructuredDecoratedCospan :: + (HasPushouts category, Eq (Ob category)) => + category -> + (leftDecoration -> rightDecoration -> combinedDecoration) -> + StructuredCospan category leftDecoration -> + StructuredCospan category rightDecoration -> + Either (StructuredCospanError category) (StructuredCospan category combinedDecoration) +composeStructuredDecoratedCospan = + composeStructuredCospan +{-# INLINE composeStructuredDecoratedCospan #-} + +-- | Accept obligations only when their count fits the reconciliation budget. +reconcileCompositionObligations :: + [obligation] -> + Natural -> + Either (NonEmpty obligation) () +reconcileCompositionObligations obligations budget = + case NonEmpty.nonEmpty obligations of + Nothing -> Right () + Just nonEmptyObligations -> + if null (genericDrop budget obligations) + then Right () + else Left nonEmptyObligations diff --git a/src-abstract/Moonlight/Category/Pure/DecoratedPresentation.hs b/src-abstract/Moonlight/Category/Pure/DecoratedPresentation.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/DecoratedPresentation.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Decorated presentation trees — leaves glued along boundaries — and their +-- fold and compilation to a single decorated composition result. +module Moonlight.Category.Pure.DecoratedPresentation + ( DecoratedPresentation (..), + presentationLeaf, + presentationGlue, + foldDecoratedPresentation, + compileDecoratedPresentation, + compileDecoratedPresentationStructured, + ) +where + +import Data.Kind (Type) +import Data.Foldable (toList) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Moonlight.Category.Pure.DecoratedComposition + ( CompositionResult (..), + DecoratedCompositionError, + StructuredCompositionAlgebra, + composeDecorated, + composeDecoratedStructured, + ) +import Moonlight.Category.Pure.Category (Ob) +import Moonlight.Category.Pure.Limits (HasPushouts) + +type DecoratedPresentation :: Type -> Type -> Type -> Type +-- | A free binary gluing tree over decorated leaves. +data DecoratedPresentation boundary ir decoration + = PresentationLeaf ir decoration + | PresentationGlue boundary (DecoratedPresentation boundary ir decoration) (DecoratedPresentation boundary ir decoration) + deriving stock (Eq, Show) + +data CompiledPresentation ir obligation decoration = CompiledPresentation + { compiledPresentationIR :: ir, + compiledPresentationObligations :: Seq obligation, + compiledPresentationDecoration :: decoration + } + +-- | Inject one decorated leaf. +presentationLeaf :: ir -> decoration -> DecoratedPresentation boundary ir decoration +presentationLeaf = + PresentationLeaf + +-- | Join two presentations at a declared boundary. +presentationGlue :: + boundary -> + DecoratedPresentation boundary ir decoration -> + DecoratedPresentation boundary ir decoration -> + DecoratedPresentation boundary ir decoration +presentationGlue = + PresentationGlue + +-- | Eliminate a presentation with leaf and gluing algebras. +foldDecoratedPresentation :: + (ir -> decoration -> result) -> + (boundary -> result -> result -> result) -> + DecoratedPresentation boundary ir decoration -> + result +foldDecoratedPresentation leafAlgebra glueAlgebra = + foldPresentation + where + foldPresentation presentationValue = + case presentationValue of + PresentationLeaf ir decoration -> + leafAlgebra ir decoration + PresentationGlue boundary leftPresentation rightPresentation -> + glueAlgebra boundary (foldPresentation leftPresentation) (foldPresentation rightPresentation) + +-- | Compile every local gluing into one result while accumulating obligations. +compileDecoratedPresentation :: + (decoration -> decoration -> decoration) -> + (boundary -> (ir, decoration) -> (ir, decoration) -> (ir, [obligation])) -> + DecoratedPresentation boundary ir decoration -> + CompositionResult ir obligation decoration +compileDecoratedPresentation combineDecorations glue = + compositionResultFromCompiled + . foldDecoratedPresentation + (\ir decoration -> CompiledPresentation ir Seq.empty decoration) + (mergeComposedPresentations combineDecorations glue) + +-- | Compile by descending through structured-cospan pushouts. +compileDecoratedPresentationStructured :: + (HasPushouts category, Eq (Ob category)) => + category -> + StructuredCompositionAlgebra boundary category ir decoration obligation -> + (decoration -> decoration -> decoration) -> + DecoratedPresentation boundary ir decoration -> + Either (DecoratedCompositionError category) (CompositionResult ir obligation decoration) +compileDecoratedPresentationStructured categoryValue compositionAlgebra combineDecorations = + fmap compositionResultFromCompiled + . foldDecoratedPresentation + (\ir decoration -> Right (CompiledPresentation ir Seq.empty decoration)) + (mergeStructuredPresentations categoryValue compositionAlgebra combineDecorations) + +compositionResultFromCompiled :: CompiledPresentation ir obligation decoration -> CompositionResult ir obligation decoration +compositionResultFromCompiled compiled = + CompositionResult + { composedIR = compiledPresentationIR compiled, + composedObligations = toList (compiledPresentationObligations compiled), + composedDecoration = compiledPresentationDecoration compiled + } + +mergeComposedPresentations :: + (decoration -> decoration -> decoration) -> + (boundary -> (ir, decoration) -> (ir, decoration) -> (ir, [obligation])) -> + boundary -> + CompiledPresentation ir obligation decoration -> + CompiledPresentation ir obligation decoration -> + CompiledPresentation ir obligation decoration +mergeComposedPresentations combineDecorations glue boundary leftResult rightResult = + let localResult = + composeDecorated + combineDecorations + glue + boundary + (compiledPresentationIR leftResult, compiledPresentationDecoration leftResult) + (compiledPresentationIR rightResult, compiledPresentationDecoration rightResult) + in CompiledPresentation + { compiledPresentationIR = composedIR localResult, + compiledPresentationObligations = + compiledPresentationObligations leftResult + <> compiledPresentationObligations rightResult + <> Seq.fromList (composedObligations localResult), + compiledPresentationDecoration = composedDecoration localResult + } + +mergeStructuredPresentations :: + (HasPushouts category, Eq (Ob category)) => + category -> + StructuredCompositionAlgebra boundary category ir decoration obligation -> + (decoration -> decoration -> decoration) -> + boundary -> + Either (DecoratedCompositionError category) (CompiledPresentation ir obligation decoration) -> + Either (DecoratedCompositionError category) (CompiledPresentation ir obligation decoration) -> + Either (DecoratedCompositionError category) (CompiledPresentation ir obligation decoration) +mergeStructuredPresentations categoryValue compositionAlgebra combineDecorations boundary maybeLeft maybeRight = do + leftResult <- maybeLeft + rightResult <- maybeRight + localResult <- + composeDecoratedStructured + categoryValue + compositionAlgebra + combineDecorations + boundary + (compiledPresentationIR leftResult, compiledPresentationDecoration leftResult) + (compiledPresentationIR rightResult, compiledPresentationDecoration rightResult) + pure + CompiledPresentation + { compiledPresentationIR = composedIR localResult, + compiledPresentationObligations = + compiledPresentationObligations leftResult + <> compiledPresentationObligations rightResult + <> Seq.fromList (composedObligations localResult), + compiledPresentationDecoration = composedDecoration localResult + } diff --git a/src-abstract/Moonlight/Category/Pure/DoubleCategory.hs b/src-abstract/Moonlight/Category/Pure/DoubleCategory.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/DoubleCategory.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Double categories: horizontal and vertical morphisms, squares and their +-- compositions, and the interchange law. +module Moonlight.Category.Pure.DoubleCategory + ( DoubleCategory (..), + interchangeLaw, + ) +where + +import Data.Kind (Constraint, Type) + +type DoubleCategory :: Type -> Type -> Constraint +-- | Horizontal and vertical categories connected by composable squares. +class DoubleCategory object double | double -> object where + type ObjectWitness object double :: object -> Type + type HorizontalMor object double :: object -> object -> Type + type VerticalMor object double :: object -> object -> Type + type Square object double :: object -> object -> object -> object -> Type + + horizontalIdentity :: ObjectWitness object double objectValue -> HorizontalMor object double objectValue objectValue + verticalIdentity :: ObjectWitness object double objectValue -> VerticalMor object double objectValue objectValue + + composeHorizontal :: + HorizontalMor object double boundary target -> + HorizontalMor object double source boundary -> + Maybe (HorizontalMor object double source target) + composeVertical :: + VerticalMor object double boundary target -> + VerticalMor object double source boundary -> + Maybe (VerticalMor object double source target) + + squareTop :: Square object double northWest northEast southWest southEast -> HorizontalMor object double northWest northEast + squareBottom :: Square object double northWest northEast southWest southEast -> HorizontalMor object double southWest southEast + squareLeft :: Square object double northWest northEast southWest southEast -> VerticalMor object double northWest southWest + squareRight :: Square object double northWest northEast southWest southEast -> VerticalMor object double northEast southEast + + composeSquaresHorizontal :: + Square object double middleNorth eastNorth middleSouth eastSouth -> + Square object double westNorth middleNorth westSouth middleSouth -> + Maybe (Square object double westNorth eastNorth westSouth eastSouth) + composeSquaresVertical :: + Square object double middleWest middleEast southWest southEast -> + Square object double northWest northEast middleWest middleEast -> + Maybe (Square object double northWest northEast southWest southEast) + +-- | Check that horizontal-then-vertical and vertical-then-horizontal square +-- composition agree whenever all four composites exist. +interchangeLaw :: + forall object double northWest middleNorth middleWest center eastNorth middleEast westSouth middleSouth southEast. + ( DoubleCategory object double, + Eq (Square object double northWest eastNorth westSouth southEast) + ) => + Square object double northWest middleNorth middleWest center -> + Square object double middleNorth eastNorth center middleEast -> + Square object double middleWest center westSouth middleSouth -> + Square object double center middleEast middleSouth southEast -> + Maybe Bool +interchangeLaw northWestSquare northEastSquare southWestSquare southEastSquare = do + northRow <- composeSquaresHorizontal @object @double northEastSquare northWestSquare + southRow <- composeSquaresHorizontal @object @double southEastSquare southWestSquare + horizontalThenVertical <- composeSquaresVertical @object @double southRow northRow + westColumn <- composeSquaresVertical @object @double southWestSquare northWestSquare + eastColumn <- composeSquaresVertical @object @double southEastSquare northEastSquare + verticalThenHorizontal <- composeSquaresHorizontal @object @double eastColumn westColumn + pure (horizontalThenVertical == verticalThenHorizontal) diff --git a/src-abstract/Moonlight/Category/Pure/FiniteComposable.hs b/src-abstract/Moonlight/Category/Pure/FiniteComposable.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/FiniteComposable.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Composable chains of morphisms (and the 'FiniteComposableCategory' class) for +-- enumerating a finite category by chain dimension. +module Moonlight.Category.Pure.FiniteComposable + ( ComposableChain, + chainStartObject, + chainMorphisms, + ComposableChainError (..), + SizedComposableChain, + sizedChainDimension, + sizedChainValue, + chainDimension, + chainTerminalObject, + singletonComposableChain, + mkComposableChain, + sizedComposableChain, + appendComposableMorphism, + chainsOfDimension, + FiniteComposableCategory (..), + ) +where + +import Data.Bifunctor (first) +import Control.Monad (foldM) +import Data.Foldable (toList) +import Data.Function ((&)) +import Data.Kind (Constraint, Type) +import Data.List (genericTake) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Seq +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Category (Category (..)) + +type ComposableChain :: Type -> Type +-- | A path whose adjacent morphism endpoints have been validated. +data ComposableChain c = ComposableChain + { -- | The path's source object. + chainStartObject :: Ob c, + -- | The path's current target object. + chainTerminalObject :: Ob c, + chainMorphismSequence :: Seq (Mor c) + } + +type SizedComposableChain :: Type -> Type +-- | A validated path paired with its morphism count. +data SizedComposableChain c = SizedComposableChain + { -- | The number of morphisms in the path. + sizedChainDimension :: Natural, + -- | The underlying validated path. + sizedChainValue :: ComposableChain c + } + +type ComposableChainError :: Type -> Type +-- | A category failure or an endpoint incompatibility encountered while +-- extending a path. +data ComposableChainError c + = ComposableChainCategoryError (CategoryError c) + | ComposableChainEndpointMismatch (Ob c) (Ob c) + +-- | Count the morphisms in a validated path. +chainDimension :: ComposableChain c -> Natural +chainDimension = fromIntegral . Seq.length . chainMorphismSequence + +-- | Project the morphisms in composition order. +chainMorphisms :: ComposableChain c -> [Mor c] +chainMorphisms = toList . chainMorphismSequence + +-- | The dimension-zero path at an object. +singletonComposableChain :: Ob c -> ComposableChain c +singletonComposableChain objectValue = + ComposableChain objectValue objectValue Seq.empty + +-- | Validate a morphism sequence from a declared start object. +mkComposableChain :: (Category c, Eq (Ob c)) => c -> Ob c -> [Mor c] -> Either (ComposableChainError c) (ComposableChain c) +mkComposableChain categoryValue startObject = + foldM (appendComposableMorphism categoryValue) (singletonComposableChain startObject) + +-- | Attach the derived dimension to a validated path. +sizedComposableChain :: ComposableChain c -> SizedComposableChain c +sizedComposableChain chainValue = + SizedComposableChain + { sizedChainDimension = chainDimension chainValue, + sizedChainValue = chainValue + } + +-- | Extend a path when the new morphism starts at its terminal object. +appendComposableMorphism :: (Category c, Eq (Ob c)) => c -> ComposableChain c -> Mor c -> Either (ComposableChainError c) (ComposableChain c) +appendComposableMorphism categoryValue chainValue morphism = do + morphismSource <- first ComposableChainCategoryError (source categoryValue morphism) + morphismTarget <- first ComposableChainCategoryError (target categoryValue morphism) + if morphismSource == chainTerminalObject chainValue + then + Right + ComposableChain + { chainStartObject = chainStartObject chainValue, + chainTerminalObject = morphismTarget, + chainMorphismSequence = chainMorphismSequence chainValue |> morphism + } + else Left (ComposableChainEndpointMismatch (chainTerminalObject chainValue) morphismSource) + +-- | Enumerate all composable paths at one exact dimension. +chainsOfDimension :: FiniteComposableCategory c => c -> Natural -> [ComposableChain c] +chainsOfDimension categoryValue dimensionBound = + fromMaybe [] (indexByNatural dimensionBound (chainsByDimension categoryValue)) + +indexByNatural :: Natural -> [a] -> Maybe a +indexByNatural indexValue values = + case (indexValue, values) of + (_, []) -> Nothing + (0, value : _) -> Just value + (_, _ : rest) -> indexByNatural (indexValue - 1) rest + +chainsByDimension :: FiniteComposableCategory c => c -> [[ComposableChain c]] +chainsByDimension categoryValue = + iterate (extendChains categoryValue) (map singletonComposableChain (enumerateObjects categoryValue)) + +extendChains :: FiniteComposableCategory c => c -> [ComposableChain c] -> [ComposableChain c] +extendChains categoryValue chains = + chains + >>= ( \chainValue -> + mapMaybe + (either (const Nothing) Just . appendComposableMorphism categoryValue chainValue) + (enumerateMorphismsFrom categoryValue (chainTerminalObject chainValue)) + ) + +extendGrowingChainsNonIdentity :: + (FiniteComposableCategory c, Eq (Mor c)) => + c -> + [ComposableChain c] -> + [ComposableChain c] +extendGrowingChainsNonIdentity categoryValue chains = + chains + >>= ( \chainValue -> + let terminalObject = chainTerminalObject chainValue + terminalIdentity = + either (const Nothing) Just (identity categoryValue terminalObject) + in enumerateMorphismsFrom categoryValue terminalObject + & mapMaybe + ( \morphism -> do + if Just morphism == terminalIdentity + then Nothing + else either (const Nothing) Just (appendComposableMorphism categoryValue chainValue morphism) + ) + ) + +type FiniteComposableCategory :: Type -> Constraint +-- | A finite category whose objects, morphisms, and composable paths can be +-- enumerated. +class (Category c, Eq (Ob c)) => FiniteComposableCategory c where + enumerateObjects :: c -> [Ob c] + enumerateMorphisms :: c -> [Mor c] + enumerateMorphismsFrom :: c -> Ob c -> [Mor c] + enumerateMorphismsFrom categoryValue sourceObject = + enumerateMorphisms categoryValue + & filter + ( \morphism -> + case source categoryValue morphism of + Right morphismSource -> morphismSource == sourceObject + Left _ -> False + ) + + enumerateComposableChains :: c -> Natural -> [SizedComposableChain c] + default enumerateComposableChains :: c -> Natural -> [SizedComposableChain c] + enumerateComposableChains categoryValue dimensionBound = + genericTake (dimensionBound + 1) (chainsByDimension categoryValue) + & foldMap (fmap sizedComposableChain) + + enumerateNonDegenerateChainsByDimension :: Eq (Mor c) => c -> Natural -> [[ComposableChain c]] + enumerateNonDegenerateChainsByDimension categoryValue dimensionBound = + genericTake + (dimensionBound + 1) + ( iterate + (extendGrowingChainsNonIdentity categoryValue) + (fmap singletonComposableChain (enumerateObjects categoryValue)) + ) diff --git a/src-abstract/Moonlight/Category/Pure/Galois.hs b/src-abstract/Moonlight/Category/Pure/Galois.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Galois.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FunctionalDependencies #-} + +-- | Galois connections between ordered types (the 'alpha'/'gamma' adjoint pair), with +-- the ordinal-threshold refinement. +module Moonlight.Category.Pure.Galois + ( GaloisConnection (..), + OrdinalGalois (..), + ) +where + +import Data.Kind (Constraint, Type) + +type GaloisConnection :: Type -> Type -> Constraint +-- | An adjoint pair between ordered carriers. +class (Ord a, Ord b) => GaloisConnection a b | a -> b, b -> a where + alpha :: a -> b + gamma :: b -> a + +type OrdinalGalois :: Type -> Type -> Constraint +-- | A Galois connection with a finite threshold presentation. +class GaloisConnection a b => OrdinalGalois a b where + thresholds :: [(a, b)] diff --git a/src-abstract/Moonlight/Category/Pure/Higher.hs b/src-abstract/Moonlight/Category/Pure/Higher.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Higher.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The higher-category tower: 'HigherCategory', 'TwoCategory', 'Bicategory', +-- 'MonoidalCategory' and 'EnrichedCategory'. +module Moonlight.Category.Pure.Higher + ( HigherCategory (..), + TwoCategory (..), + Bicategory (..), + MonoidalCategory (..), + EnrichedCategory (..), + ) +where + +import Data.Kind (Constraint, Type) +import Moonlight.Category.Pure.Category (Category (..)) + +type HigherCategory :: Type -> Constraint +-- | A category equipped with horizontal and vertical 2-morphism composition. +class Category c => HigherCategory c where + source2 :: TwoMor c -> Mor c + target2 :: TwoMor c -> Mor c + id2 :: Mor c -> TwoMor c + hCompose :: c -> TwoMor c -> TwoMor c -> Either (CategoryError c) (TwoMor c) + vCompose :: c -> TwoMor c -> TwoMor c -> Either (CategoryError c) (TwoMor c) + whiskerLeft :: c -> Mor c -> TwoMor c -> Either (CategoryError c) (TwoMor c) + whiskerLeft categoryValue morphism + = hCompose categoryValue (id2 morphism) + whiskerRight :: c -> TwoMor c -> Mor c -> Either (CategoryError c) (TwoMor c) + whiskerRight categoryValue twoMorphism morphism = hCompose categoryValue twoMorphism (id2 morphism) + compositor :: c -> Mor c -> Mor c -> Mor c -> Compositor c + +type TwoCategory :: Type -> Constraint +-- | A higher category whose 2-morphisms admit inverses. +class HigherCategory c => TwoCategory c where + inverse2 :: c -> TwoMor c -> Either (CategoryError c) (TwoMor c) + +type Bicategory :: Type -> Constraint +-- | A higher category with explicit unitor and associator witnesses. +class HigherCategory c => Bicategory c where + leftUnitor :: c -> Mor c -> Compositor c + rightUnitor :: c -> Mor c -> Compositor c + associator :: c -> Mor c -> Mor c -> Mor c -> Compositor c + +type MonoidalCategory :: Type -> Constraint +-- | A category with tensor product, unit, and coherence witnesses. +class Category v => MonoidalCategory v where + tensorOb :: Ob v -> Ob v -> Ob v + tensorMor :: v -> Mor v -> Mor v -> Either (CategoryError v) (Mor v, Compositor v) + unitOb :: Ob v + associatorV :: Ob v -> Ob v -> Ob v -> Compositor v + leftUnitorV :: Ob v -> Compositor v + rightUnitorV :: Ob v -> Compositor v + +type EnrichedCategory :: Type -> Type -> Constraint +-- | A category whose hom-objects and composition live in a monoidal category. +class (Category c, MonoidalCategory v) => EnrichedCategory c v | c -> v where + enrichHom :: Ob c -> Ob c -> Ob v + enrichIdentity :: Ob c -> Mor v + enrichCompose :: Ob c -> Ob c -> Ob c -> Mor v diff --git a/src-abstract/Moonlight/Category/Pure/Limits.hs b/src-abstract/Moonlight/Category/Pure/Limits.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Limits.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Universal-property classes for (co)limits: products, coproducts, pullbacks, +-- pushouts, equalizers and coequalizers over a 'Category'. +module Moonlight.Category.Pure.Limits + ( HasProducts (..), + HasCoproducts (..), + HasPullbacks (..), + HasPushouts (..), + HasEqualizers (..), + HasCoequalizers (..), + ) +where + +import Data.Kind (Constraint, Type) +import Moonlight.Category.Pure.Category (Category (..)) + +type HasProducts :: Type -> Constraint +-- | Categories with chosen binary products and their universal mediators. +class Category c => HasProducts c where + type ProductOb c :: Type + productProj1 :: c -> ProductOb c -> Mor c + productProj2 :: c -> ProductOb c -> Mor c + productUniversal :: c -> Mor c -> Mor c -> Mor c + +type HasCoproducts :: Type -> Constraint +-- | Categories with chosen binary coproducts and their universal mediators. +class Category c => HasCoproducts c where + type CoproductOb c :: Type + coproductInj1 :: c -> CoproductOb c -> Mor c + coproductInj2 :: c -> CoproductOb c -> Mor c + coproductUniversal :: c -> Mor c -> Mor c -> Mor c + +type HasPullbacks :: Type -> Constraint +-- | Categories with partial, explicitly witnessed pullback construction. +class Category c => HasPullbacks c where + pullback :: c -> Mor c -> Mor c -> Maybe (Ob c, Mor c, Mor c) + pullbackMediator :: c -> Mor c -> Mor c -> Mor c -> Mor c -> Maybe (Mor c) + +type HasPushouts :: Type -> Constraint +-- | Categories with partial, explicitly witnessed pushout construction. +class Category c => HasPushouts c where + pushout :: c -> Mor c -> Mor c -> Maybe (Ob c, Mor c, Mor c) + +type HasEqualizers :: Type -> Constraint +-- | Categories with partial equalizer construction. +class Category c => HasEqualizers c where + equalizer :: c -> Mor c -> Mor c -> Maybe (Ob c, Mor c) + +type HasCoequalizers :: Type -> Constraint +-- | Categories with partial coequalizer construction. +class Category c => HasCoequalizers c where + coequalizer :: c -> Mor c -> Mor c -> Maybe (Ob c, Mor c) diff --git a/src-abstract/Moonlight/Category/Pure/PolynomialFunctor.hs b/src-abstract/Moonlight/Category/Pure/PolynomialFunctor.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/PolynomialFunctor.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Polynomial functors as positions with directions, and the parameterized variant. +module Moonlight.Category.Pure.PolynomialFunctor + ( PolynomialFunctor (..), + ParameterizedPolynomialFunctor (..), + ) +where + +import Data.Kind (Constraint, Type) +import Moonlight.Category.Pure.CoveringFamily (Exists) + +type PolynomialFunctor :: Type -> Constraint +-- | A polynomial described by positions and the directions at each position. +class PolynomialFunctor polynomial where + data Position polynomial :: Type -> Type + type Direction polynomial position :: Type + allPositions :: [Exists (Position polynomial)] + +type ParameterizedPolynomialFunctor :: Type -> Constraint +-- | A polynomial family whose positions and directions vary by parameter. +class ParameterizedPolynomialFunctor polynomial where + type PolynomialParameter polynomial :: Type + data ParameterizedPosition polynomial :: Type -> Type + type ParameterizedDirection polynomial position :: Type + positionsAt :: PolynomialParameter polynomial -> [Exists (ParameterizedPosition polynomial)] diff --git a/src-abstract/Moonlight/Category/Pure/Poset.hs b/src-abstract/Moonlight/Category/Pure/Poset.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Poset.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | Posets viewed as thin categories: a morphism exists exactly where the +-- order relation holds. +module Moonlight.Category.Pure.Poset + ( PosetCat (..), + PosetOb (..), + PosetMor, + PosetTwoMor (..), + PosetCompositor (..), + mkPosetMor, + posetSource, + posetTarget, + OrdinalLower (..), + OrdinalUpper (..), + LowerPosetCat, + UpperPosetCat, + LowerMor, + UpperMor, + mkLowerMor, + mkUpperMor, + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Galois (GaloisConnection (..), OrdinalGalois (..)) +import Moonlight.Category.Pure.Thin + ( ThinMorphism, + identityThinMorphism, + mkThinMorphismBy, + thinMorphismSource, + thinMorphismTarget, + ) + +type PosetCat :: Type -> Type +-- | The thin category induced by an ordered carrier. +data PosetCat a = PosetCat + deriving stock (Eq, Show) + +type PosetOb :: Type -> Type +-- | An object in a poset category. +newtype PosetOb a = PosetOb {unPosetOb :: a} + deriving stock (Eq, Ord, Show) + +type PosetMor :: Type -> Type +-- | Order evidence from a source value to a target value. +data PosetMor a = PosetMor a a + deriving stock (Eq, Show) + +type PosetTwoMor :: Type -> Type +-- | The unique 2-morphism witness in a poset category. +data PosetTwoMor (a :: Type) = PosetTwoMor + deriving stock (Eq, Show) + +type PosetCompositor :: Type -> Type +-- | Composition evidence for poset morphisms. +data PosetCompositor (a :: Type) = PosetCompositor + deriving stock (Eq, Show) + +-- | Admit a poset morphism exactly when the source is below the target. +mkPosetMor :: Ord a => a -> a -> Maybe (PosetMor a) +mkPosetMor sourceValue targetValue = + fromThinMorphism <$> mkThinMorphismBy (<=) sourceValue targetValue + +-- | Project the source value. +posetSource :: PosetMor a -> a +posetSource (PosetMor sourceValue _) = sourceValue + +-- | Project the target value. +posetTarget :: PosetMor a -> a +posetTarget (PosetMor _ targetValue) = targetValue + +instance Ord a => Category (PosetCat a) where + type Ob (PosetCat a) = PosetOb a + type Mor (PosetCat a) = PosetMor a + type TwoMor (PosetCat a) = PosetTwoMor a + type Compositor (PosetCat a) = PosetCompositor a + + identity _ (PosetOb objectValue) = + Right (fromThinMorphism (identityThinMorphism objectValue)) + + compose _ leftMorphism rightMorphism + | posetTarget rightMorphism /= posetSource leftMorphism = Left () + | otherwise = + case mkPosetMor (posetSource rightMorphism) (posetTarget leftMorphism) of + Just composedMorphism -> Right (composedMorphism, PosetCompositor) + Nothing -> Left () + + source _ = Right . PosetOb . posetSource + target _ = Right . PosetOb . posetTarget + +type OrdinalLower :: Type +-- | The lower carrier of the example ordinal Galois connection. +newtype OrdinalLower = OrdinalLower {unOrdinalLower :: Int} + deriving stock (Eq, Ord, Show) + +type OrdinalUpper :: Type +-- | The upper carrier of the example ordinal Galois connection. +newtype OrdinalUpper = OrdinalUpper {unOrdinalUpper :: Int} + deriving stock (Eq, Ord, Show) + +instance GaloisConnection OrdinalLower OrdinalUpper where + alpha (OrdinalLower value) = OrdinalUpper (value * 2) + gamma (OrdinalUpper value) = OrdinalLower (value `div` 2) + +instance OrdinalGalois OrdinalLower OrdinalUpper where + thresholds = map (\value -> (OrdinalLower value, OrdinalUpper (value * 2))) [0 .. 32] + +type LowerPosetCat :: Type +-- | The poset category over t'OrdinalLower'. +type LowerPosetCat = PosetCat OrdinalLower + +type UpperPosetCat :: Type +-- | The poset category over t'OrdinalUpper'. +type UpperPosetCat = PosetCat OrdinalUpper + +type LowerMor :: Type +-- | A morphism in 'LowerPosetCat'. +type LowerMor = PosetMor OrdinalLower + +type UpperMor :: Type +-- | A morphism in 'UpperPosetCat'. +type UpperMor = PosetMor OrdinalUpper + +-- | Construct a lower-carrier order witness. +mkLowerMor :: OrdinalLower -> OrdinalLower -> Maybe LowerMor +mkLowerMor = mkPosetMor + +-- | Construct an upper-carrier order witness. +mkUpperMor :: OrdinalUpper -> OrdinalUpper -> Maybe UpperMor +mkUpperMor = mkPosetMor + + +fromThinMorphism :: ThinMorphism a -> PosetMor a +fromThinMorphism thinMorphism = + PosetMor + (thinMorphismSource thinMorphism) + (thinMorphismTarget thinMorphism) diff --git a/src-abstract/Moonlight/Category/Pure/StructuredCospan.hs b/src-abstract/Moonlight/Category/Pure/StructuredCospan.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/StructuredCospan.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Structured cospans: two legs into a shared apex carrying a decoration, with +-- boundary projections and pushout composition. +module Moonlight.Category.Pure.StructuredCospan + ( StructuredCospan, + structuredLeftLeg, + structuredRightLeg, + structuredApex, + structuredDecoration, + mkStructuredCospan, + leftBoundary, + rightBoundary, + composeStructuredCospan, + StructuredCospanError (..), + ) +where + +import Data.Bifunctor (first) +import Data.Kind (Type) +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.Limits (HasPushouts (..)) + +type StructuredCospan :: Type -> Type -> Type +-- | Two boundary morphisms with a common apex and an attached decoration. +data StructuredCospan category decoration = StructuredCospan + { structuredLeftBoundary :: Ob category, + structuredRightBoundary :: Ob category, + -- | The morphism from the left boundary into the apex. + structuredLeftLeg :: Mor category, + -- | The morphism from the right boundary into the apex. + structuredRightLeg :: Mor category, + -- | The common codomain of both legs. + structuredApex :: Ob category, + -- | Data carried by the apex. + structuredDecoration :: decoration + } + +type StructuredCospanError :: Type -> Type +-- | Failure to inspect, align, or push out structured boundaries. +data StructuredCospanError category + = StructuredCospanCategoryError (CategoryError category) + | StructuredCospanBoundaryMismatch (Ob category) (Ob category) + | StructuredCospanPushoutMissing (Mor category) (Mor category) + +-- | Validate that both legs share an apex. +mkStructuredCospan :: (Category category, Eq (Ob category)) => category -> Mor category -> Mor category -> decoration -> Either (StructuredCospanError category) (StructuredCospan category decoration) +mkStructuredCospan categoryValue leftLeg rightLeg decoration = do + leftSource <- first StructuredCospanCategoryError (source categoryValue leftLeg) + rightSource <- first StructuredCospanCategoryError (source categoryValue rightLeg) + leftTarget <- first StructuredCospanCategoryError (target categoryValue leftLeg) + rightTarget <- first StructuredCospanCategoryError (target categoryValue rightLeg) + if leftTarget == rightTarget + then Right (StructuredCospan leftSource rightSource leftLeg rightLeg leftTarget decoration) + else Left (StructuredCospanBoundaryMismatch leftTarget rightTarget) +{-# INLINE mkStructuredCospan #-} + +-- | Project the left boundary through the category's failure surface. +leftBoundary :: category -> StructuredCospan category decoration -> Either (CategoryError category) (Ob category) +leftBoundary _ = + Right . structuredLeftBoundary +{-# INLINE leftBoundary #-} + +-- | Project the right boundary through the category's failure surface. +rightBoundary :: category -> StructuredCospan category decoration -> Either (CategoryError category) (Ob category) +rightBoundary _ = + Right . structuredRightBoundary +{-# INLINE rightBoundary #-} + +-- | Glue matching boundaries by pushout and combine their decorations. +composeStructuredCospan :: + (HasPushouts category, Eq (Ob category)) => + category -> + (leftDecoration -> rightDecoration -> combinedDecoration) -> + StructuredCospan category leftDecoration -> + StructuredCospan category rightDecoration -> + Either (StructuredCospanError category) (StructuredCospan category combinedDecoration) +composeStructuredCospan categoryValue combineDecorations leftCospan rightCospan = do + if structuredRightBoundary leftCospan == structuredLeftBoundary rightCospan + then Right () + else Left (StructuredCospanBoundaryMismatch (structuredRightBoundary leftCospan) (structuredLeftBoundary rightCospan)) + (pushoutObject, pushoutLeft, pushoutRight) <- + maybe + (Left (StructuredCospanPushoutMissing (structuredRightLeg leftCospan) (structuredLeftLeg rightCospan))) + Right + (pushout categoryValue (structuredRightLeg leftCospan) (structuredLeftLeg rightCospan)) + composedLeft <- first StructuredCospanCategoryError (composeMor categoryValue pushoutLeft (structuredLeftLeg leftCospan)) + composedRight <- first StructuredCospanCategoryError (composeMor categoryValue pushoutRight (structuredRightLeg rightCospan)) + pure + ( StructuredCospan + (structuredLeftBoundary leftCospan) + (structuredRightBoundary rightCospan) + composedLeft + composedRight + pushoutObject + (combineDecorations (structuredDecoration leftCospan) (structuredDecoration rightCospan)) + ) +{-# INLINE composeStructuredCospan #-} diff --git a/src-abstract/Moonlight/Category/Pure/Thin.hs b/src-abstract/Moonlight/Category/Pure/Thin.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Thin.hs @@ -0,0 +1,45 @@ +-- | Thin morphisms over a relation: at most one morphism between any two objects, +-- with relation-checked construction, identity and composition. +module Moonlight.Category.Pure.Thin + ( ThinMorphism, + thinMorphismSource, + thinMorphismTarget, + mkThinMorphismBy, + identityThinMorphism, + composeThinMorphismBy, + ) +where + +import Data.Kind (Type) + +type ThinMorphism :: Type -> Type +-- | The unique candidate morphism between two objects of a thin category. +data ThinMorphism obj = ThinMorphism + { thinMorphismSource :: obj, + thinMorphismTarget :: obj + } + deriving stock (Eq, Ord, Show) + +-- | Admit a morphism exactly when the supplied relation holds. +mkThinMorphismBy :: (obj -> obj -> Bool) -> obj -> obj -> Maybe (ThinMorphism obj) +mkThinMorphismBy relation sourceValue targetValue = + if relation sourceValue targetValue + then Just (ThinMorphism sourceValue targetValue) + else Nothing + +-- | Construct the reflexive identity witness. +identityThinMorphism :: obj -> ThinMorphism obj +identityThinMorphism objectValue = + ThinMorphism objectValue objectValue + +-- | Compose relation-valid morphisms with matching middle endpoints. +composeThinMorphismBy :: Eq obj => (obj -> obj -> Bool) -> ThinMorphism obj -> ThinMorphism obj -> Maybe (ThinMorphism obj) +composeThinMorphismBy relation leftMorphism rightMorphism + | not (relation (thinMorphismSource leftMorphism) (thinMorphismTarget leftMorphism)) = Nothing + | not (relation (thinMorphismSource rightMorphism) (thinMorphismTarget rightMorphism)) = Nothing + | thinMorphismTarget rightMorphism == thinMorphismSource leftMorphism = + mkThinMorphismBy + relation + (thinMorphismSource rightMorphism) + (thinMorphismTarget leftMorphism) + | otherwise = Nothing diff --git a/src-abstract/Moonlight/Category/Pure/Unit.hs b/src-abstract/Moonlight/Category/Pure/Unit.hs new file mode 100644 --- /dev/null +++ b/src-abstract/Moonlight/Category/Pure/Unit.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | The one-object, identity-only category: the smallest lawful 'Category' carrier. +module Moonlight.Category.Pure.Unit + ( UnitCat (..), + UnitObj (..), + UnitMor (..), + UnitTwoMor (..), + UnitCompositor (..), + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.Adhesive + ( AdhesiveCategory (..), + MonicMatchComponents (..), + PBPOAdhesiveCategory, + PushoutComplementComponents (..), + ) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Higher (Bicategory (..), EnrichedCategory (..), HigherCategory (..), MonoidalCategory (..), TwoCategory (..)) +import Moonlight.Category.Pure.Limits (HasCoequalizers (..), HasCoproducts (..), HasEqualizers (..), HasProducts (..), HasPullbacks (..), HasPushouts (..)) + +type UnitCat :: Type +-- | The terminal one-object category. +data UnitCat = UnitCat + deriving stock (Eq, Show) + +type UnitObj :: Type +-- | The sole object of t'UnitCat'. +data UnitObj = UnitObj + deriving stock (Eq, Show, Enum, Bounded) + +type UnitMor :: Type +-- | The sole 1-morphism of t'UnitCat'. +data UnitMor = UnitMor + deriving stock (Eq, Show, Enum, Bounded) + +type UnitTwoMor :: Type +-- | A 2-morphism between the unique 1-morphism endpoints. +data UnitTwoMor = UnitTwoMor + { unitTwoSource :: UnitMor, + unitTwoTarget :: UnitMor + } + deriving stock (Eq, Show) + +type UnitCompositor :: Type +-- | Coherence evidence for the strict unit category. +data UnitCompositor + = UnitStrictCompositor + | UnitAssociator UnitMor UnitMor UnitMor + | UnitLeftUnitor UnitMor + | UnitRightUnitor UnitMor + deriving stock (Eq, Show) + +instance Category UnitCat where + type Ob UnitCat = UnitObj + type Mor UnitCat = UnitMor + type TwoMor UnitCat = UnitTwoMor + type Compositor UnitCat = UnitCompositor + + identity _ _ = Right UnitMor + + compose _ _ _ = Right (UnitMor, UnitStrictCompositor) + + source _ _ = Right UnitObj + target _ _ = Right UnitObj + +instance HigherCategory UnitCat where + source2 = unitTwoSource + target2 = unitTwoTarget + id2 morphism = UnitTwoMor morphism morphism + hCompose _ left right = + if unitTwoTarget right == unitTwoSource left + then Right (UnitTwoMor (unitTwoSource right) (unitTwoTarget left)) + else Left () + vCompose _ left right = + if unitTwoTarget right == unitTwoSource left + then Right (UnitTwoMor (unitTwoSource right) (unitTwoTarget left)) + else Left () + compositor _ = UnitAssociator + +instance TwoCategory UnitCat where + inverse2 _ twoMorphism = Right (UnitTwoMor (unitTwoTarget twoMorphism) (unitTwoSource twoMorphism)) + +instance Bicategory UnitCat where + leftUnitor _ = UnitLeftUnitor + rightUnitor _ = UnitRightUnitor + associator _ = UnitAssociator + +instance MonoidalCategory UnitCat where + tensorOb _ _ = UnitObj + tensorMor _ _ _ = Right (UnitMor, UnitStrictCompositor) + unitOb = UnitObj + associatorV _ _ _ = UnitAssociator UnitMor UnitMor UnitMor + leftUnitorV _ = UnitLeftUnitor UnitMor + rightUnitorV _ = UnitRightUnitor UnitMor + +instance EnrichedCategory UnitCat UnitCat where + enrichHom _ _ = UnitObj + enrichIdentity _ = UnitMor + enrichCompose _ _ _ = UnitMor + +instance HasProducts UnitCat where + type ProductOb UnitCat = UnitObj + productProj1 _ _ = UnitMor + productProj2 _ _ = UnitMor + productUniversal _ _ _ = UnitMor + +instance HasCoproducts UnitCat where + type CoproductOb UnitCat = UnitObj + coproductInj1 _ _ = UnitMor + coproductInj2 _ _ = UnitMor + coproductUniversal _ _ _ = UnitMor + +instance HasPullbacks UnitCat where + pullback _ _ _ = Just (UnitObj, UnitMor, UnitMor) + pullbackMediator _ _ _ _ _ = Just UnitMor + +instance HasPushouts UnitCat where + pushout _ _ _ = Just (UnitObj, UnitMor, UnitMor) + +instance HasEqualizers UnitCat where + equalizer _ _ _ = Just (UnitObj, UnitMor) + +instance HasCoequalizers UnitCat where + coequalizer _ _ _ = Just (UnitObj, UnitMor) + +instance AdhesiveCategory UnitCat where + monicMatchComponents _ _ = + Just (MonicMatchComponents UnitMor) + + pushoutComplementComponents _ _ _ = + Just + PushoutComplementComponents + { pushoutComplementComponentObject = UnitObj, + pushoutComplementComponentBorrowedLeg = UnitMor, + pushoutComplementComponentResidualLeg = UnitMor + } + +instance PBPOAdhesiveCategory UnitCat diff --git a/src-finite/Moonlight/Category/Pure/FinCat.hs b/src-finite/Moonlight/Category/Pure/FinCat.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/FinCat.hs @@ -0,0 +1,1587 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Runtime-validated finite categories ('FinCat'): object and morphism handles and +-- ids, validation errors, morphism enumeration and folds, and bit-packed thin +-- constructions. +module Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatHandle, + FinObjectId (..), + FinGeneratorId (..), + FinMorphismId (..), + FinObj, + FinMor, + FinCompositor (..), + FinTwoMor, + FinCatValidationError (..), + FinCatError (..), + finCatIsThin, + finCatObjects, + objectCount, + finCatMorphismCount, + finCatNonIdentityMorphismCount, + finCatMorphismCountFrom, + finCatMorphismCountTo, + finCatExplicitMorphismMapView, + finCatExplicitCompositionMapView, + finCatHandle, + finObjCategoryHandle, + finObjId, + finMorCategoryHandle, + finMorId, + finMorSourceId, + finMorTargetId, + finTwoSource, + finTwoTarget, + mkFinCat, + trustedFinCatWithGeneratorBasis, + finCatMorphismIdByEndpoints, + foldMapFinMorphisms, + foldMapFinMorphismsFrom, + foldMapFinMorphismsTo, + trustedThinFinCatFromTransitiveEndpoints, + trustedDenseThinFinCatFromReachabilityRows, + denseThinEndpointMorphismsFromCategory, + mkFinObject, + mkFinMorphism, + mkFinTwoMor, + finMorDomObject, + finMorCodObject, + finObjectIdentityMor, + finCatHomMorphism, + allObjects, + allMorphisms, + allMorphismsFrom, + ) +where + +import Data.Bits (bit, clearBit, popCount, shiftR, testBit, (.&.), (.|.)) +import Data.Kind (Type) +import Data.List (find, genericTake, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Data.Vector.Unboxed as UVector +import Data.Word (Word64) +import Data.Foldable (fold) +import Data.Function ((&)) +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.FiniteComposable + ( ComposableChain, + FiniteComposableCategory (..), + SizedComposableChain, + appendComposableMorphism, + chainTerminalObject, + sizedComposableChain, + singletonComposableChain, + ) +import Moonlight.Category.Pure.Higher (Bicategory (..), HigherCategory (..), TwoCategory (..)) +import Moonlight.Core + ( ExactEncoding, + ExactEncodingAtom (..), + ExactToken, + Validation (..), + exactAtomEncoding, + exactSequenceEncoding, + exactSequenceMapEncoding, + exactTokenFromEncoding, + validationToEither, + ) +import Moonlight.Category.Pure.Finite.DenseReachability (bitsToAscList, transposeBitRows) +import Numeric.Natural (Natural) + +newtype FinObjectId = FinObjectId {unFinObjectId :: Int} + deriving stock (Eq, Ord, Show) + +newtype FinGeneratorId = FinGeneratorId {unFinGeneratorId :: Int} + deriving stock (Eq, Ord, Show) + +type FinMorphismId :: Type +data FinMorphismId + = FinIdentityId FinObjectId + | FinGeneratorMorphismId FinGeneratorId + deriving stock (Eq, Ord, Show) + +type FinCatHandle :: Type +newtype FinCatHandle = FinCatHandle ExactToken + deriving stock (Eq, Ord, Show) + +type FinCat :: Type +data FinCat + = ExplicitFinCat ExplicitFinCatData + | ThinFinCat ThinFinCatData + | DenseThinFinCat DenseThinFinCatData + +finCatIsThin :: FinCat -> Bool +finCatIsThin categoryValue = + case categoryValue of + ThinFinCat _ -> True + DenseThinFinCat _ -> True + ExplicitFinCat explicitData -> + all ((<= 1) . length) (Map.elems (explicitFinCatMorphismMap explicitData)) + && all + (\((sourceObject, targetObject), morphisms) -> sourceObject /= targetObject || null morphisms) + (Map.toAscList (explicitFinCatMorphismMap explicitData)) + +type ExplicitFinCatData :: Type +data ExplicitFinCatData = ExplicitFinCatData + { explicitFinCatHandle :: FinCatHandle, + explicitFinCatObjects :: Set FinObjectId, + explicitFinCatMorphismMap :: Map (FinObjectId, FinObjectId) [FinMorphismId], + explicitFinCatCompositionMap :: Map (FinMorphismId, FinMorphismId) FinMorphismId, + explicitFinCatMorphismIndex :: Map FinMorphismId (FinObjectId, FinObjectId), + explicitFinCatMorphismsBySource :: Map FinObjectId [(FinObjectId, [FinMorphismId])], + explicitFinCatMorphismsByTarget :: Map FinObjectId [(FinObjectId, [FinMorphismId])] + } + +type ThinFinCatData :: Type +data ThinFinCatData = ThinFinCatData + { thinFinCatHandle :: FinCatHandle, + thinFinCatObjects :: Set FinObjectId, + thinFinCatEndpointMorphisms :: Map (FinObjectId, FinObjectId) FinMorphismId, + thinFinCatMorphismIndex :: Map FinMorphismId (FinObjectId, FinObjectId), + thinFinCatMorphismsBySource :: Map FinObjectId [(FinObjectId, FinMorphismId)], + thinFinCatMorphismsByTarget :: Map FinObjectId [(FinObjectId, FinMorphismId)] + } + +type DenseThinFinCatData :: Type +data DenseThinFinCatData = DenseThinFinCatData + { denseThinFinCatHandle :: FinCatHandle, + denseThinFinCatObjects :: Set FinObjectId, + denseThinFinCatObjectCount :: !Int, + denseThinFinCatNonIdentityMorphismCount :: !Int, + denseThinFinCatReachabilityRows :: Vector Integer, + denseThinFinCatPredecessorRows :: Vector Integer, + denseThinFinCatSourceCounts :: UVector.Vector Int, + denseThinFinCatTargetCounts :: UVector.Vector Int, + denseThinFinCatPrefixCounts :: UVector.Vector Int, + denseThinFinCatEndpointIndex :: UVector.Vector Int, + denseThinFinCatSourceColumn :: UVector.Vector Int, + denseThinFinCatTargetColumn :: UVector.Vector Int + } + +finCatHandle :: FinCat -> FinCatHandle +finCatHandle category = + case category of + ExplicitFinCat explicitData -> explicitFinCatHandle explicitData + ThinFinCat thinData -> thinFinCatHandle thinData + DenseThinFinCat denseData -> denseThinFinCatHandle denseData + +finCatObjects :: FinCat -> Set FinObjectId +finCatObjects category = + case category of + ExplicitFinCat explicitData -> explicitFinCatObjects explicitData + ThinFinCat thinData -> thinFinCatObjects thinData + DenseThinFinCat denseData -> denseThinFinCatObjects denseData + +objectCount :: FinCat -> Int +objectCount category = + case category of + ExplicitFinCat explicitData -> Set.size (explicitFinCatObjects explicitData) + ThinFinCat thinData -> Set.size (thinFinCatObjects thinData) + DenseThinFinCat denseData -> denseThinFinCatObjectCount denseData + +finCatNonIdentityMorphismCount :: FinCat -> Int +finCatNonIdentityMorphismCount category = + case category of + ExplicitFinCat explicitData -> + explicitFinCatMorphismMap explicitData + & Map.elems + & fmap length + & sum + ThinFinCat thinData -> + Map.size (thinFinCatEndpointMorphisms thinData) + DenseThinFinCat denseData -> + denseThinFinCatNonIdentityMorphismCount denseData + +finCatMorphismCount :: FinCat -> Int +finCatMorphismCount category = + objectCount category + finCatNonIdentityMorphismCount category + +finCatMorphismCountFrom :: FinCat -> FinObjectId -> Int +finCatMorphismCountFrom category sourceId = + case category of + DenseThinFinCat denseData -> + denseMorphismCountFrom denseData sourceId + _ + | not (finCatHasObject category sourceId) -> 0 + | otherwise -> 1 + nonIdentityCount + where + nonIdentityCount = + case category of + ExplicitFinCat explicitData -> + Map.findWithDefault [] sourceId (explicitFinCatMorphismsBySource explicitData) + & fmap (length . snd) + & sum + ThinFinCat thinData -> + Map.findWithDefault [] sourceId (thinFinCatMorphismsBySource thinData) + & length + DenseThinFinCat _ -> 0 + +finCatMorphismCountTo :: FinCat -> FinObjectId -> Int +finCatMorphismCountTo category targetId = + case category of + DenseThinFinCat denseData -> + denseMorphismCountTo denseData targetId + _ + | not (finCatHasObject category targetId) -> 0 + | otherwise -> 1 + nonIdentityCount + where + nonIdentityCount = + case category of + ExplicitFinCat explicitData -> + Map.findWithDefault [] targetId (explicitFinCatMorphismsByTarget explicitData) + & fmap (length . snd) + & sum + ThinFinCat thinData -> + Map.findWithDefault [] targetId (thinFinCatMorphismsByTarget thinData) + & length + DenseThinFinCat _ -> 0 + +finCatExplicitMorphismMapView :: FinCat -> Map (FinObjectId, FinObjectId) [FinMorphismId] +finCatExplicitMorphismMapView category = + case category of + ExplicitFinCat explicitData -> explicitFinCatMorphismMap explicitData + ThinFinCat thinData -> thinMorphismMap (thinFinCatEndpointMorphisms thinData) + DenseThinFinCat denseData -> thinMorphismMap (denseThinEndpointMorphisms denseData) + +-- | Materializes the full composition table, so the cost is bound below by the +-- output size: one entry per composable generator pair, which is @Θ(n³)@ for a +-- linear site on @n@ objects. No implementation of this contract can be +-- asymptotically faster. For a thin category the table is redundant — composition +-- is a function of endpoints already answered in @O(1)@ from @Θ(n²/w)@ storage by +-- the dense handle — so consumers that need composition at scale should query the +-- 'FinCat' directly and reserve this view for explicit witnesses (law tests, +-- 'Moonlight.Category.Pure.FinCat.mkFinCat' round-trips). +finCatExplicitCompositionMapView :: FinCat -> Map (FinMorphismId, FinMorphismId) FinMorphismId +finCatExplicitCompositionMapView category = + case category of + ExplicitFinCat explicitData -> explicitFinCatCompositionMap explicitData + ThinFinCat thinData -> thinCompositionMap (thinCompositionEntries (thinFinCatEndpointMorphisms thinData)) + DenseThinFinCat denseData -> denseThinCompositionMap denseData + +finCatHasObject :: FinCat -> FinObjectId -> Bool +finCatHasObject category = + (`Set.member` finCatObjects category) + +finCatMorphismIndex :: FinCat -> Map FinMorphismId (FinObjectId, FinObjectId) +finCatMorphismIndex category = + case category of + ExplicitFinCat explicitData -> explicitFinCatMorphismIndex explicitData + ThinFinCat thinData -> thinFinCatMorphismIndex thinData + DenseThinFinCat denseData -> denseThinMorphismIndex denseData + + +type FinObj :: Type +data FinObj = FinObj + { finObjCategoryHandle :: FinCatHandle, + finObjId :: FinObjectId + } + deriving stock (Show) + +type FinMor :: Type +data FinMor = FinMor + { finMorCategoryHandle :: FinCatHandle, + finMorId :: FinMorphismId, + finMorSourceId :: FinObjectId, + finMorTargetId :: FinObjectId + } + deriving stock (Show) + +type FinCompositor :: Type +data FinCompositor + = FinStrictCompositor + | FinAssociator FinMor FinMor FinMor + | FinLeftUnitor FinMor + | FinRightUnitor FinMor + deriving stock (Eq, Ord, Show) + +type FinTwoMor :: Type +data FinTwoMor = FinTwoMor + { finTwoSource :: FinMor, + finTwoTarget :: FinMor + } + deriving stock (Eq, Ord, Show) + +type FinCatValidationError :: Type +data FinCatValidationError + = MorphismEndpointOutsideObjects FinObjectId FinObjectId + | ReservedIdentityMorphismId FinMorphismId + | DuplicateMorphismId FinMorphismId + | CompositionReferencesUnknownMorphism FinMorphismId + | CompositionPairNotComposable FinMorphismId FinMorphismId + | CompositionResultUnknownMorphism FinMorphismId + | CompositionResultEndpointMismatch FinMorphismId FinMorphismId FinMorphismId + | CompositionTableUsesIdentityKey FinMorphismId FinMorphismId + | MissingCompositionForPair FinMorphismId FinMorphismId + | AssociativityViolation FinMorphismId FinMorphismId FinMorphismId (Maybe FinMorphismId) (Maybe FinMorphismId) + deriving stock (Eq, Show) + +type FinCatError :: Type +data FinCatError + = FinCatObjectNotDeclared FinCatHandle FinObjectId + | FinCatMorphismNotDeclared FinCatHandle FinMorphismId + | FinCatObjectWrongCategory FinCatHandle FinCatHandle FinObjectId + | FinCatMorphismWrongCategory FinCatHandle FinCatHandle FinMorphismId + | FinCatMorphismNotComposable FinMorphismId FinMorphismId FinObjectId FinObjectId + | FinCatTwoMorphismBoundaryNotParallel FinMor FinMor + | FinCatTwoMorphismNotVerticallyComposable FinTwoMor FinTwoMor + | FinCatCompositionMissing FinMorphismId FinMorphismId + | FinCatCompositionResultInvalid FinMorphismId FinObjectId FinObjectId + deriving stock (Eq, Show) + +type AssociativityMiddleCover :: Type +data AssociativityMiddleCover + = GeneratorRestrictedMiddleCover (Set FinMorphismId) + | ExhaustiveMiddleCover + +instance Eq FinCat where + left == right = finCatHandle left == finCatHandle right + +instance Ord FinCat where + compare left right = compare (finCatHandle left) (finCatHandle right) + +instance Show FinCat where + show category = + case category of + ExplicitFinCat explicitData -> + "FinCat " + <> show (explicitFinCatObjects explicitData) + <> " " + <> show (explicitFinCatMorphismMap explicitData) + <> " " + <> show (explicitFinCatCompositionMap explicitData) + ThinFinCat thinData -> + "ThinFinCat " + <> show (thinFinCatObjects thinData) + <> " " + <> show (thinMorphismMap (thinFinCatEndpointMorphisms thinData)) + DenseThinFinCat denseData -> + "DenseThinFinCat " + <> show (denseThinFinCatObjects denseData) + <> " morphisms=" + <> show (denseThinFinCatNonIdentityMorphismCount denseData) + +instance Eq FinObj where + left == right = + finObjCategoryHandle left == finObjCategoryHandle right + && finObjId left == finObjId right + +instance Ord FinObj where + compare left right = + compare (finObjCategoryHandle left) (finObjCategoryHandle right) + <> compare (finObjId left) (finObjId right) + +instance Eq FinMor where + left == right = + finMorCategoryHandle left == finMorCategoryHandle right + && finMorId left == finMorId right + && finMorSourceId left == finMorSourceId right + && finMorTargetId left == finMorTargetId right + +instance Ord FinMor where + compare left right = + compare (finMorCategoryHandle left) (finMorCategoryHandle right) + <> compare (finMorId left) (finMorId right) + <> compare (finMorSourceId left) (finMorSourceId right) + <> compare (finMorTargetId left) (finMorTargetId right) + +encodingAtom :: ExactEncodingAtom -> ExactEncoding +encodingAtom = + exactAtomEncoding + +encodingInt :: Int -> ExactEncoding +encodingInt = + encodingAtom . ExactInt + +finCatCategoryEncoding :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> ExactEncoding +finCatCategoryEncoding objects morphismMap compositionMap = + exactSequenceEncoding + [ encodingAtom (ExactWord8 0), + exactSequenceMapEncoding finCatObjectIdEncoding objects, + exactSequenceMapEncoding finCatMorphismBucketEncoding (Map.toAscList morphismMap), + exactSequenceMapEncoding finCatCompositionEntryEncoding (Map.toAscList compositionMap) + ] + +finCatDenseThinCategoryEncoding :: Set FinObjectId -> Vector Integer -> ExactEncoding +finCatDenseThinCategoryEncoding objects reachabilityRows = + exactSequenceEncoding + [ encodingAtom (ExactWord8 5), + exactSequenceMapEncoding finCatObjectIdEncoding objects, + exactSequenceMapEncoding (finCatReachabilityRowEncoding (Set.size objects)) reachabilityRows + ] + +finCatReachabilityRowEncoding :: Int -> Integer -> ExactEncoding +finCatReachabilityRowEncoding objectTotal bits = + exactSequenceEncoding + [ encodingAtom (ExactWord8 7), + exactSequenceMapEncoding encodingInt (denseRowWordChunks objectTotal bits) + ] + +denseRowWordChunks :: Int -> Integer -> [Int] +denseRowWordChunks objectTotal bits = + [0 .. ((objectTotal + 63) `div` 64) - 1] + & fmap (\chunkIndex -> fromIntegral (fromIntegral (bits `shiftR` (64 * chunkIndex)) :: Word64)) + +finCatObjectIdEncoding :: FinObjectId -> ExactEncoding +finCatObjectIdEncoding (FinObjectId objectId) = + exactSequenceEncoding [encodingAtom (ExactWord8 1), encodingInt objectId] + +finCatGeneratorIdEncoding :: FinGeneratorId -> ExactEncoding +finCatGeneratorIdEncoding (FinGeneratorId generatorId) = + exactSequenceEncoding [encodingAtom (ExactWord8 2), encodingInt generatorId] + +finCatMorphismIdEncoding :: FinMorphismId -> ExactEncoding +finCatMorphismIdEncoding morphismId = + case morphismId of + FinIdentityId objectId -> + exactSequenceEncoding [encodingAtom (ExactWord8 3), finCatObjectIdEncoding objectId] + FinGeneratorMorphismId generatorId -> + exactSequenceEncoding [encodingAtom (ExactWord8 4), finCatGeneratorIdEncoding generatorId] + +finCatMorphismBucketEncoding :: ((FinObjectId, FinObjectId), [FinMorphismId]) -> ExactEncoding +finCatMorphismBucketEncoding ((sourceId, targetId), morphismIds) = + exactSequenceEncoding + [ finCatObjectIdEncoding sourceId, + finCatObjectIdEncoding targetId, + exactSequenceMapEncoding finCatMorphismIdEncoding morphismIds + ] + +finCatCompositionEntryEncoding :: ((FinMorphismId, FinMorphismId), FinMorphismId) -> ExactEncoding +finCatCompositionEntryEncoding ((left, right), result) = + exactSequenceEncoding + [ finCatMorphismIdEncoding left, + finCatMorphismIdEncoding right, + finCatMorphismIdEncoding result + ] + +mkFinCatHandle :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> FinCatHandle +mkFinCatHandle objects morphismMap compositionMap = + FinCatHandle + (exactTokenFromEncoding (finCatCategoryEncoding objects morphismMap compositionMap)) + +normalizeMorphismMap :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinObjectId, FinObjectId) [FinMorphismId] +normalizeMorphismMap = + Map.filter (not . null) . fmap sort + +morphismBucketsBySource :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map FinObjectId [(FinObjectId, [FinMorphismId])] +morphismBucketsBySource morphismMap = + morphismMap + & Map.toAscList + & fmap (\((sourceId, targetId), morphismIds) -> (sourceId, [(targetId, morphismIds)])) + & Map.fromListWith (flip (<>)) + +morphismBucketsByTarget :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map FinObjectId [(FinObjectId, [FinMorphismId])] +morphismBucketsByTarget morphismMap = + morphismMap + & Map.toAscList + & fmap (\((sourceId, targetId), morphismIds) -> (targetId, [(sourceId, morphismIds)])) + & Map.fromListWith (flip (<>)) + +thinEndpointMorphismsBySource :: Map (FinObjectId, FinObjectId) FinMorphismId -> Map FinObjectId [(FinObjectId, FinMorphismId)] +thinEndpointMorphismsBySource endpointMorphisms = + endpointMorphisms + & Map.toAscList + & fmap (\((sourceId, targetId), morphismId) -> (sourceId, [(targetId, morphismId)])) + & Map.fromListWith (flip (<>)) + +thinEndpointMorphismsByTargetSimple :: Map (FinObjectId, FinObjectId) FinMorphismId -> Map FinObjectId [(FinObjectId, FinMorphismId)] +thinEndpointMorphismsByTargetSimple endpointMorphisms = + endpointMorphisms + & Map.toAscList + & fmap (\((sourceId, targetId), morphismId) -> (targetId, [(sourceId, morphismId)])) + & Map.fromListWith (flip (<>)) + +buildFinCat :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> FinCat +buildFinCat objects morphismMap compositionMap = + let normalizedMorphismMap = normalizeMorphismMap morphismMap + index = declaredMorphismIndex objects normalizedMorphismMap + in ExplicitFinCat + ExplicitFinCatData + { explicitFinCatHandle = mkFinCatHandle objects normalizedMorphismMap compositionMap, + explicitFinCatObjects = objects, + explicitFinCatMorphismMap = normalizedMorphismMap, + explicitFinCatCompositionMap = compositionMap, + explicitFinCatMorphismIndex = index, + explicitFinCatMorphismsBySource = morphismBucketsBySource normalizedMorphismMap, + explicitFinCatMorphismsByTarget = morphismBucketsByTarget normalizedMorphismMap + } + +buildThinFinCat :: Set FinObjectId -> Map (FinObjectId, FinObjectId) FinMorphismId -> FinCat +buildThinFinCat objects endpointMorphisms = + let morphismMap = thinMorphismMap endpointMorphisms + index = declaredMorphismIndex objects morphismMap + in ThinFinCat + ThinFinCatData + { thinFinCatHandle = mkFinCatHandle objects morphismMap Map.empty, + thinFinCatObjects = objects, + thinFinCatEndpointMorphisms = endpointMorphisms, + thinFinCatMorphismIndex = index, + thinFinCatMorphismsBySource = thinEndpointMorphismsBySource endpointMorphisms, + thinFinCatMorphismsByTarget = thinEndpointMorphismsByTargetSimple endpointMorphisms + } + +buildDenseThinFinCat :: Set FinObjectId -> Vector Integer -> FinCat +buildDenseThinFinCat objects reachabilityRows = + let objectTotal = Set.size objects + canonicalRows = denseCanonicalReachabilityRows objectTotal reachabilityRows + predecessorRows = transposeBitRows objectTotal canonicalRows + sourceCounts = denseRowCounts canonicalRows + targetCounts = denseRowCounts predecessorRows + prefixCounts = densePrefixCountsFromCounts sourceCounts + endpointIndex = denseEndpointIndex objectTotal canonicalRows prefixCounts + pairs = denseReachablePairs objectTotal canonicalRows + sourceColumn = UVector.fromList (fmap fst pairs) + targetColumn = UVector.fromList (fmap snd pairs) + in DenseThinFinCat + DenseThinFinCatData + { denseThinFinCatHandle = mkDenseThinFinCatHandle objects canonicalRows, + denseThinFinCatObjects = objects, + denseThinFinCatObjectCount = objectTotal, + denseThinFinCatNonIdentityMorphismCount = UVector.sum sourceCounts, + denseThinFinCatReachabilityRows = canonicalRows, + denseThinFinCatPredecessorRows = predecessorRows, + denseThinFinCatSourceCounts = sourceCounts, + denseThinFinCatTargetCounts = targetCounts, + denseThinFinCatPrefixCounts = prefixCounts, + denseThinFinCatEndpointIndex = endpointIndex, + denseThinFinCatSourceColumn = sourceColumn, + denseThinFinCatTargetColumn = targetColumn + } + +denseCanonicalReachabilityRows :: Int -> Vector Integer -> Vector Integer +denseCanonicalReachabilityRows objectTotal reachabilityRows = + Vector.generate + objectTotal + ( \sourceIndex -> + reachabilityRows + Vector.!? sourceIndex + & maybe 0 (denseCanonicalReachabilityRow objectTotal sourceIndex) + ) + +denseCanonicalReachabilityRow :: Int -> Int -> Integer -> Integer +denseCanonicalReachabilityRow objectTotal sourceIndex reachableBits = + (reachableBits .&. denseBitMask objectTotal) `clearBit` sourceIndex + +denseBitMask :: Int -> Integer +denseBitMask objectTotal = + if objectTotal <= 0 + then 0 + else bit objectTotal - 1 + +mkDenseThinFinCatHandle :: Set FinObjectId -> Vector Integer -> FinCatHandle +mkDenseThinFinCatHandle objects reachabilityRows = + FinCatHandle (exactTokenFromEncoding (finCatDenseThinCategoryEncoding objects reachabilityRows)) + +denseRowCounts :: Vector Integer -> UVector.Vector Int +denseRowCounts rows = + rows + & Vector.toList + & fmap popCount + & UVector.fromList + +densePrefixCountsFromCounts :: UVector.Vector Int -> UVector.Vector Int +densePrefixCountsFromCounts = + UVector.scanl (+) 0 + +denseEndpointIndex :: Int -> Vector Integer -> UVector.Vector Int -> UVector.Vector Int +denseEndpointIndex objectTotal reachabilityRows prefixCounts = + UVector.concat + ( [0 .. objectTotal - 1] + & fmap + ( \sourceIndex -> + denseEndpointIndexRow + objectTotal + (fromMaybe 0 (reachabilityRows Vector.!? sourceIndex)) + (fromMaybe 0 (prefixCounts UVector.!? sourceIndex)) + ) + ) + +denseEndpointIndexRow :: Int -> Integer -> Int -> UVector.Vector Int +denseEndpointIndexRow objectTotal reachableBits prefixCount = + UVector.fromListN + objectTotal + ( zipWith + (\targetIndex rank -> if testBit reachableBits targetIndex then rank else -1) + [0 .. objectTotal - 1] + (scanl (\rank targetIndex -> if testBit reachableBits targetIndex then rank + 1 else rank) prefixCount [0 .. objectTotal - 1]) + ) + +denseReachablePairs :: Int -> Vector Integer -> [(Int, Int)] +denseReachablePairs objectTotal reachabilityRows = + reachabilityRows + & Vector.toList + & zip [0 ..] + >>= ( \(sourceIndex, reachableBits) -> + bitsToAscList objectTotal reachableBits + & fmap (\targetIndex -> (sourceIndex, targetIndex)) + ) + +denseThinEndpointMorphisms :: DenseThinFinCatData -> Map (FinObjectId, FinObjectId) FinMorphismId +denseThinEndpointMorphisms denseData = + zip3 + [0 ..] + (UVector.toList (denseThinFinCatSourceColumn denseData)) + (UVector.toList (denseThinFinCatTargetColumn denseData)) + & fmap + ( \(morphismIndex, sourceIndex, targetIndex) -> + ((FinObjectId sourceIndex, FinObjectId targetIndex), denseMorphismId morphismIndex) + ) + & Map.fromDistinctAscList + +denseThinCompositionMap :: DenseThinFinCatData -> Map (FinMorphismId, FinMorphismId) FinMorphismId +denseThinCompositionMap denseData = + Map.fromDistinctAscList ([0 .. objectTotal - 1] >>= entriesForLeftSource) + where + objectTotal = denseThinFinCatObjectCount denseData + reachabilityRows = denseThinFinCatReachabilityRows denseData + predecessorRows = denseThinFinCatPredecessorRows denseData + endpointIndex = denseThinFinCatEndpointIndex denseData + + morphismIds = + Vector.generate (denseThinFinCatNonIdentityMorphismCount denseData) denseMorphismId + + indexAt sourceIndex targetIndex = + UVector.unsafeIndex endpointIndex (sourceIndex * objectTotal + targetIndex) + + composedIdAt rightSourceIndex leftTargetIndex + | rightSourceIndex == leftTargetIndex = + Just (identityMorphismId (FinObjectId rightSourceIndex)) + | otherwise = + let composedIndex = indexAt rightSourceIndex leftTargetIndex + in if composedIndex >= 0 + then Just (Vector.unsafeIndex morphismIds composedIndex) + else Nothing + + entriesForLeftSource leftSourceIndex = + let rightEntries = + bitsToAscList objectTotal (Vector.unsafeIndex predecessorRows leftSourceIndex) + & fmap + ( \rightSourceIndex -> + (rightSourceIndex, Vector.unsafeIndex morphismIds (indexAt rightSourceIndex leftSourceIndex)) + ) + in bitsToAscList objectTotal (Vector.unsafeIndex reachabilityRows leftSourceIndex) + >>= entriesForLeft leftSourceIndex rightEntries + + entriesForLeft leftSourceIndex rightEntries leftTargetIndex = + let leftId = Vector.unsafeIndex morphismIds (indexAt leftSourceIndex leftTargetIndex) + in rightEntries + & mapMaybe + ( \(rightSourceIndex, rightId) -> + fmap + (\composedId -> ((leftId, rightId), composedId)) + (composedIdAt rightSourceIndex leftTargetIndex) + ) + +denseThinMorphismIndex :: DenseThinFinCatData -> Map FinMorphismId (FinObjectId, FinObjectId) +denseThinMorphismIndex denseData = + let identityEntries = + Set.toAscList (denseThinFinCatObjects denseData) + & fmap (\objectId -> (identityMorphismId objectId, (objectId, objectId))) + generatorEntries = + denseThinEndpointMorphisms denseData + & Map.toAscList + & fmap (\(endpoints, morphismId) -> (morphismId, endpoints)) + in Map.fromList (identityEntries <> generatorEntries) + +denseMorphismId :: Int -> FinMorphismId +denseMorphismId = + FinGeneratorMorphismId . FinGeneratorId + +denseMorphismIdIndex :: FinMorphismId -> Maybe Int +denseMorphismIdIndex morphismId = + case morphismId of + FinGeneratorMorphismId (FinGeneratorId indexValue) + | indexValue >= 0 -> Just indexValue + _ -> Nothing + +denseMorphismEndpoints :: DenseThinFinCatData -> FinMorphismId -> Maybe (FinObjectId, FinObjectId) +denseMorphismEndpoints denseData morphismId = + case morphismId of + FinIdentityId objectId + | denseObjectIdInBounds denseData objectId -> Just (objectId, objectId) + _ -> do + morphismIndex <- denseMorphismIdIndex morphismId + sourceIndex <- denseThinFinCatSourceColumn denseData UVector.!? morphismIndex + targetIndex <- denseThinFinCatTargetColumn denseData UVector.!? morphismIndex + pure (FinObjectId sourceIndex, FinObjectId targetIndex) + +denseObjectIdInBounds :: DenseThinFinCatData -> FinObjectId -> Bool +denseObjectIdInBounds denseData (FinObjectId objectIndex) = + objectIndex >= 0 && objectIndex < denseThinFinCatObjectCount denseData + +denseMorphismCountFrom :: DenseThinFinCatData -> FinObjectId -> Int +denseMorphismCountFrom denseData sourceId@(FinObjectId sourceIndex) = + if denseObjectIdInBounds denseData sourceId + then 1 + UVector.unsafeIndex (denseThinFinCatSourceCounts denseData) sourceIndex + else 0 + +denseMorphismCountTo :: DenseThinFinCatData -> FinObjectId -> Int +denseMorphismCountTo denseData targetId@(FinObjectId targetIndex) = + if denseObjectIdInBounds denseData targetId + then 1 + UVector.unsafeIndex (denseThinFinCatTargetCounts denseData) targetIndex + else 0 + +denseEndpointMorphism :: DenseThinFinCatData -> FinObjectId -> FinObjectId -> Maybe FinMorphismId +denseEndpointMorphism denseData sourceId targetId = + denseMorphismId <$> denseEndpointMorphismIndex denseData sourceId targetId + +denseEndpointMorphismIndex :: DenseThinFinCatData -> FinObjectId -> FinObjectId -> Maybe Int +denseEndpointMorphismIndex denseData sourceId@(FinObjectId sourceIndex) targetId@(FinObjectId targetIndex) = + if denseObjectIdInBounds denseData sourceId && denseObjectIdInBounds denseData targetId && sourceId /= targetId + then + let endpointOffset = sourceIndex * denseThinFinCatObjectCount denseData + targetIndex + morphismIndex = UVector.unsafeIndex (denseThinFinCatEndpointIndex denseData) endpointOffset + in if morphismIndex >= 0 then Just morphismIndex else Nothing + else Nothing + +strictDenseThinFinCat :: Set FinObjectId -> Map (FinObjectId, FinObjectId) FinMorphismId -> Maybe FinCat +strictDenseThinFinCat objects endpointMorphisms = do + reachabilityRows <- denseRowsFromEndpointMorphisms objects endpointMorphisms + let denseCategory = buildDenseThinFinCat objects reachabilityRows + if denseThinEndpointMorphismsFromCategory denseCategory == endpointMorphisms + then Just denseCategory + else Nothing + +denseRowsFromEndpointMorphisms :: Set FinObjectId -> Map (FinObjectId, FinObjectId) FinMorphismId -> Maybe (Vector Integer) +denseRowsFromEndpointMorphisms objects endpointMorphisms = + let objectIds = Set.toAscList objects + expectedObjectIds = FinObjectId <$> [0 .. Set.size objects - 1] + in if objectIds == expectedObjectIds + then + endpointMorphisms + & Map.toAscList + & traverse denseEndpointBit + & fmap + ( \endpointBits -> + endpointBits + & fmap (\(sourceIndex, targetBit) -> (sourceIndex, targetBit)) + & Map.fromListWith (.|.) + & (\rowMap -> Vector.generate (Set.size objects) (\sourceIndex -> Map.findWithDefault 0 sourceIndex rowMap)) + ) + else Nothing + +denseEndpointBit :: ((FinObjectId, FinObjectId), FinMorphismId) -> Maybe (Int, Integer) +denseEndpointBit ((FinObjectId sourceIndex, FinObjectId targetIndex), _) + | sourceIndex >= 0 && targetIndex >= 0 && sourceIndex /= targetIndex = Just (sourceIndex, bit targetIndex) + | otherwise = Nothing + +denseThinEndpointMorphismsFromCategory :: FinCat -> Map (FinObjectId, FinObjectId) FinMorphismId +denseThinEndpointMorphismsFromCategory category = + case category of + DenseThinFinCat denseData -> denseThinEndpointMorphisms denseData + _ -> Map.empty + +strictThinEndpointMorphisms :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Maybe (Map (FinObjectId, FinObjectId) FinMorphismId) +strictThinEndpointMorphisms morphismMap = + morphismMap + & Map.toAscList + & traverse strictThinEndpointMorphism + & fmap Map.fromList + +strictThinEndpointMorphism :: ((FinObjectId, FinObjectId), [FinMorphismId]) -> Maybe ((FinObjectId, FinObjectId), FinMorphismId) +strictThinEndpointMorphism ((sourceId, targetId), morphismIds) = + case morphismIds of + [morphismId] + | sourceId /= targetId && not (isIdentityMorphismId morphismId) -> Just ((sourceId, targetId), morphismId) + _ -> Nothing + +identityMorphismId :: FinObjectId -> FinMorphismId +identityMorphismId = FinIdentityId + +isIdentityMorphismId :: FinMorphismId -> Bool +isIdentityMorphismId morphismId = + case morphismId of + FinIdentityId _ -> True + FinGeneratorMorphismId _ -> False + +morphismEntries :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> [(FinMorphismId, (FinObjectId, FinObjectId))] +morphismEntries morphismMap = + Map.toList morphismMap + & concatMap + (\((sourceId, targetId), morphismIds) -> + map (\morphismId -> (morphismId, (sourceId, targetId))) morphismIds + ) + +duplicates :: Ord a => [a] -> [a] +duplicates values = + values + & foldr (\value -> Map.insertWith (+) value (1 :: Int)) Map.empty + & Map.toAscList + & foldMap (\(value, count) -> if count > 1 then [value] else []) + +declaredMorphismIndex :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map FinMorphismId (FinObjectId, FinObjectId) +declaredMorphismIndex objects morphismMap = + let identityEntries = + Set.toAscList objects + & map (\objectId -> (identityMorphismId objectId, (objectId, objectId))) + in Map.fromList (identityEntries <> morphismEntries morphismMap) + +lookupMorphismEndpoints :: Map FinMorphismId (FinObjectId, FinObjectId) -> FinMorphismId -> Maybe (FinObjectId, FinObjectId) +lookupMorphismEndpoints index morphismId = Map.lookup morphismId index + +composeMorphismIds :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> FinMorphismId -> FinMorphismId -> Maybe FinMorphismId +composeMorphismIds index compositionMap left right = do + (leftSourceId, _) <- lookupMorphismEndpoints index left + (_, rightTargetId) <- lookupMorphismEndpoints index right + if rightTargetId == leftSourceId + then + if isIdentityMorphismId left + then pure right + else + if isIdentityMorphismId right + then pure left + else Map.lookup (left, right) compositionMap + else Nothing + +validationFromErrors :: [FinCatValidationError] -> Validation (NonEmpty FinCatValidationError) () +validationFromErrors errors = + case errors of + [] -> Valid () + firstError : restErrors -> Invalid (firstError :| restErrors) + +validateMorphismEndpoints :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Validation (NonEmpty FinCatValidationError) () +validateMorphismEndpoints objects morphismMap = + morphismMap + & Map.keys + & foldMap + (\(sourceId, targetId) -> + if Set.member sourceId objects && Set.member targetId objects + then [] + else [MorphismEndpointOutsideObjects sourceId targetId] + ) + & validationFromErrors + +validateReservedIds :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Validation (NonEmpty FinCatValidationError) () +validateReservedIds morphismMap = + morphismEntries morphismMap + & foldMap ((\morphismId -> if isIdentityMorphismId morphismId then [ReservedIdentityMorphismId morphismId] else []) . fst) + & validationFromErrors + +validateUniqueMorphismIds :: Map (FinObjectId, FinObjectId) [FinMorphismId] -> Validation (NonEmpty FinCatValidationError) () +validateUniqueMorphismIds morphismMap = + morphismEntries morphismMap + & fmap fst + & duplicates + & fmap DuplicateMorphismId + & validationFromErrors + +validateCompositionTable :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateCompositionTable index compositionMap = + compositionMap + & Map.toAscList + & foldMap (compositionEntryErrors index) + & validationFromErrors + +compositionEntryErrors :: Map FinMorphismId (FinObjectId, FinObjectId) -> ((FinMorphismId, FinMorphismId), FinMorphismId) -> [FinCatValidationError] +compositionEntryErrors index ((left, right), result) = + identityKeyErrors <> unknownErrors <> composabilityErrors <> endpointErrors + where + maybeLeftEndpoints = lookupMorphismEndpoints index left + maybeRightEndpoints = lookupMorphismEndpoints index right + maybeResultEndpoints = lookupMorphismEndpoints index result + + identityKeyErrors = + if isIdentityMorphismId left || isIdentityMorphismId right + then [CompositionTableUsesIdentityKey left right] + else [] + + unknownErrors = + fold + [ maybe [CompositionReferencesUnknownMorphism left] (const []) maybeLeftEndpoints, + maybe [CompositionReferencesUnknownMorphism right] (const []) maybeRightEndpoints, + maybe [CompositionResultUnknownMorphism result] (const []) maybeResultEndpoints + ] + + composabilityErrors = + case (maybeLeftEndpoints, maybeRightEndpoints) of + (Just (leftSourceId, _), Just (_, rightTargetId)) + | rightTargetId /= leftSourceId -> [CompositionPairNotComposable left right] + _ -> [] + + endpointErrors = + case (maybeLeftEndpoints, maybeRightEndpoints, maybeResultEndpoints) of + (Just (_, leftTargetId), Just (rightSourceId, _), Just (resultSourceId, resultTargetId)) + | resultSourceId /= rightSourceId || resultTargetId /= leftTargetId -> [CompositionResultEndpointMismatch left right result] + _ -> [] + +morphismsBySourceId :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map FinObjectId [FinMorphismId] +morphismsBySourceId index = + index + & Map.toAscList + & fmap (\(morphismId, (sourceId, _)) -> (sourceId, [morphismId])) + & Map.fromListWith (<>) + +morphismsByTargetId :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map FinObjectId [FinMorphismId] +morphismsByTargetId index = + index + & Map.toAscList + & fmap (\(morphismId, (_, targetId)) -> (targetId, [morphismId])) + & Map.fromListWith (<>) + +composablePairs :: Map FinMorphismId (FinObjectId, FinObjectId) -> [(FinMorphismId, FinMorphismId)] +composablePairs index = + index + & Map.toAscList + & foldMap + ( \(rightMorphism, (_, rightTargetId)) -> + morphismsFrom rightTargetId + & fmap (\leftMorphism -> (leftMorphism, rightMorphism)) + ) + where + bySource = morphismsBySourceId index + morphismsFrom sourceId = Map.findWithDefault [] sourceId bySource + +composableTriples :: Map FinMorphismId (FinObjectId, FinObjectId) -> [(FinMorphismId, FinMorphismId, FinMorphismId)] +composableTriples index = + index + & Map.toAscList + & foldMap triplesFromRight + where + bySource = morphismsBySourceId index + morphismsFrom sourceId = Map.findWithDefault [] sourceId bySource + triplesFromRight (rightMorphism, (_, rightTargetId)) = + morphismsFrom rightTargetId + & foldMap (triplesFromMiddle rightMorphism) + triplesFromMiddle rightMorphism middleMorphism = + case Map.lookup middleMorphism index of + Nothing -> [] + Just (_, middleTargetId) -> + morphismsFrom middleTargetId + & fmap (\leftMorphism -> (leftMorphism, middleMorphism, rightMorphism)) + + +composableTriplesWithMiddleIn :: Set FinMorphismId -> Map FinMorphismId (FinObjectId, FinObjectId) -> [(FinMorphismId, FinMorphismId, FinMorphismId)] +composableTriplesWithMiddleIn middleIds index = + index + & Map.toAscList + & foldMap triplesFromMiddle + where + bySource = morphismsBySourceId index + byTarget = morphismsByTargetId index + morphismsFrom sourceId = Map.findWithDefault [] sourceId bySource + morphismsTo targetId = Map.findWithDefault [] targetId byTarget + + triplesFromMiddle (middleMorphism, (middleSourceId, middleTargetId)) + | Set.member middleMorphism middleIds = + morphismsFrom middleTargetId + & foldMap + ( \leftMorphism -> + morphismsTo middleSourceId + & fmap + ( \rightMorphism -> + (leftMorphism, middleMorphism, rightMorphism) + ) + ) + | otherwise = [] + +validateClosure :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateClosure index compositionMap = + composablePairs index + & foldMap + (\(left, right) -> + if composeMorphismIds index compositionMap left right == Nothing + then [MissingCompositionForPair left right] + else [] + ) + & validationFromErrors + +validateAssociativityExhaustive :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateAssociativityExhaustive index compositionMap = + composableTriples index + & foldMap (associativityErrors index compositionMap) + & validationFromErrors + +validateAssociativity :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateAssociativity index compositionMap = + case associativityMiddleCover index compositionMap of + GeneratorRestrictedMiddleCover middleIds -> + composableTriplesWithMiddleIn middleIds index + & foldMap (associativityErrors index compositionMap) + & validationFromErrors + ExhaustiveMiddleCover -> + validateAssociativityExhaustive index compositionMap + +validateAssociativityAtGenerators :: Set FinMorphismId -> Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateAssociativityAtGenerators generatorIds index compositionMap = + composableTriplesWithMiddleIn (Set.filter (not . isIdentityMorphismId) generatorIds) index + & foldMap (associativityErrors index compositionMap) + & validationFromErrors + +associativityMiddleCover :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> AssociativityMiddleCover +associativityMiddleCover index compositionMap = + let nonIdentityMorphisms = + Map.keysSet index + & Set.filter (not . isIdentityMorphismId) + primaryGenerators = + explicitCompositionGenerators index compositionMap + generatedFromPrimary = + generatedMorphisms index compositionMap primaryGenerators + uncoveredMorphisms = + Set.difference nonIdentityMorphisms generatedFromPrimary + verifiedGenerators = + Set.union primaryGenerators uncoveredMorphisms + generatedFromVerified = + generatedMorphisms index compositionMap verifiedGenerators + in if Set.isSubsetOf nonIdentityMorphisms generatedFromVerified + then GeneratorRestrictedMiddleCover verifiedGenerators + else ExhaustiveMiddleCover + +explicitCompositionGenerators :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Set FinMorphismId +explicitCompositionGenerators index compositionMap = + let compositeResults = + compositionMap + & Map.elems + & Set.fromList + & Set.filter (not . isIdentityMorphismId) + in Map.keysSet index + & Set.filter (not . isIdentityMorphismId) + & (`Set.difference` compositeResults) + +generatedMorphisms :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Set FinMorphismId -> Set FinMorphismId +generatedMorphisms index compositionMap generators = + let initialMorphisms = + Set.union (identityMorphismSet index) generators + closeMorphisms = + closeGeneratedMorphisms index compositionMap + generatedSequence = + take (Map.size index + 1) (iterate closeMorphisms initialMorphisms) + stableMorphisms = + zip generatedSequence (drop 1 generatedSequence) + & find (uncurry (==)) + & fmap snd + in case stableMorphisms of + Just morphisms -> morphisms + Nothing -> + Set.unions generatedSequence + +identityMorphismSet :: Map FinMorphismId (FinObjectId, FinObjectId) -> Set FinMorphismId +identityMorphismSet index = + Map.keysSet index + & Set.filter isIdentityMorphismId + +closeGeneratedMorphisms :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Set FinMorphismId -> Set FinMorphismId +closeGeneratedMorphisms _ compositionMap knownMorphisms = + let composedMorphisms = + compositionMap + & Map.toAscList + & foldMap + ( \((leftMorphism, rightMorphism), composedMorphism) -> + if Set.member leftMorphism knownMorphisms && Set.member rightMorphism knownMorphisms + then [composedMorphism] + else [] + ) + & Set.fromList + in Set.union knownMorphisms composedMorphisms + +associativityErrors :: Map FinMorphismId (FinObjectId, FinObjectId) -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> (FinMorphismId, FinMorphismId, FinMorphismId) -> [FinCatValidationError] +associativityErrors index compositionMap (left, middle, right) = + let leftAssociated = + composeMorphismIds index compositionMap left middle + >>= (\composed -> composeMorphismIds index compositionMap composed right) + rightAssociated = + composeMorphismIds index compositionMap middle right + >>= composeMorphismIds index compositionMap left + in if leftAssociated == rightAssociated + then [] + else [AssociativityViolation left middle right leftAssociated rightAssociated] + +thinMorphismMap :: Map (FinObjectId, FinObjectId) FinMorphismId -> Map (FinObjectId, FinObjectId) [FinMorphismId] +thinMorphismMap = + fmap (: []) + +thinEndpointMorphismsByTarget :: + Map (FinObjectId, FinObjectId) FinMorphismId -> + Map FinObjectId [((FinObjectId, FinObjectId), FinMorphismId)] +thinEndpointMorphismsByTarget endpointMorphisms = + endpointMorphisms + & Map.toAscList + & fmap (\entry@((_, targetId), _) -> (targetId, [entry])) + & Map.fromListWith (<>) + +thinCompositionEntries :: Map (FinObjectId, FinObjectId) FinMorphismId -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +thinCompositionEntries endpointMorphisms = + endpointMorphisms + & thinCompositionExpectations + & mapMaybe + ( \(compositionKey, maybeComposedId) -> + fmap (\composedId -> (compositionKey, composedId)) maybeComposedId + ) + +thinCompositionExpectations :: Map (FinObjectId, FinObjectId) FinMorphismId -> [((FinMorphismId, FinMorphismId), Maybe FinMorphismId)] +thinCompositionExpectations endpointMorphisms = + endpointMorphisms + & Map.toAscList + & foldMap entriesForLeft + where + rightMorphismsByTarget = thinEndpointMorphismsByTarget endpointMorphisms + + entriesForLeft ((leftSourceId, leftTargetId), leftId) = + Map.findWithDefault [] leftSourceId rightMorphismsByTarget + & foldMap (entryForRight leftTargetId leftId) + + entryForRight leftTargetId leftId ((rightSourceId, _), rightId) = + [((leftId, rightId), thinCompositeMorphismId endpointMorphisms rightSourceId leftTargetId)] + +thinCompositeMorphismId :: Map (FinObjectId, FinObjectId) FinMorphismId -> FinObjectId -> FinObjectId -> Maybe FinMorphismId +thinCompositeMorphismId endpointMorphisms sourceId targetId = + if sourceId == targetId + then Just (identityMorphismId sourceId) + else Map.lookup (sourceId, targetId) endpointMorphisms + +validateThinCompositionClosure :: Map (FinObjectId, FinObjectId) FinMorphismId -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Validation (NonEmpty FinCatValidationError) () +validateThinCompositionClosure endpointMorphisms compositionMap = + endpointMorphisms + & thinCompositionExpectations + & foldMap (thinCompositionExpectationErrors compositionMap) + & validationFromErrors + +thinCompositionExpectationErrors :: Map (FinMorphismId, FinMorphismId) FinMorphismId -> ((FinMorphismId, FinMorphismId), Maybe FinMorphismId) -> [FinCatValidationError] +thinCompositionExpectationErrors compositionMap ((left, right), maybeExpected) = + case maybeExpected of + Nothing -> [MissingCompositionForPair left right] + Just expected -> + case Map.lookup (left, right) compositionMap of + Nothing -> [MissingCompositionForPair left right] + Just actual + | actual == expected -> [] + | otherwise -> [CompositionResultEndpointMismatch left right actual] + +thinCompositionMap :: [((FinMorphismId, FinMorphismId), FinMorphismId)] -> Map (FinMorphismId, FinMorphismId) FinMorphismId +thinCompositionMap = + Map.fromList + +checkedThinFinCat :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Maybe (Either (NonEmpty FinCatValidationError) FinCat) +checkedThinFinCat objects morphismMap compositionMap = + strictThinEndpointMorphisms morphismMap + & fmap + ( \endpointMorphisms -> + trustedThinFinCatFromTransitiveEndpoints objects endpointMorphisms + <$ validationToEither (validateThinCompositionClosure endpointMorphisms compositionMap) + ) + +mkFinCat :: Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Either (NonEmpty FinCatValidationError) FinCat +mkFinCat = + mkFinCatWithAssociativityValidation validateAssociativity + +trustedFinCatWithGeneratorBasis :: Set FinMorphismId -> Set FinObjectId -> Map (FinObjectId, FinObjectId) [FinMorphismId] -> Map (FinMorphismId, FinMorphismId) FinMorphismId -> Either (NonEmpty FinCatValidationError) FinCat +trustedFinCatWithGeneratorBasis generatorIds = + mkFinCatWithAssociativityValidation (validateAssociativityAtGenerators generatorIds) + +mkFinCatWithAssociativityValidation :: + ( Map FinMorphismId (FinObjectId, FinObjectId) -> + Map (FinMorphismId, FinMorphismId) FinMorphismId -> + Validation (NonEmpty FinCatValidationError) () + ) -> + Set FinObjectId -> + Map (FinObjectId, FinObjectId) [FinMorphismId] -> + Map (FinMorphismId, FinMorphismId) FinMorphismId -> + Either (NonEmpty FinCatValidationError) FinCat +mkFinCatWithAssociativityValidation associativityValidation objects morphismMap compositionMap = + let normalizedMorphismMap = normalizeMorphismMap morphismMap + index = declaredMorphismIndex objects normalizedMorphismMap + basicValidation = + validateMorphismEndpoints objects morphismMap + *> validateReservedIds morphismMap + *> validateUniqueMorphismIds morphismMap + *> validateCompositionTable index compositionMap + genericValidation = + validateClosure index compositionMap + *> associativityValidation index compositionMap + in case validationToEither basicValidation of + Left errors -> Left errors + Right () -> + case checkedThinFinCat objects normalizedMorphismMap compositionMap of + Just checkedThinCategory -> checkedThinCategory + Nothing -> buildFinCat objects normalizedMorphismMap compositionMap <$ validationToEither genericValidation + +trustedThinFinCatFromTransitiveEndpoints :: Set FinObjectId -> Map (FinObjectId, FinObjectId) FinMorphismId -> FinCat +trustedThinFinCatFromTransitiveEndpoints objects endpointMorphisms = + fromMaybe (buildThinFinCat objects endpointMorphisms) (strictDenseThinFinCat objects endpointMorphisms) + +trustedDenseThinFinCatFromReachabilityRows :: Set FinObjectId -> Vector Integer -> FinCat +trustedDenseThinFinCatFromReachabilityRows = + buildDenseThinFinCat + +finCatMorphismIdByEndpoints :: FinCat -> FinObjectId -> FinObjectId -> Maybe FinMorphismId +finCatMorphismIdByEndpoints category sourceId targetId = + case category of + DenseThinFinCat denseData + | sourceId == targetId && denseObjectIdInBounds denseData sourceId -> + Just (identityMorphismId sourceId) + | otherwise -> + denseEndpointMorphism denseData sourceId targetId + ExplicitFinCat explicitData + | sourceId == targetId && Set.member sourceId (explicitFinCatObjects explicitData) -> + Just (identityMorphismId sourceId) + | otherwise -> + case Map.lookup (sourceId, targetId) (explicitFinCatMorphismMap explicitData) of + Just [morphismId] -> Just morphismId + _ -> Nothing + ThinFinCat thinData + | sourceId == targetId && Set.member sourceId (thinFinCatObjects thinData) -> + Just (identityMorphismId sourceId) + | otherwise -> + Map.lookup (sourceId, targetId) (thinFinCatEndpointMorphisms thinData) +{-# INLINABLE finCatMorphismIdByEndpoints #-} + +mkFinObject :: FinCat -> FinObjectId -> Either FinCatError FinObj +mkFinObject category objectId = + case category of + DenseThinFinCat denseData -> + if denseObjectIdInBounds denseData objectId + then Right (mkFinObj category objectId) + else Left (FinCatObjectNotDeclared (finCatHandle category) objectId) + _ -> + if Set.member objectId (finCatObjects category) + then Right (mkFinObj category objectId) + else Left (FinCatObjectNotDeclared (finCatHandle category) objectId) + +mkFinObj :: FinCat -> FinObjectId -> FinObj +mkFinObj category objectId = + FinObj + { finObjCategoryHandle = finCatHandle category, + finObjId = objectId + } + +mkFinMorphism :: FinCat -> FinMorphismId -> Either FinCatError FinMor +mkFinMorphism category morphismId = + case category of + DenseThinFinCat denseData -> + case denseMorphismEndpoints denseData morphismId of + Nothing -> Left (FinCatMorphismNotDeclared (finCatHandle category) morphismId) + Just (sourceId, targetId) -> Right (mkFinMor category morphismId sourceId targetId) + _ -> + case Map.lookup morphismId (finCatMorphismIndex category) of + Nothing -> Left (FinCatMorphismNotDeclared (finCatHandle category) morphismId) + Just (sourceId, targetId) -> Right (mkFinMor category morphismId sourceId targetId) + +mkFinMor :: FinCat -> FinMorphismId -> FinObjectId -> FinObjectId -> FinMor +mkFinMor category morphismId sourceId targetId = + FinMor + { finMorCategoryHandle = finCatHandle category, + finMorId = morphismId, + finMorSourceId = sourceId, + finMorTargetId = targetId + } + +-- | Trusted O(1) view of a morphism's source object. Total: every t'FinMor' is built +-- by a validated path (its constructor is unexported), so the recorded source is +-- necessarily a declared object of the morphism's category — no re-validation needed. +finMorDomObject :: FinMor -> FinObj +finMorDomObject morphism = + FinObj (finMorCategoryHandle morphism) (finMorSourceId morphism) +{-# INLINE finMorDomObject #-} + +-- | Trusted O(1) view of a morphism's target object. Total, for the same reason as +-- 'finMorDomObject'. +finMorCodObject :: FinMor -> FinObj +finMorCodObject morphism = + FinObj (finMorCategoryHandle morphism) (finMorTargetId morphism) +{-# INLINE finMorCodObject #-} + +-- | Total O(1) identity morphism at an already validated object handle. +finObjectIdentityMor :: FinObj -> FinMor +finObjectIdentityMor objectValue = + FinMor + (finObjCategoryHandle objectValue) + (identityMorphismId (finObjId objectValue)) + (finObjId objectValue) + (finObjId objectValue) +{-# INLINE finObjectIdentityMor #-} + +-- | The unique morphism between two endpoints when one exists (O(1) on the dense form), +-- including the identity when the endpoints coincide and the object is declared. +finCatHomMorphism :: FinCat -> FinObjectId -> FinObjectId -> Maybe FinMor +finCatHomMorphism category sourceId targetId = + fmap + (\morphismId -> FinMor (finCatHandle category) morphismId sourceId targetId) + (finCatMorphismIdByEndpoints category sourceId targetId) +{-# INLINE finCatHomMorphism #-} + +allObjects :: FinCat -> [FinObj] +allObjects category = + fmap + (\objectId -> FinObj (finCatHandle category) objectId) + (Set.toAscList (finCatObjects category)) + +foldMapFinMorphisms :: Monoid monoid => (FinMor -> monoid) -> FinCat -> monoid +foldMapFinMorphisms morphismValue category = + let objectIds = Set.toAscList (finCatObjects category) + identityMorphisms = + objectIds + & foldMap (\objectId -> morphismValue (mkFinMor category (identityMorphismId objectId) objectId objectId)) + nonIdentityMorphisms = + objectIds + & foldMap (foldMapNonIdentityMorphismsFrom morphismValue category) + in identityMorphisms <> nonIdentityMorphisms + +foldMapFinMorphismsFrom :: Monoid monoid => (FinMor -> monoid) -> FinCat -> FinObjectId -> monoid +foldMapFinMorphismsFrom morphismValue category sourceId + | not (finCatHasObject category sourceId) = mempty + | otherwise = + morphismValue (mkFinMor category (identityMorphismId sourceId) sourceId sourceId) + <> foldMapNonIdentityMorphismsFrom morphismValue category sourceId + +foldMapFinMorphismsTo :: Monoid monoid => (FinMor -> monoid) -> FinCat -> FinObjectId -> monoid +foldMapFinMorphismsTo morphismValue category targetId + | not (finCatHasObject category targetId) = mempty + | otherwise = + morphismValue (mkFinMor category (identityMorphismId targetId) targetId targetId) + <> foldMapNonIdentityMorphismsTo morphismValue category targetId + +foldMapNonIdentityMorphismsFrom :: Monoid monoid => (FinMor -> monoid) -> FinCat -> FinObjectId -> monoid +foldMapNonIdentityMorphismsFrom morphismValue category sourceId = + case category of + ExplicitFinCat explicitData -> + Map.findWithDefault [] sourceId (explicitFinCatMorphismsBySource explicitData) + & foldMap + ( \(targetId, morphismIds) -> + morphismIds + & foldMap (\morphismId -> morphismValue (mkFinMor category morphismId sourceId targetId)) + ) + ThinFinCat thinData -> + Map.findWithDefault [] sourceId (thinFinCatMorphismsBySource thinData) + & foldMap + ( \(targetId, morphismId) -> + morphismValue (mkFinMor category morphismId sourceId targetId) + ) + DenseThinFinCat denseData -> + denseMorphismsFrom category denseData sourceId + & foldMap morphismValue + +foldMapNonIdentityMorphismsTo :: Monoid monoid => (FinMor -> monoid) -> FinCat -> FinObjectId -> monoid +foldMapNonIdentityMorphismsTo morphismValue category targetId = + case category of + ExplicitFinCat explicitData -> + Map.findWithDefault [] targetId (explicitFinCatMorphismsByTarget explicitData) + & foldMap + ( \(sourceId, morphismIds) -> + morphismIds + & foldMap (\morphismId -> morphismValue (mkFinMor category morphismId sourceId targetId)) + ) + ThinFinCat thinData -> + Map.findWithDefault [] targetId (thinFinCatMorphismsByTarget thinData) + & foldMap + ( \(sourceId, morphismId) -> + morphismValue (mkFinMor category morphismId sourceId targetId) + ) + DenseThinFinCat denseData -> + denseMorphismsTo category denseData targetId + & foldMap morphismValue + +allMorphisms :: FinCat -> [FinMor] +allMorphisms = + foldMapFinMorphisms (: []) + +allMorphismsFrom :: FinCat -> FinObj -> [FinMor] +allMorphismsFrom category sourceObject + | finObjCategoryHandle sourceObject /= finCatHandle category = [] + | otherwise = foldMapFinMorphismsFrom (: []) category (finObjId sourceObject) + +denseMorphismsFrom :: FinCat -> DenseThinFinCatData -> FinObjectId -> [FinMor] +denseMorphismsFrom category denseData sourceObjectId@(FinObjectId sourceIndex) = + case (denseThinFinCatPrefixCounts denseData UVector.!? sourceIndex, denseThinFinCatReachabilityRows denseData Vector.!? sourceIndex) of + (Just startIndex, Just reachableBits) -> + bitsToAscList (denseThinFinCatObjectCount denseData) reachableBits + & zip [startIndex ..] + & fmap + ( \(morphismIndex, targetIndex) -> + FinMor (finCatHandle category) (denseMorphismId morphismIndex) sourceObjectId (FinObjectId targetIndex) + ) + _ -> [] + +denseMorphismsTo :: FinCat -> DenseThinFinCatData -> FinObjectId -> [FinMor] +denseMorphismsTo category denseData targetObjectId@(FinObjectId targetIndex) = + case denseThinFinCatPredecessorRows denseData Vector.!? targetIndex of + Nothing -> [] + Just predecessorBits -> + bitsToAscList (denseThinFinCatObjectCount denseData) predecessorBits + >>= ( \sourceIndex -> + case denseEndpointMorphism denseData (FinObjectId sourceIndex) targetObjectId of + Nothing -> [] + Just morphismId -> [mkFinMor category morphismId (FinObjectId sourceIndex) targetObjectId] + ) + +finMorphismsBySource :: FinCat -> Map FinObjectId [FinMor] +finMorphismsBySource category = + allObjects category + & fmap (\objectValue -> (finObjId objectValue, allMorphismsFrom category objectValue)) + & Map.fromList + +finCatComposableChains :: FinCat -> Natural -> [SizedComposableChain FinCat] +finCatComposableChains category dimensionBound = + genericTake (dimensionBound + 1) (finCatChainsByDimension category) + & foldMap (fmap sizedComposableChain) + +finCatNonDegenerateChainsByDimension :: FinCat -> Natural -> [[ComposableChain FinCat]] +finCatNonDegenerateChainsByDimension category dimensionBound = + genericTake + (dimensionBound + 1) + (iterate extendNonIdentityChains seedChains) + where + nonIdentityBySource = + allObjects category + & fmap + ( \objectValue -> + ( finObjId objectValue, + foldMapNonIdentityMorphismsFrom (: []) category (finObjId objectValue) + ) + ) + & Map.fromList + + seedChains = + allObjects category + & fmap singletonComposableChain + + extendNonIdentityChains chains = + chains + >>= ( \chainValue -> + Map.findWithDefault [] (finObjId (chainTerminalObject chainValue)) nonIdentityBySource + & mapMaybe + (either (const Nothing) Just . appendComposableMorphism category chainValue) + ) + +finCatChainsByDimension :: FinCat -> [[ComposableChain FinCat]] +finCatChainsByDimension category = + iterate + (extendFinCatChains category (finMorphismsBySource category)) + (fmap singletonComposableChain (allObjects category)) + +extendFinCatChains :: FinCat -> Map FinObjectId [FinMor] -> [ComposableChain FinCat] -> [ComposableChain FinCat] +extendFinCatChains category morphismsBySource chains = + chains + >>= ( \chainValue -> + mapMaybe + (either (const Nothing) Just . appendComposableMorphism category chainValue) + (Map.findWithDefault [] (finObjId (chainTerminalObject chainValue)) morphismsBySource) + ) + +morphismIsDeclared :: FinCat -> FinObjectId -> FinObjectId -> FinMorphismId -> Bool +morphismIsDeclared category sourceId targetId morphismId = + case category of + DenseThinFinCat denseData -> + denseMorphismEndpoints denseData morphismId == Just (sourceId, targetId) + _ -> + case Map.lookup morphismId (finCatMorphismIndex category) of + Just endpoints -> endpoints == (sourceId, targetId) + Nothing -> False + +mkFinTwoMor :: FinMor -> FinMor -> Either FinCatError FinTwoMor +mkFinTwoMor sourceMorphism targetMorphism = + if finMorCategoryHandle sourceMorphism /= finMorCategoryHandle targetMorphism + then Left (FinCatMorphismWrongCategory (finMorCategoryHandle sourceMorphism) (finMorCategoryHandle targetMorphism) (finMorId targetMorphism)) + else + if finMorSourceId sourceMorphism == finMorSourceId targetMorphism && finMorTargetId sourceMorphism == finMorTargetId targetMorphism + then Right (FinTwoMor sourceMorphism targetMorphism) + else Left (FinCatTwoMorphismBoundaryNotParallel sourceMorphism targetMorphism) + +instance Category FinCat where + type Ob FinCat = FinObj + type Mor FinCat = FinMor + type TwoMor FinCat = FinTwoMor + type Compositor FinCat = FinCompositor + type CategoryError FinCat = FinCatError + + identity category objectValue + | finObjCategoryHandle objectValue /= finCatHandle category = + Left (FinCatObjectWrongCategory (finCatHandle category) (finObjCategoryHandle objectValue) (finObjId objectValue)) + | otherwise = + Right (FinMor (finCatHandle category) (identityMorphismId (finObjId objectValue)) (finObjId objectValue) (finObjId objectValue)) + + compose category left right + | finMorCategoryHandle left /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle left) (finMorId left)) + | finMorCategoryHandle right /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle right) (finMorId right)) + | finMorTargetId right /= finMorSourceId left = + Left (FinCatMorphismNotComposable (finMorId left) (finMorId right) (finMorSourceId left) (finMorTargetId right)) + | isIdentityMorphismId (finMorId left) = Right (right, FinStrictCompositor) + | isIdentityMorphismId (finMorId right) = Right (left, FinStrictCompositor) + | otherwise = + composeNonIdentityMorphisms category left right + + source category morphism + | finMorCategoryHandle morphism /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle morphism) (finMorId morphism)) + | otherwise = mkFinObject category (finMorSourceId morphism) + + target category morphism + | finMorCategoryHandle morphism /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle morphism) (finMorId morphism)) + | otherwise = mkFinObject category (finMorTargetId morphism) + +composeNonIdentityMorphisms :: FinCat -> FinMor -> FinMor -> Either FinCatError (FinMor, FinCompositor) +composeNonIdentityMorphisms category left right = + let composedSourceId = finMorSourceId right + composedTargetId = finMorTargetId left + in case category of + ExplicitFinCat explicitData -> + case Map.lookup (finMorId left, finMorId right) (explicitFinCatCompositionMap explicitData) of + Nothing -> Left (FinCatCompositionMissing (finMorId left) (finMorId right)) + Just composedId -> + if morphismIsDeclared category composedSourceId composedTargetId composedId + then Right (FinMor (finCatHandle category) composedId composedSourceId composedTargetId, FinStrictCompositor) + else Left (FinCatCompositionResultInvalid composedId composedSourceId composedTargetId) + ThinFinCat thinData -> + if composedSourceId == composedTargetId + then Right (FinMor (finCatHandle category) (identityMorphismId composedSourceId) composedSourceId composedTargetId, FinStrictCompositor) + else + case Map.lookup (composedSourceId, composedTargetId) (thinFinCatEndpointMorphisms thinData) of + Nothing -> Left (FinCatCompositionMissing (finMorId left) (finMorId right)) + Just composedId -> Right (FinMor (finCatHandle category) composedId composedSourceId composedTargetId, FinStrictCompositor) + DenseThinFinCat denseData -> + if composedSourceId == composedTargetId && denseObjectIdInBounds denseData composedSourceId + then Right (FinMor (finCatHandle category) (identityMorphismId composedSourceId) composedSourceId composedTargetId, FinStrictCompositor) + else + case denseEndpointMorphismIndex denseData composedSourceId composedTargetId of + Nothing -> Left (FinCatCompositionMissing (finMorId left) (finMorId right)) + Just composedIndex -> Right (FinMor (finCatHandle category) (denseMorphismId composedIndex) composedSourceId composedTargetId, FinStrictCompositor) + +instance HigherCategory FinCat where + source2 = finTwoSource + target2 = finTwoTarget + id2 morphism = FinTwoMor morphism morphism + + hCompose category left right = do + sourceComposed <- composeMor @FinCat category (finTwoSource left) (finTwoSource right) + targetComposed <- composeMor @FinCat category (finTwoTarget left) (finTwoTarget right) + mkFinTwoMor sourceComposed targetComposed + + vCompose category left right + | finMorCategoryHandle (finTwoSource left) /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle (finTwoSource left)) (finMorId (finTwoSource left))) + | finMorCategoryHandle (finTwoTarget left) /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle (finTwoTarget left)) (finMorId (finTwoTarget left))) + | finMorCategoryHandle (finTwoSource right) /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle (finTwoSource right)) (finMorId (finTwoSource right))) + | finMorCategoryHandle (finTwoTarget right) /= finCatHandle category = + Left (FinCatMorphismWrongCategory (finCatHandle category) (finMorCategoryHandle (finTwoTarget right)) (finMorId (finTwoTarget right))) + | finTwoSource left /= finTwoTarget right = + Left (FinCatTwoMorphismNotVerticallyComposable left right) + | otherwise = + mkFinTwoMor (finTwoSource right) (finTwoTarget left) + + compositor _ = FinAssociator + +instance TwoCategory FinCat where + -- FinCat 2-cells are invertible equality witnesses, not directed rewrites. + inverse2 _ twoMorphism = Right (FinTwoMor (finTwoTarget twoMorphism) (finTwoSource twoMorphism)) + +instance Bicategory FinCat where + leftUnitor _ = FinLeftUnitor + rightUnitor _ = FinRightUnitor + associator _ = FinAssociator + +instance FiniteComposableCategory FinCat where + enumerateObjects = allObjects + enumerateMorphisms = allMorphisms + enumerateMorphismsFrom = allMorphismsFrom + enumerateComposableChains = finCatComposableChains + enumerateNonDegenerateChainsByDimension = finCatNonDegenerateChainsByDimension diff --git a/src-finite/Moonlight/Category/Pure/FinCat/Functor.hs b/src-finite/Moonlight/Category/Pure/FinCat/Functor.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/FinCat/Functor.hs @@ -0,0 +1,139 @@ +-- | Object maps between finite thin categories, validated once against the +-- source and target reachability relations. +module Moonlight.Category.Pure.FinCat.Functor + ( FinThinFunctor, + FinThinFunctorValidationError (..), + FinThinFunctorApplicationError (..), + mkFinThinFunctor, + finThinFunctorSource, + finThinFunctorTarget, + finThinFunctorObjectMap, + applyFinThinFunctor, + ) +where + +import Data.Kind (Type) +import Data.List (find) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinObjectId, + finCatExplicitMorphismMapView, + finCatIsThin, + finCatObjects, + ) + +-- | A validated functor between finite thin categories. Thinness makes the +-- morphism action proof-irrelevant: a total object action is functorial exactly +-- when it preserves every source reachability relation. +type FinThinFunctor :: Type +data FinThinFunctor = FinThinFunctor + { finThinFunctorSource :: !FinCat, + finThinFunctorTarget :: !FinCat, + finThinFunctorObjectMap :: !(Map FinObjectId FinObjectId) + } + +type FinThinFunctorValidationError :: Type +data FinThinFunctorValidationError + = FinThinFunctorSourceNotThin + | FinThinFunctorTargetNotThin + | FinThinFunctorMissingSourceObject !FinObjectId + | FinThinFunctorUnexpectedSourceObject !FinObjectId + | FinThinFunctorTargetObjectAbsent !FinObjectId !FinObjectId + | FinThinFunctorOrderNotPreserved !FinObjectId !FinObjectId !FinObjectId !FinObjectId + deriving stock (Eq, Ord, Show) + +type FinThinFunctorApplicationError :: Type +data FinThinFunctorApplicationError + = FinThinFunctorUnknownSourceObject !FinObjectId + deriving stock (Eq, Ord, Show) + +-- | Check a total finite object table once and retain its thin-functor proof. +mkFinThinFunctor :: + FinCat -> + FinCat -> + Map FinObjectId FinObjectId -> + Either FinThinFunctorValidationError FinThinFunctor +mkFinThinFunctor sourceCategory targetCategory objectMap = do + requireThin FinThinFunctorSourceNotThin sourceCategory + requireThin FinThinFunctorTargetNotThin targetCategory + validateObjectMapDomain + validateObjectMapCodomain + validateOrderPreservation + Right + FinThinFunctor + { finThinFunctorSource = sourceCategory, + finThinFunctorTarget = targetCategory, + finThinFunctorObjectMap = objectMap + } + where + sourceObjects = finCatObjects sourceCategory + targetObjects = finCatObjects targetCategory + suppliedSourceObjects = Map.keysSet objectMap + + validateObjectMapDomain = + case Set.lookupMin (Set.difference sourceObjects suppliedSourceObjects) of + Just missingObject -> Left (FinThinFunctorMissingSourceObject missingObject) + Nothing -> + case Set.lookupMin (Set.difference suppliedSourceObjects sourceObjects) of + Just unexpectedObject -> Left (FinThinFunctorUnexpectedSourceObject unexpectedObject) + Nothing -> Right () + + validateObjectMapCodomain = + case find (not . (`Set.member` targetObjects) . snd) (Map.toAscList objectMap) of + Just (sourceObject, targetObject) -> + Left (FinThinFunctorTargetObjectAbsent sourceObject targetObject) + Nothing -> Right () + + validateOrderPreservation = + case findOrderViolation of + Just (sourceObject, sourceTarget, mappedSource, mappedTarget) -> + Left + ( FinThinFunctorOrderNotPreserved + sourceObject + sourceTarget + mappedSource + mappedTarget + ) + Nothing -> Right () + + findOrderViolation = + listToMaybe + [ (sourceObject, targetObject, mappedSource, mappedTarget) + | ((sourceObject, targetObject), morphisms) <- Map.toAscList sourceMorphismMap, + not (null morphisms), + Just mappedSource <- [Map.lookup sourceObject objectMap], + Just mappedTarget <- [Map.lookup targetObject objectMap], + not (targetRelates mappedSource mappedTarget) + ] + + sourceMorphismMap = finCatExplicitMorphismMapView sourceCategory + targetMorphismMap = finCatExplicitMorphismMapView targetCategory + + targetRelates sourceObject targetObject = + sourceObject == targetObject + || not + ( null + ( Map.findWithDefault + [] + (sourceObject, targetObject) + targetMorphismMap + ) + ) + +requireThin :: FinThinFunctorValidationError -> FinCat -> Either FinThinFunctorValidationError () +requireThin notThinError categoryValue + | finCatIsThin categoryValue = Right () + | otherwise = Left notThinError + +applyFinThinFunctor :: + FinThinFunctor -> + FinObjectId -> + Either FinThinFunctorApplicationError FinObjectId +applyFinThinFunctor functorValue sourceObject = + case Map.lookup sourceObject (finThinFunctorObjectMap functorValue) of + Just targetObject -> Right targetObject + Nothing -> Left (FinThinFunctorUnknownSourceObject sourceObject) diff --git a/src-finite/Moonlight/Category/Pure/FinCat/Opposite.hs b/src-finite/Moonlight/Category/Pure/FinCat/Opposite.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/FinCat/Opposite.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | Opposite finite categories: 'FinCat' with sources and targets reversed. +module Moonlight.Category.Pure.FinCat.Opposite + ( OppositeFinCat (..), + OppositeFinObj (..), + OppositeFinMor (..), + OppositeFinTwoMor (..), + OppositeFinCompositor (..), + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.Category (Category (..), Compositor, Mor, Ob, TwoMor) +import Moonlight.Category.Pure.FinCat (FinCat, FinCatError) + +type OppositeFinCat :: Type +newtype OppositeFinCat = OppositeFinCat {oppositeFinCatSource :: FinCat} + deriving stock (Eq, Show) + +type OppositeFinObj :: Type +newtype OppositeFinObj = OppositeFinObj {unwrapOppositeFinObj :: Ob FinCat} + deriving stock (Eq, Show) + +type OppositeFinMor :: Type +newtype OppositeFinMor = OppositeFinMor {unwrapOppositeFinMor :: Mor FinCat} + deriving stock (Eq, Show) + +type OppositeFinTwoMor :: Type +newtype OppositeFinTwoMor = OppositeFinTwoMor {unwrapOppositeFinTwoMor :: TwoMor FinCat} + deriving stock (Eq, Show) + +type OppositeFinCompositor :: Type +newtype OppositeFinCompositor = OppositeFinCompositor {unwrapOppositeFinCompositor :: Compositor FinCat} + deriving stock (Eq, Show) + +instance Category OppositeFinCat where + type Ob OppositeFinCat = OppositeFinObj + type Mor OppositeFinCat = OppositeFinMor + type TwoMor OppositeFinCat = OppositeFinTwoMor + type Compositor OppositeFinCat = OppositeFinCompositor + type CategoryError OppositeFinCat = FinCatError + + identity (OppositeFinCat categoryValue) (OppositeFinObj objectValue) = + OppositeFinMor <$> identity @FinCat categoryValue objectValue + + compose (OppositeFinCat categoryValue) (OppositeFinMor left) (OppositeFinMor right) = do + (composed, coherence) <- compose @FinCat categoryValue right left + pure (OppositeFinMor composed, OppositeFinCompositor coherence) + + source (OppositeFinCat categoryValue) (OppositeFinMor morphism) = + OppositeFinObj <$> target @FinCat categoryValue morphism + + target (OppositeFinCat categoryValue) (OppositeFinMor morphism) = + OppositeFinObj <$> source @FinCat categoryValue morphism diff --git a/src-finite/Moonlight/Category/Pure/FinPresentation.hs b/src-finite/Moonlight/Category/Pure/FinPresentation.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/FinPresentation.hs @@ -0,0 +1,887 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} + +{-| A name-binding builder for finite categories that compiles to the validated +'FinCat' semantic representation. + +The builder has two deliberately separate dialects: + +* A finite-poset dialect. 'below' declares strict generating inequalities; + transitive closure is computed and cyclic declarations are rejected. Identities + are implicit, so the resulting category carries the corresponding reflexive + order. + +* A fully enumerated finite-category dialect. 'arrow' declares every nonidentity + morphism, 'identityAt' denotes an identity, and 'equate' supplies the composition + table. The 'FinCat' constructors remain the semantic owners that validate + closure and associativity. + +A longer path equation is accepted only when each proper intermediate composite can +already be resolved from other equations. This module does not construct quotients +of free categories by arbitrary path congruences. +-} +module Moonlight.Category.Pure.FinPresentation + ( FinBuilder, + ObjRef, + ArrowExpr, + FinCatBuildError (..), + object, + objects, + arrow, + identityAt, + below, + after, + equate, + finCategory, + ) +where + +import Control.Applicative ((<|>)) +import Data.Bifunctor (first) +import Data.Bits (bit, (.|.)) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Sequence (Seq, ViewL (..), (|>)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatValidationError, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + trustedFinCatWithGeneratorBasis, + trustedDenseThinFinCatFromReachabilityRows, + ) +import Moonlight.Category.Pure.Finite.DenseReachability + ( denseClosureCycleComponents, + denseClosureReachabilityRows, + denseReachabilityWithCycles, + ) + +-- | An opaque reference to an object declared by 'object'. +type ObjRef :: Type +data ObjRef = ObjRef !FinObjectId !String + deriving stock (Eq, Show) + +-- | An opaque morphism expression. Expressions are identities, named nonidentity +-- morphisms, or composites built with 'after'. +type ArrowExpr :: Type +data ArrowExpr + = ExprIdentity !FinObjectId !String + | ExprGen !FinGeneratorId !FinObjectId !FinObjectId !String + | ExprComp !ArrowExpr !ArrowExpr + deriving stock (Eq, Ord) + +instance Show ArrowExpr where + showsPrec precedence expression = + case expression of + ExprIdentity _ objectName -> + showString "id[" . showString objectName . showChar ']' + ExprGen _ _ _ arrowName -> + showString arrowName + ExprComp leftExpression rightExpression -> + showParen + (precedence > 9) + ( showsPrec 10 leftExpression + . showString " `after` " + . showsPrec 9 rightExpression + ) + +-- | Faults discovered while building or compiling a presentation. +type FinCatBuildError :: Type +data FinCatBuildError + = DuplicateObjectName String + | DuplicateArrowName String + | DanglingObjectReference FinObjectId + | MixedPresentationModes + | CyclicStrictOrder [FinObjectId] + | NonComposablePath ArrowExpr ArrowExpr FinObjectId FinObjectId + | NonParallelEquation + ArrowExpr + ArrowExpr + (FinObjectId, FinObjectId) + (FinObjectId, FinObjectId) + | UnsupportedEquation ArrowExpr ArrowExpr + | UnresolvedComposite ArrowExpr + | ConflictingComposition ArrowExpr ArrowExpr ArrowExpr ArrowExpr + | IdentityEquationMismatch ArrowExpr ArrowExpr ArrowExpr + | BuilderPatternFailure String + | InvalidPresentation (NonEmpty FinCatValidationError) + deriving stock (Eq, Show) + +type ArrowDecl :: Type +data ArrowDecl = + ArrowDecl !FinGeneratorId !FinObjectId !FinObjectId + +type BuilderState :: Type +data BuilderState = BuilderState + { builderObjectIds :: !(Map String FinObjectId), + builderNextObject :: !Int, + builderArrows :: !(Map String ArrowDecl), + builderNextArrow :: !Int, + builderBelowEdgesRev :: ![(FinObjectId, FinObjectId)], + builderEquationsRev :: ![(ArrowExpr, ArrowExpr)], + builderFirstError :: !(Maybe FinCatBuildError) + } + +initialState :: BuilderState +initialState = + BuilderState + { builderObjectIds = Map.empty, + builderNextObject = 0, + builderArrows = Map.empty, + builderNextArrow = 0, + builderBelowEdgesRev = [], + builderEquationsRev = [], + builderFirstError = Nothing + } + +-- | A pure presentation builder. The 'Maybe' lets refutable @do@-patterns +-- (e.g. @[a, b, c] <- objects [..]@) short-circuit via 'fail' while still +-- preserving the declarations accumulated so far for error reporting. +type FinBuilder :: Type -> Type +newtype FinBuilder a = FinBuilder {unFinBuilder :: BuilderState -> (Maybe a, BuilderState)} + +instance Functor FinBuilder where + fmap f (FinBuilder run) = + FinBuilder (\state -> let (result, state') = run state in (fmap f result, state')) + +instance Applicative FinBuilder where + pure value = FinBuilder (\state -> (Just value, state)) + FinBuilder runF <*> FinBuilder runA = + FinBuilder + ( \state -> + case runF state of + (Nothing, state') -> (Nothing, state') + (Just f, state') -> + let (result, state'') = runA state' + in (fmap f result, state'') + ) + +instance Monad FinBuilder where + FinBuilder run >>= k = + FinBuilder + ( \state -> + case run state of + (Nothing, state') -> (Nothing, state') + (Just value, state') -> unFinBuilder (k value) state' + ) + +instance MonadFail FinBuilder where + fail message = + FinBuilder (\state -> (Nothing, recordError (BuilderPatternFailure message) state)) + +recordError :: FinCatBuildError -> BuilderState -> BuilderState +recordError buildError state = + case builderFirstError state of + Nothing -> state {builderFirstError = Just buildError} + Just _ -> state +{-# INLINE recordError #-} + +objectReferenceDeclared :: BuilderState -> FinObjectId -> Bool +objectReferenceDeclared state (FinObjectId objectIndex) = + objectIndex >= 0 && objectIndex < builderNextObject state +{-# INLINE objectReferenceDeclared #-} + +recordObjectReference :: FinObjectId -> BuilderState -> BuilderState +recordObjectReference objectId state = + if objectReferenceDeclared state objectId + then state + else recordError (DanglingObjectReference objectId) state +{-# INLINE recordObjectReference #-} + +-- | Declare an object, returning an opaque reference for subsequent declarations. +object :: String -> FinBuilder ObjRef +object objectName = + FinBuilder + ( \state -> + case Map.lookup objectName (builderObjectIds state) of + Just objectId -> + ( Just (ObjRef objectId objectName), + recordError (DuplicateObjectName objectName) state + ) + Nothing -> + let objectId = FinObjectId (builderNextObject state) + nextState = + state + { builderObjectIds = + Map.insert + objectName + objectId + (builderObjectIds state), + builderNextObject = + builderNextObject state + 1 + } + in (Just (ObjRef objectId objectName), nextState) + ) + +-- | Declare several objects in source order. +objects :: [String] -> FinBuilder [ObjRef] +objects = traverse object + +-- | Declare a named nonidentity morphism. Every nonidentity morphism of a general +-- presentation must be declared explicitly. +arrow :: ObjRef -> ObjRef -> String -> FinBuilder ArrowExpr +arrow (ObjRef sourceId _) (ObjRef targetId _) arrowName = + FinBuilder + ( \state -> + case Map.lookup arrowName (builderArrows state) of + Just (ArrowDecl generatorId existingSource existingTarget) -> + ( Just + ( ExprGen + generatorId + existingSource + existingTarget + arrowName + ), + recordError (DuplicateArrowName arrowName) state + ) + Nothing -> + let checkedState = + recordObjectReference targetId + (recordObjectReference sourceId state) + generatorId = + FinGeneratorId (builderNextArrow checkedState) + nextState = + checkedState + { builderArrows = + Map.insert + arrowName + (ArrowDecl generatorId sourceId targetId) + (builderArrows checkedState), + builderNextArrow = + builderNextArrow checkedState + 1 + } + in ( Just + (ExprGen generatorId sourceId targetId arrowName), + nextState + ) + ) + +-- | The identity morphism at a declared object. +identityAt :: ObjRef -> ArrowExpr +identityAt (ObjRef objectId objectName) = + ExprIdentity objectId objectName +{-# INLINE identityAt #-} + +-- | Declare a strict generating inequality. Cyclic strict inequalities are +-- rejected; identities and transitive consequences are supplied by compilation. +below :: ObjRef -> ObjRef -> FinBuilder () +below (ObjRef sourceId _) (ObjRef targetId _) = + FinBuilder + ( \state -> + let checkedState = + recordObjectReference targetId + (recordObjectReference sourceId state) + in ( Just (), + checkedState + { builderBelowEdgesRev = + (sourceId, targetId) + : builderBelowEdgesRev checkedState + } + ) + ) + +-- | @g `after` f@ denotes @g ∘ f@: first @f@, then @g@. +infixr 9 `after` + +after :: ArrowExpr -> ArrowExpr -> ArrowExpr +after = ExprComp +{-# INLINE after #-} + +-- | Record an equation between parallel morphism expressions. +equate :: ArrowExpr -> ArrowExpr -> FinBuilder () +equate leftExpression rightExpression = + FinBuilder + ( \state -> + ( Just (), + state + { builderEquationsRev = + (leftExpression, rightExpression) + : builderEquationsRev state + } + ) + ) + +-- | Compile a presentation to a validated finite category. +finCategory :: FinBuilder a -> Either FinCatBuildError FinCat +finCategory builder = + case unFinBuilder builder initialState of + (_, state) -> + case builderFirstError state of + Just buildError -> Left buildError + Nothing -> compilePresentation state + +compilePresentation :: BuilderState -> Either FinCatBuildError FinCat +compilePresentation state = + let objectCount = builderNextObject state + objectSet = + Set.fromDistinctAscList + (FinObjectId <$> [0 .. objectCount - 1]) + belowEdges = + reverse (builderBelowEdgesRev state) + arrows = + Map.elems (builderArrows state) + equations = + reverse (builderEquationsRev state) + hasBelow = + not (null belowEdges) + hasGeneral = + not (null arrows) || not (null equations) + in case (hasBelow, hasGeneral) of + (True, True) -> + Left MixedPresentationModes + (True, False) -> + compileStrictOrder objectCount objectSet belowEdges + (False, _) -> + compileGeneral objectCount objectSet arrows equations + +compileStrictOrder :: + Int -> + Set FinObjectId -> + [(FinObjectId, FinObjectId)] -> + Either FinCatBuildError FinCat +compileStrictOrder objectCount objectSet belowEdges = + case + danglingEndpoints + objectCount + (belowEdges >>= \(sourceId, targetId) -> [sourceId, targetId]) + of + badObject : _ -> + Left (DanglingObjectReference badObject) + [] -> + let closure = + denseReachabilityWithCycles + (importRowsFromEdges objectCount belowEdges) + closedRows = + denseClosureReachabilityRows closure + cycleComponents = + denseClosureCycleComponents closure + in if null cycleComponents + then + Right + ( trustedDenseThinFinCatFromReachabilityRows + objectSet + closedRows + ) + else + Left + (CyclicStrictOrder (objectIdsFromComponents cycleComponents)) + +compileGeneral :: + Int -> + Set FinObjectId -> + [ArrowDecl] -> + [(ArrowExpr, ArrowExpr)] -> + Either FinCatBuildError FinCat +compileGeneral objectCount objectSet arrows equations = + case danglingEndpoints objectCount (arrowEndpointIds arrows) of + badObject : _ -> + Left (DanglingObjectReference badObject) + [] -> + case firstDanglingEquationObject objectCount equations of + Just badObject -> + Left (DanglingObjectReference badObject) + Nothing -> do + compositionMap <- compileEquations equations + let generatorBasis = + Set.fromList (arrowMorphismId <$> arrows) + first + InvalidPresentation + ( trustedFinCatWithGeneratorBasis + generatorBasis + objectSet + (morphismMapFromArrows arrows) + compositionMap + ) + +arrowEndpointIds :: [ArrowDecl] -> [FinObjectId] +arrowEndpointIds = + foldr + ( \(ArrowDecl _ sourceId targetId) rest -> + sourceId : targetId : rest + ) + [] + +arrowMorphismId :: ArrowDecl -> FinMorphismId +arrowMorphismId (ArrowDecl generatorId _ _) = + FinGeneratorMorphismId generatorId + +morphismMapFromArrows :: + [ArrowDecl] -> + Map (FinObjectId, FinObjectId) [FinMorphismId] +morphismMapFromArrows = + foldl' insertArrow Map.empty + where + insertArrow morphismMap (ArrowDecl generatorId sourceId targetId) = + Map.insertWith + (<>) + (sourceId, targetId) + [FinGeneratorMorphismId generatorId] + morphismMap + +type CompositionKey :: Type +type CompositionKey = + (FinMorphismId, FinMorphismId) + +type OrientedEquation :: Type +data OrientedEquation = + OrientedEquation !ArrowExpr !ArrowExpr !FinMorphismId + +type CompositionClaim :: Type +data CompositionClaim = + CompositionClaim !ArrowExpr !ArrowExpr !FinMorphismId + +type BlockedExpression :: Type +data BlockedExpression = + BlockedExpression !CompositionKey !ArrowExpr + +type EquationAttempt :: Type +data EquationAttempt + = EquationBlocked !BlockedExpression + | EquationSatisfied + | EquationClaims !CompositionKey !CompositionClaim + +type WaitingEquation :: Type +data WaitingEquation = + WaitingEquation !ArrowExpr !OrientedEquation + +compileEquations :: + [(ArrowExpr, ArrowExpr)] -> + Either FinCatBuildError (Map CompositionKey FinMorphismId) +compileEquations equations = do + preparedEquations <- traverse prepareEquation equations + claims <- + solveEquations + Map.empty + Map.empty + (Seq.fromList (catMaybes preparedEquations)) + pure (fmap compositionClaimResultId claims) + +prepareEquation :: + (ArrowExpr, ArrowExpr) -> + Either FinCatBuildError (Maybe OrientedEquation) +prepareEquation (leftExpression, rightExpression) = do + leftEndpoints <- expressionEndpoints leftExpression + rightEndpoints <- expressionEndpoints rightExpression + if leftEndpoints == rightEndpoints + then orientParallelEquation leftExpression rightExpression + else + Left + ( NonParallelEquation + leftExpression + rightExpression + leftEndpoints + rightEndpoints + ) + +orientParallelEquation :: + ArrowExpr -> + ArrowExpr -> + Either FinCatBuildError (Maybe OrientedEquation) +orientParallelEquation leftExpression rightExpression + | leftExpression == rightExpression = + Right Nothing + | otherwise = + case + ( leftExpression, + rightExpression, + atomicMorphismId leftExpression, + atomicMorphismId rightExpression + ) + of + (ExprComp _ _, _, _, Just resultId) -> + Right + ( Just + ( OrientedEquation + leftExpression + rightExpression + resultId + ) + ) + (_, ExprComp _ _, Just resultId, _) -> + Right + ( Just + ( OrientedEquation + rightExpression + leftExpression + resultId + ) + ) + (_, _, Just leftId, Just rightId) + | leftId == rightId -> + Right Nothing + _ -> + Left + (UnsupportedEquation leftExpression rightExpression) + +atomicMorphismId :: ArrowExpr -> Maybe FinMorphismId +atomicMorphismId expression = + case expression of + ExprIdentity objectId _ -> + Just (FinIdentityId objectId) + ExprGen generatorId _ _ _ -> + Just (FinGeneratorMorphismId generatorId) + ExprComp _ _ -> + Nothing + +expressionEndpoints :: + ArrowExpr -> + Either FinCatBuildError (FinObjectId, FinObjectId) +expressionEndpoints expression = + case expression of + ExprIdentity objectId _ -> + Right (objectId, objectId) + ExprGen _ sourceId targetId _ -> + Right (sourceId, targetId) + ExprComp leftExpression rightExpression -> do + (leftSource, leftTarget) <- + expressionEndpoints leftExpression + (rightSource, rightTarget) <- + expressionEndpoints rightExpression + if rightTarget == leftSource + then Right (rightSource, leftTarget) + else + Left + ( NonComposablePath + leftExpression + rightExpression + rightTarget + leftSource + ) + +solveEquations :: + Map CompositionKey CompositionClaim -> + Map CompositionKey (Seq WaitingEquation) -> + Seq OrientedEquation -> + Either FinCatBuildError (Map CompositionKey CompositionClaim) +solveEquations !claims !waiting !ready = + case Seq.viewl ready of + EmptyL -> + case firstWaitingExpression waiting of + Nothing -> + Right claims + Just unresolvedExpression -> + Left (UnresolvedComposite unresolvedExpression) + equation :< remaining -> do + attempt <- attemptEquation claims equation + case attempt of + EquationBlocked + (BlockedExpression dependencyKey unresolvedExpression) -> + solveEquations + claims + ( enqueueWaitingEquation + dependencyKey + (WaitingEquation unresolvedExpression equation) + waiting + ) + remaining + EquationSatisfied -> + solveEquations claims waiting remaining + EquationClaims compositionKey proposedClaim -> do + (claimWasInserted, nextClaims) <- + insertCompositionClaim + compositionKey + proposedClaim + claims + if claimWasInserted + then + let awakened = + Map.lookup compositionKey waiting + nextWaiting = + Map.delete compositionKey waiting + nextReady = + remaining + Seq.>< maybe + Seq.empty + waitingEquations + awakened + in solveEquations + nextClaims + nextWaiting + nextReady + else + solveEquations nextClaims waiting remaining + +waitingEquations :: + Seq WaitingEquation -> + Seq OrientedEquation +waitingEquations = + fmap + (\(WaitingEquation _ equation) -> equation) + +firstWaitingExpression :: + Map CompositionKey (Seq WaitingEquation) -> + Maybe ArrowExpr +firstWaitingExpression waiting = do + (_, equations) <- Map.lookupMin waiting + case Seq.viewl equations of + EmptyL -> + Nothing + WaitingEquation unresolvedExpression _ :< _ -> + Just unresolvedExpression + +enqueueWaitingEquation :: + CompositionKey -> + WaitingEquation -> + Map CompositionKey (Seq WaitingEquation) -> + Map CompositionKey (Seq WaitingEquation) +enqueueWaitingEquation dependencyKey equation = + Map.alter + ( \maybeEquations -> + Just + ( maybe + (Seq.singleton equation) + (|> equation) + maybeEquations + ) + ) + dependencyKey + +attemptEquation :: + Map CompositionKey CompositionClaim -> + OrientedEquation -> + Either FinCatBuildError EquationAttempt +attemptEquation + claims + (OrientedEquation compositeExpression resultExpression resultId) = + case compositeExpression of + ExprComp leftExpression rightExpression -> + case resolveArrowExpression claims leftExpression of + Left blockedExpression -> + Right (EquationBlocked blockedExpression) + Right leftId -> + case resolveArrowExpression claims rightExpression of + Left blockedExpression -> + Right (EquationBlocked blockedExpression) + Right rightId -> + case + identityComposite + leftExpression + leftId + rightExpression + rightId + of + Just (actualId, expectedExpression) + | actualId == resultId -> + Right EquationSatisfied + | otherwise -> + Left + ( IdentityEquationMismatch + compositeExpression + resultExpression + expectedExpression + ) + Nothing -> + Right + ( EquationClaims + (leftId, rightId) + ( CompositionClaim + compositeExpression + resultExpression + resultId + ) + ) + _ -> + Left + (UnsupportedEquation compositeExpression resultExpression) + +resolveArrowExpression :: + Map CompositionKey CompositionClaim -> + ArrowExpr -> + Either BlockedExpression FinMorphismId +resolveArrowExpression claims expression = + case expression of + ExprIdentity objectId _ -> + Right (FinIdentityId objectId) + ExprGen generatorId _ _ _ -> + Right (FinGeneratorMorphismId generatorId) + ExprComp leftExpression rightExpression -> do + leftId <- + resolveArrowExpression claims leftExpression + rightId <- + resolveArrowExpression claims rightExpression + case + identityComposite + leftExpression + leftId + rightExpression + rightId + of + Just (composedId, _) -> + Right composedId + Nothing -> + let compositionKey = + (leftId, rightId) + in case Map.lookup compositionKey claims of + Nothing -> + Left + ( BlockedExpression + compositionKey + expression + ) + Just claim -> + Right (compositionClaimResultId claim) + +identityComposite :: + ArrowExpr -> + FinMorphismId -> + ArrowExpr -> + FinMorphismId -> + Maybe (FinMorphismId, ArrowExpr) +identityComposite leftExpression leftId rightExpression rightId = + case leftId of + FinIdentityId _ -> + Just (rightId, rightExpression) + FinGeneratorMorphismId _ -> + case rightId of + FinIdentityId _ -> + Just (leftId, leftExpression) + FinGeneratorMorphismId _ -> + Nothing + +insertCompositionClaim :: + CompositionKey -> + CompositionClaim -> + Map CompositionKey CompositionClaim -> + Either + FinCatBuildError + (Bool, Map CompositionKey CompositionClaim) +insertCompositionClaim compositionKey proposedClaim claims = + case Map.lookup compositionKey claims of + Nothing -> + Right + ( True, + Map.insert compositionKey proposedClaim claims + ) + Just existingClaim + | compositionClaimResultId existingClaim + == compositionClaimResultId proposedClaim -> + Right (False, claims) + | otherwise -> + Left + ( ConflictingComposition + (compositionClaimComposite existingClaim) + (compositionClaimResultExpression existingClaim) + (compositionClaimComposite proposedClaim) + (compositionClaimResultExpression proposedClaim) + ) + +compositionClaimComposite :: CompositionClaim -> ArrowExpr +compositionClaimComposite + (CompositionClaim compositeExpression _ _) = + compositeExpression + +compositionClaimResultExpression :: + CompositionClaim -> + ArrowExpr +compositionClaimResultExpression + (CompositionClaim _ resultExpression _) = + resultExpression + +compositionClaimResultId :: + CompositionClaim -> + FinMorphismId +compositionClaimResultId + (CompositionClaim _ _ resultId) = + resultId + +firstDanglingEquationObject :: + Int -> + [(ArrowExpr, ArrowExpr)] -> + Maybe FinObjectId +firstDanglingEquationObject objectCount = + foldr + ( \(leftExpression, rightExpression) nextDanglingObject -> + firstDanglingExpressionObject objectCount leftExpression + <|> firstDanglingExpressionObject objectCount rightExpression + <|> nextDanglingObject + ) + Nothing + +firstDanglingExpressionObject :: + Int -> + ArrowExpr -> + Maybe FinObjectId +firstDanglingExpressionObject objectCount expression = + case expression of + ExprIdentity objectId _ -> + danglingObject objectCount objectId + ExprGen _ sourceId targetId _ -> + danglingObject objectCount sourceId + <|> danglingObject objectCount targetId + ExprComp leftExpression rightExpression -> + firstDanglingExpressionObject objectCount leftExpression + <|> firstDanglingExpressionObject objectCount rightExpression + +danglingObject :: Int -> FinObjectId -> Maybe FinObjectId +danglingObject objectCount objectId@(FinObjectId objectIndex) = + if objectIndex < 0 || objectIndex >= objectCount + then Just objectId + else Nothing + +importRowsFromEdges :: + Int -> + [(FinObjectId, FinObjectId)] -> + Vector Integer +importRowsFromEdges objectCount edges = + let rowsBySource = + foldl' insertEdge IntMap.empty edges + in Vector.generate + objectCount + (\sourceIndex -> + IntMap.findWithDefault 0 sourceIndex rowsBySource + ) + where + insertEdge :: + IntMap Integer -> + (FinObjectId, FinObjectId) -> + IntMap Integer + insertEdge + rows + (FinObjectId sourceIndex, FinObjectId targetIndex) + | sourceIndex >= 0, + sourceIndex < objectCount, + targetIndex >= 0, + targetIndex < objectCount = + IntMap.insertWith + (.|.) + sourceIndex + (bit targetIndex) + rows + | otherwise = + rows + +objectIdsFromComponents :: + [NonEmpty Int] -> + [FinObjectId] +objectIdsFromComponents components = + fmap FinObjectId (Set.toAscList (foldr insertComponent Set.empty components)) + where + insertComponent :: NonEmpty Int -> Set Int -> Set Int + insertComponent component objectIds = + foldr Set.insert objectIds component + +danglingEndpoints :: + Int -> + [FinObjectId] -> + [FinObjectId] +danglingEndpoints objectCount = + foldr + ( \objectId rest -> + case danglingObject objectCount objectId of + Nothing -> + rest + Just badObject -> + badObject : rest + ) + [] diff --git a/src-finite/Moonlight/Category/Pure/Finite/DenseReachability.hs b/src-finite/Moonlight/Category/Pure/Finite/DenseReachability.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/Finite/DenseReachability.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Dense bit-packed reachability closure over finite relations: Tarjan SCC with +-- per-component reachability, in single-'Word64' and packed-row variants. +module Moonlight.Category.Pure.Finite.DenseReachability + ( DenseClosure (..), + denseReachabilityWithCycles, + denseReachabilityRows, + relationUniverse, + relationBitRows, + transposeBitRows, + objectIndexOf, + objectComponentsFromIndices, + objectSetFromBits, + bitsDifference, + intListBits, + bitsToAscList, + ) +where + +import Control.Monad (foldM, when) +import Control.Monad.ST (ST, runST) +import Data.Bits (bit, popCount, testBit, (.&.), (.|.)) +import qualified Data.Bits as Bits +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Kind (Type) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.STRef (modifySTRef', newSTRef, readSTRef, writeSTRef) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified Data.Vector.Unboxed as UVector +import qualified Data.Vector.Unboxed.Mutable as UMVector +import Data.Word (Word64) + +type DenseClosure :: Type +data DenseClosure = DenseClosure + { denseClosureReachabilityRows :: !(Vector Integer), + denseClosureCycleComponents :: ![NonEmpty Int], + denseClosureComponentCount :: !Int + } + deriving stock (Eq, Show) + + +data PackedRows = PackedRows !Int !(UVector.Vector Word64) + +data MutablePackedRows s = MutablePackedRows !Int !(UMVector.MVector s Word64) + +data RowCursor + = EmptyRowCursor + | RowCursor !Int !Int !Word64 + +denseReachabilityWithCycles :: Vector Integer -> DenseClosure +denseReachabilityWithCycles inputRows = + runST (denseReachabilityWithCyclesST inputRows) +{-# INLINABLE denseReachabilityWithCycles #-} + +denseReachabilityWithCyclesST :: forall s. Vector Integer -> ST s DenseClosure +denseReachabilityWithCyclesST inputRows + | Vector.length inputRows <= wordBitCount = + denseReachabilityWithCyclesWord64ST inputRows + | otherwise = + denseReachabilityWithCyclesPackedST inputRows +{-# INLINABLE denseReachabilityWithCyclesST #-} + +denseReachabilityWithCyclesWord64ST :: forall s. Vector Integer -> ST s DenseClosure +denseReachabilityWithCyclesWord64ST inputRows = do + let vertexCount = Vector.length inputRows + rows = + UVector.generate vertexCount $ + integerRowChunkWord vertexCount 0 . (inputRows Vector.!) + + discoveryOf <- UMVector.replicate vertexCount (-1 :: Int) + lowlinkOf <- UMVector.replicate vertexCount (0 :: Int) + onStackOf <- UMVector.replicate vertexCount False + componentOf <- UMVector.replicate vertexCount (-1 :: Int) + nextDiscovery <- newSTRef (0 :: Int) + nextComponent <- newSTRef (0 :: Int) + tarjanStack <- newSTRef ([] :: [Int]) + + closure <- UMVector.replicate vertexCount (0 :: Word64) + componentReach <- UMVector.replicate vertexCount (0 :: Word64) + cyclicAccumulator <- newSTRef ([] :: [NonEmpty Int]) + + let discover :: Int -> ST s () + discover vertex = do + stamp <- readSTRef nextDiscovery + writeSTRef nextDiscovery (stamp + 1) + UMVector.write discoveryOf vertex stamp + UMVector.write lowlinkOf vertex stamp + UMVector.write onStackOf vertex True + modifySTRef' tarjanStack (vertex :) + + popComponentMembers :: Int -> ST s (NonEmpty Int) + popComponentMembers rootVertex = do + stacked <- readSTRef tarjanStack + let (above, rest) = List.break (== rootVertex) stacked + case rest of + _root : below -> do + writeSTRef tarjanStack below + pure (rootVertex :| above) + [] -> do + writeSTRef tarjanStack [] + pure (rootVertex :| above) + + distinctSuccessorComponents :: Word64 -> ST s IntSet + distinctSuccessorComponents = + collect IntSet.empty + where + collect :: IntSet -> Word64 -> ST s IntSet + collect !acc successorBits + | successorBits == 0 = + pure acc + | otherwise = do + let successor = Bits.countTrailingZeros successorBits + componentId <- UMVector.read componentOf successor + let nextAcc = + if componentId >= 0 + then IntSet.insert componentId acc + else acc + collect nextAcc (clearLowestSetBitWord successorBits) + + emitComponent :: Int -> ST s () + emitComponent rootVertex = do + members <- popComponentMembers rootVertex + componentId <- readSTRef nextComponent + writeSTRef nextComponent (componentId + 1) + traverse_ + ( \member -> do + UMVector.write componentOf member componentId + UMVector.write onStackOf member False + ) + members + let memberBits = List.foldl' (\bits member -> bits .|. bit member) 0 members + outBits = List.foldl' (\bits member -> bits .|. wordRowAt rows member) 0 members + successorBits = outBits `withoutWordBits` memberBits + cyclic = + case members of + single :| [] -> testBit (wordRowAt rows single) single + _ -> True + selfBits = + if cyclic + then memberBits + else 0 + successorComponents <- distinctSuccessorComponents successorBits + downstreamBits <- + foldM + ( \ !acc successorComponentId -> + (acc .|.) <$> UMVector.read componentReach successorComponentId + ) + 0 + (IntSet.toList successorComponents) + let reachabilityBits = selfBits .|. successorBits .|. downstreamBits + UMVector.write componentReach componentId reachabilityBits + traverse_ + (\member -> UMVector.write closure member reachabilityBits) + members + when cyclic $ + modifySTRef' cyclicAccumulator (NonEmpty.sort members :) + + walk :: [(Int, Word64)] -> ST s () + walk [] = + pure () + walk ((vertex, remaining) : parents) + | remaining /= 0 = do + let successor = Bits.countTrailingZeros remaining + remainingTail = clearLowestSetBitWord remaining + successorDiscovery <- UMVector.read discoveryOf successor + if successorDiscovery < 0 + then do + discover successor + walk + ( (successor, wordRowAt rows successor) : + (vertex, remainingTail) : + parents + ) + else do + stacked <- UMVector.read onStackOf successor + when stacked $ do + lowlink <- UMVector.read lowlinkOf vertex + UMVector.write lowlinkOf vertex (min lowlink successorDiscovery) + walk ((vertex, remainingTail) : parents) + | otherwise = do + lowlink <- UMVector.read lowlinkOf vertex + discovery <- UMVector.read discoveryOf vertex + when (lowlink == discovery) (emitComponent vertex) + case parents of + (parent, _) : _ -> do + parentLowlink <- UMVector.read lowlinkOf parent + UMVector.write lowlinkOf parent (min parentLowlink lowlink) + [] -> + pure () + walk parents + + traverse_ + ( \vertex -> do + discovery <- UMVector.read discoveryOf vertex + when (discovery < 0) $ do + discover vertex + walk [(vertex, wordRowAt rows vertex)] + ) + [0 .. vertexCount - 1] + + frozenClosure <- Vector.generateM vertexCount (fmap toInteger . UMVector.read closure) + cycleComponents <- readSTRef cyclicAccumulator + totalComponents <- readSTRef nextComponent + pure + DenseClosure + { denseClosureReachabilityRows = frozenClosure, + denseClosureCycleComponents = List.sortOn NonEmpty.head cycleComponents, + denseClosureComponentCount = totalComponents + } +{-# INLINABLE denseReachabilityWithCyclesWord64ST #-} + +denseReachabilityWithCyclesPackedST :: forall s. Vector Integer -> ST s DenseClosure +denseReachabilityWithCyclesPackedST inputRows = do + let vertexCount = Vector.length inputRows + rows@(PackedRows chunkCount _) = packedRowsFromIntegerRows vertexCount inputRows + + discoveryOf <- UMVector.replicate vertexCount (-1 :: Int) + lowlinkOf <- UMVector.replicate vertexCount (0 :: Int) + onStackOf <- UMVector.replicate vertexCount False + componentOf <- UMVector.replicate vertexCount (-1 :: Int) + nextDiscovery <- newSTRef (0 :: Int) + nextComponent <- newSTRef (0 :: Int) + tarjanStack <- newSTRef ([] :: [Int]) + + closure <- newMutablePackedRows vertexCount chunkCount + componentReach <- newMutablePackedRows vertexCount chunkCount + scratchRow <- UMVector.replicate chunkCount (0 :: Word64) + cyclicAccumulator <- newSTRef ([] :: [NonEmpty Int]) + + let discover :: Int -> ST s () + discover vertex = do + stamp <- readSTRef nextDiscovery + writeSTRef nextDiscovery (stamp + 1) + UMVector.write discoveryOf vertex stamp + UMVector.write lowlinkOf vertex stamp + UMVector.write onStackOf vertex True + modifySTRef' tarjanStack (vertex :) + + popComponentMembers :: Int -> ST s (NonEmpty Int) + popComponentMembers rootVertex = do + stacked <- readSTRef tarjanStack + let (above, rest) = List.break (== rootVertex) stacked + case rest of + _root : below -> do + writeSTRef tarjanStack below + pure (rootVertex :| above) + [] -> do + writeSTRef tarjanStack [] + pure (rootVertex :| above) + + distinctSuccessorComponents :: ST s IntSet + distinctSuccessorComponents = + foldChunkIndicesM chunkCount IntSet.empty $ \ !acc chunkIndex -> do + successorWord <- UMVector.read scratchRow chunkIndex + collectChunkSuccessorComponents (chunkIndex * wordBitCount) acc successorWord + where + collectChunkSuccessorComponents :: Int -> IntSet -> Word64 -> ST s IntSet + collectChunkSuccessorComponents !chunkBase !acc successorWord + | successorWord == 0 = + pure acc + | otherwise = do + let successor = chunkBase + Bits.countTrailingZeros successorWord + componentId <- UMVector.read componentOf successor + let nextAcc = + if componentId >= 0 + then IntSet.insert componentId acc + else acc + collectChunkSuccessorComponents chunkBase nextAcc (clearLowestSetBitWord successorWord) + + emitComponent :: Int -> ST s () + emitComponent rootVertex = do + members <- popComponentMembers rootVertex + componentId <- readSTRef nextComponent + writeSTRef nextComponent (componentId + 1) + traverse_ (\member -> do + UMVector.write componentOf member componentId + UMVector.write onStackOf member False) members + clearScratchRow scratchRow chunkCount + traverse_ (orPackedRowIntoScratch scratchRow rows) members + traverse_ (clearScratchBit scratchRow) members + let cyclic = + case members of + single :| [] -> testPackedRowBit rows single single + _ -> True + successorComponents <- distinctSuccessorComponents + traverse_ + (orMutablePackedRowIntoScratch scratchRow componentReach) + (IntSet.toList successorComponents) + when cyclic $ + traverse_ (setScratchBit scratchRow) members + writeScratchRowToMutablePackedRow scratchRow componentReach componentId + traverse_ + (writeScratchRowToMutablePackedRow scratchRow closure) + members + when cyclic $ + modifySTRef' cyclicAccumulator (NonEmpty.sort members :) + + walk :: [(Int, RowCursor)] -> ST s () + walk [] = + pure () + walk ((vertex, remaining) : parents) = + case nextRowCursorSuccessor rows remaining of + Just (successor, remainingTail) -> do + successorDiscovery <- UMVector.read discoveryOf successor + if successorDiscovery < 0 + then do + discover successor + walk + ( (successor, initialRowCursor rows successor) : + (vertex, remainingTail) : + parents + ) + else do + stacked <- UMVector.read onStackOf successor + when stacked $ do + lowlink <- UMVector.read lowlinkOf vertex + UMVector.write lowlinkOf vertex (min lowlink successorDiscovery) + walk ((vertex, remainingTail) : parents) + Nothing -> do + lowlink <- UMVector.read lowlinkOf vertex + discovery <- UMVector.read discoveryOf vertex + when (lowlink == discovery) (emitComponent vertex) + case parents of + (parent, _) : _ -> do + parentLowlink <- UMVector.read lowlinkOf parent + UMVector.write lowlinkOf parent (min parentLowlink lowlink) + [] -> + pure () + walk parents + + traverse_ (\vertex -> do + discovery <- UMVector.read discoveryOf vertex + when (discovery < 0) $ do + discover vertex + walk [(vertex, initialRowCursor rows vertex)]) [0 .. vertexCount - 1] + + frozenClosure <- integerRowsFromMutablePackedRows vertexCount closure + cycleComponents <- readSTRef cyclicAccumulator + totalComponents <- readSTRef nextComponent + pure + DenseClosure + { denseClosureReachabilityRows = frozenClosure, + denseClosureCycleComponents = List.sortOn NonEmpty.head cycleComponents, + denseClosureComponentCount = totalComponents + } +{-# INLINABLE denseReachabilityWithCyclesPackedST #-} + +denseReachabilityRows :: Vector Integer -> Vector Integer +denseReachabilityRows = + denseClosureReachabilityRows . denseReachabilityWithCycles +{-# INLINABLE denseReachabilityRows #-} + +lowestSetBitIndex :: Integer -> Int +lowestSetBitIndex bits = + popCount (lowestBit - 1) + where + lowestBit = bits .&. negate bits +{-# INLINE lowestSetBitIndex #-} + +clearLowestSetBit :: Integer -> Integer +clearLowestSetBit bits = + bits .&. (bits - 1) +{-# INLINE clearLowestSetBit #-} + +withoutBits :: Integer -> Integer -> Integer +withoutBits leftBits rightBits = + leftBits .&. Bits.complement rightBits +{-# INLINE withoutBits #-} + +withoutWordBits :: Word64 -> Word64 -> Word64 +withoutWordBits leftBits rightBits = + leftBits .&. Bits.complement rightBits +{-# INLINE withoutWordBits #-} + +wordBitCount :: Int +wordBitCount = + 64 +{-# INLINE wordBitCount #-} + +chunksForBitCount :: Int -> Int +chunksForBitCount bitCount = + if bitCount <= 0 + then 0 + else (bitCount + wordBitCount - 1) `quot` wordBitCount +{-# INLINE chunksForBitCount #-} + +rowChunkOffset :: Int -> Int -> Int -> Int +rowChunkOffset chunkCount rowIndex chunkIndex = + rowIndex * chunkCount + chunkIndex +{-# INLINE rowChunkOffset #-} + +wordMaskForChunk :: Int -> Int -> Word64 +wordMaskForChunk bitCount chunkIndex + | remainingBits >= wordBitCount = maxBound + | remainingBits <= 0 = 0 + | otherwise = bit remainingBits - 1 + where + remainingBits = bitCount - chunkIndex * wordBitCount +{-# INLINE wordMaskForChunk #-} + +integerRowChunkWord :: Int -> Int -> Integer -> Word64 +integerRowChunkWord bitCount chunkIndex bits = + if chunkIndex == 0 + then fromInteger bits .&. wordMaskForChunk bitCount chunkIndex + else fromInteger ((bits `Bits.shiftR` (chunkIndex * wordBitCount)) .&. toInteger (wordMaskForChunk bitCount chunkIndex)) +{-# INLINE integerRowChunkWord #-} + +wordRowAt :: UVector.Vector Word64 -> Int -> Word64 +wordRowAt = (UVector.!) +{-# INLINE wordRowAt #-} + +packedRowsFromIntegerRows :: Int -> Vector Integer -> PackedRows +packedRowsFromIntegerRows bitCount rows = + PackedRows chunkCount $ + UVector.generate (bitCount * chunkCount) $ \flatIndex -> + let (rowIndex, chunkIndex) = flatIndex `quotRem` chunkCount + in integerRowChunkWord bitCount chunkIndex (rows Vector.! rowIndex) + where + chunkCount = chunksForBitCount bitCount +{-# INLINE packedRowsFromIntegerRows #-} + +newMutablePackedRows :: Int -> Int -> ST s (MutablePackedRows s) +newMutablePackedRows rowCount chunkCount = + MutablePackedRows chunkCount <$> UMVector.replicate (rowCount * chunkCount) 0 +{-# INLINE newMutablePackedRows #-} + +packedRowChunkAt :: PackedRows -> Int -> Int -> Word64 +packedRowChunkAt (PackedRows chunkCount chunks) rowIndex chunkIndex = + chunks UVector.! rowChunkOffset chunkCount rowIndex chunkIndex +{-# INLINE packedRowChunkAt #-} + +readMutablePackedRowChunk :: MutablePackedRows s -> Int -> Int -> ST s Word64 +readMutablePackedRowChunk (MutablePackedRows chunkCount chunks) rowIndex chunkIndex = + UMVector.read chunks (rowChunkOffset chunkCount rowIndex chunkIndex) +{-# INLINE readMutablePackedRowChunk #-} + +writeMutablePackedRowChunk :: MutablePackedRows s -> Int -> Int -> Word64 -> ST s () +writeMutablePackedRowChunk (MutablePackedRows chunkCount chunks) rowIndex chunkIndex = + UMVector.write chunks (rowChunkOffset chunkCount rowIndex chunkIndex) +{-# INLINE writeMutablePackedRowChunk #-} + +foldChunkIndicesM :: Monad m => Int -> a -> (a -> Int -> m a) -> m a +foldChunkIndicesM chunkCount initial step = + ascend 0 initial + where + ascend !chunkIndex !acc + | chunkIndex >= chunkCount = pure acc + | otherwise = do + nextAcc <- step acc chunkIndex + ascend (chunkIndex + 1) nextAcc +{-# INLINE foldChunkIndicesM #-} + +traverseChunkIndices_ :: Monad m => Int -> (Int -> m ()) -> m () +traverseChunkIndices_ chunkCount action = + foldChunkIndicesM chunkCount () (\() chunkIndex -> action chunkIndex) +{-# INLINE traverseChunkIndices_ #-} + +clearScratchRow :: UMVector.MVector s Word64 -> Int -> ST s () +clearScratchRow scratchRow chunkCount = + traverseChunkIndices_ chunkCount $ \chunkIndex -> + UMVector.write scratchRow chunkIndex 0 +{-# INLINE clearScratchRow #-} + +orPackedRowIntoScratch :: UMVector.MVector s Word64 -> PackedRows -> Int -> ST s () +orPackedRowIntoScratch scratchRow rows@(PackedRows chunkCount _) rowIndex = + traverseChunkIndices_ chunkCount $ \chunkIndex -> do + scratchWord <- UMVector.read scratchRow chunkIndex + let rowWord = packedRowChunkAt rows rowIndex chunkIndex + UMVector.write scratchRow chunkIndex (scratchWord .|. rowWord) +{-# INLINE orPackedRowIntoScratch #-} + +orMutablePackedRowIntoScratch :: UMVector.MVector s Word64 -> MutablePackedRows s -> Int -> ST s () +orMutablePackedRowIntoScratch scratchRow murows@(MutablePackedRows chunkCount _) rowIndex = + traverseChunkIndices_ chunkCount $ \chunkIndex -> do + scratchWord <- UMVector.read scratchRow chunkIndex + rowWord <- readMutablePackedRowChunk murows rowIndex chunkIndex + UMVector.write scratchRow chunkIndex (scratchWord .|. rowWord) +{-# INLINE orMutablePackedRowIntoScratch #-} + +writeScratchRowToMutablePackedRow :: UMVector.MVector s Word64 -> MutablePackedRows s -> Int -> ST s () +writeScratchRowToMutablePackedRow scratchRow murows@(MutablePackedRows chunkCount _) rowIndex = + traverseChunkIndices_ chunkCount $ \chunkIndex -> do + scratchWord <- UMVector.read scratchRow chunkIndex + writeMutablePackedRowChunk murows rowIndex chunkIndex scratchWord +{-# INLINE writeScratchRowToMutablePackedRow #-} + +scratchBitAddress :: Int -> (Int, Int) +scratchBitAddress bitIndex = + bitIndex `quotRem` wordBitCount +{-# INLINE scratchBitAddress #-} + +clearScratchBit :: UMVector.MVector s Word64 -> Int -> ST s () +clearScratchBit scratchRow bitIndex = do + let (chunkIndex, wordBitIndex) = scratchBitAddress bitIndex + scratchWord <- UMVector.read scratchRow chunkIndex + UMVector.write scratchRow chunkIndex (scratchWord .&. Bits.complement (bit wordBitIndex)) +{-# INLINE clearScratchBit #-} + +setScratchBit :: UMVector.MVector s Word64 -> Int -> ST s () +setScratchBit scratchRow bitIndex = do + let (chunkIndex, wordBitIndex) = scratchBitAddress bitIndex + scratchWord <- UMVector.read scratchRow chunkIndex + UMVector.write scratchRow chunkIndex (scratchWord .|. bit wordBitIndex) +{-# INLINE setScratchBit #-} + +clearLowestSetBitWord :: Word64 -> Word64 +clearLowestSetBitWord word = + word .&. (word - 1) +{-# INLINE clearLowestSetBitWord #-} + +testPackedRowBit :: PackedRows -> Int -> Int -> Bool +testPackedRowBit rows rowIndex bitIndex = + testBit (packedRowChunkAt rows rowIndex chunkIndex) wordBitIndex + where + (chunkIndex, wordBitIndex) = scratchBitAddress bitIndex +{-# INLINE testPackedRowBit #-} + +initialRowCursor :: PackedRows -> Int -> RowCursor +initialRowCursor rows rowIndex = + rowCursorFromChunk rows rowIndex 0 +{-# INLINE initialRowCursor #-} + +rowCursorFromChunk :: PackedRows -> Int -> Int -> RowCursor +rowCursorFromChunk rows@(PackedRows chunkCount _) rowIndex chunkIndex + | chunkIndex >= chunkCount = EmptyRowCursor + | chunkWord == 0 = rowCursorFromChunk rows rowIndex (chunkIndex + 1) + | otherwise = RowCursor rowIndex chunkIndex chunkWord + where + chunkWord = packedRowChunkAt rows rowIndex chunkIndex +{-# INLINE rowCursorFromChunk #-} + +rowCursorTail :: PackedRows -> Int -> Int -> Word64 -> RowCursor +rowCursorTail rows rowIndex chunkIndex chunkWord = + if tailWord == 0 + then rowCursorFromChunk rows rowIndex (chunkIndex + 1) + else RowCursor rowIndex chunkIndex tailWord + where + tailWord = clearLowestSetBitWord chunkWord +{-# INLINE rowCursorTail #-} + +nextRowCursorSuccessor :: PackedRows -> RowCursor -> Maybe (Int, RowCursor) +nextRowCursorSuccessor _ EmptyRowCursor = + Nothing +nextRowCursorSuccessor rows (RowCursor rowIndex chunkIndex chunkWord) = + Just + ( chunkIndex * wordBitCount + Bits.countTrailingZeros chunkWord, + rowCursorTail rows rowIndex chunkIndex chunkWord + ) +{-# INLINE nextRowCursorSuccessor #-} + +integerRowsFromMutablePackedRows :: Int -> MutablePackedRows s -> ST s (Vector Integer) +integerRowsFromMutablePackedRows rowCount murows = + Vector.generateM rowCount (integerFromMutablePackedRow murows) +{-# INLINE integerRowsFromMutablePackedRows #-} + +integerFromMutablePackedRow :: MutablePackedRows s -> Int -> ST s Integer +integerFromMutablePackedRow murows@(MutablePackedRows chunkCount _) rowIndex = + descend (chunkCount - 1) 0 + where + descend !chunkIndex !acc + | chunkIndex < 0 = pure acc + | otherwise = do + chunkWord <- readMutablePackedRowChunk murows rowIndex chunkIndex + descend (chunkIndex - 1) ((acc `Bits.shiftL` wordBitCount) .|. toInteger chunkWord) +{-# INLINE integerFromMutablePackedRow #-} + + +relationUniverse :: Ord obj => Map obj (Set obj) -> Set obj +relationUniverse = + Map.foldlWithKey' (\accumulated objectValue members -> Set.insert objectValue (Set.union members accumulated)) Set.empty + +relationBitRows :: Ord obj => Map obj Int -> Vector obj -> Map obj (Set obj) -> Vector Integer +relationBitRows objectIndex objectVector relation = + Vector.map + ( \objectValue -> + Map.findWithDefault Set.empty objectValue relation + & Set.toAscList + & mapMaybe (`Map.lookup` objectIndex) + & intListBits + ) + objectVector + +transposeBitRows :: Int -> Vector Integer -> Vector Integer +transposeBitRows objectCount rows = + Vector.generate + objectCount + ( \targetIndex -> + [0 .. objectCount - 1] + & foldr + ( \sourceIndex predecessorBits -> + if maybe False (`testBit` targetIndex) (rows Vector.!? sourceIndex) + then predecessorBits .|. bit sourceIndex + else predecessorBits + ) + 0 + ) + +objectIndexOf :: Ord obj => Vector obj -> Map obj Int +objectIndexOf = + Vector.ifoldl' + (\objectIndex objectPosition objectValue -> Map.insert objectValue objectPosition objectIndex) + Map.empty + +objectComponentsFromIndices :: Ord obj => Vector obj -> [NonEmpty Int] -> [NonEmpty obj] +objectComponentsFromIndices objectVector = + List.sortOn NonEmpty.head . mapMaybe (objectComponentFromIndices objectVector) + +objectComponentFromIndices :: Ord obj => Vector obj -> NonEmpty Int -> Maybe (NonEmpty obj) +objectComponentFromIndices objectVector component = + component + & NonEmpty.toList + & mapMaybe (objectVector Vector.!?) + & List.sort + & NonEmpty.nonEmpty + +objectSetFromBits :: Ord obj => Vector obj -> Integer -> Set obj +objectSetFromBits objectVector bits = + bitsToAscList (Vector.length objectVector) bits + & mapMaybe (objectVector Vector.!?) + & Set.fromList + +bitsDifference :: Integer -> Integer -> Integer +bitsDifference leftBits rightBits = + leftBits `withoutBits` rightBits + +intListBits :: [Int] -> Integer +intListBits = + foldr (\objectIndex bits -> bits .|. bit objectIndex) 0 +{-# INLINE intListBits #-} + +bitsToAscList :: Int -> Integer -> [Int] +bitsToAscList objectCount bits + | objectCount <= 0 = [] + | bits < 0 = [0 .. objectCount - 1] + | objectCount <= wordBitCount = + [0 .. objectCount - 1] & filter (testBit bits) + | otherwise = + collect [] bits + where + collect !acc remainingBits + | remainingBits == 0 = List.reverse acc + | objectIndex >= objectCount = List.reverse acc + | otherwise = + collect (objectIndex : acc) (clearLowestSetBit remainingBits) + where + objectIndex = lowestSetBitIndex remainingBits +{-# INLINE bitsToAscList #-} diff --git a/src-finite/Moonlight/Category/Pure/Invertibility.hs b/src-finite/Moonlight/Category/Pure/Invertibility.hs new file mode 100644 --- /dev/null +++ b/src-finite/Moonlight/Category/Pure/Invertibility.hs @@ -0,0 +1,364 @@ +-- | Invertible-morphism structure of a finite category: the core groupoid and +-- per-object automorphism groupoids, with their forgetful maps to the base category. +module Moonlight.Category.Pure.Invertibility + ( InvertibilityIndex, + CoreGroupoid, + CoreGroupoidObject, + CoreGroupoidMorphism, + AutomorphismGroupoid, + AutomorphismGroupoidObject, + AutomorphismGroupoidMorphism, + forgetCoreGroupoidObject, + forgetCoreGroupoidMorphism, + forgetAutomorphismGroupoidObject, + forgetAutomorphismGroupoidMorphism, + invertibilityIndex, + coreGroupoid, + coreGroupoidFromIndex, + coreGroupoidObjects, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + automorphismGroupoid, + automorphismGroupoidFromIndex, + automorphismGroupoidObjects, + automorphismGroupAt, + ) +where + +import Data.Function ((&)) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.FinCat (FinCat) +import Moonlight.Category.Pure.FiniteComposable (FiniteComposableCategory (..)) + +type InvertibilityIndex :: Type -> Type +data InvertibilityIndex c = InvertibilityIndex + { invertibilityByEndpoints :: Map (Ob c, Ob c) (Set (Mor c)), + invertibilityAutomorphisms :: Map (Ob c) (Set (Mor c)) + } + +type CoreGroupoid :: Type -> Type +data CoreGroupoid c = CoreGroupoid + { coreGroupoidBaseCategory :: c, + coreGroupoidObjectSet :: Set (Ob c), + coreGroupoidHomSets :: Map (Ob c, Ob c) (Set (Mor c)) + } + +type CoreGroupoidObject :: Type -> Type +newtype CoreGroupoidObject c = CoreGroupoidObject + { forgetCoreGroupoidObject :: Ob c + } + +type CoreGroupoidMorphism :: Type -> Type +newtype CoreGroupoidMorphism c = CoreGroupoidMorphism + { forgetCoreGroupoidMorphism :: Mor c + } + +type CoreGroupoidTwoMorphism :: Type -> Type +data CoreGroupoidTwoMorphism c + +type CoreGroupoidCompositor :: Type -> Type +newtype CoreGroupoidCompositor c = CoreGroupoidCompositor (Compositor c) + +type AutomorphismGroupoid :: Type -> Type +data AutomorphismGroupoid c = AutomorphismGroupoid + { automorphismGroupoidBaseCategory :: c, + automorphismGroupoidObjectSet :: Set (Ob c), + automorphismGroupoidHomSets :: Map (Ob c) (Set (Mor c)) + } + +type AutomorphismGroupoidObject :: Type -> Type +newtype AutomorphismGroupoidObject c = AutomorphismGroupoidObject + { forgetAutomorphismGroupoidObject :: Ob c + } + +type AutomorphismGroupoidMorphism :: Type -> Type +newtype AutomorphismGroupoidMorphism c = AutomorphismGroupoidMorphism + { forgetAutomorphismGroupoidMorphism :: Mor c + } + +type AutomorphismGroupoidTwoMorphism :: Type -> Type +data AutomorphismGroupoidTwoMorphism c + +type AutomorphismGroupoidCompositor :: Type -> Type +newtype AutomorphismGroupoidCompositor c = AutomorphismGroupoidCompositor (Compositor c) + +instance Eq (Ob c) => Eq (CoreGroupoidObject c) where + CoreGroupoidObject left == CoreGroupoidObject right = left == right + +instance Ord (Ob c) => Ord (CoreGroupoidObject c) where + compare (CoreGroupoidObject left) (CoreGroupoidObject right) = compare left right + +instance Show (Ob c) => Show (CoreGroupoidObject c) where + show (CoreGroupoidObject objectValue) = show objectValue + +instance Eq (Mor c) => Eq (CoreGroupoidMorphism c) where + CoreGroupoidMorphism left == CoreGroupoidMorphism right = left == right + +instance Ord (Mor c) => Ord (CoreGroupoidMorphism c) where + compare (CoreGroupoidMorphism left) (CoreGroupoidMorphism right) = compare left right + +instance Show (Mor c) => Show (CoreGroupoidMorphism c) where + show (CoreGroupoidMorphism morphismValue) = show morphismValue + +instance Eq (Ob c) => Eq (AutomorphismGroupoidObject c) where + AutomorphismGroupoidObject left == AutomorphismGroupoidObject right = left == right + +instance Ord (Ob c) => Ord (AutomorphismGroupoidObject c) where + compare (AutomorphismGroupoidObject left) (AutomorphismGroupoidObject right) = compare left right + +instance Show (Ob c) => Show (AutomorphismGroupoidObject c) where + show (AutomorphismGroupoidObject objectValue) = show objectValue + +instance Eq (Mor c) => Eq (AutomorphismGroupoidMorphism c) where + AutomorphismGroupoidMorphism left == AutomorphismGroupoidMorphism right = left == right + +instance Ord (Mor c) => Ord (AutomorphismGroupoidMorphism c) where + compare (AutomorphismGroupoidMorphism left) (AutomorphismGroupoidMorphism right) = compare left right + +instance Show (Mor c) => Show (AutomorphismGroupoidMorphism c) where + show (AutomorphismGroupoidMorphism morphismValue) = show morphismValue + +instance Category c => Category (CoreGroupoid c) where + type Ob (CoreGroupoid c) = CoreGroupoidObject c + type Mor (CoreGroupoid c) = CoreGroupoidMorphism c + type TwoMor (CoreGroupoid c) = CoreGroupoidTwoMorphism c + type Compositor (CoreGroupoid c) = CoreGroupoidCompositor c + type CategoryError (CoreGroupoid c) = CategoryError c + + identity coreGroupoidValue (CoreGroupoidObject objectValue) = + CoreGroupoidMorphism <$> identity (coreGroupoidBaseCategory coreGroupoidValue) objectValue + + compose coreGroupoidValue (CoreGroupoidMorphism left) (CoreGroupoidMorphism right) = + compose (coreGroupoidBaseCategory coreGroupoidValue) left right + & fmap (\(morphismValue, compositorValue) -> (CoreGroupoidMorphism morphismValue, CoreGroupoidCompositor compositorValue)) + + source coreGroupoidValue (CoreGroupoidMorphism morphismValue) = + CoreGroupoidObject <$> source (coreGroupoidBaseCategory coreGroupoidValue) morphismValue + + target coreGroupoidValue (CoreGroupoidMorphism morphismValue) = + CoreGroupoidObject <$> target (coreGroupoidBaseCategory coreGroupoidValue) morphismValue + +instance (Category c, Eq (Ob c), Ord (Ob c), Ord (Mor c)) => FiniteComposableCategory (CoreGroupoid c) where + enumerateObjects = + coreGroupoidObjects + + enumerateMorphisms = + coreGroupoidMorphisms + + enumerateMorphismsFrom coreGroupoidValue sourceObject = + coreGroupoidValue + & coreGroupoidObjectSet + & Set.toAscList + & foldMap (coreGroupoidMorphismsBetween coreGroupoidValue sourceObject . CoreGroupoidObject) + +instance Category c => Category (AutomorphismGroupoid c) where + type Ob (AutomorphismGroupoid c) = AutomorphismGroupoidObject c + type Mor (AutomorphismGroupoid c) = AutomorphismGroupoidMorphism c + type TwoMor (AutomorphismGroupoid c) = AutomorphismGroupoidTwoMorphism c + type Compositor (AutomorphismGroupoid c) = AutomorphismGroupoidCompositor c + type CategoryError (AutomorphismGroupoid c) = CategoryError c + + identity automorphismGroupoidValue (AutomorphismGroupoidObject objectValue) = + AutomorphismGroupoidMorphism <$> identity (automorphismGroupoidBaseCategory automorphismGroupoidValue) objectValue + + compose automorphismGroupoidValue (AutomorphismGroupoidMorphism left) (AutomorphismGroupoidMorphism right) = + compose (automorphismGroupoidBaseCategory automorphismGroupoidValue) left right + & fmap (\(morphismValue, compositorValue) -> (AutomorphismGroupoidMorphism morphismValue, AutomorphismGroupoidCompositor compositorValue)) + + source automorphismGroupoidValue (AutomorphismGroupoidMorphism morphismValue) = + AutomorphismGroupoidObject <$> source (automorphismGroupoidBaseCategory automorphismGroupoidValue) morphismValue + + target automorphismGroupoidValue (AutomorphismGroupoidMorphism morphismValue) = + AutomorphismGroupoidObject <$> target (automorphismGroupoidBaseCategory automorphismGroupoidValue) morphismValue + +instance (Category c, Eq (Ob c), Ord (Ob c), Ord (Mor c)) => FiniteComposableCategory (AutomorphismGroupoid c) where + enumerateObjects = + automorphismGroupoidObjects + + enumerateMorphisms automorphismGroupoidValue = + automorphismGroupoidValue + & automorphismGroupoidObjectSet + & Set.toAscList + & foldMap (automorphismGroupAt automorphismGroupoidValue . AutomorphismGroupoidObject) + + enumerateMorphismsFrom = + automorphismGroupAt + +isInversePairWithIdentities :: (Category c, Eq (Mor c)) => c -> Mor c -> Mor c -> Mor c -> Mor c -> Bool +isInversePairWithIdentities categoryValue targetIdentity sourceIdentity left right = + case + ( composeMor categoryValue left right, + composeMor categoryValue right left + ) + of + (Right leftThenRight, Right rightThenLeft) -> + leftThenRight == targetIdentity && rightThenLeft == sourceIdentity + _ -> + False +{-# INLINE isInversePairWithIdentities #-} + +endpointMorphismIndex :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Map (Ob c, Ob c) (Set (Mor c)) +endpointMorphismIndex categoryValue = + enumerateMorphisms categoryValue + & List.foldl' insertMorphism Map.empty + where + insertMorphism accumulated morphism = + case (source categoryValue morphism, target categoryValue morphism) of + (Right sourceObject, Right targetObject) -> + Map.insertWith Set.union (sourceObject, targetObject) (Set.singleton morphism) accumulated + _ -> + accumulated + +invertibleBucket :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Map (Ob c, Ob c) (Set (Mor c)) -> + (Ob c, Ob c) -> + Set (Mor c) -> + Set (Mor c) +invertibleBucket categoryValue endpointIndex (sourceObject, targetObject) morphismsInBucket = + let inverseCandidates = + Map.findWithDefault Set.empty (targetObject, sourceObject) endpointIndex + in case (identity categoryValue targetObject, identity categoryValue sourceObject) of + (Right targetIdentity, Right sourceIdentity) -> + morphismsInBucket + & Set.filter + ( \morphism -> + inverseCandidates + & any (isInversePairWithIdentities categoryValue targetIdentity sourceIdentity morphism) + ) + _ -> + Set.empty + +invertibleEndpointIndex :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Map (Ob c, Ob c) (Set (Mor c)) -> + Map (Ob c, Ob c) (Set (Mor c)) +invertibleEndpointIndex categoryValue endpointIndex = + endpointIndex + & Map.foldlWithKey' + ( \accumulated endpoints morphismsInBucket -> + let invertibles = invertibleBucket categoryValue endpointIndex endpoints morphismsInBucket + in if Set.null invertibles + then accumulated + else Map.insert endpoints invertibles accumulated + ) + Map.empty + +automorphismIndex :: + (Ord (Ob c), Ord (Mor c)) => + Map (Ob c, Ob c) (Set (Mor c)) -> + Map (Ob c) (Set (Mor c)) +automorphismIndex invertibleIndex = + invertibleIndex + & Map.foldlWithKey' + ( \accumulated (sourceObject, targetObject) invertibles -> + if sourceObject == targetObject + then Map.insertWith Set.union sourceObject invertibles accumulated + else accumulated + ) + Map.empty + +objectsFromIndex :: Ord (Ob c) => InvertibilityIndex c -> Set (Ob c) +objectsFromIndex invertibilityIndexValue = + let endpointObjects = + invertibilityByEndpoints invertibilityIndexValue + & Map.foldlWithKey' + (\accumulated (sourceObject, targetObject) _ -> Set.insert sourceObject (Set.insert targetObject accumulated)) + Set.empty + in Set.union endpointObjects (Map.keysSet (invertibilityAutomorphisms invertibilityIndexValue)) + +invertibilityIndex :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + InvertibilityIndex c +invertibilityIndex categoryValue = + let endpointIndex = endpointMorphismIndex categoryValue + invertibleIndex = invertibleEndpointIndex categoryValue endpointIndex + in InvertibilityIndex + { invertibilityByEndpoints = invertibleIndex, + invertibilityAutomorphisms = automorphismIndex invertibleIndex + } +{-# SPECIALIZE invertibilityIndex :: FinCat -> InvertibilityIndex FinCat #-} + +coreGroupoidFromIndex :: Ord (Ob c) => c -> InvertibilityIndex c -> CoreGroupoid c +coreGroupoidFromIndex categoryValue invertibilityIndexValue = + CoreGroupoid + { coreGroupoidBaseCategory = categoryValue, + coreGroupoidObjectSet = objectsFromIndex invertibilityIndexValue, + coreGroupoidHomSets = invertibilityByEndpoints invertibilityIndexValue + } + +coreGroupoid :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + CoreGroupoid c +coreGroupoid categoryValue = + coreGroupoidFromIndex categoryValue (invertibilityIndex categoryValue) +{-# SPECIALIZE coreGroupoid :: FinCat -> CoreGroupoid FinCat #-} + +coreGroupoidObjects :: CoreGroupoid c -> [CoreGroupoidObject c] +coreGroupoidObjects coreGroupoidValue = + coreGroupoidObjectSet coreGroupoidValue + & Set.toAscList + & fmap CoreGroupoidObject + +coreGroupoidMorphisms :: CoreGroupoid c -> [CoreGroupoidMorphism c] +coreGroupoidMorphisms coreGroupoidValue = + coreGroupoidHomSets coreGroupoidValue + & Map.elems + & foldMap Set.toAscList + & fmap CoreGroupoidMorphism + +coreGroupoidMorphismsBetween :: + Ord (Ob c) => + CoreGroupoid c -> + CoreGroupoidObject c -> + CoreGroupoidObject c -> + [CoreGroupoidMorphism c] +coreGroupoidMorphismsBetween coreGroupoidValue (CoreGroupoidObject sourceObject) (CoreGroupoidObject targetObject) = + Map.findWithDefault Set.empty (sourceObject, targetObject) (coreGroupoidHomSets coreGroupoidValue) + & Set.toAscList + & fmap CoreGroupoidMorphism + +automorphismGroupoidFromIndex :: Ord (Ob c) => c -> InvertibilityIndex c -> AutomorphismGroupoid c +automorphismGroupoidFromIndex categoryValue invertibilityIndexValue = + AutomorphismGroupoid + { automorphismGroupoidBaseCategory = categoryValue, + automorphismGroupoidObjectSet = objectsFromIndex invertibilityIndexValue, + automorphismGroupoidHomSets = invertibilityAutomorphisms invertibilityIndexValue + } + +automorphismGroupoid :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + AutomorphismGroupoid c +automorphismGroupoid categoryValue = + automorphismGroupoidFromIndex categoryValue (invertibilityIndex categoryValue) +{-# SPECIALIZE automorphismGroupoid :: FinCat -> AutomorphismGroupoid FinCat #-} + +automorphismGroupoidObjects :: AutomorphismGroupoid c -> [AutomorphismGroupoidObject c] +automorphismGroupoidObjects automorphismGroupoidValue = + automorphismGroupoidObjectSet automorphismGroupoidValue + & Set.toAscList + & fmap AutomorphismGroupoidObject + +automorphismGroupAt :: + Ord (Ob c) => + AutomorphismGroupoid c -> + AutomorphismGroupoidObject c -> + [AutomorphismGroupoidMorphism c] +automorphismGroupAt automorphismGroupoidValue (AutomorphismGroupoidObject baseObject) = + Map.findWithDefault Set.empty baseObject (automorphismGroupoidHomSets automorphismGroupoidValue) + & Set.toAscList + & fmap AutomorphismGroupoidMorphism diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Adjunction.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Adjunction.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Adjunction.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, FlexibleContexts, ScopedTypeVariables, RankNTypes, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Adjunction ( + + -- * Adjunctions + Adjunction(..) + , mkAdjunction + , mkAdjunctionUnits + , mkAdjunctionInit + , mkAdjunctionTerm + + , leftAdjunct + , rightAdjunct + , adjunctionUnit + , adjunctionCounit + + -- * Adjunctions as a category + , idAdj + , composeAdj + , AdjArrow(..) + + -- * Examples + , precomposeAdj + , postcomposeAdj + , contAdj + +) where + +import Data.Type.Equality (type (~)) +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor +import Moonlight.Category.Pure.Indexed.Product +import Moonlight.Category.Pure.Indexed.NaturalTransformation + +data Adjunction c d f g = (Functor f, Functor g, Category c, Category d, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) + => Adjunction + { leftAdjoint :: f + , rightAdjoint :: g + , leftAdjunctN :: Profunctors c d (Costar f) (Star g) + , rightAdjunctN :: Profunctors c d (Star g) (Costar f) + } + +-- | Make an adjunction from the hom-set isomorphism. +mkAdjunction :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) + => f -> g + -> (forall a b. Obj d a -> c (f :% a) b -> d a (g :% b)) + -> (forall a b. Obj c b -> d a (g :% b) -> c (f :% a) b) + -> Adjunction c d f g +mkAdjunction f g l r = Adjunction f g (Nat (Costar f) (Star g) (\(Op a :**: _) -> l a)) (Nat (Star g) (Costar f) (\(_ :**: b) -> r b)) + +-- | Make an adjunction from the unit and counit. +mkAdjunctionUnits :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) + => f -> g + -> (forall a. Obj d a -> Component (Id d) (g :.: f) a) + -> (forall a. Obj c a -> Component (f :.: g) (Id c) a) + -> Adjunction c d f g +mkAdjunctionUnits f g un coun = mkAdjunction f g (\a h -> (g % h) . un a) (\b h -> coun b . (f % h)) + +-- | Make an adjunction from an initial universal property. +mkAdjunctionInit :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) + => f -> g + -> (forall a. Obj d a -> d a (g :% (f :% a))) + -> (forall a b. Obj c b -> d a (g :% b) -> c (f :% a) b) + -> Adjunction c d f g +mkAdjunctionInit f g un = mkAdjunction f g (\a h -> (g % h) . un a) + +-- | Make an adjunction from a terminal universal property. +mkAdjunctionTerm :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) + => f -> g + -> (forall a b. Obj d a -> c (f :% a) b -> d a (g :% b)) + -> (forall b. Obj c b -> c (f :% (g :% b)) b) + -> Adjunction c d f g +mkAdjunctionTerm f g adj coun = mkAdjunction f g adj (\b h -> coun b . (f % h)) + +leftAdjunct :: Adjunction c d f g -> Obj d a -> c (f :% a) b -> d a (g :% b) +leftAdjunct (Adjunction _ _ l _) a h = (l ! (Op a :**: tgt h)) h +rightAdjunct :: Adjunction c d f g -> Obj c b -> d a (g :% b) -> c (f :% a) b +rightAdjunct (Adjunction _ _ _ r) b h = (r ! (Op (src h) :**: b)) h + +adjunctionUnit :: Adjunction c d f g -> Nat d d (Id d) (g :.: f) +adjunctionUnit adj@(Adjunction f g _ _) = Nat Id (g :.: f) (\a -> leftAdjunct adj a (f % a)) +adjunctionCounit :: Adjunction c d f g -> Nat c c (f :.: g) (Id c) +adjunctionCounit adj@(Adjunction f g _ _) = Nat (f :.: g) Id (\b -> rightAdjunct adj b (g % b)) + + +idAdj :: Category k => Adjunction k k (Id k) (Id k) +idAdj = mkAdjunction Id Id (\_ f -> f) (\_ f -> f) + +composeAdj :: Adjunction d e f g -> Adjunction c d f' g' -> Adjunction c e (f' :.: f) (g :.: g') +composeAdj l@(Adjunction f g _ _) r@(Adjunction f' g' _ _) = mkAdjunction (f' :.: f) (g :.: g') + (\a -> leftAdjunct l a . leftAdjunct r (f % a)) (\b -> rightAdjunct r b . rightAdjunct l (g' % b)) + + +data AdjArrow c d where + AdjArrow :: (Category c, Category d) => Adjunction c d f g -> AdjArrow c d + +-- | The category with categories as objects and adjunctions as arrows. +instance Category AdjArrow where + + src (AdjArrow Adjunction{}) = AdjArrow idAdj + tgt (AdjArrow Adjunction{}) = AdjArrow idAdj + + AdjArrow x . AdjArrow y = AdjArrow (composeAdj x y) + + + +precomposeAdj :: Category e => Adjunction c d f g -> Adjunction (Nat c e) (Nat d e) (Precompose g e) (Precompose f e) +precomposeAdj adj@(Adjunction f g _ _) = mkAdjunctionUnits + (Precompose g) + (Precompose f) + (\nh@(Nat h _ _) -> compAssocInv h g f . (nh `o` adjunctionUnit adj) . idPrecompInv h) + (\nh@(Nat h _ _) -> idPrecomp h . (nh `o` adjunctionCounit adj) . compAssoc h f g) + +postcomposeAdj :: Category e => Adjunction c d f g -> Adjunction (Nat e c) (Nat e d) (Postcompose f e) (Postcompose g e) +postcomposeAdj adj@(Adjunction f g _ _) = mkAdjunctionUnits + (Postcompose f) + (Postcompose g) + (\nh@(Nat h _ _) -> compAssoc g f h . (adjunctionUnit adj `o` nh) . idPostcompInv h) + (\nh@(Nat h _ _) -> idPostcomp h . (adjunctionCounit adj `o` nh) . compAssocInv f g h) + +contAdj :: Adjunction (Op (->)) (->) (Opposite ((->) :-*: r) :.: OpOpInv (->)) ((->) :-*: r) +contAdj = mkAdjunction + (Opposite (Hom_X obj) :.: OpOpInv) + (Hom_X obj) + (\_ -> \(Op f) -> \b a -> f a b) + (\_ -> \f -> Op (\b a -> f a b)) diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Category.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Category.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Category.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TypeFamilies, GADTs, RankNTypes, PolyKinds, LinearTypes, FlexibleInstances, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Category ( + + -- * Category + Category(..) + , Obj + , Kind + + -- * Opposite category + , Op(..) + + -- * Haskell function category + , obj + +) where + +import GHC.Exts +import Data.Kind (Type) + +infixr 8 . + +-- | Whenever objects are required at value level, they are represented by their identity arrows. +type Obj k a = k a a + +-- | An instance of @Category k@ declares the arrow @k@ as a category. +class Category k where + + src :: k a b -> Obj k a + tgt :: k a b -> Obj k b + + (.) :: k b c -> k a b -> k a c + + +obj :: Obj (FUN m) a +obj x = x + +-- | For @m ~ Many@: The category with Haskell types as objects and ordinary functions as arrows. +-- For @m ~ One@: The category with Haskell types as objects and Haskell linear functions as arrows, i.e. @(%1->)@. +instance Category (FUN m) where + + src _ = obj + tgt _ = obj + + f . g = \x -> f (g x) + + +newtype Op k a b = Op { unOp :: k b a } + +-- | @Op k@ is opposite category of the category @k@. +instance Category k => Category (Op k) where + + src (Op a) = Op (tgt a) + tgt (Op a) = Op (src a) + + (Op a) . (Op b) = Op (b . a) + + +-- | @Kind k@ is the kind of the objects of the category @k@. +type family Kind (k :: o -> o -> Type) :: Type where + Kind (k :: o -> o -> Type) = o diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Coproduct.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Coproduct.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Coproduct.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances, GADTs, FlexibleContexts, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Coproduct where + +import Data.Kind (Type) +import Data.Type.Equality (type (~)) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor + +import Moonlight.Category.Pure.Indexed.NaturalTransformation +import Moonlight.Category.Pure.Indexed.Product +import Moonlight.Category.Pure.Indexed.Unit + + +data I1 a +data I2 a + +data (:++:) :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where + I1 :: c1 a1 b1 -> (:++:) c1 c2 (I1 a1) (I1 b1) + I2 :: c2 a2 b2 -> (:++:) c1 c2 (I2 a2) (I2 b2) + +-- | The coproduct category of categories @c1@ and @c2@. +instance (Category c1, Category c2) => Category (c1 :++: c2) where + + src (I1 a) = I1 (src a) + src (I2 a) = I2 (src a) + tgt (I1 a) = I1 (tgt a) + tgt (I2 a) = I2 (tgt a) + + (I1 a) . (I1 b) = I1 (a . b) + (I2 a) . (I2 b) = I2 (a . b) + + + + +data Inj1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Inj1 +-- | t'Inj1' is a functor which injects into the left category. +instance (Category c1, Category c2) => Functor (Inj1 c1 c2) where + type Dom (Inj1 c1 c2) = c1 + type Cod (Inj1 c1 c2) = c1 :++: c2 + type Inj1 c1 c2 :% a = I1 a + Inj1 % f = I1 f + +data Inj2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Inj2 +-- | t'Inj2' is a functor which injects into the right category. +instance (Category c1, Category c2) => Functor (Inj2 c1 c2) where + type Dom (Inj2 c1 c2) = c2 + type Cod (Inj2 c1 c2) = c1 :++: c2 + type Inj2 c1 c2 :% a = I2 a + Inj2 % f = I2 f + +data f1 :+++: f2 = f1 :+++: f2 +-- | @f1 :+++: f2@ is the coproduct of the functors @f1@ and @f2@. +instance (Functor f1, Functor f2) => Functor (f1 :+++: f2) where + type Dom (f1 :+++: f2) = Dom f1 :++: Dom f2 + type Cod (f1 :+++: f2) = Cod f1 :++: Cod f2 + type (f1 :+++: f2) :% (I1 a) = I1 (f1 :% a) + type (f1 :+++: f2) :% (I2 a) = I2 (f2 :% a) + (g :+++: _) % I1 f = I1 (g % f) + (_ :+++: g) % I2 f = I2 (g % f) + +data CodiagCoprod (k :: Type -> Type -> Type) = CodiagCoprod +-- | t'CodiagCoprod' is the codiagonal functor for coproducts. +instance Category k => Functor (CodiagCoprod k) where + type Dom (CodiagCoprod k) = k :++: k + type Cod (CodiagCoprod k) = k + type CodiagCoprod k :% I1 a = a + type CodiagCoprod k :% I2 a = a + CodiagCoprod % I1 f = f + CodiagCoprod % I2 f = f + +newtype Cotuple1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) a = Cotuple1 (Obj c1 a) +-- | t'Cotuple1' projects out to the left category, replacing a value from the right category with a fixed object. +instance (Category c1, Category c2) => Functor (Cotuple1 c1 c2 a1) where + type Dom (Cotuple1 c1 c2 a1) = c1 :++: c2 + type Cod (Cotuple1 c1 c2 a1) = c1 + type Cotuple1 c1 c2 a1 :% I1 a = a + type Cotuple1 c1 c2 a1 :% I2 a = a1 + Cotuple1 _ % I1 f = f + Cotuple1 a % I2 _ = a + +newtype Cotuple2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) a = Cotuple2 (Obj c2 a) +-- | t'Cotuple2' projects out to the right category, replacing a value from the left category with a fixed object. +instance (Category c1, Category c2) => Functor (Cotuple2 c1 c2 a2) where + type Dom (Cotuple2 c1 c2 a2) = c1 :++: c2 + type Cod (Cotuple2 c1 c2 a2) = c2 + type Cotuple2 c1 c2 a2 :% I1 a = a2 + type Cotuple2 c1 c2 a2 :% I2 a = a + Cotuple2 a % I1 _ = a + Cotuple2 _ % I2 f = f + + +data Cograph c d f :: Type -> Type -> Type where + I1A :: c a1 b1 -> Cograph c d f (I1 a1) (I1 b1) + I2A :: d a2 b2 -> Cograph c d f (I2 a2) (I2 b2) + I12 :: Obj c a -> Obj d b -> f -> f :% (a, b) -> Cograph c d f (I1 a) (I2 b) + +-- | The cograph of the profunctor @f@. +instance ProfunctorOf c d f => Category (Cograph c d f) where + + src (I1A a) = I1A (src a) + src (I2A a) = I2A (src a) + src (I12 a _ _ _) = I1A a + tgt (I1A a) = I1A (tgt a) + tgt (I2A a) = I2A (tgt a) + tgt (I12 _ b _ _) = I2A b + + (I1A a) . (I1A b) = I1A (a . b) + (I12 _ b f ab) . (I1A a) = I12 (src a) b f ((f % (Op a :**: b)) ab) + (I2A b) . (I12 a _ f ab) = I12 a (tgt b) f ((f % (Op a :**: b)) ab) + (I2A a) . (I2A b) = I2A (a . b) + +-- | The directed coproduct category of categories @c1@ and @c2@. +newtype (c1 :>>: c2) a b = DC (Cograph c1 c2 (Const (Op c1 :**: c2) (->) ()) a b) deriving newtype Category + + +newtype NatAsFunctor f g = NatAsFunctor (Nat (Dom f) (Cod f) f g) + +-- | A natural transformation @Nat c d@ is isomorphic to a functor from @c :**: 2@ to @d@. +instance (Functor f, Functor g, Dom f ~ Dom g, Cod f ~ Cod g) => Functor (NatAsFunctor f g) where + + type Dom (NatAsFunctor f g) = Dom f :**: Cograph Unit Unit (Hom Unit) + type Cod (NatAsFunctor f g) = Cod f + type NatAsFunctor f g :% (a, I1 ()) = f :% a + type NatAsFunctor f g :% (a, I2 ()) = g :% a + + NatAsFunctor (Nat f _ _) % (a :**: I1A Unit) = f % a + NatAsFunctor (Nat _ g _) % (a :**: I2A Unit) = g % a + NatAsFunctor n % (a :**: I12 Unit Unit Hom Unit) = n ! a diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Functor.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Functor.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Functor.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE + GADTs + , PolyKinds + , RankNTypes + , ConstraintKinds + , NoImplicitPrelude + , TypeOperators + , TypeFamilies + , PatternSynonyms + , FlexibleContexts + , FlexibleInstances + , UndecidableInstances + , DerivingStrategies + , GeneralizedNewtypeDeriving + #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Functor ( + + -- * Cat + Cat(..) + + -- * Functors + , Functor(..) + , FunctorOf + + -- ** Functor instances + , Id(..) + , (:.:)(..) + , Const(..), ConstF + , OpOp(..) + , OpOpInv(..) + , Any(..) + + -- *** Related to the product category + , Proj1(..) + , Proj2(..) + , (:***:)(..) + , DiagProd(..) + , Tuple1, data Tuple1 + , Tuple2, data Tuple2 + , Swap, data Swap + + -- *** Hom functors + , Hom(..) + , (:*-:), data HomX_ + , (:-*:), data Hom_X + + -- *** Profunctors + , ProfunctorOf + +) where + +import Data.Kind (Type) +import Data.Type.Equality (type (~)) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Product + +infixr 9 % +infixr 9 :% + + + +-- | Functors map objects and arrows. +class (Category (Dom ftag), Category (Cod ftag)) => Functor ftag where + + -- | The domain, or source category, of the functor. + type Dom ftag :: Type -> Type -> Type + -- | The codomain, or target category, of the functor. + type Cod ftag :: Type -> Type -> Type + + -- | @:%@ maps objects. + type ftag :% a :: Type + + -- | @%@ maps arrows. + (%) :: ftag -> Dom ftag a b -> Cod ftag (ftag :% a) (ftag :% b) + +type FunctorOf a b t = (Functor t, Dom t ~ a, Cod t ~ b) + + +-- | Functors are arrows in the category Cat. +data Cat :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type where + CatA :: (Functor ftag, Category (Dom ftag), Category (Cod ftag)) => ftag -> Cat (Dom ftag) (Cod ftag) + + +-- | @Cat@ is the category with categories as objects and funtors as arrows. +instance Category Cat where + + src (CatA _) = CatA Id + tgt (CatA _) = CatA Id + + CatA f1 . CatA f2 = CatA (f1 :.: f2) + + + +data Id (k :: Type -> Type -> Type) = Id + +-- | The identity functor on k +instance Category k => Functor (Id k) where + type Dom (Id k) = k + type Cod (Id k) = k + type Id k :% a = a + + _ % f = f + + +data (g :.: h) where + (:.:) :: (Functor g, Functor h, Cod h ~ Dom g) => g -> h -> g :.: h + +-- | The composition of two functors. +instance (Category (Cod g), Category (Dom h)) => Functor (g :.: h) where + type Dom (g :.: h) = Dom h + type Cod (g :.: h) = Cod g + type (g :.: h) :% a = g :% (h :% a) + + (g :.: h) % f = g % (h % f) + + + +data Const (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) x where + Const :: Obj c2 x -> Const c1 c2 x + +-- | The constant functor. +instance (Category c1, Category c2) => Functor (Const c1 c2 x) where + type Dom (Const c1 c2 x) = c1 + type Cod (Const c1 c2 x) = c2 + type Const c1 c2 x :% a = x + + Const x % _ = x + +-- | The constant functor with the same domain and codomain as f. +type ConstF f = Const (Dom f) (Cod f) + + + +data OpOp (k :: Type -> Type -> Type) = OpOp + +-- | The @Op (Op x) = x@ functor. +instance Category k => Functor (OpOp k) where + type Dom (OpOp k) = Op (Op k) + type Cod (OpOp k) = k + type OpOp k :% a = a + + OpOp % Op (Op f) = f + + +data OpOpInv (k :: Type -> Type -> Type) = OpOpInv + +-- | The @x = Op (Op x)@ functor. +instance Category k => Functor (OpOpInv k) where + type Dom (OpOpInv k) = k + type Cod (OpOpInv k) = Op (Op k) + type OpOpInv k :% a = a + + OpOpInv % f = Op (Op f) + + +-- | A functor wrapper in case of conflicting family instance declarations +newtype Any f = Any f deriving newtype Functor + + +data Proj1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Proj1 + +-- | t'Proj1' is a bifunctor that projects out the first component of a product. +instance (Category c1, Category c2) => Functor (Proj1 c1 c2) where + type Dom (Proj1 c1 c2) = c1 :**: c2 + type Cod (Proj1 c1 c2) = c1 + type Proj1 c1 c2 :% (a1, a2) = a1 + + Proj1 % (f1 :**: _) = f1 + + +data Proj2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Proj2 + +-- | t'Proj2' is a bifunctor that projects out the second component of a product. +instance (Category c1, Category c2) => Functor (Proj2 c1 c2) where + type Dom (Proj2 c1 c2) = c1 :**: c2 + type Cod (Proj2 c1 c2) = c2 + type Proj2 c1 c2 :% (a1, a2) = a2 + + Proj2 % (_ :**: f2) = f2 + + +data f1 :***: f2 where (:***:) :: (Functor f1, Functor f2) => f1 -> f2 -> f1 :***: f2 + +-- | @f1 :***: f2@ is the product of the functors @f1@ and @f2@. +instance (Functor f1, Functor f2) => Functor (f1 :***: f2) where + type Dom (f1 :***: f2) = Dom f1 :**: Dom f2 + type Cod (f1 :***: f2) = Cod f1 :**: Cod f2 + type (f1 :***: f2) :% (a1, a2) = (f1 :% a1, f2 :% a2) + + (g1 :***: g2) % (f1 :**: f2) = (g1 % f1) :**: (g2 % f2) + + +data DiagProd (k :: Type -> Type -> Type) = DiagProd + +-- | t'DiagProd' is the diagonal functor for products. +instance Category k => Functor (DiagProd k) where + type Dom (DiagProd k) = k + type Cod (DiagProd k) = k :**: k + type DiagProd k :% a = (a, a) + + DiagProd % f = f :**: f + + +type Tuple1 c1 c2 a = (Const c2 c1 a :***: Id c2) :.: DiagProd c2 +-- | t'Tuple1' tuples with a fixed object on the left. +pattern Tuple1 :: (Category c1, Category c2) => Obj c1 a -> Tuple1 c1 c2 a +pattern Tuple1 a = (Const a :***: Id) :.: DiagProd + +type Swap (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = (Proj2 c1 c2 :***: Proj1 c1 c2) :.: DiagProd (c1 :**: c2) +-- | Swaps the two categories of a product category. +pattern Swap :: (Category c1, Category c2) => Swap c1 c2 +pattern Swap = (Proj2 :***: Proj1) :.: DiagProd + +type Tuple2 c1 c2 a = Swap c2 c1 :.: Tuple1 c2 c1 a +-- | t'Tuple2' tuples with a fixed object on the right. +pattern Tuple2 :: (Category c1, Category c2) => Obj c2 a -> Tuple2 c1 c2 a +pattern Tuple2 a = Swap :.: Tuple1 a + + + +data Hom (k :: Type -> Type -> Type) = Hom + +-- | The Hom functor, Hom(--,--), a bifunctor contravariant in its first argument and covariant in its second argument. +instance Category k => Functor (Hom k) where + type Dom (Hom k) = Op k :**: k + type Cod (Hom k) = (->) + type (Hom k) :% (a1, a2) = k a1 a2 + + Hom % (Op f1 :**: f2) = \g -> f2 . g . f1 + + +type x :*-: k = Hom k :.: Tuple1 (Op k) k x +-- | The covariant functor Hom(X,--) +pattern HomX_ :: Category k => Obj k x -> x :*-: k +pattern HomX_ x = Hom :.: Tuple1 (Op x) + +type k :-*: x = Hom k :.: Tuple2 (Op k) k x +-- | The contravariant functor Hom(--,X) +pattern Hom_X :: Category k => Obj k x -> k :-*: x +pattern Hom_X x = Hom :.: Tuple2 x + + +type ProfunctorOf c d t = (FunctorOf (Op c :**: d) (->) t, Category c, Category d) diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/KanExtension.hs b/src-indexed/Moonlight/Category/Pure/Indexed/KanExtension.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/KanExtension.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE + FlexibleInstances + , GADTs + , MultiParamTypeClasses + , RankNTypes + , TypeOperators + , TypeFamilies + , UndecidableInstances + , NoImplicitPrelude + #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.KanExtension where + +import Data.Kind (Type) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor +import Moonlight.Category.Pure.Indexed.NaturalTransformation +import Moonlight.Category.Pure.Indexed.Adjunction +import Moonlight.Category.Pure.Indexed.Limit +import Moonlight.Category.Pure.Indexed.Unit + + +-- | An instance of @HasRightKan p k@ says there are right Kan extensions for all functors with codomain @k@. +class (Functor p, Category k) => HasRightKan p k where + -- | The right Kan extension of a functor @p@ for functors @f@ with codomain @k@. + type RanFam p k (f :: Type) :: Type + -- | 'ran' gives the defining natural transformation of the right Kan extension of @f@ along @p@. + ran :: p -> Obj (Nat (Dom p) k) f -> Nat (Dom p) k (RanFam p k f :.: p) f + -- | 'ranFactorizer' shows that this extension is universal. + ranFactorizer :: Nat (Dom p) k (h :.: p) f -> Nat (Cod p) k h (RanFam p k f) + +type Ran p f = RanFam p (Cod f) f + +ranF :: HasRightKan p k => p -> Obj (Nat (Dom p) k) f -> Obj (Nat (Cod p) k) (RanFam p k f) +ranF p f = ranF' (ran p f) + +ranF' :: Nat (Dom p) k (RanFam p k f :.: p) f -> Obj (Nat (Cod p) k) (RanFam p k f) +ranF' (Nat (r :.: _) _ _) = natId r + +newtype RanFunctor (p :: Type) (k :: Type -> Type -> Type) = RanFunctor p +instance HasRightKan p k => Functor (RanFunctor p k) where + type Dom (RanFunctor p k) = Nat (Dom p) k + type Cod (RanFunctor p k) = Nat (Cod p) k + type RanFunctor p k :% f = RanFam p k f + + RanFunctor p % n = ranFactorizer (n . ran p (src n)) + +-- | The right Kan extension along @p@ is right adjoint to precomposition with @p@. +ranAdj :: forall p k. HasRightKan p k => p -> Adjunction (Nat (Dom p) k) (Nat (Cod p) k) (Precompose p k) (RanFunctor p k) +ranAdj p = mkAdjunctionTerm (Precompose p) (RanFunctor p) (\_ -> ranFactorizer) (ran p) + + +-- | An instance of @HasLeftKan p k@ says there are left Kan extensions for all functors with codomain @k@. +class (Functor p, Category k) => HasLeftKan p k where + -- | The left Kan extension of a functor @p@ for functors @f@ with codomain @k@. + type LanFam (p :: Type) (k :: Type -> Type -> Type) (f :: Type) :: Type + -- | 'lan' gives the defining natural transformation of the left Kan extension of @f@ along @p@. + lan :: p -> Obj (Nat (Dom p) k) f -> Nat (Dom p) k f (LanFam p k f :.: p) + -- | 'lanFactorizer' shows that this extension is universal. + lanFactorizer :: Nat (Dom p) k f (h :.: p) -> Nat (Cod p) k (LanFam p k f) h + +type Lan p f = LanFam p (Cod f) f + +lanF :: HasLeftKan p k => p -> Obj (Nat (Dom p) k) f -> Obj (Nat (Cod p) k) (LanFam p k f) +lanF p f = lanF' (lan p f) + +lanF' :: Nat (Dom p) k f (LanFam p k f :.: p) -> Obj (Nat (Cod p) k) (LanFam p k f) +lanF' (Nat _ (r :.: _) _) = natId r + +newtype LanFunctor (p :: Type) (k :: Type -> Type -> Type) = LanFunctor p +instance HasLeftKan p k => Functor (LanFunctor p k) where + type Dom (LanFunctor p k) = Nat (Dom p) k + type Cod (LanFunctor p k) = Nat (Cod p) k + type LanFunctor p k :% f = LanFam p k f + + LanFunctor p % n = lanFactorizer (lan p (tgt n) . n) + +-- | The left Kan extension along @p@ is left adjoint to precomposition with @p@. +lanAdj :: forall p k. HasLeftKan p k => p -> Adjunction (Nat (Cod p) k) (Nat (Dom p) k) (LanFunctor p k) (Precompose p k) +lanAdj p = mkAdjunctionInit (LanFunctor p) (Precompose p) (lan p) (\_ -> lanFactorizer) + + +-- | The right Kan extension of @f@ along a functor to the unit category is the limit of @f@. +instance HasLimits j k => HasRightKan (Const j Unit ()) k where + type RanFam (Const j Unit ()) k f = Const Unit k (LimitFam j k f) + ran p f@Nat{} = let cone = limit f in Nat (Const (coneVertex cone) :.: p) (srcF f) (cone !) + ranFactorizer n@(Nat (h :.: _) _ _) = let fact = limitFactorizer (constPrecompIn n) in Nat h (Const (tgt fact)) (\Unit -> fact) + +-- | The left Kan extension of @f@ along a functor to the unit category is the colimit of @f@. +instance HasColimits j k => HasLeftKan (Const j Unit ()) k where + type LanFam (Const j Unit ()) k f = Const Unit k (ColimitFam j k f) + lan p f@Nat{} = let cocone = colimit f in Nat (srcF f) (Const (coconeVertex cocone) :.: p) (cocone !) + lanFactorizer n@(Nat _ (h :.: _) _) = let fact = colimitFactorizer (constPrecompOut n) in Nat (Const (src fact)) h (\Unit -> fact) + + +-- | Ran id = id +instance (Category j, Category k) => HasRightKan (Id j) k where + type RanFam (Id j) k f = f + ran Id (Nat f _ _) = idPrecomp f + ranFactorizer n@(Nat (h :.: Id) _ _) = n . idPrecompInv h + +-- | Lan id = id +instance (Category j, Category k) => HasLeftKan (Id j) k where + type LanFam (Id j) k f = f + lan Id (Nat f _ _) = idPrecompInv f + lanFactorizer n@(Nat _ (h :.: Id) _) = idPrecomp h . n + + +-- | Ran (q . p) = Ran q . Ran p +instance (HasRightKan q k, HasRightKan p k) => HasRightKan (q :.: p) k where + type RanFam (q :.: p) k f = RanFam q k (RanFam p k f) + ran (q :.: p) f = let ranp = ran p f in case ran q (ranF' ranp) of + ranq@(Nat (r :.: _) _ _) -> ranp . (ranq `o` natId p) . compAssocInv r q p + ranFactorizer n@(Nat (h :.: (q :.: p)) _ _) = ranFactorizer (ranFactorizer (n . compAssoc h q p)) + +-- | Lan (q . p) = Lan q . Lan p +instance (HasLeftKan q k, HasLeftKan p k) => HasLeftKan (q :.: p) k where + type LanFam (q :.: p) k f = LanFam q k (LanFam p k f) + lan (q :.: p) f = let lanp = lan p f in case lan q (lanF' lanp) of + lanq@(Nat _ (l :.: _) _) -> compAssoc l q p . (lanq `o` natId p) . lanp + lanFactorizer n@(Nat _ (h :.: (q :.: p)) _) = lanFactorizer (lanFactorizer (compAssocInv h q p . n)) + + +newtype RanHask p (f :: Type) a = RanHask (forall c. Obj (Dom p) c -> Cod p a (p :% c) -> f :% c) +data RanHaskF p (f :: Type) = RanHaskF +instance Functor p => Functor (RanHaskF p f) where + type Dom (RanHaskF p f) = Cod p + type Cod (RanHaskF p f) = (->) + type RanHaskF p f :% a = RanHask p f a + RanHaskF % ab = \(RanHask r) -> RanHask (\c bpc -> r c (bpc . ab)) + +instance Functor p => HasRightKan (Any p) (->) where + type RanFam (Any p) (->) f = RanHaskF p f + ran (Any p) (Nat f _ _) = Nat (RanHaskF :.: Any p) f (\z (RanHask r) -> r z (p % z)) + ranFactorizer (Nat (h :.: _) _ n) = Nat h RanHaskF (\_ hz -> RanHask (\c zpc -> n c ((h % zpc) hz))) + +data LanHask p (f :: Type) a where + LanHask :: Obj (Dom p) c -> Cod p (p :% c) a -> f :% c -> LanHask p f a +data LanHaskF p (f :: Type) = LanHaskF +instance Functor p => Functor (LanHaskF p f) where + type Dom (LanHaskF p f) = Cod p + type Cod (LanHaskF p f) = (->) + type LanHaskF p f :% a = LanHask p f a + LanHaskF % ab = \(LanHask c pca fc) -> LanHask c (ab . pca) fc + +instance Functor p => HasLeftKan (Any p) (->) where + type LanFam (Any p) (->) f = LanHaskF p f + lan (Any p) (Nat f _ _) = Nat f (LanHaskF :.: Any p) (\z fz -> LanHask z (p % z) fz) + lanFactorizer (Nat _ (h :.: _) n) = Nat LanHaskF h (\_ (LanHask c pcz fc) -> (h % pcz) (n c fc)) diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Limit.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Limit.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Limit.hs @@ -0,0 +1,742 @@ +{-# LANGUAGE + FlexibleContexts, + FlexibleInstances, + GADTs, + PolyKinds, + DataKinds, + LinearTypes, + LambdaCase, + EmptyCase, + BlockArguments, + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + TypeOperators, + TypeFamilies, + TypeSynonymInstances, + UndecidableInstances, + NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Limit ( + + -- * Preliminairies + + -- ** Diagonal Functor + Diag(..) + , DiagF + + -- ** Cones + , Cone + , Cocone + , coneVertex + , coconeVertex + + -- * Limits + , HasLimits(..) + , Limit + , LimitFunctor(..) + , limitAdj + , adjLimit + , adjLimitFactorizer + , rightAdjointPreservesLimits + , rightAdjointPreservesLimitsInv + + -- * Colimits + , HasColimits(..) + , Colimit + , ColimitFunctor(..) + , colimitAdj + , adjColimit + , adjColimitFactorizer + , leftAdjointPreservesColimits + , leftAdjointPreservesColimitsInv + + -- * Limits of type Void + , HasTerminalObject(..) + , HasInitialObject(..) + , Zero + + -- * Limits of type Pair + , HasBinaryProducts(..) + , ProductFunctor(..) + , (:*:)(..) + , prodAdj + , type (&)(..) + , HasBinaryCoproducts(..) + , CoproductFunctor(..) + , (:+:)(..) + , coprodAdj + , Either(..) + +) where + +import Data.Kind (Type) +import Data.Type.Equality (type (~)) +import GHC.Exts (FUN, Multiplicity (One)) +import Prelude (Either(..), fst, snd) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor +import Moonlight.Category.Pure.Indexed.NaturalTransformation +import Moonlight.Category.Pure.Indexed.Adjunction + +import Moonlight.Category.Pure.Indexed.Product +import Moonlight.Category.Pure.Indexed.Coproduct +import Moonlight.Category.Pure.Indexed.Unit +import Moonlight.Category.Pure.Indexed.Void + +infixl 3 *** +infixl 3 &&& +infixl 2 +++ +infixl 2 ||| + + +data Diag :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type where + Diag :: Diag j k + +-- | The diagonal functor from (index-) category J to k. +instance (Category j, Category k) => Functor (Diag j k) where + type Dom (Diag j k) = k + type Cod (Diag j k) = Nat j k + type Diag j k :% a = Const j k a + + Diag % f = Nat (Const (src f)) (Const (tgt f)) (\_ -> f) + +-- | The diagonal functor with the same domain and codomain as @f@. +type DiagF f = Diag (Dom f) (Cod f) + + + +-- | A cone from N to F is a natural transformation from the constant functor to N to F. +type Cone j k f n = Nat j k (Const j k n) f + +-- | A co-cone from F to N is a natural transformation from F to the constant functor to N. +type Cocone j k f n = Nat j k f (Const j k n) + + +-- | The vertex (or apex) of a cone. +coneVertex :: Cone j k f n -> Obj k n +coneVertex (Nat (Const x) _ _) = x + +-- | The vertex (or apex) of a co-cone. +coconeVertex :: Cocone j k f n -> Obj k n +coconeVertex (Nat _ (Const x) _) = x + + +-- | An instance of @HasLimits j k@ says that @k@ has all limits of type @j@. +class (Category j, Category k) => HasLimits j k where + -- | Limits in a category @k@ by means of a diagram of type @j@, which is a functor from @j@ to @k@. + type LimitFam (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) (f :: Type) :: Type + -- | 'limit' returns the limiting cone for a functor @f@. + limit :: Obj (Nat j k) f -> Cone j k f (LimitFam j k f) + -- | 'limitFactorizer' shows that the limiting cone is universal – i.e. any other cone of @f@ factors through it + -- by returning the morphism between the vertices of the cones. + limitFactorizer :: Cone j k f n -> k n (LimitFam j k f) + +type Limit f = LimitFam (Dom f) (Cod f) f + +data LimitFunctor (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) = LimitFunctor +-- | If every diagram of type @j@ has a limit in @k@ there exists a limit functor. +-- It can be seen as a generalisation of @(***)@. +instance HasLimits j k => Functor (LimitFunctor j k) where + type Dom (LimitFunctor j k) = Nat j k + type Cod (LimitFunctor j k) = k + type LimitFunctor j k :% f = LimitFam j k f + + LimitFunctor % n = limitFactorizer (n . limit (src n)) + +-- | The limit functor is right adjoint to the diagonal functor. +limitAdj :: forall j k. HasLimits j k => Adjunction (Nat j k) k (Diag j k) (LimitFunctor j k) +limitAdj = mkAdjunctionTerm Diag LimitFunctor (\_ -> limitFactorizer) limit + +adjLimit :: Category k => Adjunction (Nat j k) k (Diag j k) r -> Obj (Nat j k) f -> Cone j k f (r :% f) +adjLimit adj f = adjunctionCounit adj ! f + +adjLimitFactorizer :: Adjunction (Nat j k) k (Diag j k) r -> Cone j k f n -> k n (r :% f) +adjLimitFactorizer adj cone = leftAdjunct adj (coneVertex cone) cone + + +-- Cone (g :.: t) (Limit (g :.: t)) +-- Obj j z -> d (Limit (g :.: t)) ((g :.: t) :% z) +-- Obj j z -> d (f :% Limit (g :.: t)) (t :% z) +-- Cone t (f :% Limit (g :.: t)) +-- d (f :% Limit (g :.: t)) (Limit t) +-- d (Limit (g :.: t)) (g :% Limit t) +rightAdjointPreservesLimits + :: (HasLimits j c, HasLimits j d) + => Adjunction c d f g -> Obj (Nat j c) t -> d (Limit (g :.: t)) (g :% Limit t) +rightAdjointPreservesLimits adj@(Adjunction f g _ _) (Nat t _ _) = + leftAdjunct adj x (limitFactorizer cone) + where + l = limit (natId (g :.: t)) + x = coneVertex l + -- cone :: Cone t (f :% Limit (g :.: t)) + cone = Nat (Const (f % x)) t (\z -> rightAdjunct adj (t % z) (l ! z)) + +-- Cone t (Limit t) +-- Cone (g :.: t) (g :% Limit t) +-- d (g :% Limit t) (Limit (g :.: t)) +rightAdjointPreservesLimitsInv + :: (HasLimits j c, HasLimits j d) + => Obj (Nat c d) g -> Obj (Nat j c) t -> d (g :% LimitFam j c t) (LimitFam j d (g :.: t)) +rightAdjointPreservesLimitsInv g t = limitFactorizer (constPrecompIn (g `o` limit t)) + + +-- | An instance of @HasColimits j k@ says that @k@ has all colimits of type @j@. +class (Category j, Category k) => HasColimits j k where + -- | Colimits in a category @k@ by means of a diagram of type @j@, which is a functor from @j@ to @k@. + type ColimitFam (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) (f :: Type) :: Type + -- | 'colimit' returns the limiting co-cone for a functor @f@. + colimit :: Obj (Nat j k) f -> Cocone j k f (ColimitFam j k f) + -- | 'colimitFactorizer' shows that the limiting co-cone is universal – i.e. any other co-cone of @f@ factors through it + -- by returning the morphism between the vertices of the cones. + colimitFactorizer :: Cocone j k f n -> k (ColimitFam j k f) n + +type Colimit f = ColimitFam (Dom f) (Cod f) f + +data ColimitFunctor (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) = ColimitFunctor +-- | If every diagram of type @j@ has a colimit in @k@ there exists a colimit functor. +-- It can be seen as a generalisation of @(+++)@. +instance HasColimits j k => Functor (ColimitFunctor j k) where + type Dom (ColimitFunctor j k) = Nat j k + type Cod (ColimitFunctor j k) = k + type ColimitFunctor j k :% f = ColimitFam j k f + + ColimitFunctor % n = colimitFactorizer (colimit (tgt n) . n) + +-- | The colimit functor is left adjoint to the diagonal functor. +colimitAdj :: forall j k. HasColimits j k => Adjunction k (Nat j k) (ColimitFunctor j k) (Diag j k) +colimitAdj = mkAdjunctionInit ColimitFunctor Diag colimit (\_ -> colimitFactorizer) + +adjColimit :: Category k => Adjunction k (Nat j k) l (Diag j k) -> Obj (Nat j k) f -> Cocone j k f (l :% f) +adjColimit adj f = adjunctionUnit adj ! f + +adjColimitFactorizer :: Adjunction k (Nat j k) l (Diag j k) -> Cocone j k f n -> k (l :% f) n +adjColimitFactorizer adj cocone = rightAdjunct adj (coconeVertex cocone) cocone + + +leftAdjointPreservesColimits + :: (HasColimits j c, HasColimits j d) + => Adjunction c d f g -> Obj (Nat j d) t -> c (f :% Colimit t) (Colimit (f :.: t)) +leftAdjointPreservesColimits adj@(Adjunction f g _ _) (Nat t _ _) = + rightAdjunct adj x (colimitFactorizer cocone) + where + l = colimit (natId (f :.: t)) + x = coconeVertex l + cocone = Nat t (Const (g % x)) (\z -> leftAdjunct adj (t % z) (l ! z)) + +leftAdjointPreservesColimitsInv + :: (HasColimits j c, HasColimits j d) + => Obj (Nat d c) f -> Obj (Nat j d) t -> c (ColimitFam j c (f :.: t)) (f :% ColimitFam j d t) +leftAdjointPreservesColimitsInv f t = colimitFactorizer (constPrecompOut (f `o` colimit t)) + + +class Category k => HasTerminalObject k where + + type TerminalObject k :: Kind k + + terminalObject :: Obj k (TerminalObject k) + + terminate :: Obj k a -> k a (TerminalObject k) + + +-- | A terminal object is the limit of the functor from /0/ to k. +instance (Category k, HasTerminalObject k) => HasLimits Void k where + type LimitFam Void k f = TerminalObject k + limit (Nat f _ _) = voidNat (Const terminalObject) f + limitFactorizer = terminate . coneVertex + + +-- | @()@ is the terminal object in @Hask@. +instance HasTerminalObject (->) where + type TerminalObject (->) = () + + terminalObject = obj + + terminate _ _ = () + +data Top where + Top :: a %1 -> Top +-- | The terminal object in the category of linear types is @Top@. +instance HasTerminalObject (FUN 'One) where + type TerminalObject (FUN 'One) = Top + + terminalObject = obj + + terminate _ = Top + +-- | @Unit@ is the terminal category. +instance HasTerminalObject Cat where + type TerminalObject Cat = Unit + + terminalObject = CatA Id + + terminate (CatA _) = CatA (Const Unit) + +-- | The constant functor to the terminal object is itself the terminal object in its functor category. +instance (Category c, HasTerminalObject d) => HasTerminalObject (Nat c d) where + type TerminalObject (Nat c d) = Const c d (TerminalObject d) + + terminalObject = natId (Const terminalObject) + + terminate (Nat f _ _) = Nat f (Const terminalObject) (terminate . (f %)) + +-- | The category of one object has that object as terminal object. +instance HasTerminalObject Unit where + type TerminalObject Unit = () + + terminalObject = Unit + + terminate Unit = Unit + +-- | The terminal object of the product of 2 categories is the product of their terminal objects. +instance (HasTerminalObject c1, HasTerminalObject c2) => HasTerminalObject (c1 :**: c2) where + type TerminalObject (c1 :**: c2) = (TerminalObject c1, TerminalObject c2) + + terminalObject = terminalObject :**: terminalObject + + terminate (a1 :**: a2) = terminate a1 :**: terminate a2 + +-- | The terminal object of the direct coproduct of categories is the terminal object of the terminal category. +instance (Category c1, HasTerminalObject c2) => HasTerminalObject (c1 :>>: c2) where + type TerminalObject (c1 :>>: c2) = I2 (TerminalObject c2) + + terminalObject = DC (I2A terminalObject) + + terminate (DC (I1A a)) = DC (I12 a terminalObject (Const (\() -> ())) ()) + terminate (DC (I2A a)) = DC (I2A (terminate a)) + + + +class Category k => HasInitialObject k where + type InitialObject k :: Kind k + + initialObject :: Obj k (InitialObject k) + + initialize :: Obj k a -> k (InitialObject k) a + + +-- | An initial object is the colimit of the functor from /0/ to k. +instance (Category k, HasInitialObject k) => HasColimits Void k where + type ColimitFam Void k f = InitialObject k + colimit (Nat f _ _) = voidNat f (Const initialObject) + colimitFactorizer = initialize . coconeVertex + + +data Zero +absurd :: FUN m Zero a +absurd = \case + +-- | Any empty data type is an initial object in @Hask@. +instance HasInitialObject (FUN m) where + type InitialObject (FUN m) = Zero + + initialObject = obj + + initialize _ = absurd + +-- | The empty category is the initial object in @Cat@. +instance HasInitialObject Cat where + type InitialObject Cat = Void + + initialObject = CatA Id + + initialize (CatA _) = CatA Magic + +-- | The constant functor to the initial object is itself the initial object in its functor category. +instance (Category c, HasInitialObject d) => HasInitialObject (Nat c d) where + type InitialObject (Nat c d) = Const c d (InitialObject d) + + initialObject = natId (Const initialObject) + + initialize (Nat f _ _) = Nat (Const initialObject) f (initialize . (f %)) + +-- | The initial object of the product of 2 categories is the product of their initial objects. +instance (HasInitialObject c1, HasInitialObject c2) => HasInitialObject (c1 :**: c2) where + type InitialObject (c1 :**: c2) = (InitialObject c1, InitialObject c2) + + initialObject = initialObject :**: initialObject + + initialize (a1 :**: a2) = initialize a1 :**: initialize a2 + +-- | The category of one object has that object as initial object. +instance HasInitialObject Unit where + type InitialObject Unit = () + + initialObject = Unit + + initialize Unit = Unit + +-- | The initial object of the direct coproduct of categories is the initial object of the initial category. +instance (HasInitialObject c1, Category c2) => HasInitialObject (c1 :>>: c2) where + type InitialObject (c1 :>>: c2) = I1 (InitialObject c1) + + initialObject = DC (I1A initialObject) + + initialize (DC (I1A a)) = DC (I1A (initialize a)) + initialize (DC (I2A a)) = DC (I12 initialObject a (Const (\() -> ())) ()) + + +class Category k => HasBinaryProducts k where + type BinaryProduct k (x :: Kind k) (y :: Kind k) :: Kind k + + proj1 :: Obj k x -> Obj k y -> k (BinaryProduct k x y) x + proj2 :: Obj k x -> Obj k y -> k (BinaryProduct k x y) y + + (&&&) :: k a x -> k a y -> k a (BinaryProduct k x y) + + (***) :: k a1 b1 -> k a2 b2 -> k (BinaryProduct k a1 a2) (BinaryProduct k b1 b2) + l *** r = (l . proj1 (src l) (src r)) &&& (r . proj2 (src l) (src r)) + + +-- | If @k@ has binary products, we can take the limit of two joined diagrams. +instance (HasLimits i k, HasLimits j k, HasBinaryProducts k) => HasLimits (i :++: j) k where + type LimitFam (i :++: j) k f = BinaryProduct k + (LimitFam i k (f :.: Inj1 i j)) + (LimitFam j k (f :.: Inj2 i j)) + + limit = limit' + where + limit' :: forall f. Obj (Nat (i :++: j) k) f -> Cone (i :++: j) k f (LimitFam (i :++: j) k f) + limit' l@Nat{} = Nat (Const (x *** y)) (srcF l) h + where + x = coneVertex lim1 + y = coneVertex lim2 + lim1 = limit (l `o` natId Inj1) + lim2 = limit (l `o` natId Inj2) + h :: Obj (i :++: j) z -> Component (ConstF f (LimitFam (i :++: j) k f)) f z + h (I1 n) = lim1 ! n . proj1 x y + h (I2 n) = lim2 ! n . proj2 x y + + limitFactorizer c = + limitFactorizer (constPostcompIn (c `o` natId Inj1)) + &&& + limitFactorizer (constPostcompIn (c `o` natId Inj2)) + + +-- | The tuple is the binary product in @Hask@. +instance HasBinaryProducts (->) where + type BinaryProduct (->) x y = (x, y) + + proj1 _ _ = fst + proj2 _ _ = snd + + f &&& g = \x -> (f x, g x) + f *** g = \(x, y) -> (f x, g y) + + +newtype x & y = AddConj (forall r. Either (x %1-> r) (y %1-> r) %1-> r) + +-- | The product in the category of linear types is a & b, where you have access to a and b, but not both at the same time. +instance HasBinaryProducts (FUN 'One) where + type BinaryProduct (FUN 'One) x y = x & y + + proj1 _ _ (AddConj f) = f (Left obj) + proj2 _ _ (AddConj f) = f (Right obj) + + f &&& g = \x -> AddConj \case + Left h -> h (f x) + Right h -> h (g x) + f *** g = \(AddConj h) -> AddConj \case + Left l -> h (Left (\x -> l (f x))) + Right r -> h (Right (\x -> r (g x))) + + + +-- | The product of categories t':**:' is the binary product in 'Cat'. +instance HasBinaryProducts Cat where + type BinaryProduct Cat c1 c2 = c1 :**: c2 + + proj1 (CatA _) (CatA _) = CatA Proj1 + proj2 (CatA _) (CatA _) = CatA Proj2 + + CatA f1 &&& CatA f2 = CatA ((f1 :***: f2) :.: DiagProd) + CatA f1 *** CatA f2 = CatA (f1 :***: f2) + +-- | In the category of one object that object is its own product. +instance HasBinaryProducts Unit where + type BinaryProduct Unit () () = () + + proj1 Unit Unit = Unit + proj2 Unit Unit = Unit + + Unit &&& Unit = Unit + Unit *** Unit = Unit + +-- | The binary product of the product of 2 categories is the product of their binary products. +instance (HasBinaryProducts c1, HasBinaryProducts c2) => HasBinaryProducts (c1 :**: c2) where + type BinaryProduct (c1 :**: c2) (x1, x2) (y1, y2) = (BinaryProduct c1 x1 y1, BinaryProduct c2 x2 y2) + + proj1 (x1 :**: x2) (y1 :**: y2) = proj1 x1 y1 :**: proj1 x2 y2 + proj2 (x1 :**: x2) (y1 :**: y2) = proj2 x1 y1 :**: proj2 x2 y2 + + (f1 :**: f2) &&& (g1 :**: g2) = (f1 &&& g1) :**: (f2 &&& g2) + (f1 :**: f2) *** (g1 :**: g2) = (f1 *** g1) :**: (f2 *** g2) + +instance (HasBinaryProducts c1, HasBinaryProducts c2) => HasBinaryProducts (c1 :>>: c2) where + type BinaryProduct (c1 :>>: c2) (I1 a) (I1 b) = I1 (BinaryProduct c1 a b) + type BinaryProduct (c1 :>>: c2) (I1 a) (I2 b) = I1 a + type BinaryProduct (c1 :>>: c2) (I2 a) (I1 b) = I1 b + type BinaryProduct (c1 :>>: c2) (I2 a) (I2 b) = I2 (BinaryProduct c2 a b) + + proj1 (DC (I1A a)) (DC (I1A b)) = DC (I1A (proj1 a b)) + proj1 (DC (I1A a)) (DC (I2A _)) = DC (I1A a) + proj1 (DC (I2A a)) (DC (I1A b)) = DC (I12 b a (Const (\() -> ())) ()) + proj1 (DC (I2A a)) (DC (I2A b)) = DC (I2A (proj1 a b)) + + proj2 (DC (I1A a)) (DC (I1A b)) = DC (I1A (proj2 a b)) + proj2 (DC (I1A a)) (DC (I2A b)) = DC (I12 a b (Const (\() -> ())) ()) + proj2 (DC (I2A _)) (DC (I1A b)) = DC (I1A b) + proj2 (DC (I2A a)) (DC (I2A b)) = DC (I2A (proj2 a b)) + + DC (I1A a) &&& DC (I1A b) = DC (I1A (a &&& b)) + DC (I1A a) &&& DC I12{} = DC (I1A a) + DC I12{} &&& DC (I1A b) = DC (I1A b) + DC (I2A a) &&& DC (I2A b) = DC (I2A (a &&& b)) + DC (I12 a b1 _ _) &&& DC (I12 _ b2 _ _) = DC (I12 a (b1 *** b2) (Const (\() -> ())) ()) + + +data ProductFunctor (k :: Type -> Type -> Type) = ProductFunctor +-- | Binary product as a bifunctor. +instance HasBinaryProducts k => Functor (ProductFunctor k) where + type Dom (ProductFunctor k) = k :**: k + type Cod (ProductFunctor k) = k + type ProductFunctor k :% (a, b) = BinaryProduct k a b + + ProductFunctor % (a1 :**: a2) = a1 *** a2 + +-- | A specialisation of the limit adjunction to products. +prodAdj :: HasBinaryProducts k => Adjunction (k :**: k) k (DiagProd k) (ProductFunctor k) +prodAdj = mkAdjunctionTerm DiagProd ProductFunctor (\_ (l :**: r) -> l &&& r) (\(l :**: r) -> proj1 l r :**: proj2 l r) + +data p :*: q where + (:*:) :: (Functor p, Functor q, Dom p ~ Dom q, Cod p ~ k, Cod q ~ k, HasBinaryProducts k) => p -> q -> p :*: q +-- | The product of two functors, passing the same object to both functors and taking the product of the results. +instance (Category (Dom p), Category (Cod p)) => Functor (p :*: q) where + type Dom (p :*: q) = Dom p + type Cod (p :*: q) = Cod p + type (p :*: q) :% a = BinaryProduct (Cod p) (p :% a) (q :% a) + + (p :*: q) % f = (p % f) *** (q % f) + +-- | The functor product t':*:' is the binary product in functor categories. +instance (Category c, HasBinaryProducts d) => HasBinaryProducts (Nat c d) where + type BinaryProduct (Nat c d) x y = x :*: y + + proj1 (Nat f _ _) (Nat g _ _) = Nat (f :*: g) f (\z -> proj1 (f % z) (g % z)) + proj2 (Nat f _ _) (Nat g _ _) = Nat (f :*: g) g (\z -> proj2 (f % z) (g % z)) + + Nat a f af &&& Nat _ g ag = Nat a (f :*: g) (\z -> af z &&& ag z) + Nat f1 f2 f *** Nat g1 g2 g = Nat (f1 :*: g1) (f2 :*: g2) (\z -> f z *** g z) + + + +class Category k => HasBinaryCoproducts k where + type BinaryCoproduct k (x :: Kind k) (y :: Kind k) :: Kind k + + inj1 :: Obj k x -> Obj k y -> k x (BinaryCoproduct k x y) + inj2 :: Obj k x -> Obj k y -> k y (BinaryCoproduct k x y) + + (|||) :: k x a -> k y a -> k (BinaryCoproduct k x y) a + + (+++) :: k a1 b1 -> k a2 b2 -> k (BinaryCoproduct k a1 a2) (BinaryCoproduct k b1 b2) + l +++ r = (inj1 (tgt l) (tgt r) . l) ||| (inj2 (tgt l) (tgt r) . r) + + +-- | If @k@ has binary coproducts, we can take the colimit of two joined diagrams. +instance (HasColimits i k, HasColimits j k, HasBinaryCoproducts k) => HasColimits (i :++: j) k where + type ColimitFam (i :++: j) k f = BinaryCoproduct k + (ColimitFam i k (f :.: Inj1 i j)) + (ColimitFam j k (f :.: Inj2 i j)) + + colimit = colimit' + where + colimit' :: forall f. Obj (Nat (i :++: j) k) f -> Cocone (i :++: j) k f (ColimitFam (i :++: j) k f) + colimit' l@Nat{} = Nat (srcF l) (Const (x +++ y)) h + where + x = coconeVertex col1 + y = coconeVertex col2 + col1 = colimit (l `o` natId Inj1) + col2 = colimit (l `o` natId Inj2) + h :: Obj (i :++: j) z -> Component f (ConstF f (ColimitFam (i :++: j) k f)) z + h (I1 n) = inj1 x y . col1 ! n + h (I2 n) = inj2 x y . col2 ! n + + colimitFactorizer c = + colimitFactorizer (constPostcompOut (c `o` natId Inj1)) + ||| + colimitFactorizer (constPostcompOut (c `o` natId Inj2)) + + +instance HasBinaryCoproducts (FUN m) where + type BinaryCoproduct (FUN m) a b = Either a b + + inj1 _ _ = Left + inj2 _ _ = Right + + f ||| g = \case + Left a -> f a + Right b -> g b + f +++ g = \case + Left a -> Left (f a) + Right b -> Right (g b) + +-- | The coproduct of categories t':++:' is the binary coproduct in 'Cat'. +instance HasBinaryCoproducts Cat where + type BinaryCoproduct Cat c1 c2 = c1 :++: c2 + + inj1 (CatA _) (CatA _) = CatA Inj1 + inj2 (CatA _) (CatA _) = CatA Inj2 + + CatA f1 ||| CatA f2 = CatA (CodiagCoprod :.: (f1 :+++: f2)) + CatA f1 +++ CatA f2 = CatA (f1 :+++: f2) + +-- | In the category of one object that object is its own coproduct. +instance HasBinaryCoproducts Unit where + type BinaryCoproduct Unit () () = () + + inj1 Unit Unit = Unit + inj2 Unit Unit = Unit + + Unit ||| Unit = Unit + Unit +++ Unit = Unit + +-- | The binary coproduct of the product of 2 categories is the product of their binary coproducts. +instance (HasBinaryCoproducts c1, HasBinaryCoproducts c2) => HasBinaryCoproducts (c1 :**: c2) where + type BinaryCoproduct (c1 :**: c2) (x1, x2) (y1, y2) = (BinaryCoproduct c1 x1 y1, BinaryCoproduct c2 x2 y2) + + inj1 (x1 :**: x2) (y1 :**: y2) = inj1 x1 y1 :**: inj1 x2 y2 + inj2 (x1 :**: x2) (y1 :**: y2) = inj2 x1 y1 :**: inj2 x2 y2 + + (f1 :**: f2) ||| (g1 :**: g2) = (f1 ||| g1) :**: (f2 ||| g2) + (f1 :**: f2) +++ (g1 :**: g2) = (f1 +++ g1) :**: (f2 +++ g2) + +instance (HasBinaryCoproducts c1, HasBinaryCoproducts c2) => HasBinaryCoproducts (c1 :>>: c2) where + type BinaryCoproduct (c1 :>>: c2) (I1 a) (I1 b) = I1 (BinaryCoproduct c1 a b) + type BinaryCoproduct (c1 :>>: c2) (I1 a) (I2 b) = I2 b + type BinaryCoproduct (c1 :>>: c2) (I2 a) (I1 b) = I2 a + type BinaryCoproduct (c1 :>>: c2) (I2 a) (I2 b) = I2 (BinaryCoproduct c2 a b) + + inj1 (DC (I1A a)) (DC (I1A b)) = DC (I1A (inj1 a b)) + inj1 (DC (I1A a)) (DC (I2A b)) = DC (I12 a b (Const (\() -> ())) ()) + inj1 (DC (I2A a)) (DC (I1A _)) = DC (I2A a) + inj1 (DC (I2A a)) (DC (I2A b)) = DC (I2A (inj1 a b)) + + inj2 (DC (I1A a)) (DC (I1A b)) = DC (I1A (inj2 a b)) + inj2 (DC (I1A _)) (DC (I2A b)) = DC (I2A b) + inj2 (DC (I2A a)) (DC (I1A b)) = DC (I12 b a (Const (\() -> ())) ()) + inj2 (DC (I2A a)) (DC (I2A b)) = DC (I2A (inj2 a b)) + + DC (I1A a) ||| DC (I1A b) = DC (I1A (a ||| b)) + DC (I2A a) ||| DC I12{} = DC (I2A a) + DC I12{} ||| DC (I2A b) = DC (I2A b) + DC (I2A a) ||| DC (I2A b) = DC (I2A (a ||| b)) + DC (I12 a1 b _ _) ||| DC (I12 a2 _ _ _) = DC (I12 (a1 +++ a2) b (Const (\() -> ())) ()) + + +data CoproductFunctor (k :: Type -> Type -> Type) = CoproductFunctor +-- | Binary coproduct as a bifunctor. +instance HasBinaryCoproducts k => Functor (CoproductFunctor k) where + type Dom (CoproductFunctor k) = k :**: k + type Cod (CoproductFunctor k) = k + type CoproductFunctor k :% (a, b) = BinaryCoproduct k a b + + CoproductFunctor % (a1 :**: a2) = a1 +++ a2 + +-- | A specialisation of the colimit adjunction to coproducts. +coprodAdj :: HasBinaryCoproducts k => Adjunction k (k :**: k) (CoproductFunctor k) (DiagProd k) +coprodAdj = mkAdjunctionInit CoproductFunctor DiagProd (\(l :**: r) -> inj1 l r :**: inj2 l r) (\_ (l :**: r) -> l ||| r) + +data p :+: q where + (:+:) :: (Functor p, Functor q, Dom p ~ Dom q, Cod p ~ k, Cod q ~ k, HasBinaryCoproducts k) => p -> q -> p :+: q +-- | The coproduct of two functors, passing the same object to both functors and taking the coproduct of the results. +instance (Category (Dom p), Category (Cod p)) => Functor (p :+: q) where + type Dom (p :+: q) = Dom p + type Cod (p :+: q) = Cod p + type (p :+: q) :% a = BinaryCoproduct (Cod p) (p :% a) (q :% a) + + (p :+: q) % f = (p % f) +++ (q % f) + +-- | The functor coproduct t':+:' is the binary coproduct in functor categories. +instance (Category c, HasBinaryCoproducts d) => HasBinaryCoproducts (Nat c d) where + type BinaryCoproduct (Nat c d) x y = x :+: y + + inj1 (Nat f _ _) (Nat g _ _) = Nat f (f :+: g) (\z -> inj1 (f % z) (g % z)) + inj2 (Nat f _ _) (Nat g _ _) = Nat g (f :+: g) (\z -> inj2 (f % z) (g % z)) + + Nat f a fa ||| Nat g _ ga = Nat (f :+: g) a (\z -> fa z ||| ga z) + Nat f1 f2 f +++ Nat g1 g2 g = Nat (f1 :+: g1) (f2 :+: g2) (\z -> f z +++ g z) + +-- | Terminal objects are the dual of initial objects. +instance HasInitialObject k => HasTerminalObject (Op k) where + type TerminalObject (Op k) = InitialObject k + terminalObject = Op initialObject + terminate (Op f) = Op (initialize f) + +-- | Terminal objects are the dual of initial objects. +instance HasTerminalObject k => HasInitialObject (Op k) where + type InitialObject (Op k) = TerminalObject k + initialObject = Op terminalObject + initialize (Op f) = Op (terminate f) + +-- | Binary products are the dual of binary coproducts. +instance HasBinaryCoproducts k => HasBinaryProducts (Op k) where + type BinaryProduct (Op k) x y = BinaryCoproduct k x y + + proj1 (Op x) (Op y) = Op (inj1 x y) + proj2 (Op x) (Op y) = Op (inj2 x y) + Op f &&& Op g = Op (f ||| g) + Op f *** Op g = Op (f +++ g) + +-- | Binary products are the dual of binary coproducts. +instance HasBinaryProducts k => HasBinaryCoproducts (Op k) where + type BinaryCoproduct (Op k) x y = BinaryProduct k x y + + inj1 (Op x) (Op y) = Op (proj1 x y) + inj2 (Op x) (Op y) = Op (proj2 x y) + Op f ||| Op g = Op (f &&& g) + Op f +++ Op g = Op (f *** g) + + + + +-- | The limit of a single object is that object. +instance Category k => HasLimits Unit k where + type LimitFam Unit k f = f :% () + limit (Nat f _ _) = Nat (Const (f % Unit)) f (\Unit -> f % Unit) + limitFactorizer n = n ! Unit + +-- | The limit of any diagram with an initial object, has the limit at the initial object. +instance (HasInitialObject (i :>>: j), Category k) => HasLimits (i :>>: j) k where + type LimitFam (i :>>: j) k f = f :% InitialObject (i :>>: j) + limit (Nat f _ _) = Nat (Const (f % initialObject)) f (\z -> f % initialize z) + limitFactorizer n = n ! initialObject + + +-- | The colimit of a single object is that object. +instance Category k => HasColimits Unit k where + type ColimitFam Unit k f = f :% () + colimit (Nat f _ _) = Nat f (Const (f % Unit)) (\Unit -> f % Unit) + colimitFactorizer n = n ! Unit + +-- | The colimit of any diagram with a terminal object, has the limit at the terminal object. +instance (HasTerminalObject (i :>>: j), Category k) => HasColimits (i :>>: j) k where + type ColimitFam (i :>>: j) k f = f :% TerminalObject (i :>>: j) + colimit (Nat f _ _) = Nat f (Const (f % terminalObject)) (\z -> f % terminate z) + colimitFactorizer n = n ! terminalObject + + +newtype ForAll f = ForAll (forall a. Obj (->) a -> f :% a) + +instance HasLimits (->) (->) where + type LimitFam (->) (->) f = ForAll f + limit (Nat f _ _) = Nat (Const obj) f (\a (ForAll g) -> g a) + limitFactorizer n z = ForAll (\a -> (n ! a) z) + +data Exists f = forall a. Exists (Obj (->) a) (f :% a) + +instance HasColimits (->) (->) where + type ColimitFam (->) (->) f = Exists f + colimit (Nat f _ _) = Nat f (Const obj) Exists + colimitFactorizer n (Exists a fa) = (n ! a) fa diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/NaturalTransformation.hs b/src-indexed/Moonlight/Category/Pure/Indexed/NaturalTransformation.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/NaturalTransformation.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE TypeOperators, TypeFamilies, PatternSynonyms, FlexibleInstances, FlexibleContexts, UndecidableInstances, RankNTypes, GADTs, LiberalTypeSynonyms, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.NaturalTransformation ( + + -- * Natural transformations + (:~>) + , Component + , (!) + , o + , natId + , data NatId + , srcF + , tgtF + + -- * Functor category + , Nat(..) + , Endo + , Presheaves + , Profunctors + + -- * Functor isomorphisms + , compAssoc + , compAssocInv + , idPrecomp + , idPrecompInv + , idPostcomp + , idPostcompInv + , constPrecompIn + , constPrecompOut + , constPostcompIn + , constPostcompOut + + -- * Related functors + , FunctorCompose(..) + , EndoFunctorCompose + , Precompose, data Precompose + , Postcompose, data Postcompose + , Curry1, data Curry1 + , Curry2, data Curry2 + , Wrap(..) + , Apply(..) + , Tuple(..) + , Opp(..), Opposite, data Opposite + , HomF, data HomF + , Star, data Star + , Costar, data Costar + , (:*%:), data HomXF + , (:%*:), data HomFX + +) where + +import Data.Kind (Type) +import Data.Type.Equality (type (~)) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor +import Moonlight.Category.Pure.Indexed.Product + +infixl 9 ! + +-- | @f :~> g@ is a natural transformation from functor f to functor g. +type f :~> g = forall c d. (c ~ Dom f, c ~ Dom g, d ~ Cod f, d ~ Cod g) => Nat c d f g + +-- | Natural transformations are built up of components, +-- one for each object @z@ in the domain category of @f@ and @g@. +data Nat :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where + Nat :: (Functor f, Functor g, c ~ Dom f, c ~ Dom g, d ~ Cod f, d ~ Cod g) + => f -> g -> (forall z. Obj c z -> Component f g z) -> Nat c d f g + + +-- | A component for an object @z@ is an arrow from @F z@ to @G z@. +type Component f g z = Cod f (f :% z) (g :% z) + +-- | 'n ! a' returns the component for the object @a@ of a natural transformation @n@. +-- This can be generalized to any arrow (instead of just identity arrows). +(!) :: (Category c, Category d) => Nat c d f g -> c a b -> d (f :% a) (g :% b) +Nat f _ n ! h = n (tgt h) . f % h -- or g % h . n (src h), or n h when h is an identity arrow + + +-- | Horizontal composition of natural transformations. +o :: (Category c, Category d, Category e) => Nat d e j k -> Nat c d f g -> Nat c e (j :.: f) (k :.: g) +njk@(Nat j k _) `o` nfg@(Nat f g _) = Nat (j :.: f) (k :.: g) ((njk !) . (nfg !)) +-- Nat j k njk `o` Nat f g nfg = Nat (j :.: f) (k :.: g) (\x -> njk (g % x) . j % nfg x) -- or k % nfg x . njk (f % x) + +-- | The identity natural transformation of a functor. +natId :: Functor f => f -> Nat (Dom f) (Cod f) f f +natId f = Nat f f (f %) + +pattern NatId :: () => (Functor f, c ~ Dom f, d ~ Cod f) => f -> Nat c d f f +pattern NatId f <- Nat f _ _ where + NatId f = Nat f f (f %) +{-# COMPLETE NatId #-} + +srcF :: Nat c d f g -> f +srcF (Nat f _ _) = f + +tgtF :: Nat c d f g -> g +tgtF (Nat _ g _) = g + +-- | Functor category D^C. +-- Objects of D^C are functors from C to D. +-- Arrows of D^C are natural transformations. +instance Category d => Category (Nat c d) where + + src (Nat f _ _) = natId f + tgt (Nat _ g _) = natId g + + Nat _ h ngh . Nat f _ nfg = Nat f h (\i -> ngh i . nfg i) + + +compAssoc :: (Functor f, Functor g, Functor h, Dom f ~ Cod g, Dom g ~ Cod h) + => f -> g -> h -> Nat (Dom h) (Cod f) ((f :.: g) :.: h) (f :.: (g :.: h)) +compAssoc f g h = Nat ((f :.: g) :.: h) (f :.: (g :.: h)) (\i -> f % g % h % i) + +compAssocInv :: (Functor f, Functor g, Functor h, Dom f ~ Cod g, Dom g ~ Cod h) + => f -> g -> h -> Nat (Dom h) (Cod f) (f :.: (g :.: h)) ((f :.: g) :.: h) +compAssocInv f g h = Nat (f :.: (g :.: h)) ((f :.: g) :.: h) (\i -> f % g % h % i) + +idPrecomp :: Functor f => f -> Nat (Dom f) (Cod f) (f :.: Id (Dom f)) f +idPrecomp f = Nat (f :.: Id) f (f %) + +idPrecompInv :: Functor f => f -> Nat (Dom f) (Cod f) f (f :.: Id (Dom f)) +idPrecompInv f = Nat f (f :.: Id) (f %) + +idPostcomp :: Functor f => f -> Nat (Dom f) (Cod f) (Id (Cod f) :.: f) f +idPostcomp f = Nat (Id :.: f) f (f %) + +idPostcompInv :: Functor f => f -> Nat (Dom f) (Cod f) f (Id (Cod f) :.: f) +idPostcompInv f = Nat f (Id :.: f) (f %) + + +constPrecompIn :: Nat j d (f :.: Const j c x) g -> Nat j d (Const j d (f :% x)) g +constPrecompIn (Nat (f :.: Const x) g n) = Nat (Const (f % x)) g n + +constPrecompOut :: Nat j d f (g :.: Const j c x) -> Nat j d f (Const j d (g :% x)) +constPrecompOut (Nat f (g :.: Const x) n) = Nat f (Const (g % x)) n + +constPostcompIn :: Nat j d (Const k d x :.: f) g -> Nat j d (Const j d x) g +constPostcompIn (Nat (Const x :.: _) g n) = Nat (Const x) g n + +constPostcompOut :: Nat j d f (Const k d x :.: g) -> Nat j d f (Const j d x) +constPostcompOut (Nat f (Const x :.: _) n) = Nat f (Const x) n + + +data FunctorCompose (c :: Type -> Type -> Type) (d :: Type -> Type -> Type) (e :: Type -> Type -> Type) = FunctorCompose + +-- | Composition of functors is a functor. +instance (Category c, Category d, Category e) => Functor (FunctorCompose c d e) where + type Dom (FunctorCompose c d e) = Nat d e :**: Nat c d + type Cod (FunctorCompose c d e) = Nat c e + type FunctorCompose c d e :% (f, g) = f :.: g + + FunctorCompose % (n1 :**: n2) = n1 `o` n2 + + +-- | The category of endofunctors. +type Endo k = Nat k k +-- | Composition of endofunctors is a functor. +type EndoFunctorCompose k = FunctorCompose k k k + +type Presheaves k = Nat (Op k) (->) + +type Profunctors c d = Nat (Op d :**: c) (->) + + +-- | @Precompose f e@ is the functor such that @Precompose f e :% g = g :.: f@, +-- for functors @g@ that compose with @f@ and with codomain @e@. +type Precompose f e = FunctorCompose (Dom f) (Cod f) e :.: Tuple2 (Nat (Cod f) e) (Nat (Dom f) (Cod f)) f +pattern Precompose :: (Category e, Functor f) => f -> Precompose f e +pattern Precompose f = FunctorCompose :.: Tuple2 (NatId f) + +-- | @Postcompose f c@ is the functor such that @Postcompose f c :% g = f :.: g@, +-- for functors @g@ that compose with @f@ and with domain @c@. +type Postcompose f c = FunctorCompose c (Dom f) (Cod f) :.: Tuple1 (Nat (Dom f) (Cod f)) (Nat c (Dom f)) f +pattern Postcompose :: (Category c, Functor f) => f -> Postcompose f c +pattern Postcompose f = FunctorCompose :.: Tuple1 (NatId f) + + +type Curry1 c1 c2 f = Postcompose f c2 :.: Tuple c1 c2 +-- | Curry on the first "argument" of a functor from a product category. +pattern Curry1 :: (Functor f, Dom f ~ c1 :**: c2, Category c1, Category c2) => f -> Curry1 c1 c2 f +pattern Curry1 f = Postcompose f :.: Tuple + +type Curry2 c1 c2 f = Postcompose f c1 :.: Curry1 c2 c1 (Swap c2 c1) +-- | Curry on the second "argument" of a functor from a product category. +pattern Curry2 :: (Functor f, Dom f ~ c1 :**: c2, Category c1, Category c2) => f -> Curry2 c1 c2 f +pattern Curry2 f = Postcompose f :.: Curry1 Swap + + +data Wrap f h = Wrap f h + +-- | @Wrap f h@ is the functor such that @Wrap f h :% g = f :.: g :.: h@, +-- for functors @g@ that compose with @f@ and @h@. +instance (Functor f, Functor h) => Functor (Wrap f h) where + type Dom (Wrap f h) = Nat (Cod h) (Dom f) + type Cod (Wrap f h) = Nat (Dom h) (Cod f) + type Wrap f h :% g = f :.: g :.: h + + Wrap f h % n = natId f `o` n `o` natId h + + +data Apply (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Apply +-- | t'Apply' is a bifunctor; @Apply :% (f, a)@ applies @f@ to @a@. +instance (Category c1, Category c2) => Functor (Apply c1 c2) where + type Dom (Apply c1 c2) = Nat c2 c1 :**: c2 + type Cod (Apply c1 c2) = c1 + type Apply c1 c2 :% (f, a) = f :% a + Apply % (l :**: r) = l ! r + +data Tuple (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Tuple +-- | t'Tuple' converts an object @a@ to the functor t'Tuple1' @a@. +instance (Category c1, Category c2) => Functor (Tuple c1 c2) where + type Dom (Tuple c1 c2) = c1 + type Cod (Tuple c1 c2) = Nat c2 (c1 :**: c2) + type Tuple c1 c2 :% a = Tuple1 c1 c2 a + Tuple % f = Nat (Tuple1 (src f)) (Tuple1 (tgt f)) (f :**:) + + +data Opp (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Opp +-- | Turning a functor into its dual is contravariantly functorial. +instance (Category c1, Category c2) => Functor (Opp c1 c2) where + type Dom (Opp c1 c2) = Op (Nat c1 c2) :**: Op c1 + type Cod (Opp c1 c2) = Op c2 + type Opp c1 c2 :% (f, a) = f :% a + Opp % (Op n :**: Op f) = Op (n ! f) + +type Opposite f = Opp (Dom f) (Cod f) :.: Tuple1 (Op (Nat (Dom f) (Cod f))) (Op (Dom f)) f +-- | The dual of a functor +pattern Opposite :: Functor f => f -> Opposite f +pattern Opposite f = Opp :.: Tuple1 (Op (NatId f)) +{-# COMPLETE Opposite #-} + + +type HomF f g = Hom (Cod f) :.: (Opposite f :***: g) +pattern HomF :: (Functor f, Functor g, Cod f ~ Cod g) => f -> g -> HomF f g +pattern HomF f g = Hom :.: (Opposite f :***: g) +{-# COMPLETE HomF #-} + +type Star f = HomF (Id (Cod f)) f +pattern Star :: Functor f => f -> Star f +pattern Star f = HomF Id f +{-# COMPLETE Star #-} + +type Costar f = HomF f (Id (Cod f)) +pattern Costar :: Functor f => f -> Costar f +pattern Costar f = HomF f Id +{-# COMPLETE Costar #-} + +type x :*%: f = (x :*-: Cod f) :.: f +-- | The covariant functor Hom(X,F-) +pattern HomXF :: Functor f => Obj (Cod f) x -> f -> x :*%: f +pattern HomXF x f = HomX_ x :.: f +{-# COMPLETE HomXF #-} + +type f :%*: x = (Cod f :-*: x) :.: Opposite f +-- | The contravariant functor Hom(F-,X) +pattern HomFX :: Functor f => f -> Obj (Cod f) x -> f :%*: x +pattern HomFX f x = Hom_X x :.: Opposite f +{-# COMPLETE HomFX #-} diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Product.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Product.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Product.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeFamilies, TypeOperators, GADTs, FlexibleContexts, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Product where + +import Data.Kind (Type) + +import Moonlight.Category.Pure.Indexed.Category + + +data (:**:) :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where + (:**:) :: c1 a1 b1 -> c2 a2 b2 -> (:**:) c1 c2 (a1, a2) (b1, b2) + +-- | The product category of categories @c1@ and @c2@. +instance (Category c1, Category c2) => Category (c1 :**: c2) where + + src (a1 :**: a2) = src a1 :**: src a2 + tgt (a1 :**: a2) = tgt a1 :**: tgt a2 + + (a1 :**: a2) . (b1 :**: b2) = (a1 . b1) :**: (a2 . b2) diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Simplex.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Simplex.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Simplex.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +-- +-- The ordinary simplex category, presented as the non-empty slice of the +-- augmented simplex category from data-category. +module Moonlight.Category.Pure.Indexed.Simplex + ( -- * Ordinary simplex category + Simplex, + Z, + S, + simplexZero, + simplexSucc, + simplexFirstVertex, + simplexWeakenCodomain, + simplexExtendDomain, + simplexCollapse, + simplexValues, + cofaceFirst, + cofaceLast, + cofaceSucc, + codegeneracyFirst, + codegeneracyLast, + codegeneracySucc, + + -- * Finite ordinal elements + Fin (..), + SimplexFin, + finToNatural, + + -- * Functor to Hask + ForgetSimplex (..), + + -- * Simplicial-set aliases + SSet, + StandardSimplex, + ) +where + +import Numeric.Natural (Natural) +import Prelude (Bool (..), Eq (..), Show (..), id, map, (+), (++)) + +import Moonlight.Category.Pure.Indexed.Category (Category (..), Obj) +import Moonlight.Category.Pure.Indexed.Functor (Functor (..), (:-*:)) +import Moonlight.Category.Pure.Indexed.NaturalTransformation (Presheaves) + +-- | Zero in the public ordinary simplex index. Public @Z@ denotes the standard +-- simplex object @[0]@ through t'Simplex', not the hidden augmented empty ordinal. +data Z + +-- | Successor in the public ordinary simplex index. Public @S Z@ denotes @[1]@. +data S n + +-- | The augmented simplex category. Its object @AugmentedZ@ is the empty finite +-- ordinal; public t'Simplex' shifts both endpoints by 'S' so that the empty +-- ordinal cannot appear at the public boundary. +data AugmentedSimplex x y where + AugmentedZ :: AugmentedSimplex Z Z + AugmentedY :: AugmentedSimplex x y -> AugmentedSimplex x (S y) + AugmentedX :: AugmentedSimplex x (S y) -> AugmentedSimplex (S x) (S y) + +instance Eq (AugmentedSimplex a b) where + AugmentedZ == AugmentedZ = True + AugmentedY left == AugmentedY right = left == right + AugmentedX left == AugmentedX right = left == right + _ == _ = False + +instance Show (AugmentedSimplex a b) where + show AugmentedZ = "AugmentedZ" + show (AugmentedY arrow) = "AugmentedY (" ++ show arrow ++ ")" + show (AugmentedX arrow) = "AugmentedX (" ++ show arrow ++ ")" + +augmentedSucc :: Obj AugmentedSimplex n -> Obj AugmentedSimplex (S n) +augmentedSucc = AugmentedX . AugmentedY + +-- | The augmented simplex category is the category of finite ordinals and +-- order-preserving maps, including the empty ordinal. +instance Category AugmentedSimplex where + src AugmentedZ = AugmentedZ + src (AugmentedY arrow) = src arrow + src (AugmentedX arrow) = augmentedSucc (src arrow) + + tgt AugmentedZ = AugmentedZ + tgt (AugmentedY arrow) = augmentedSucc (tgt arrow) + tgt (AugmentedX arrow) = tgt arrow + + AugmentedZ . arrow = arrow + arrow . AugmentedZ = arrow + AugmentedY left . right = AugmentedY (left . right) + AugmentedX left . AugmentedY right = left . right + AugmentedX left . AugmentedX right = AugmentedX (AugmentedX left . right) + +-- | Ordinary simplex category Δ. Object @n@ denotes the non-empty finite ordinal +-- @[n]@, represented internally by the augmented object @S n@. +newtype Simplex a b = Simplex (AugmentedSimplex (S a) (S b)) + +instance Eq (Simplex a b) where + Simplex left == Simplex right = left == right + +instance Show (Simplex a b) where + show (Simplex arrow) = "Simplex (" ++ show arrow ++ ")" + +-- | The ordinary simplex category is the full non-empty subcategory of the +-- augmented simplex category. +instance Category Simplex where + src (Simplex arrow) = Simplex (src arrow) + tgt (Simplex arrow) = Simplex (tgt arrow) + + Simplex left . Simplex right = Simplex (left . right) + +-- | The identity arrow on @[0]@. +simplexZero :: Obj Simplex Z +simplexZero = Simplex (augmentedSucc AugmentedZ) + +-- | Given the identity arrow on @[n]@, construct the identity arrow on @[n+1]@. +simplexSucc :: Obj Simplex n -> Obj Simplex (S n) +simplexSucc objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (augmentedSucc canonicalObject) + +-- | The first vertex inclusion @[0] -> [n]@. +simplexFirstVertex :: Obj Simplex n -> Simplex Z n +simplexFirstVertex objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (AugmentedX (augmentedInitial canonicalObject)) + +-- | Shift a map into the upper face of the codomain. +simplexWeakenCodomain :: Simplex a b -> Simplex a (S b) +simplexWeakenCodomain (Simplex arrow) = Simplex (AugmentedY arrow) + +-- | Extend a map by sending the new least domain element to the least codomain +-- element and shifting the previous domain through the supplied map. +simplexExtendDomain :: Simplex a (S b) -> Simplex (S a) (S b) +simplexExtendDomain (Simplex arrow) = Simplex (AugmentedX arrow) + +-- | The unique monotone map @[n] -> [0]@. +simplexCollapse :: Obj Simplex n -> Simplex n Z +simplexCollapse objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (augmentedTerminalObject canonicalObject) + +-- | Decode a simplex arrow as the monotone list of target ordinal values. +simplexValues :: Simplex a b -> [Natural] +simplexValues (Simplex arrow) = + map (finToNatural . augmentedForget arrow) (augmentedFinElements (src arrow)) + +-- | The first coface @δ₀ : [n] -> [n+1]@, skipping the least codomain value. +cofaceFirst :: Obj Simplex n -> Simplex n (S n) +cofaceFirst objectArrow = + simplexWeakenCodomain (canonicalSimplexObject objectArrow) + +-- | The last coface @δₙ₊₁ : [n] -> [n+1]@, skipping the greatest codomain value. +cofaceLast :: Obj Simplex n -> Simplex n (S n) +cofaceLast objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (augmentedPreserveValuesCodomainSucc canonicalObject) + +-- | Shift @δᵢ@ to @δᵢ₊₁@ by adjoining a new least endpoint. +cofaceSucc :: Simplex n (S n) -> Simplex (S n) (S (S n)) +cofaceSucc cofaceArrow = + simplexExtendDomain (simplexWeakenCodomain cofaceArrow) + +-- | The first codegeneracy @σ₀ : [n+1] -> [n]@, identifying the first pair. +codegeneracyFirst :: Obj Simplex n -> Simplex (S n) n +codegeneracyFirst objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (AugmentedX canonicalObject) + +-- | The last codegeneracy @σₙ : [n+1] -> [n]@, identifying the last pair. +codegeneracyLast :: Obj Simplex n -> Simplex (S n) n +codegeneracyLast objectArrow = + case canonicalSimplexObject objectArrow of + Simplex canonicalObject -> Simplex (augmentedDuplicateLastDomain canonicalObject) + +-- | Shift @σᵢ@ to @σᵢ₊₁@ by adjoining a new least endpoint. +codegeneracySucc :: Simplex (S n) n -> Simplex (S (S n)) (S n) +codegeneracySucc codegeneracyArrow = + simplexExtendDomain (simplexWeakenCodomain codegeneracyArrow) + +-- | Elements of a finite ordinal. +data Fin n where + Fz :: Fin (S n) + Fs :: Fin n -> Fin (S n) + +instance Eq (Fin n) where + Fz == Fz = True + Fs left == Fs right = left == right + _ == _ = False + +instance Show (Fin n) where + show Fz = "Fz" + show (Fs value) = "Fs (" ++ show value ++ ")" + +-- | Elements of the public ordinary simplex object @[n]@. +type SimplexFin n = Fin (S n) + +finToNatural :: Fin n -> Natural +finToNatural Fz = 0 +finToNatural (Fs value) = 1 + finToNatural value + +data ForgetSimplex = ForgetSimplex + +-- | Forget an ordinary simplex arrow to its monotone function between finite +-- ordinal element types. +instance Functor ForgetSimplex where + type Dom ForgetSimplex = Simplex + type Cod ForgetSimplex = (->) + type ForgetSimplex :% n = SimplexFin n + + ForgetSimplex % Simplex arrow = augmentedForget arrow + +-- | Simplicial sets as presheaves on the ordinary simplex category. +type SSet = Presheaves Simplex + +-- | The representable standard simplex @Δ[n] = Hom(-, [n])@. +type StandardSimplex n = Simplex :-*: n + +canonicalSimplexObject :: Obj Simplex n -> Obj Simplex n +canonicalSimplexObject = src + +augmentedForget :: AugmentedSimplex x y -> Fin x -> Fin y +augmentedForget AugmentedZ = id +augmentedForget (AugmentedY arrow) = Fs . augmentedForget arrow +augmentedForget (AugmentedX arrow) = \case + Fz -> Fz + Fs value -> augmentedForget arrow value + +augmentedPreserveValuesCodomainSucc :: AugmentedSimplex x y -> AugmentedSimplex x (S y) +augmentedPreserveValuesCodomainSucc AugmentedZ = AugmentedY AugmentedZ +augmentedPreserveValuesCodomainSucc (AugmentedY arrow) = AugmentedY (augmentedPreserveValuesCodomainSucc arrow) +augmentedPreserveValuesCodomainSucc (AugmentedX arrow) = AugmentedX (augmentedPreserveValuesCodomainSucc arrow) + +augmentedDuplicateLastDomain :: AugmentedSimplex x (S y) -> AugmentedSimplex (S x) (S y) +augmentedDuplicateLastDomain (AugmentedX arrow) = AugmentedX (augmentedDuplicateLastDomain arrow) +augmentedDuplicateLastDomain (AugmentedY AugmentedZ) = AugmentedX (AugmentedY AugmentedZ) +augmentedDuplicateLastDomain (AugmentedY (AugmentedY arrow)) = + AugmentedY (augmentedDuplicateLastDomain (AugmentedY arrow)) +augmentedDuplicateLastDomain (AugmentedY (AugmentedX arrow)) = + AugmentedY (augmentedDuplicateLastDomain (AugmentedX arrow)) + +augmentedInitial :: Obj AugmentedSimplex n -> AugmentedSimplex Z n +augmentedInitial AugmentedZ = AugmentedZ +augmentedInitial (AugmentedX (AugmentedY objectArrow)) = AugmentedY (augmentedInitial objectArrow) +augmentedInitial (AugmentedY arrow) = AugmentedY (augmentedInitial (tgt arrow)) +augmentedInitial (AugmentedX arrow) = augmentedInitial (tgt arrow) + +augmentedTerminalObject :: Obj AugmentedSimplex n -> AugmentedSimplex n (S Z) +augmentedTerminalObject AugmentedZ = AugmentedY AugmentedZ +augmentedTerminalObject (AugmentedY arrow) = augmentedTerminalObject (src arrow) +augmentedTerminalObject (AugmentedX arrow) = AugmentedX (augmentedTerminalObject (src arrow)) + +augmentedFinElements :: Obj AugmentedSimplex n -> [Fin n] +augmentedFinElements AugmentedZ = [] +augmentedFinElements (AugmentedY arrow) = augmentedFinElements (src arrow) +augmentedFinElements (AugmentedX arrow) = Fz : map Fs (augmentedFinElements (src arrow)) diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Unit.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Unit.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Unit.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GADTs, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Unit where + +import Moonlight.Category.Pure.Indexed.Category + + +data Unit a b where + Unit :: Unit () () + +-- | t'Unit' is the category with one object. +instance Category Unit where + + src Unit = Unit + tgt Unit = Unit + + Unit . Unit = Unit diff --git a/src-indexed/Moonlight/Category/Pure/Indexed/Void.hs b/src-indexed/Moonlight/Category/Pure/Indexed/Void.hs new file mode 100644 --- /dev/null +++ b/src-indexed/Moonlight/Category/Pure/Indexed/Void.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE EmptyCase, LambdaCase, TypeOperators, GADTs, TypeFamilies, NoImplicitPrelude #-} +-- | Adapted from data-category-0.11 (BSD-3-Clause), copyright Sjoerd Visscher 2011. +-- See compiler/foundation/moonlight-category/THIRD_PARTY_NOTICES.md. +module Moonlight.Category.Pure.Indexed.Void where + +import Data.Kind (Type) +import Data.Type.Equality (type (~)) + +import Moonlight.Category.Pure.Indexed.Category +import Moonlight.Category.Pure.Indexed.Functor +import Moonlight.Category.Pure.Indexed.NaturalTransformation + + +data Void a b + +magic :: Void a b -> x +magic = \case { } + +-- | `Void` is the category with no objects. +instance Category Void where + + src = magic + tgt = magic + + (.) = magic + + +voidNat :: (Functor f, Functor g, Dom f ~ Void, Dom g ~ Void, Cod f ~ d, Cod g ~ d) + => f -> g -> Nat Void d f g +voidNat f g = Nat f g magic + + +data Magic (k :: Type -> Type -> Type) = Magic +-- | Since there is nothing to map in `Void`, there's a functor from it to any other category. +instance Category k => Functor (Magic k) where + type Dom (Magic k) = Void + type Cod (Magic k) = k + type Magic k :% a = a + + Magic % f = magic f diff --git a/src-laws/Moonlight/Category/Effect/Fixture/FinCat.hs b/src-laws/Moonlight/Category/Effect/Fixture/FinCat.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Fixture/FinCat.hs @@ -0,0 +1,27 @@ +-- | Stable finite-category values for executable laws, tests, and benchmarks. +module Moonlight.Category.Effect.Fixture.FinCat + ( sampleFinCat, + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + trustedThinFinCatFromTransitiveEndpoints, + ) + +-- | The thin chain @0 -> 1 -> 2@ with its composite. +sampleFinCat :: FinCat +sampleFinCat = + trustedThinFinCatFromTransitiveEndpoints + (Set.fromList (FinObjectId <$> [0, 1, 2])) + ( Map.fromList + [ ((FinObjectId 0, FinObjectId 1), FinGeneratorMorphismId (FinGeneratorId 10)), + ((FinObjectId 1, FinObjectId 2), FinGeneratorMorphismId (FinGeneratorId 11)), + ((FinObjectId 0, FinObjectId 2), FinGeneratorMorphismId (FinGeneratorId 12)) + ] + ) diff --git a/src-laws/Moonlight/Category/Effect/Harness.hs b/src-laws/Moonlight/Category/Effect/Harness.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | The pooled law-harness surface: category and site law records with their +-- constructors, re-exported from the per-domain harness modules. +module Moonlight.Category.Effect.Harness + ( CategoryLaws (..), + SiteLaws (..), + mkCategoryLaws, + mkSiteLaws, + adhesiveWitnessMonicSound, + pushoutComplementSquareCommutes, + pushoutComplementUniversal, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pbpoComplementUniversal, + galoisAdjoint, + galoisDeflation, + galoisInflation, + galoisRetraction, + ordinalGaloisMonotone, + productProjection1, + productProjection2, + coproductInjection1, + coproductInjection2, + pullbackCommutative, + pushoutCommutative, + equalizerCommutative, + coequalizerCommutative, + horizontalBoundary, + verticalBoundary, + interchange, + ) +where + +import Moonlight.Category.Effect.Harness.Adhesive + ( adhesiveWitnessMonicSound, + pbpoComplementUniversal, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pushoutComplementSquareCommutes, + pushoutComplementUniversal, + ) +import Moonlight.Category.Effect.Harness.Algebra + ( galoisAdjoint, + galoisDeflation, + galoisInflation, + galoisRetraction, + ordinalGaloisMonotone, + ) +import Moonlight.Category.Effect.Harness.Category + ( mkCategoryLaws, + ) +import Moonlight.Category.Effect.Harness.Core + ( CategoryLaws (..), + SiteLaws (..), + ) +import Moonlight.Category.Effect.Harness.Higher + ( horizontalBoundary, + interchange, + verticalBoundary, + ) +import Moonlight.Category.Effect.Harness.Limits + ( coequalizerCommutative, + coproductInjection1, + coproductInjection2, + equalizerCommutative, + productProjection1, + productProjection2, + pullbackCommutative, + pushoutCommutative, + ) +import Moonlight.Category.Effect.Harness.Site (mkSiteLaws) diff --git a/src-laws/Moonlight/Category/Effect/Harness/Adhesive.hs b/src-laws/Moonlight/Category/Effect/Harness/Adhesive.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Adhesive.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Executable checks for the adhesive and PBPO rewriting laws. +module Moonlight.Category.Effect.Harness.Adhesive + ( adhesiveWitnessMonicSound, + pushoutComplementSquareCommutes, + pushoutComplementUniversal, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pbpoComplementUniversal, + pullbackMediatorCommutes, + ) +where + +import Moonlight.Category.Pure.Adhesive + ( AdhesiveCategory, + PBPOAdhesiveCategory, + PBPOComplementWitness, + PushoutComplementWitness, + monicMatchArrow, + pbpoComplement, + pushoutComplement, + witnessMonic, + ) +import Moonlight.Category.Pure.Adhesive qualified as Adhesive +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.Limits (HasPullbacks (..)) +import Prelude hiding (Functor) + +adhesiveWitnessMonicSound :: forall c. (AdhesiveCategory c, Eq (Mor c)) => c -> (Mor c -> Bool) -> Mor c -> Bool +adhesiveWitnessMonicSound categoryValue isMonic morphism = + case witnessMonic @c categoryValue morphism of + Nothing -> + True + Just witness -> + monicMatchArrow witness == morphism && isMonic morphism + +pushoutComplementSquareCommutes :: forall c. (AdhesiveCategory c, Eq (Mor c)) => c -> Mor c -> Mor c -> Bool +pushoutComplementSquareCommutes categoryValue ruleLeg matchArrow = + maybe True (Adhesive.pushoutComplementSquareCommutes categoryValue) (pushoutComplementWitness @c categoryValue ruleLeg matchArrow) + +pushoutComplementUniversal :: forall c. AdhesiveCategory c => c -> (PushoutComplementWitness c -> Bool) -> Mor c -> Mor c -> Bool +pushoutComplementUniversal categoryValue isUniversal ruleLeg matchArrow = + maybe True isUniversal (pushoutComplementWitness @c categoryValue ruleLeg matchArrow) + +pbpoPullbackSquareCommutes :: forall c. (PBPOAdhesiveCategory c, Eq (Mor c)) => c -> Mor c -> Mor c -> Bool +pbpoPullbackSquareCommutes categoryValue ruleLeg matchArrow = + maybe True (Adhesive.pbpoPullbackSquareCommutes categoryValue) (pbpoComplementWitness @c categoryValue ruleLeg matchArrow) + +pbpoPushoutSquareCommutes :: forall c. (PBPOAdhesiveCategory c, Eq (Mor c)) => c -> Mor c -> Mor c -> Bool +pbpoPushoutSquareCommutes categoryValue ruleLeg matchArrow = + maybe True (Adhesive.pbpoPushoutSquareCommutes categoryValue) (pbpoComplementWitness @c categoryValue ruleLeg matchArrow) + +pbpoComplementUniversal :: forall c. PBPOAdhesiveCategory c => c -> (PBPOComplementWitness c -> Bool) -> Mor c -> Mor c -> Bool +pbpoComplementUniversal categoryValue isUniversal ruleLeg matchArrow = + maybe True isUniversal (pbpoComplementWitness @c categoryValue ruleLeg matchArrow) + +pullbackMediatorCommutes :: + forall c. + (HasPullbacks c, Eq (Mor c)) => + c -> + Mor c -> + Mor c -> + Mor c -> + Mor c -> + Bool +pullbackMediatorCommutes categoryValue leftBase rightBase coneLeft coneRight = + case pullback @c categoryValue leftBase rightBase of + Nothing -> + False + Just (_, projLeft, projRight) -> + case (composeMor @c categoryValue leftBase coneLeft, composeMor @c categoryValue rightBase coneRight) of + (Right leftComposite, Right rightComposite) + | leftComposite == rightComposite -> + case pullbackMediator @c categoryValue leftBase rightBase coneLeft coneRight of + Just mediator -> + rightEquals (composeMor @c categoryValue projLeft mediator) coneLeft + && rightEquals (composeMor @c categoryValue projRight mediator) coneRight + Nothing -> + False + _ -> + False + +pushoutComplementWitness :: forall c. AdhesiveCategory c => c -> Mor c -> Mor c -> Maybe (PushoutComplementWitness c) +pushoutComplementWitness categoryValue ruleLeg matchArrow = + witnessMonic @c categoryValue matchArrow >>= pushoutComplement @c categoryValue ruleLeg + +pbpoComplementWitness :: forall c. PBPOAdhesiveCategory c => c -> Mor c -> Mor c -> Maybe (PBPOComplementWitness c) +pbpoComplementWitness categoryValue ruleLeg matchArrow = + witnessMonic @c categoryValue matchArrow >>= pbpoComplement @c categoryValue ruleLeg + +rightEquals :: Eq value => Either err value -> value -> Bool +rightEquals eitherValue expected = + case eitherValue of + Right value -> value == expected + Left _ -> False diff --git a/src-laws/Moonlight/Category/Effect/Harness/Algebra.hs b/src-laws/Moonlight/Category/Effect/Harness/Algebra.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Algebra.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Executable checks for Galois-connection laws. +module Moonlight.Category.Effect.Harness.Algebra + ( galoisAdjoint, + galoisDeflation, + galoisInflation, + galoisRetraction, + ordinalGaloisMonotone, + ) +where + +import Moonlight.Category.Pure.Galois (GaloisConnection (..), OrdinalGalois (..)) + +galoisAdjoint :: forall a b. GaloisConnection a b => a -> b -> Bool +galoisAdjoint left right = (left <= gamma right) == (alpha left <= right) + +galoisDeflation :: forall a b. GaloisConnection a b => b -> Bool +galoisDeflation right = alpha (gamma right) <= right + +galoisInflation :: forall a b. GaloisConnection a b => a -> Bool +galoisInflation left = left <= gamma (alpha left) + +galoisRetraction :: forall a b. GaloisConnection a b => a -> Bool +galoisRetraction left = alpha (gamma (alpha left)) == alpha left + +ordinalGaloisMonotone :: forall a b. OrdinalGalois a b => Bool +ordinalGaloisMonotone = + let adjacentThresholds = zip (thresholds @a @b) (drop 1 (thresholds @a @b)) + in all (\((leftA, leftB), (rightA, rightB)) -> leftA <= rightA && leftB <= rightB) adjacentThresholds diff --git a/src-laws/Moonlight/Category/Effect/Harness/Category.hs b/src-laws/Moonlight/Category/Effect/Harness/Category.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Category.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Builds the t'CategoryLaws' record for a carrier. +module Moonlight.Category.Effect.Harness.Category + ( mkCategoryLaws, + ) +where + +import Moonlight.Category.Effect.Harness.Core + ( CategoryLaws (..), + composeC, + identityC, + sourceC, + targetC, + ) +import Moonlight.Category.Pure.Category (Category (..)) + +mkCategoryLaws :: forall c. (Category c, Eq (Mor c), Eq (Ob c)) => c -> CategoryLaws c +mkCategoryLaws categoryValue = + CategoryLaws + { categoryLeftIdentity = categoryLeftIdentityLaw @c categoryValue, + categoryRightIdentity = categoryRightIdentityLaw @c categoryValue, + categoryAssociativity = categoryAssociativityLaw @c categoryValue + } + +categoryLeftIdentityLaw :: forall c. (Category c, Eq (Mor c)) => c -> Mor c -> Bool +categoryLeftIdentityLaw categoryValue morphism = + case do + targetObject <- targetC @c categoryValue morphism + identityMorphism <- identityC @c categoryValue targetObject + composeC @c categoryValue identityMorphism morphism + of + Right composed -> composed == morphism + Left _ -> False + +categoryRightIdentityLaw :: forall c. (Category c, Eq (Mor c)) => c -> Mor c -> Bool +categoryRightIdentityLaw categoryValue morphism = + case do + sourceObject <- sourceC @c categoryValue morphism + identityMorphism <- identityC @c categoryValue sourceObject + composeC @c categoryValue morphism identityMorphism + of + Right composed -> composed == morphism + Left _ -> False + +categoryAssociativityLaw :: forall c. (Category c, Eq (Mor c), Eq (Ob c)) => c -> Mor c -> Mor c -> Mor c -> Bool +categoryAssociativityLaw categoryValue first second third = + case do + firstTarget <- targetC @c categoryValue first + secondSource <- sourceC @c categoryValue second + secondTarget <- targetC @c categoryValue second + thirdSource <- sourceC @c categoryValue third + pure (firstTarget == secondSource && secondTarget == thirdSource) + of + Left _ -> False + Right False -> True + Right True -> + rightValuesEqual + (composeC @c categoryValue third second >>= (\composed -> composeC @c categoryValue composed first)) + (composeC @c categoryValue second first >>= composeC @c categoryValue third) + +rightValuesEqual :: Eq value => Either left value -> Either right value -> Bool +rightValuesEqual left right = + case (left, right) of + (Right leftValue, Right rightValue) -> leftValue == rightValue + _ -> False diff --git a/src-laws/Moonlight/Category/Effect/Harness/Core.hs b/src-laws/Moonlight/Category/Effect/Harness/Core.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Core.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Shared plumbing for the law harnesses: law records and total accessors over +-- 'Category' operations. +module Moonlight.Category.Effect.Harness.Core + ( CategoryLaws (..), + SiteLaws (..), + identityC, + sourceC, + targetC, + composeC, + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.Category (Category (..), composeMor) +import Moonlight.Category.Pure.Site (SiteManifest) + +type CategoryLaws :: Type -> Type +data CategoryLaws c = CategoryLaws + { categoryLeftIdentity :: Mor c -> Bool, + categoryRightIdentity :: Mor c -> Bool, + categoryAssociativity :: Mor c -> Mor c -> Mor c -> Bool + } + +type SiteLaws :: Type -> Type -> Type +data SiteLaws obj layer = SiteLaws + { siteCoverageClosure :: SiteManifest obj -> Bool, + siteCategoryIdentity :: SiteManifest obj -> Bool, + siteCategoryAssociativity :: SiteManifest obj -> Bool, + siteLayerPolicyConformance :: (obj -> layer) -> (layer -> layer -> Bool) -> SiteManifest obj -> Bool + } + +identityC :: forall c. Category c => c -> Ob c -> Either (CategoryError c) (Mor c) +identityC = identity @c + +sourceC :: forall c. Category c => c -> Mor c -> Either (CategoryError c) (Ob c) +sourceC = source @c + +targetC :: forall c. Category c => c -> Mor c -> Either (CategoryError c) (Ob c) +targetC = target @c + +composeC :: forall c. Category c => c -> Mor c -> Mor c -> Either (CategoryError c) (Mor c) +composeC = composeMor @c diff --git a/src-laws/Moonlight/Category/Effect/Harness/Higher.hs b/src-laws/Moonlight/Category/Effect/Harness/Higher.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Higher.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Executable checks for 2-category boundary and interchange laws. +module Moonlight.Category.Effect.Harness.Higher + ( horizontalBoundary, + verticalBoundary, + interchange, + ) +where + +import Moonlight.Category.Effect.Harness.Core (composeC, sourceC, targetC) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Higher (HigherCategory (..)) + +horizontalBoundary :: forall c. (HigherCategory c, Eq (Mor c), Eq (Ob c)) => c -> TwoMor c -> TwoMor c -> Bool +horizontalBoundary categoryValue left right = + case horizontalComposable @c categoryValue left right of + Nothing -> False + Just False -> True + Just True -> + case + ( composeC @c categoryValue (source2 @c left) (source2 @c right), + composeC @c categoryValue (target2 @c left) (target2 @c right) + ) + of + (Right expectedSource, Right expectedTarget) -> + case hCompose @c categoryValue left right of + Left _ -> False + Right composed -> + source2 @c composed == expectedSource + && target2 @c composed == expectedTarget + _ -> False + +verticalBoundary :: forall c. (HigherCategory c, Eq (Mor c)) => c -> TwoMor c -> TwoMor c -> Bool +verticalBoundary categoryValue left right = + not (verticalComposable @c left right) + || case vCompose @c categoryValue left right of + Left _ -> False + Right composed -> + source2 @c composed == source2 @c right + && target2 @c composed == target2 @c left + +interchange :: forall c. (HigherCategory c, Eq (Ob c), Eq (Mor c), Eq (TwoMor c)) => c -> TwoMor c -> TwoMor c -> TwoMor c -> TwoMor c -> Bool +interchange categoryValue upperLeft upperRight lowerLeft lowerRight = + let horizontalUpper = hCompose @c categoryValue upperLeft upperRight + horizontalLower = hCompose @c categoryValue lowerLeft lowerRight + lhs = horizontalUpper >>= (\upper -> horizontalLower >>= vCompose @c categoryValue upper) + verticalLeft = vCompose @c categoryValue upperLeft lowerLeft + verticalRight = vCompose @c categoryValue upperRight lowerRight + rhs = verticalLeft >>= (\left -> verticalRight >>= hCompose @c categoryValue left) + horizontalApplicability = + liftA2 + (&&) + (horizontalComposable @c categoryValue upperLeft upperRight) + (horizontalComposable @c categoryValue lowerLeft lowerRight) + in case horizontalApplicability of + Nothing -> False + Just horizontalApplicable -> + let applicable = + horizontalApplicable + && verticalComposable @c upperLeft lowerLeft + && verticalComposable @c upperRight lowerRight + in not applicable || rightValuesEqual lhs rhs + +rightValuesEqual :: Eq value => Either left value -> Either right value -> Bool +rightValuesEqual left right = + case (left, right) of + (Right leftValue, Right rightValue) -> leftValue == rightValue + _ -> False + +horizontalComposable :: forall c. (HigherCategory c, Eq (Ob c)) => c -> TwoMor c -> TwoMor c -> Maybe Bool +horizontalComposable categoryValue left right = + liftA2 + (&&) + (endpointAgreement (sourceC @c categoryValue (source2 @c left)) (targetC @c categoryValue (source2 @c right))) + (endpointAgreement (sourceC @c categoryValue (target2 @c left)) (targetC @c categoryValue (target2 @c right))) + +endpointAgreement :: Eq object => Either left object -> Either right object -> Maybe Bool +endpointAgreement left right = + case (left, right) of + (Right leftObject, Right rightObject) -> Just (leftObject == rightObject) + _ -> Nothing + +verticalComposable :: forall c. (HigherCategory c, Eq (Mor c)) => TwoMor c -> TwoMor c -> Bool +verticalComposable left right = + target2 @c right == source2 @c left diff --git a/src-laws/Moonlight/Category/Effect/Harness/Limits.hs b/src-laws/Moonlight/Category/Effect/Harness/Limits.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Limits.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Executable checks for limit and colimit universal-property laws. +module Moonlight.Category.Effect.Harness.Limits + ( productProjection1, + productProjection2, + coproductInjection1, + coproductInjection2, + pullbackCommutative, + pushoutCommutative, + equalizerCommutative, + coequalizerCommutative, + ) +where + +import Moonlight.Category.Effect.Harness.Core (composeC, sourceC, targetC) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Limits + ( HasCoequalizers (..), + HasCoproducts (..), + HasEqualizers (..), + HasProducts (..), + HasPullbacks (..), + HasPushouts (..), + ) +import Prelude hiding (Functor) + +productProjection1 :: forall c. (HasProducts c, Eq (Mor c)) => c -> ProductOb c -> Mor c -> Mor c -> Bool +productProjection1 categoryValue productObject first second = + rightEquals (composeC @c categoryValue (productProj1 @c categoryValue productObject) (productUniversal @c categoryValue first second)) first + +productProjection2 :: forall c. (HasProducts c, Eq (Mor c)) => c -> ProductOb c -> Mor c -> Mor c -> Bool +productProjection2 categoryValue productObject first second = + rightEquals (composeC @c categoryValue (productProj2 @c categoryValue productObject) (productUniversal @c categoryValue first second)) second + +coproductInjection1 :: forall c. (HasCoproducts c, Eq (Mor c)) => c -> CoproductOb c -> Mor c -> Mor c -> Bool +coproductInjection1 categoryValue coproductObject first second = + rightEquals (composeC @c categoryValue (coproductUniversal @c categoryValue first second) (coproductInj1 @c categoryValue coproductObject)) first + +coproductInjection2 :: forall c. (HasCoproducts c, Eq (Mor c)) => c -> CoproductOb c -> Mor c -> Mor c -> Bool +coproductInjection2 categoryValue coproductObject first second = + rightEquals (composeC @c categoryValue (coproductUniversal @c categoryValue first second) (coproductInj2 @c categoryValue coproductObject)) second + +pullbackCommutative :: forall c. (HasPullbacks c, Eq (Mor c), Eq (Ob c)) => c -> Mor c -> Mor c -> Bool +pullbackCommutative categoryValue first second = + case endpointAgreement (targetC @c categoryValue first) (targetC @c categoryValue second) of + Nothing -> False + Just False -> True + Just True -> + case pullback @c categoryValue first second of + Nothing -> False + Just (_, leftLeg, rightLeg) -> + rightValuesEqual + (composeC @c categoryValue first leftLeg) + (composeC @c categoryValue second rightLeg) + +pushoutCommutative :: forall c. (HasPushouts c, Eq (Mor c), Eq (Ob c)) => c -> Mor c -> Mor c -> Bool +pushoutCommutative categoryValue first second = + case endpointAgreement (sourceC @c categoryValue first) (sourceC @c categoryValue second) of + Nothing -> False + Just False -> True + Just True -> + case pushout @c categoryValue first second of + Nothing -> False + Just (_, leftLeg, rightLeg) -> + rightValuesEqual + (composeC @c categoryValue leftLeg first) + (composeC @c categoryValue rightLeg second) + +equalizerCommutative :: forall c. (HasEqualizers c, Eq (Mor c), Eq (Ob c)) => c -> Mor c -> Mor c -> Bool +equalizerCommutative categoryValue first second = + case parallelMorphisms @c categoryValue first second of + Nothing -> False + Just False -> True + Just True -> + case equalizer @c categoryValue first second of + Nothing -> False + Just (_, equalizerMorphism) -> + rightValuesEqual + (composeC @c categoryValue first equalizerMorphism) + (composeC @c categoryValue second equalizerMorphism) + +coequalizerCommutative :: forall c. (HasCoequalizers c, Eq (Mor c), Eq (Ob c)) => c -> Mor c -> Mor c -> Bool +coequalizerCommutative categoryValue first second = + case parallelMorphisms @c categoryValue first second of + Nothing -> False + Just False -> True + Just True -> + case coequalizer @c categoryValue first second of + Nothing -> False + Just (_, coequalizerMorphism) -> + rightValuesEqual + (composeC @c categoryValue coequalizerMorphism first) + (composeC @c categoryValue coequalizerMorphism second) + +rightEquals :: Eq value => Either err value -> value -> Bool +rightEquals eitherValue expected = + case eitherValue of + Right value -> value == expected + Left _ -> False + +rightValuesEqual :: Eq value => Either left value -> Either right value -> Bool +rightValuesEqual left right = + case (left, right) of + (Right leftValue, Right rightValue) -> leftValue == rightValue + _ -> False + +endpointAgreement :: Eq object => Either left object -> Either right object -> Maybe Bool +endpointAgreement left right = + case (left, right) of + (Right leftObject, Right rightObject) -> Just (leftObject == rightObject) + _ -> Nothing + +parallelMorphisms :: forall c. (Category c, Eq (Ob c)) => c -> Mor c -> Mor c -> Maybe Bool +parallelMorphisms categoryValue first second = do + sourcesAgree <- endpointAgreement (sourceC @c categoryValue first) (sourceC @c categoryValue second) + targetsAgree <- endpointAgreement (targetC @c categoryValue first) (targetC @c categoryValue second) + pure (sourcesAgree && targetsAgree) diff --git a/src-laws/Moonlight/Category/Effect/Harness/Site.hs b/src-laws/Moonlight/Category/Effect/Harness/Site.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Harness/Site.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Builds the t'SiteLaws' record for a site presentation. +module Moonlight.Category.Effect.Harness.Site + ( mkSiteLaws, + ) +where + +import Data.Function ((&)) +import qualified Data.Set as Set +import Moonlight.Category.Effect.Harness.Category (mkCategoryLaws) +import Moonlight.Category.Effect.Harness.Core (CategoryLaws (..), SiteLaws (..)) +import Moonlight.Category.Pure.FinCat (FinCat, allMorphisms) +import Moonlight.Category.Pure.Site + ( SiteManifest, + SiteViolation (..), + siteImportsAsFinCat, + siteImportEdges, + validateSiteManifest, + ) +import Prelude hiding (Functor) + +mkSiteLaws :: forall obj layer. Ord obj => SiteLaws obj layer +mkSiteLaws = + SiteLaws + { siteCoverageClosure = siteCoverageClosureLaw @obj, + siteCategoryIdentity = siteCategoryIdentityLaw @obj, + siteCategoryAssociativity = siteCategoryAssociativityLaw @obj, + siteLayerPolicyConformance = siteLayerPolicyConformanceLaw @obj @layer + } + +siteCoverageClosureLaw :: forall obj. Ord obj => SiteManifest obj -> Bool +siteCoverageClosureLaw manifest = + validateSiteManifest manifest + & all + ( \violation -> + case violation of + CoverOutsideReachable {} -> False + CoverNotClosed {} -> False + MissingCover {} -> False + _ -> True + ) + +siteCategoryIdentityLaw :: forall obj. Ord obj => SiteManifest obj -> Bool +siteCategoryIdentityLaw manifest = + case siteImportsAsFinCat manifest of + Left _ -> False + Right finCategory -> + let morphisms = allMorphisms finCategory + laws = mkCategoryLaws @FinCat finCategory + in all (categoryLeftIdentity laws) morphisms + && all (categoryRightIdentity laws) morphisms + +siteCategoryAssociativityLaw :: forall obj. Ord obj => SiteManifest obj -> Bool +siteCategoryAssociativityLaw manifest = + case siteImportsAsFinCat manifest of + Left _ -> False + Right finCategory -> + let morphisms = allMorphisms finCategory + laws = mkCategoryLaws @FinCat finCategory + in [ (firstValue, secondValue, thirdValue) + | firstValue <- morphisms, + secondValue <- morphisms, + thirdValue <- morphisms + ] + & all + ( \(firstValue, secondValue, thirdValue) -> + categoryAssociativity laws firstValue secondValue thirdValue + ) + +siteLayerPolicyConformanceLaw :: forall obj layer. Ord obj => (obj -> layer) -> (layer -> layer -> Bool) -> SiteManifest obj -> Bool +siteLayerPolicyConformanceLaw layerOf isAllowed manifest = + siteImportEdges manifest + & Set.toList + & all + ( \(importer, imported) -> + isAllowed (layerOf importer) (layerOf imported) + ) diff --git a/src-laws/Moonlight/Category/Effect/LawNames.hs b/src-laws/Moonlight/Category/Effect/LawNames.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/LawNames.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DerivingStrategies #-} + +-- | The 'LawName' registry: one constructor per law exercised by the suite. +-- Renderings derive from constructors, so a rename breaks the build. +module Moonlight.Category.Effect.LawNames + ( LawName (..), + lawName, + ) +where + +import Data.Kind (Type) +import Moonlight.Core (IsLawName (..), constructorLawNameWithOverrides) + +type LawName :: Type +data LawName + = FinCatWellFormed + | SiteCoverageClosure + | SiteCategoryIdentity + | SiteCategoryAssociativity + | SiteLayerPolicyConformance + | SiteFreePathWitness + | SiteQuotientCoherence + | SiteQuotientIdentity + | SiteQuotientComposition + | PathThinCodomainIdentity + | PathThinCodomainComposition + | PathQuotientUniqueness + | PathQuotientFaithful + | PathQuotientInterpreterCoherence + | CategoryLeftId + | CategoryRightId + | CategoryAssoc + | GaloisAdjoint + | GaloisDeflation + | GaloisInflation + | GaloisRetraction + | OrdinalGaloisMonotone + | ProductProj1 + | ProductProj2 + | CoproductInj1 + | CoproductInj2 + | PullbackCommutes + | PushoutCommutes + | AdhesiveWitnessMonicSound + | PushoutComplementSquareCommutes + | PushoutComplementUniversal + | PBPOPullbackSquareCommutes + | PBPOPushoutSquareCommutes + | PBPOComplementUniversal + | EqualizerCommutes + | CoequalizerCommutes + | HigherHorizontalBoundary + | HigherVerticalBoundary + | HigherInterchange + deriving stock (Eq, Ord, Show) + +instance IsLawName LawName where + lawNameText = lawName + +lawName :: LawName -> String +lawName = + constructorLawNameWithOverrides [("FinCatWellFormed", "fincat_well_formed"), ("ProductProj1", "limits_product_proj1"), ("ProductProj2", "limits_product_proj2"), ("CoproductInj1", "limits_coproduct_inj1"), ("CoproductInj2", "limits_coproduct_inj2"), ("PullbackCommutes", "limits_pullback_commutes"), ("PushoutCommutes", "limits_pushout_commutes"), ("EqualizerCommutes", "limits_equalizer_commutes"), ("CoequalizerCommutes", "limits_coequalizer_commutes")] . show diff --git a/src-laws/Moonlight/Category/Effect/Laws.hs b/src-laws/Moonlight/Category/Effect/Laws.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws.hs @@ -0,0 +1,30 @@ +-- | The aggregated law suite: every subtree from the per-domain law modules, +-- rendered as one tasty tree. +module Moonlight.Category.Effect.Laws + ( tests, + ) +where + +import qualified Moonlight.Category.Effect.Laws.Algebra as Algebra +import qualified Moonlight.Category.Effect.Laws.Adhesive as Adhesive +import qualified Moonlight.Category.Effect.Laws.Category as Category +import qualified Moonlight.Category.Effect.Laws.Generators as Generators +import qualified Moonlight.Category.Effect.Laws.Higher as Higher +import qualified Moonlight.Category.Effect.Laws.Limits as Limits +import qualified Moonlight.Category.Effect.Laws.Site as Site +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, renderLawSuite) +import Test.Tasty (TestTree) + +tests :: TestTree +tests = + renderLawSuite (lawGroup "moonlight-category" categoryLawSuites) + +categoryLawSuites :: [LawSuite] +categoryLawSuites = + Site.lawSuites + <> Category.lawSuites + <> Algebra.lawSuites + <> Limits.lawSuites + <> Adhesive.lawSuites + <> Higher.lawSuites + <> Generators.lawSuites diff --git a/src-laws/Moonlight/Category/Effect/Laws/Adhesive.hs b/src-laws/Moonlight/Category/Effect/Laws/Adhesive.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Adhesive.hs @@ -0,0 +1,60 @@ +module Moonlight.Category.Effect.Laws.Adhesive + ( lawSuites, + ) +where + +import qualified Moonlight.Category.Effect.Harness as Harness +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators (SampleUnitMorphism (..)) +import Moonlight.Category.Pure.Adhesive (PBPOComplementWitness, PushoutComplementWitness) +import Moonlight.Category.Pure.Unit (UnitCat (..), UnitMor) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, namedQuickCheckLaw) + +adhesiveWitnessMonicSoundProp :: SampleUnitMorphism -> Bool +adhesiveWitnessMonicSoundProp (SampleUnitMorphism morphism) = + Harness.adhesiveWitnessMonicSound @UnitCat UnitCat unitMorphismIsMonic morphism + +pushoutComplementSquareProp :: SampleUnitMorphism -> Bool +pushoutComplementSquareProp (SampleUnitMorphism morphism) = + Harness.pushoutComplementSquareCommutes @UnitCat UnitCat morphism morphism + +pushoutComplementUniversalProp :: SampleUnitMorphism -> Bool +pushoutComplementUniversalProp (SampleUnitMorphism morphism) = + Harness.pushoutComplementUniversal @UnitCat UnitCat unitPushoutComplementUniversal morphism morphism + +pbpoPullbackSquareProp :: SampleUnitMorphism -> Bool +pbpoPullbackSquareProp (SampleUnitMorphism morphism) = + Harness.pbpoPullbackSquareCommutes @UnitCat UnitCat morphism morphism + +pbpoPushoutSquareProp :: SampleUnitMorphism -> Bool +pbpoPushoutSquareProp (SampleUnitMorphism morphism) = + Harness.pbpoPushoutSquareCommutes @UnitCat UnitCat morphism morphism + +pbpoComplementUniversalProp :: SampleUnitMorphism -> Bool +pbpoComplementUniversalProp (SampleUnitMorphism morphism) = + Harness.pbpoComplementUniversal @UnitCat UnitCat unitPBPOComplementUniversal morphism morphism + +unitMorphismIsMonic :: UnitMor -> Bool +unitMorphismIsMonic _ = + True + +unitPushoutComplementUniversal :: PushoutComplementWitness UnitCat -> Bool +unitPushoutComplementUniversal _ = + True + +unitPBPOComplementUniversal :: PBPOComplementWitness UnitCat -> Bool +unitPBPOComplementUniversal _ = + True + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "adhesive" + [ namedQuickCheckLaw AdhesiveWitnessMonicSound adhesiveWitnessMonicSoundProp, + namedQuickCheckLaw PushoutComplementSquareCommutes pushoutComplementSquareProp, + namedQuickCheckLaw PushoutComplementUniversal pushoutComplementUniversalProp, + namedQuickCheckLaw PBPOPullbackSquareCommutes pbpoPullbackSquareProp, + namedQuickCheckLaw PBPOPushoutSquareCommutes pbpoPushoutSquareProp, + namedQuickCheckLaw PBPOComplementUniversal pbpoComplementUniversalProp + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Algebra.hs b/src-laws/Moonlight/Category/Effect/Laws/Algebra.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Algebra.hs @@ -0,0 +1,47 @@ +module Moonlight.Category.Effect.Laws.Algebra + ( lawSuites, + ) +where + +import qualified Moonlight.Category.Effect.Harness as Harness +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators + ( SampleOrdinalLower (..), + SampleOrdinalUpper (..), + ) +import Moonlight.Category.Pure.Poset + ( OrdinalLower, + OrdinalUpper, + ) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, namedQuickCheckLaw) + +galoisAdjointProp :: SampleOrdinalLower -> SampleOrdinalUpper -> Bool +galoisAdjointProp (SampleOrdinalLower leftValue) (SampleOrdinalUpper rightValue) = + Harness.galoisAdjoint @OrdinalLower @OrdinalUpper leftValue rightValue + +galoisDeflationProp :: SampleOrdinalUpper -> Bool +galoisDeflationProp (SampleOrdinalUpper rightValue) = + Harness.galoisDeflation @OrdinalLower @OrdinalUpper rightValue + +galoisInflationProp :: SampleOrdinalLower -> Bool +galoisInflationProp (SampleOrdinalLower leftValue) = + Harness.galoisInflation @OrdinalLower @OrdinalUpper leftValue + +galoisRetractionProp :: SampleOrdinalLower -> Bool +galoisRetractionProp (SampleOrdinalLower leftValue) = + Harness.galoisRetraction @OrdinalLower @OrdinalUpper leftValue + +ordinalMonotoneProp :: Bool +ordinalMonotoneProp = Harness.ordinalGaloisMonotone @OrdinalLower @OrdinalUpper + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "galois" + [ namedQuickCheckLaw GaloisAdjoint galoisAdjointProp, + namedQuickCheckLaw GaloisDeflation galoisDeflationProp, + namedQuickCheckLaw GaloisInflation galoisInflationProp, + namedQuickCheckLaw GaloisRetraction galoisRetractionProp, + namedQuickCheckLaw OrdinalGaloisMonotone ordinalMonotoneProp + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Category.hs b/src-laws/Moonlight/Category/Effect/Laws/Category.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Category.hs @@ -0,0 +1,43 @@ +module Moonlight.Category.Effect.Laws.Category + ( lawSuites, + ) +where + +import qualified Moonlight.Category.Effect.Harness as Harness +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators + ( SampleComposableFinTriple (..), + SampleFinMorphism (..), + ) +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Pure.FinCat (FinCat) +import Moonlight.Pale.Test.Laws.Suite + ( LawSuite, + lawGroup, + namedQuickCheckLaw, + ) + +finCategoryLaws :: Harness.CategoryLaws FinCat +finCategoryLaws = Harness.mkCategoryLaws @FinCat sampleFinCat + +categoryLeftIdProp :: SampleFinMorphism -> Bool +categoryLeftIdProp (SampleFinMorphism morphism) = + Harness.categoryLeftIdentity finCategoryLaws morphism + +categoryRightIdProp :: SampleFinMorphism -> Bool +categoryRightIdProp (SampleFinMorphism morphism) = + Harness.categoryRightIdentity finCategoryLaws morphism + +categoryAssocProp :: SampleComposableFinTriple -> Bool +categoryAssocProp (SampleComposableFinTriple firstValue secondValue thirdValue) = + Harness.categoryAssociativity finCategoryLaws firstValue secondValue thirdValue + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "category" + [ namedQuickCheckLaw CategoryLeftId categoryLeftIdProp, + namedQuickCheckLaw CategoryRightId categoryRightIdProp, + namedQuickCheckLaw CategoryAssoc categoryAssocProp + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Generators.hs b/src-laws/Moonlight/Category/Effect/Laws/Generators.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Generators.hs @@ -0,0 +1,228 @@ + +{-# LANGUAGE DerivingStrategies #-} + +module Moonlight.Category.Effect.Laws.Generators + ( SampleFinObject (..), + SampleFinMorphism (..), + SampleComposableFinTriple (..), + SampleOrdinalLower (..), + SampleOrdinalUpper (..), + SampleLowerObject (..), + SampleUpperObject (..), + SampleLowerMorphism (..), + SampleUpperMorphism (..), + SampleUnitObject (..), + SampleUnitMorphism (..), + SampleUnitTwoMorphism (..), + allPairs, + lawSuites, + ) +where + +import Data.Kind (Type) +import Data.Function ((&)) +import Data.Maybe (mapMaybe) +import qualified Hedgehog as HH +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Pure.FinCat + ( FinMor, + FinObj, + allMorphisms, + allObjects, + ) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.Poset + ( LowerMor, + OrdinalLower (..), + OrdinalUpper (..), + PosetOb (..), + UpperMor, + mkLowerMor, + mkUpperMor, + ) +import Moonlight.Category.Pure.Unit + ( UnitMor (..), + UnitObj (..), + UnitTwoMor (..), + ) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, hedgehogLaw, lawGroup) +import qualified Test.Tasty.QuickCheck as QC + +type SampleFinObject :: Type +newtype SampleFinObject = SampleFinObject {unSampleFinObject :: FinObj} + deriving stock (Show) + +type SampleFinMorphism :: Type +newtype SampleFinMorphism = SampleFinMorphism {unSampleFinMorphism :: FinMor} + deriving stock (Show) + +type SampleComposableFinTriple :: Type +data SampleComposableFinTriple = SampleComposableFinTriple FinMor FinMor FinMor + deriving stock (Show) + +type SampleOrdinalLower :: Type +newtype SampleOrdinalLower = SampleOrdinalLower {unSampleOrdinalLower :: OrdinalLower} + deriving stock (Show) + +type SampleOrdinalUpper :: Type +newtype SampleOrdinalUpper = SampleOrdinalUpper {unSampleOrdinalUpper :: OrdinalUpper} + deriving stock (Show) + +type SampleLowerObject :: Type +newtype SampleLowerObject = SampleLowerObject {unSampleLowerObject :: PosetOb OrdinalLower} + deriving stock (Show) + +type SampleUpperObject :: Type +newtype SampleUpperObject = SampleUpperObject {unSampleUpperObject :: PosetOb OrdinalUpper} + deriving stock (Show) + +type SampleLowerMorphism :: Type +newtype SampleLowerMorphism = SampleLowerMorphism {unSampleLowerMorphism :: LowerMor} + deriving stock (Show) + +type SampleUpperMorphism :: Type +newtype SampleUpperMorphism = SampleUpperMorphism {unSampleUpperMorphism :: UpperMor} + deriving stock (Show) + +type SampleUnitObject :: Type +newtype SampleUnitObject = SampleUnitObject {unSampleUnitObject :: UnitObj} + deriving stock (Show) + +type SampleUnitMorphism :: Type +newtype SampleUnitMorphism = SampleUnitMorphism {unSampleUnitMorphism :: UnitMor} + deriving stock (Show) + +type SampleUnitTwoMorphism :: Type +newtype SampleUnitTwoMorphism = SampleUnitTwoMorphism {unSampleUnitTwoMorphism :: UnitTwoMor} + deriving stock (Show) + +sampleObjects :: [FinObj] +sampleObjects = allObjects sampleFinCat + +sampleMorphisms :: [FinMor] +sampleMorphisms = allMorphisms sampleFinCat + +sampleComposableFinTriples :: [SampleComposableFinTriple] +sampleComposableFinTriples = + sampleMorphisms + >>= ( \firstMorphism -> + sampleMorphisms + >>= ( \secondMorphism -> + sampleMorphisms + & foldMap + ( \thirdMorphism -> + case + ( target sampleFinCat firstMorphism, + source sampleFinCat secondMorphism, + target sampleFinCat secondMorphism, + source sampleFinCat thirdMorphism + ) + of + (Right firstTarget, Right secondSource, Right secondTarget, Right thirdSource) + | firstTarget == secondSource && secondTarget == thirdSource -> + [SampleComposableFinTriple firstMorphism secondMorphism thirdMorphism] + _ -> [] + ) + ) + ) + +lowerMorphismSamples :: [LowerMor] +lowerMorphismSamples = + [0 .. 32] + >>= ( \lower -> + mapMaybe (mkLowerMor (OrdinalLower lower) . OrdinalLower) [lower .. 32] + ) + +upperMorphismSamples :: [UpperMor] +upperMorphismSamples = + [0 .. 64] + >>= ( \lower -> + mapMaybe (mkUpperMor (OrdinalUpper lower) . OrdinalUpper) [lower .. 64] + ) + +instance QC.Arbitrary SampleFinObject where + arbitrary = SampleFinObject <$> QC.elements sampleObjects + shrink _ = [] + +instance QC.Arbitrary SampleFinMorphism where + arbitrary = SampleFinMorphism <$> QC.elements sampleMorphisms + shrink _ = [] + +instance QC.Arbitrary SampleComposableFinTriple where + arbitrary = QC.elements sampleComposableFinTriples + shrink _ = [] + +instance QC.Arbitrary SampleOrdinalLower where + arbitrary = SampleOrdinalLower . OrdinalLower <$> QC.chooseInt (0, 32) + shrink (SampleOrdinalLower (OrdinalLower value)) = + map (SampleOrdinalLower . OrdinalLower) (QC.shrink value) + +instance QC.Arbitrary SampleOrdinalUpper where + arbitrary = SampleOrdinalUpper . OrdinalUpper <$> QC.chooseInt (0, 64) + shrink (SampleOrdinalUpper (OrdinalUpper value)) = + map (SampleOrdinalUpper . OrdinalUpper) (QC.shrink value) + +instance QC.Arbitrary SampleLowerObject where + arbitrary = SampleLowerObject . PosetOb . OrdinalLower <$> QC.chooseInt (0, 32) + shrink (SampleLowerObject (PosetOb (OrdinalLower value))) = + map (SampleLowerObject . PosetOb . OrdinalLower) (QC.shrink value) + +instance QC.Arbitrary SampleUpperObject where + arbitrary = SampleUpperObject . PosetOb . OrdinalUpper <$> QC.chooseInt (0, 64) + shrink (SampleUpperObject (PosetOb (OrdinalUpper value))) = + map (SampleUpperObject . PosetOb . OrdinalUpper) (QC.shrink value) + +instance QC.Arbitrary SampleLowerMorphism where + arbitrary = SampleLowerMorphism <$> QC.elements lowerMorphismSamples + shrink _ = [] + +instance QC.Arbitrary SampleUpperMorphism where + arbitrary = SampleUpperMorphism <$> QC.elements upperMorphismSamples + shrink _ = [] + +instance QC.Arbitrary SampleUnitObject where + arbitrary = pure (SampleUnitObject UnitObj) + shrink _ = [] + +instance QC.Arbitrary SampleUnitMorphism where + arbitrary = pure (SampleUnitMorphism UnitMor) + shrink _ = [] + +instance QC.Arbitrary SampleUnitTwoMorphism where + arbitrary = pure (SampleUnitTwoMorphism (UnitTwoMor UnitMor UnitMor)) + shrink _ = [] + +hedgehogSampleFinObject :: HH.Gen FinObj +hedgehogSampleFinObject = Gen.element sampleObjects + +hedgehogSampleFinMorphism :: HH.Gen FinMor +hedgehogSampleFinMorphism = Gen.element sampleMorphisms + +finObjectGeneratorSound :: FinObj -> Bool +finObjectGeneratorSound objectValue = objectValue `elem` sampleObjects + +finMorphismGeneratorSound :: FinMor -> Bool +finMorphismGeneratorSound morphism = morphism `elem` sampleMorphisms + +allPairs :: [a] -> [(a, a)] +allPairs values = + values >>= (\leftValue -> fmap (\rightValue -> (leftValue, rightValue)) values) + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "generators" + [ hedgehogLaw "generator_fin_object_sound" hedgehogSampleFinObject finObjectGeneratorSound, + hedgehogLaw "generator_fin_morphism_sound" hedgehogSampleFinMorphism finMorphismGeneratorSound, + hedgehogLaw + "generator_ordinal_lower_bounds" + (OrdinalLower <$> Gen.int (Range.linear 0 32)) + (\(OrdinalLower value) -> value >= 0 && value <= 32), + hedgehogLaw + "generator_ordinal_upper_bounds" + (OrdinalUpper <$> Gen.int (Range.linear 0 64)) + (\(OrdinalUpper value) -> value >= 0 && value <= 64) + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Higher.hs b/src-laws/Moonlight/Category/Effect/Laws/Higher.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Higher.hs @@ -0,0 +1,40 @@ +module Moonlight.Category.Effect.Laws.Higher + ( lawSuites, + ) +where + +import qualified Moonlight.Category.Effect.Harness as Harness +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators + ( SampleUnitTwoMorphism (..), + ) +import Moonlight.Category.Pure.Unit + ( UnitCat (..), + ) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, namedQuickCheckLaw) + +higherHorizontalProp :: SampleUnitTwoMorphism -> SampleUnitTwoMorphism -> Bool +higherHorizontalProp (SampleUnitTwoMorphism leftValue) (SampleUnitTwoMorphism rightValue) = + Harness.horizontalBoundary @UnitCat UnitCat leftValue rightValue + +higherVerticalProp :: SampleUnitTwoMorphism -> SampleUnitTwoMorphism -> Bool +higherVerticalProp (SampleUnitTwoMorphism leftValue) (SampleUnitTwoMorphism rightValue) = + Harness.verticalBoundary @UnitCat UnitCat leftValue rightValue + +higherInterchangeProp :: SampleUnitTwoMorphism -> SampleUnitTwoMorphism -> SampleUnitTwoMorphism -> SampleUnitTwoMorphism -> Bool +higherInterchangeProp + (SampleUnitTwoMorphism upperLeftValue) + (SampleUnitTwoMorphism upperRightValue) + (SampleUnitTwoMorphism lowerLeftValue) + (SampleUnitTwoMorphism lowerRightValue) = + Harness.interchange @UnitCat UnitCat upperLeftValue upperRightValue lowerLeftValue lowerRightValue + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "higher" + [ namedQuickCheckLaw HigherHorizontalBoundary higherHorizontalProp, + namedQuickCheckLaw HigherVerticalBoundary higherVerticalProp, + namedQuickCheckLaw HigherInterchange higherInterchangeProp + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Limits.hs b/src-laws/Moonlight/Category/Effect/Laws/Limits.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Limits.hs @@ -0,0 +1,61 @@ + +module Moonlight.Category.Effect.Laws.Limits + ( lawSuites, + ) +where + +import qualified Moonlight.Category.Effect.Harness as Harness +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators + ( SampleUnitMorphism (..), + SampleUnitObject (..), + ) +import Moonlight.Category.Pure.Unit (UnitCat (..), UnitMor (..)) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, namedQuickCheckLaw) + +productProj1Prop :: SampleUnitObject -> Bool +productProj1Prop (SampleUnitObject productObject) = + Harness.productProjection1 @UnitCat UnitCat productObject UnitMor UnitMor + +productProj2Prop :: SampleUnitObject -> Bool +productProj2Prop (SampleUnitObject productObject) = + Harness.productProjection2 @UnitCat UnitCat productObject UnitMor UnitMor + +coproductInj1Prop :: SampleUnitObject -> Bool +coproductInj1Prop (SampleUnitObject coproductObject) = + Harness.coproductInjection1 @UnitCat UnitCat coproductObject UnitMor UnitMor + +coproductInj2Prop :: SampleUnitObject -> Bool +coproductInj2Prop (SampleUnitObject coproductObject) = + Harness.coproductInjection2 @UnitCat UnitCat coproductObject UnitMor UnitMor + +pullbackProp :: SampleUnitMorphism -> Bool +pullbackProp (SampleUnitMorphism morphism) = + Harness.pullbackCommutative @UnitCat UnitCat morphism morphism + +pushoutProp :: SampleUnitMorphism -> Bool +pushoutProp (SampleUnitMorphism morphism) = + Harness.pushoutCommutative @UnitCat UnitCat morphism morphism + +equalizerProp :: SampleUnitMorphism -> Bool +equalizerProp (SampleUnitMorphism morphism) = + Harness.equalizerCommutative @UnitCat UnitCat morphism morphism + +coequalizerProp :: SampleUnitMorphism -> Bool +coequalizerProp (SampleUnitMorphism morphism) = + Harness.coequalizerCommutative @UnitCat UnitCat morphism morphism + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "limits" + [ namedQuickCheckLaw ProductProj1 productProj1Prop, + namedQuickCheckLaw ProductProj2 productProj2Prop, + namedQuickCheckLaw CoproductInj1 coproductInj1Prop, + namedQuickCheckLaw CoproductInj2 coproductInj2Prop, + namedQuickCheckLaw PullbackCommutes pullbackProp, + namedQuickCheckLaw PushoutCommutes pushoutProp, + namedQuickCheckLaw EqualizerCommutes equalizerProp, + namedQuickCheckLaw CoequalizerCommutes coequalizerProp + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/Laws/Site.hs b/src-laws/Moonlight/Category/Effect/Laws/Site.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/Laws/Site.hs @@ -0,0 +1,229 @@ +module Moonlight.Category.Effect.Laws.Site + ( lawSuites, + ) +where + +import Data.Either (isRight) +import Data.Function ((&)) +import Data.Maybe (mapMaybe) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Moonlight.Category.Effect.Harness as Harness +import qualified Moonlight.Category.Effect.PathQuotientHarness as PathQuotientHarness +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Effect.LawNames (LawName (..)) +import Moonlight.Category.Effect.Laws.Generators (allPairs) +import Moonlight.Category.Effect.SiteGen (diamondManifest) +import Moonlight.Category.Pure.Category (Category (..), Mor, Ob) +import Moonlight.Category.Pure.FinCat + ( finCatExplicitCompositionMapView, + finCatExplicitMorphismMapView, + finCatObjects, + mkFinCat, + ) +import Moonlight.Category.Pure.Site + ( SiteManifest (..), + SitePathCategory, + mkSitePathObject, + pathThinCat, + pathThinCodomainMorphism, + pathThinCodomainObject, + quotientPathThinMorphism, + quotientPathThinObject, + siteImportsAsFinCat, + sitePathCategory, + sitePathManifest, + sitePathMorphismsBetween, + thinPresentationToFinCat, + thinSiteKernel, + thinSitePresentation, + ) +import Moonlight.Pale.Test.Laws.Suite (LawSuite, lawGroup, namedQuickCheckLaw) + +sampleSiteManifest :: SiteManifest Int +sampleSiteManifest = + SiteManifest + { siteObjects = sampleSiteObjects, + siteImports = sampleSiteImports, + siteCovers = sampleSiteCovers + } + +sampleDiamondPathCategory :: Either () (SitePathCategory Int) +sampleDiamondPathCategory = + case thinSiteKernel diamondManifest of + Left _ -> Left () + Right kernel -> Right (sitePathCategory kernel) + +sampleSiteObjects :: Set.Set Int +sampleSiteObjects = Set.fromList [0, 1, 2, 3] + +sampleSiteImports :: Map.Map Int (Set.Set Int) +sampleSiteImports = + Map.fromList + [ (0, Set.empty), + (1, Set.singleton 0), + (2, Set.singleton 1), + (3, Set.fromList [1, 2]) + ] + +sampleSiteCovers :: Map.Map Int (Set.Set Int) +sampleSiteCovers = + Map.fromList + [ (0, Set.empty), + (1, Set.singleton 0), + (2, Set.fromList [0, 1]), + (3, Set.fromList [0, 1, 2]) + ] + +sampleLayerOf :: Int -> Int +sampleLayerOf objectValue = + case objectValue of + 0 -> 0 + 1 -> 1 + 2 -> 2 + _ -> 3 + +sampleLayerPolicy :: Int -> Int -> Bool +sampleLayerPolicy importer imported = imported <= importer + +fincatWellFormedLaw :: Bool +fincatWellFormedLaw = + isRight + ( mkFinCat + (finCatObjects sampleFinCat) + (finCatExplicitMorphismMapView sampleFinCat) + (finCatExplicitCompositionMapView sampleFinCat) + ) + && thinSiteFinCatGenericAgreementLaw + +thinSiteFinCatGenericAgreementLaw :: Bool +thinSiteFinCatGenericAgreementLaw = + case (siteImportsAsFinCat diamondManifest, thinSiteKernel diamondManifest) of + (Right thinDerived, Right kernel) -> + case thinPresentationToFinCat (thinSitePresentation kernel) of + Left _ -> False + Right genericallyChecked -> + thinDerived == genericallyChecked + && finCatObjects thinDerived == finCatObjects genericallyChecked + && finCatExplicitMorphismMapView thinDerived == finCatExplicitMorphismMapView genericallyChecked + && finCatExplicitCompositionMapView thinDerived == finCatExplicitCompositionMapView genericallyChecked + _ -> False + +siteQuotientIdentityLaw :: SitePathCategory Int -> Bool +siteQuotientIdentityLaw category = + let thinCategory = pathThinCat category + in all + ( \objectValue -> + case (identity category objectValue, identity thinCategory (quotientPathThinObject objectValue)) of + (Right domainIdentity, Right thinIdentity) -> quotientPathThinMorphism domainIdentity == thinIdentity + _ -> False + ) + (sitePathObjects category) + +siteQuotientCompositionLaw :: SitePathCategory Int -> Bool +siteQuotientCompositionLaw category = + let thinCategory = pathThinCat category + in all + ( \(leftValue, rightValue) -> + case compose category leftValue rightValue of + Left _ -> True + Right (composedDomain, _) -> + case compose thinCategory (quotientPathThinMorphism leftValue) (quotientPathThinMorphism rightValue) of + Left _ -> False + Right (composedThin, _) -> quotientPathThinMorphism composedDomain == composedThin + ) + (allPairs (sitePathMorphisms category)) + +pathThinCodomainIdentityLaw :: SitePathCategory Int -> Bool +pathThinCodomainIdentityLaw category = + case siteImportsAsFinCat (sitePathManifest category) of + Left _ -> False + Right finCategory -> + let thinCategory = pathThinCat category + in all + ( \sitePathObject -> + let objectValue = quotientPathThinObject sitePathObject + in case (identity thinCategory objectValue, identity finCategory (pathThinCodomainObject objectValue)) of + (Right thinIdentity, Right finIdentity) -> pathThinCodomainMorphism thinIdentity == finIdentity + _ -> False + ) + (sitePathObjects category) + +pathThinCodomainCompositionLaw :: SitePathCategory Int -> Bool +pathThinCodomainCompositionLaw category = + case siteImportsAsFinCat (sitePathManifest category) of + Left _ -> False + Right finCategory -> + let thinCategory = pathThinCat category + in all + ( \(leftValue, rightValue) -> + case compose thinCategory leftValue rightValue of + Left _ -> True + Right (composedThin, _) -> + case compose finCategory (pathThinCodomainMorphism leftValue) (pathThinCodomainMorphism rightValue) of + Left _ -> False + Right (composedFin, _) -> pathThinCodomainMorphism composedThin == composedFin + ) + (sitePathMorphisms category & fmap quotientPathThinMorphism & allPairs) + +pathQuotientUniquenessLaw :: SitePathCategory Int -> Bool +pathQuotientUniquenessLaw category = + diamondHasMultiplePathWitnesses category + && all + ( \(sourceValue, targetValue) -> + PathQuotientHarness.quotientUniquenessPerEndpoint @Int category sourceValue targetValue + ) + (siteObjects (sitePathManifest category) & Set.toList & allPairs) + +diamondHasMultiplePathWitnesses :: SitePathCategory Int -> Bool +diamondHasMultiplePathWitnesses category = + length (sitePathMorphismsBetween category 0 3) >= 2 + +pathQuotientFaithfulLaw :: SitePathCategory Int -> Bool +pathQuotientFaithfulLaw = + PathQuotientHarness.pathThinCodomainFaithful @Int + +pathQuotientInterpreterCoherenceLaw :: SitePathCategory Int -> Bool +pathQuotientInterpreterCoherenceLaw = + PathQuotientHarness.quotientInterpreterCoherence @Int + +sitePathObjects :: SitePathCategory Int -> [Ob (SitePathCategory Int)] +sitePathObjects category = + siteObjects (sitePathManifest category) + & Set.toList + & mapMaybe (mkSitePathObject category) + +sitePathMorphisms :: SitePathCategory Int -> [Mor (SitePathCategory Int)] +sitePathMorphisms category = + siteObjects (sitePathManifest category) + & Set.toList + & allPairs + >>= (\(sourceValue, targetValue) -> sitePathMorphismsBetween category sourceValue targetValue) + +withSampleDiamondPathCategory :: (SitePathCategory Int -> Bool) -> Bool +withSampleDiamondPathCategory predicate = + case sampleDiamondPathCategory of + Left () -> False + Right category -> predicate category + +sampleSiteLaws :: Harness.SiteLaws Int Int +sampleSiteLaws = Harness.mkSiteLaws @Int @Int + +lawSuites :: [LawSuite] +lawSuites = + [ lawGroup + "site" + [ namedQuickCheckLaw FinCatWellFormed fincatWellFormedLaw, + namedQuickCheckLaw SiteCoverageClosure (Harness.siteCoverageClosure sampleSiteLaws sampleSiteManifest), + namedQuickCheckLaw SiteCategoryIdentity (Harness.siteCategoryIdentity sampleSiteLaws sampleSiteManifest), + namedQuickCheckLaw SiteCategoryAssociativity (Harness.siteCategoryAssociativity sampleSiteLaws sampleSiteManifest), + namedQuickCheckLaw SiteLayerPolicyConformance (Harness.siteLayerPolicyConformance sampleSiteLaws sampleLayerOf sampleLayerPolicy sampleSiteManifest), + namedQuickCheckLaw SiteQuotientIdentity (withSampleDiamondPathCategory siteQuotientIdentityLaw), + namedQuickCheckLaw SiteQuotientComposition (withSampleDiamondPathCategory siteQuotientCompositionLaw), + namedQuickCheckLaw PathThinCodomainIdentity (withSampleDiamondPathCategory pathThinCodomainIdentityLaw), + namedQuickCheckLaw PathThinCodomainComposition (withSampleDiamondPathCategory pathThinCodomainCompositionLaw), + namedQuickCheckLaw PathQuotientUniqueness (withSampleDiamondPathCategory pathQuotientUniquenessLaw), + namedQuickCheckLaw PathQuotientFaithful (withSampleDiamondPathCategory pathQuotientFaithfulLaw), + namedQuickCheckLaw PathQuotientInterpreterCoherence (withSampleDiamondPathCategory pathQuotientInterpreterCoherenceLaw) + ] + ] diff --git a/src-laws/Moonlight/Category/Effect/PathQuotientHarness.hs b/src-laws/Moonlight/Category/Effect/PathQuotientHarness.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/PathQuotientHarness.hs @@ -0,0 +1,73 @@ +-- | Executable checks for path-quotient uniqueness, faithfulness, and +-- interpreter coherence. +module Moonlight.Category.Effect.PathQuotientHarness + ( quotientUniquenessPerEndpoint, + pathThinCodomainFaithful, + quotientInterpreterCoherence, + ) +where + +import Data.Function ((&)) +import Moonlight.Category.Effect.Laws.Generators (allPairs) +import Moonlight.Category.Effect.SitePathEnumeration + ( allEqual, + sitePathMorphisms, + sitePathObjects, + ) +import Moonlight.Category.Pure.Site + ( SitePathCategory, + pathThinCodomainMorphism, + pathThinCodomainObject, + quotientMapMorphism, + quotientMapObject, + quotientPathThinMorphism, + quotientPathThinObject, + sitePathMorphismsBetween, + sitePathQuotient, + ) + +quotientUniquenessPerEndpoint :: forall obj. Ord obj => SitePathCategory obj -> obj -> obj -> Bool +quotientUniquenessPerEndpoint category sourceValue targetValue = + sitePathMorphismsBetween category sourceValue targetValue + & fmap quotientPathThinMorphism + & allEqual + +pathThinCodomainFaithful :: forall obj. Ord obj => SitePathCategory obj -> Bool +pathThinCodomainFaithful category = + let mappedMorphisms = + sitePathMorphisms category + & fmap quotientPathThinMorphism + in all + ( \pairValue -> + let leftValue = fst pairValue + rightValue = snd pairValue + mappedLeft = pathThinCodomainMorphism leftValue + mappedRight = pathThinCodomainMorphism rightValue + in mappedLeft /= mappedRight || leftValue == rightValue + ) + (allPairs mappedMorphisms) + +quotientInterpreterCoherence :: forall obj. Ord obj => SitePathCategory obj -> Bool +quotientInterpreterCoherence category = + let quotient = sitePathQuotient category + objectCoherence = + sitePathObjects category + & all + ( \objectValue -> + let interpreted = + pathThinCodomainObject (quotientPathThinObject objectValue) + in case quotientMapObject quotient objectValue of + Left _ -> False + Right expected -> interpreted == expected + ) + morphismCoherence = + sitePathMorphisms category + & all + ( \morphismValue -> + let interpreted = + pathThinCodomainMorphism (quotientPathThinMorphism morphismValue) + in case quotientMapMorphism quotient morphismValue of + Left _ -> False + Right expected -> interpreted == expected + ) + in objectCoherence && morphismCoherence diff --git a/src-laws/Moonlight/Category/Effect/SiteGen.hs b/src-laws/Moonlight/Category/Effect/SiteGen.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/SiteGen.hs @@ -0,0 +1,29 @@ +-- | Shared site-manifest fixtures for the law suite. +module Moonlight.Category.Effect.SiteGen + ( diamondManifest, + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Category.Pure.Site (SiteManifest (..)) + +diamondManifest :: SiteManifest Int +diamondManifest = + SiteManifest + { siteObjects = Set.fromList [0, 1, 2, 3], + siteImports = + Map.fromList + [ (0, Set.fromList [1, 2]), + (1, Set.singleton 3), + (2, Set.singleton 3), + (3, Set.empty) + ], + siteCovers = + Map.fromList + [ (0, Set.fromList [1, 2, 3]), + (1, Set.singleton 3), + (2, Set.singleton 3), + (3, Set.empty) + ] + } diff --git a/src-laws/Moonlight/Category/Effect/SitePathEnumeration.hs b/src-laws/Moonlight/Category/Effect/SitePathEnumeration.hs new file mode 100644 --- /dev/null +++ b/src-laws/Moonlight/Category/Effect/SitePathEnumeration.hs @@ -0,0 +1,42 @@ +module Moonlight.Category.Effect.SitePathEnumeration + ( allEqual, + sitePathObjectValues, + sitePathObjects, + sitePathMorphisms, + ) +where + +import Data.Function ((&)) +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Moonlight.Category.Pure.Site + ( SitePathCategory, + SitePathMorphism, + SitePathObject, + mkSitePathObject, + siteObjects, + sitePathManifest, + sitePathMorphismsBetween, + ) + +allEqual :: Eq a => [a] -> Bool +allEqual values = + case values of + [] -> True + firstValue : restValues -> all (== firstValue) restValues + +sitePathObjectValues :: SitePathCategory obj -> [obj] +sitePathObjectValues category = + siteObjects (sitePathManifest category) + & Set.toList + +sitePathObjects :: Ord obj => SitePathCategory obj -> [SitePathObject obj] +sitePathObjects category = + sitePathObjectValues category + & mapMaybe (mkSitePathObject category) + +sitePathMorphisms :: Ord obj => SitePathCategory obj -> [SitePathMorphism obj] +sitePathMorphisms category = + let objectValues = sitePathObjectValues category + in objectValues + >>= (\sourceValue -> objectValues >>= sitePathMorphismsBetween category sourceValue) diff --git a/src-public/Moonlight/Category.hs b/src-public/Moonlight/Category.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Category.hs @@ -0,0 +1,53 @@ +{-| The primary entry point to @moonlight-category@, re-exporting the categorical +layer as a single convenience surface. + +The base abstraction is "Moonlight.Category.Pure.Category": a totalised, +explicit-error @Category@ class whose objects, morphisms, 2-morphisms, compositors +and errors are associated types and whose operations return @Either@. On top of it +this module gathers the limit and colimit class tower, the higher-category tower +(2-categories, bicategories, monoidal and enriched categories), runtime-validated +finite categories (@FinCat@) with their thin and composable-chain variants, +core/automorphism groupoid extraction, the adhesive and PBPO rewriting witnesses, +structured cospans, double categories, decorated composition and presentation, +Galois connections, polynomial functors, covering families, and the site/path +presentation layer. + +@UnitCat@ is the terminal one-object category, useful as a base case and in tests. + +For direct finite-category authoring, import +"Moonlight.Category.Presentation". For scoped mathematical operations on an +already-compiled finite category, import "Moonlight.Category.Notation". + +The indexed, typed-arrow layer is exposed separately as "Moonlight.Category.Indexed". +-} +module Moonlight.Category + ( UnitCat (..), + UnitMor (..), + UnitObj (..), + module X, + ) +where + +import Moonlight.Category.Pure.Category as X +import Moonlight.Category.Pure.Adhesive as X +import Moonlight.Category.Pure.DoubleCategory as X +import Moonlight.Category.Pure.CoveringFamily as X +import Moonlight.Category.Pure.CoveringProduct as X +import Moonlight.Category.Pure.Thin as X +import Moonlight.Category.Pure.DecoratedComposition as X +import Moonlight.Category.Pure.DecoratedPresentation as X +import Moonlight.Category.Pure.FiniteComposable as X +import Moonlight.Category.Pure.FinCat as X hiding (denseThinEndpointMorphismsFromCategory, trustedDenseThinFinCatFromReachabilityRows, trustedFinCatWithGeneratorBasis, trustedThinFinCatFromTransitiveEndpoints) +import Moonlight.Category.Pure.FinCat.Functor as X +import Moonlight.Category.Pure.Galois as X +import Moonlight.Category.Pure.Higher as X +import Moonlight.Category.Pure.Invertibility as X +import Moonlight.Category.Pure.PolynomialFunctor as X +import Moonlight.Category.Pure.Limits as X +import Moonlight.Category.Pure.StructuredCospan as X +import Moonlight.Category.Pure.Site as X +import Moonlight.Category.Pure.Unit + ( UnitCat (..), + UnitMor (..), + UnitObj (..), + ) diff --git a/src-public/Moonlight/Category/Indexed.hs b/src-public/Moonlight/Category/Indexed.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Category/Indexed.hs @@ -0,0 +1,24 @@ +{-| The indexed, typed-arrow category-theory layer. + +This is the layer adapted from Sjoerd Visscher's @data-category@: indexed categories +and functors, natural transformations, adjunctions, limits and colimits, Kan +extensions, products and coproducts, the unit and empty categories, and the simplex +category. For general indexed category theory, prefer @data-category@ directly; see +@THIRD_PARTY_NOTICES.md@. +-} +module Moonlight.Category.Indexed + ( module X, + ) +where + +import Moonlight.Category.Pure.Indexed.Adjunction as X +import Moonlight.Category.Pure.Indexed.Category as X +import Moonlight.Category.Pure.Indexed.Coproduct as X +import Moonlight.Category.Pure.Indexed.Functor as X +import Moonlight.Category.Pure.Indexed.KanExtension as X +import Moonlight.Category.Pure.Indexed.Limit as X +import Moonlight.Category.Pure.Indexed.NaturalTransformation as X +import Moonlight.Category.Pure.Indexed.Product as X +import Moonlight.Category.Pure.Indexed.Simplex as X +import Moonlight.Category.Pure.Indexed.Unit as X +import Moonlight.Category.Pure.Indexed.Void as X diff --git a/src-public/Moonlight/Category/Notation.hs b/src-public/Moonlight/Category/Notation.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Category/Notation.hs @@ -0,0 +1,95 @@ +-- | An opt-in ergonomic notation for working with 'FinCat' morphisms that reads as +-- mathematics while staying zero-cost. Every binding here is a trusted, total view +-- over already-validated data: because the 'FinMor' constructor is unexported, every +-- morphism in hand was produced by a checked path, so 'dom'/'cod' need not re-validate +-- and compile to plain record reads. +-- +-- Construction of finite categories lives in "Moonlight.Category.Presentation". +-- This module begins only after a 'FinCat' has been compiled and validated. +-- +-- This module is deliberately /not/ re-exported by "Moonlight.Category": the scoped +-- operators below are introduced only where you ask for them, leaving the rest of the +-- public facade operator-averse. +-- +-- == Scoped operators +-- +-- Composition and reachability need the category, so pin it once with a @let@ and the +-- mathematics reads on the page: +-- +-- > import Moonlight.Category.Notation +-- > +-- > example category f g h = +-- > let (∘) = composeIn category -- g ∘ f ≡ g after f +-- > (≤) = reachableIn category +-- > in (h ∘ g ∘ f, dom f, cod h, 0 ≤ (2 :: FinObjectId)) +module Moonlight.Category.Notation + ( dom, + cod, + domObj, + codObj, + idOf, + hom, + composeIn, + reachableIn, + ) +where + +import Data.Maybe (isJust) +import Moonlight.Category.Pure.Category (composeMor) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatError, + FinMor, + FinObj, + FinObjectId, + finCatHomMorphism, + finObjectIdentityMor, + finCatMorphismIdByEndpoints, + finMorCodObject, + finMorDomObject, + finMorSourceId, + finMorTargetId, + ) + +-- | The source object identifier of a morphism. O(1), total. +dom :: FinMor -> FinObjectId +dom = finMorSourceId +{-# INLINE dom #-} + +-- | The target object identifier of a morphism. O(1), total. +cod :: FinMor -> FinObjectId +cod = finMorTargetId +{-# INLINE cod #-} + +-- | The source object of a morphism. O(1), total. +domObj :: FinMor -> FinObj +domObj = finMorDomObject +{-# INLINE domObj #-} + +-- | The target object of a morphism. O(1), total. +codObj :: FinMor -> FinObj +codObj = finMorCodObject +{-# INLINE codObj #-} + +-- | The identity morphism at an already validated object. +idOf :: FinObj -> FinMor +idOf = finObjectIdentityMor +{-# INLINE idOf #-} + +-- | The unique morphism between two endpoints, when one exists. +hom :: FinCat -> FinObjectId -> FinObjectId -> Maybe FinMor +hom = finCatHomMorphism +{-# INLINE hom #-} + +-- | Composition pinned to a category: @composeIn cat g f@ is @g ∘ f@ (f then g), and +-- is 'Left' exactly when the endpoints do not meet. Bind to @(∘)@ at the use site. +composeIn :: FinCat -> FinMor -> FinMor -> Either FinCatError FinMor +composeIn = composeMor +{-# INLINE composeIn #-} + +-- | Whether the second object is reachable from the first (O(1) on the dense form). +-- Bind to @(≤)@ at the use site for a preorder reading. +reachableIn :: FinCat -> FinObjectId -> FinObjectId -> Bool +reachableIn category sourceId targetId = + isJust (finCatMorphismIdByEndpoints category sourceId targetId) +{-# INLINE reachableIn #-} diff --git a/src-public/Moonlight/Category/Presentation.hs b/src-public/Moonlight/Category/Presentation.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Category/Presentation.hs @@ -0,0 +1,52 @@ +{-| The focused authoring surface for finite categories. + +The semantic result is always 'FinCat'; this module contributes syntax and +compilation, not a second category representation. + +Two dialects are supported: + +* finite posets, declared by objects and strict generating inequalities with + 'below'; +* fully enumerated finite categories, declared by every nonidentity morphism and + enough equations to determine every nonidentity composable pair. + +Identities are implicit in 'FinCat' and may be referenced in equations with +'identityAt'. Longer paths are accepted when their proper intermediate composites +are determined by the same presentation. Arbitrary quotients of free categories by +path congruences are intentionally outside this surface. + +For querying a compiled category with mathematical names, import +"Moonlight.Category.Notation" separately. +-} +module Moonlight.Category.Presentation + ( FinCat, + FinBuilder, + ObjRef, + ArrowExpr, + FinCatBuildError (..), + object, + objects, + arrow, + identityAt, + below, + after, + equate, + finCategory, + ) +where + +import Moonlight.Category.Pure.FinCat (FinCat) +import Moonlight.Category.Pure.FinPresentation + ( ArrowExpr, + FinBuilder, + FinCatBuildError (..), + ObjRef, + after, + arrow, + below, + equate, + finCategory, + identityAt, + object, + objects, + ) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/CategoricalSimplex.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/CategoricalSimplex.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/CategoricalSimplex.hs @@ -0,0 +1,39 @@ +module Moonlight.Category.Pure.Simplicial.CategoricalSimplex + ( categoricalSimplexToDeltaMorphism, + categoricalSimplexValues, + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.Indexed.Category qualified as Indexed +import Moonlight.Category.Pure.Indexed.Simplex qualified as Indexed +import Moonlight.Category.Pure.Simplicial.Delta.Types (DeltaMorphism (..)) +import Numeric.Natural (Natural) + +-- | Lower a statically indexed categorical Δ arrow into the operational +-- runtime-dimensional representation. +-- +-- This is total because the arrow already carries a typed monotone map between +-- ordinary non-empty finite ordinals. The operational constructor stays +-- hidden from public callers; this module is the checked package-internal +-- bridge. +categoricalSimplexToDeltaMorphism :: Indexed.Simplex (n :: Type) (m :: Type) -> DeltaMorphism +categoricalSimplexToDeltaMorphism simplexArrow = + DeltaMorphism + { deltaDomainDimension = simplexObjectDimension (Indexed.src simplexArrow), + deltaCodomainDimension = simplexObjectDimension (Indexed.tgt simplexArrow), + deltaMapValues = categoricalSimplexValues simplexArrow + } + +categoricalSimplexValues :: Indexed.Simplex (n :: Type) (m :: Type) -> [Natural] +categoricalSimplexValues = + Indexed.simplexValues + +-- | Decode the public ordinary ordinal dimension. Public constructor values are +-- non-empty; the empty branch +-- keeps the derived view total instead of manufacturing a partial assertion. +simplexObjectDimension :: Indexed.Obj Indexed.Simplex (n :: Type) -> Natural +simplexObjectDimension objectArrow = + case Indexed.simplexValues objectArrow of + [] -> 0 + _ : lowerSimplexValues -> fromIntegral (length lowerSimplexValues) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta.hs @@ -0,0 +1,204 @@ +-- | Runtime-dimensional morphisms in the simplex category Δ. +module Moonlight.Category.Pure.Simplicial.Delta + ( DeltaOb (..), + Coface (..), + Codegeneracy (..), + DeltaMorphism, + deltaDomainDimension, + deltaCodomainDimension, + deltaMapValues, + mkDeltaMorphism, + deltaIdentity, + composeDeltaMorphism, + cofaceMorphism, + codegeneracyMorphism, + DeltaNormalForm, + normalDomainDimension, + normalCodomainDimension, + normalSurjection, + normalInjection, + normalizeDeltaMorphism, + denormalizeDeltaNormalForm, + deltaMorphismEqual, + allDeltaMorphisms, + deltaToSomeMonotone, + deltaFromSomeMonotone, + surjectionDegeneracyIndices, + injectionMissingIndices, + ) +where + +import Data.Function ((&)) +import Data.Kind (Type) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) +import Data.Proxy (Proxy (..)) +import qualified Data.Set as Set +import GHC.TypeNats (KnownNat, Nat, natVal, type (+)) +import Moonlight.Core (safeIndexNatural) +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Simplicial.Delta.Types (DeltaMorphism (..)) +import Moonlight.Category.Pure.Simplicial.Ordinal + ( SomeMonotone (..), + SomeNormalizedMonotone (..), + composeSomeMonotone, + mkSomeMonotone, + monotoneCodomainDimension, + monotoneDomainDimension, + monotoneValues, + normalizeSomeMonotone, + normalizedInjectionValues, + normalizedSurjectionValues, + someMonotoneEqualByNormalForm, + ) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Fin, finValue) + +type DeltaOb :: Nat -> Type +data DeltaOb (n :: Nat) = DeltaOb + +type Coface :: Nat -> Type +data Coface (n :: Nat) where + CofaceMap :: KnownNat n => Fin (n + 2) -> Coface n + +type Codegeneracy :: Nat -> Type +data Codegeneracy (n :: Nat) where + CodegeneracyMap :: KnownNat n => Fin (n + 1) -> Codegeneracy n + +mkDeltaMorphism :: Natural -> Natural -> [Natural] -> Maybe DeltaMorphism +mkDeltaMorphism domainDimension codomainDimension mapValues = + (\_ -> DeltaMorphism domainDimension codomainDimension mapValues) + <$> mkSomeMonotone domainDimension codomainDimension mapValues + +deltaIdentity :: Natural -> DeltaMorphism +deltaIdentity nValue = + DeltaMorphism + { deltaDomainDimension = nValue, + deltaCodomainDimension = nValue, + deltaMapValues = [0 .. nValue] + } + +composeDeltaMorphism :: DeltaMorphism -> DeltaMorphism -> Maybe DeltaMorphism +composeDeltaMorphism outer inner = + do + outerMonotone <- deltaToSomeMonotone outer + innerMonotone <- deltaToSomeMonotone inner + composed <- composeSomeMonotone outerMonotone innerMonotone + pure (deltaFromSomeMonotone composed) + +cofaceMorphism :: forall n. Coface n -> DeltaMorphism +cofaceMorphism (CofaceMap skippedIndex) = + let domainDimension = natVal (Proxy @n) + codomainDimension = domainDimension + 1 + skippedValue = finValue skippedIndex + mappedValues = + [0 .. domainDimension] + & map (\domainValue -> if domainValue < skippedValue then domainValue else domainValue + 1) + in DeltaMorphism + { deltaDomainDimension = domainDimension, + deltaCodomainDimension = codomainDimension, + deltaMapValues = mappedValues + } + +codegeneracyMorphism :: forall n. Codegeneracy n -> DeltaMorphism +codegeneracyMorphism (CodegeneracyMap repeatedIndex) = + let codomainDimension = natVal (Proxy @n) + domainDimension = codomainDimension + 1 + repeatedValue = finValue repeatedIndex + mappedValues = + [0 .. domainDimension] + & map + ( \domainValue -> + if domainValue <= repeatedValue + then domainValue + else domainValue - 1 + ) + in DeltaMorphism + { deltaDomainDimension = domainDimension, + deltaCodomainDimension = codomainDimension, + deltaMapValues = mappedValues + } + +type DeltaNormalForm :: Type +data DeltaNormalForm = DeltaNormalForm + { normalDomainDimension :: Natural, + normalCodomainDimension :: Natural, + normalSurjection :: [Natural], + normalInjection :: [Natural] + } + deriving stock (Eq, Show) + +normalizeDeltaMorphism :: DeltaMorphism -> Maybe DeltaNormalForm +normalizeDeltaMorphism morphism = + case deltaToSomeMonotone morphism >>= normalizeSomeMonotone of + Just (SomeNormalizedMonotone _ _ normalized) -> + Just + DeltaNormalForm + { normalDomainDimension = deltaDomainDimension morphism, + normalCodomainDimension = deltaCodomainDimension morphism, + normalSurjection = normalizedSurjectionValues normalized, + normalInjection = normalizedInjectionValues normalized + } + Nothing -> Nothing + +denormalizeDeltaNormalForm :: DeltaNormalForm -> Maybe DeltaMorphism +denormalizeDeltaNormalForm normalForm = do + mappedValues <- traverse (`safeIndexNatural` normalInjection normalForm) (normalSurjection normalForm) + mkDeltaMorphism + (normalDomainDimension normalForm) + (normalCodomainDimension normalForm) + mappedValues + +deltaMorphismEqual :: DeltaMorphism -> DeltaMorphism -> Bool +deltaMorphismEqual left right = + case (deltaToSomeMonotone left, deltaToSomeMonotone right) of + (Just leftMonotone, Just rightMonotone) -> someMonotoneEqualByNormalForm leftMonotone rightMonotone + _ -> False + +nondecreasingRows :: Natural -> Natural -> Natural -> [[Natural]] +nondecreasingRows lowerBound upperBound rowLength = + if rowLength == 0 + then [[]] + else + [lowerBound .. upperBound] + & concatMap + ( \headValue -> + nondecreasingRows headValue upperBound (rowLength - 1) + & map (headValue :) + ) + +allDeltaMorphisms :: Natural -> Natural -> [DeltaMorphism] +allDeltaMorphisms domainDimension codomainDimension = + nondecreasingRows 0 codomainDimension (domainDimension + 1) + & mapMaybe (mkDeltaMorphism domainDimension codomainDimension) + +deltaToSomeMonotone :: DeltaMorphism -> Maybe SomeMonotone +deltaToSomeMonotone morphism = + mkSomeMonotone + (deltaDomainDimension morphism) + (deltaCodomainDimension morphism) + (deltaMapValues morphism) + +deltaFromSomeMonotone :: SomeMonotone -> DeltaMorphism +deltaFromSomeMonotone (SomeMonotone _ _ monotone) = + DeltaMorphism + { deltaDomainDimension = monotoneDomainDimension monotone, + deltaCodomainDimension = monotoneCodomainDimension monotone, + deltaMapValues = monotoneValues monotone + } + +surjectionDegeneracyIndices :: [Natural] -> [Natural] +surjectionDegeneracyIndices surjectionRanks = + NonEmpty.group surjectionRanks + & zip [0 ..] + & foldMap + ( \(runIndex, rankRun) -> + rankRun + & NonEmpty.tail + & fmap (const runIndex) + ) + +injectionMissingIndices :: Natural -> [Natural] -> [Natural] +injectionMissingIndices codomainDimension injectionValues = + let injectionImage = Set.fromList injectionValues + in [0 .. codomainDimension] + & filter (`Set.notMember` injectionImage) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta/Types.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta/Types.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Delta/Types.hs @@ -0,0 +1,20 @@ +module Moonlight.Category.Pure.Simplicial.Delta.Types + ( DeltaMorphism (..), + ) +where + +import Data.Kind (Type) +import Numeric.Natural (Natural) + +-- | Internal representation for operational Δ morphisms. +-- +-- This module is intentionally hidden from the package surface. Public callers +-- construct values through 'Moonlight.Category.Pure.Simplicial.Delta.mkDeltaMorphism', +-- or by lowering a statically indexed categorical simplex arrow. +type DeltaMorphism :: Type +data DeltaMorphism = DeltaMorphism + { deltaDomainDimension :: Natural, + deltaCodomainDimension :: Natural, + deltaMapValues :: [Natural] + } + deriving stock (Eq, Show) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Homotopy.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Homotopy.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Homotopy.hs @@ -0,0 +1,117 @@ +-- | Homotopy-flavoured queries over nerves: connected components and +-- core\/automorphism groupoids. +module Moonlight.Category.Pure.Simplicial.Homotopy + ( pi0Nerve, + CoreGroupoid, + CoreGroupoidObject, + CoreGroupoidMorphism, + AutomorphismGroupoid, + AutomorphismGroupoidObject, + AutomorphismGroupoidMorphism, + forgetCoreGroupoidObject, + forgetCoreGroupoidMorphism, + forgetAutomorphismGroupoidObject, + forgetAutomorphismGroupoidMorphism, + coreGroupoidOfNerve, + coreGroupoidObjects, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + automorphismGroupoidOfNerve, + automorphismGroupoidObjects, + automorphismGroupAt, + ) +where + +import Algebra.Graph.AdjacencyMap qualified as AdjacencyMap +import Algebra.Graph.AdjacencyMap.Algorithm qualified as AdjacencyMapAlgorithm +import Algebra.Graph.NonEmpty.AdjacencyMap qualified as NonEmptyAdjacencyMap +import Data.Function ((&)) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.FiniteComposable (FiniteComposableCategory (..)) +import Moonlight.Category.Pure.Invertibility + ( AutomorphismGroupoid, + AutomorphismGroupoidMorphism, + AutomorphismGroupoidObject, + CoreGroupoid, + CoreGroupoidMorphism, + CoreGroupoidObject, + automorphismGroupoid, + automorphismGroupAt, + automorphismGroupoidObjects, + coreGroupoid, + coreGroupoidObjects, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + forgetAutomorphismGroupoidMorphism, + forgetAutomorphismGroupoidObject, + forgetCoreGroupoidMorphism, + forgetCoreGroupoidObject, + ) + +adjacencyFromEdges :: Ord a => [a] -> [(a, a)] -> Map a (Set a) +adjacencyFromEdges vertices edges = + let vertexAdjacency = + foldr + (\vertex -> Map.insertWith Set.union vertex Set.empty) + Map.empty + vertices + edgeAdjacency = + foldr + (\(sourceVertex, targetVertex) -> + Map.insertWith Set.union sourceVertex (Set.singleton targetVertex) + . Map.insertWith Set.union targetVertex (Set.singleton sourceVertex) + ) + vertexAdjacency + edges + in edgeAdjacency + +pi0Nerve :: (FiniteComposableCategory c, Ord (Ob c)) => c -> [[Ob c]] +pi0Nerve categoryValue = + let objects = enumerateObjects categoryValue + undirectedEdges = + enumerateMorphisms categoryValue + & mapMaybe + ( \morphism -> + case (source categoryValue morphism, target categoryValue morphism) of + (Right sourceObject, Right targetObject) -> Just (sourceObject, targetObject) + _ -> Nothing + ) + in componentsFromAdjacency (adjacencyFromEdges objects undirectedEdges) + & fmap Set.toAscList + +coreGroupoidOfNerve :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + CoreGroupoid c +coreGroupoidOfNerve = + coreGroupoid + +automorphismGroupoidOfNerve :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + AutomorphismGroupoid c +automorphismGroupoidOfNerve = + automorphismGroupoid + +componentsFromAdjacency :: Ord vertex => Map vertex (Set vertex) -> [Set vertex] +componentsFromAdjacency = + strongComponentSets + . AdjacencyMap.symmetricClosure + . AdjacencyMap.fromAdjacencySets + . Map.toAscList + +strongComponentSets :: Ord vertex => AdjacencyMap.AdjacencyMap vertex -> [Set vertex] +strongComponentSets graph = + List.sortOn + Set.lookupMin + ( fmap + (Set.fromList . NonEmpty.toList . NonEmptyAdjacencyMap.vertexList1) + (AdjacencyMap.vertexList (AdjacencyMapAlgorithm.scc graph)) + ) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Kan.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Kan.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Kan.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Horns and Kan filling interfaces over generated simplicial sets. +module Moonlight.Category.Pure.Simplicial.Kan + ( HornFrame, + hornFrameDimension, + hornFrameMissingFace, + hornFrameFaces, + Horn, + hornDimension, + hornMissingFace, + hornFaces, + IndexedHornFrame, + indexedHornFrameMissingFace, + indexedHornFrameFaces, + IndexedHorn, + indexedHornMissingFace, + indexedHornFaces, + SomeIndexedHorn (..), + InnerHorn, + innerHorn, + HornFrameError (..), + HornError (..), + InnerHornError (..), + HornIndexError (..), + mkHornFrame, + mkHorn, + mkIndexedHornFrame, + mkIndexedHorn, + mkInnerHorn, + indexedHornDimension, + indexedHornToHorn, + hornToIndexedHorn, + isInnerHorn, + InnerKan (..), + KanComplex (..), + ) +where + +import Data.Bifunctor (first) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.Kind (Constraint, Type) +import Data.List (find, sort) +import Data.Maybe (listToMaybe) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat, Nat, natVal, type (+)) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Dimension (..), Fin, finValue, mkFinOffset) +import Numeric.Natural (Natural) + +type HornFrame :: Type -> Type +data HornFrame simplex = HornFrame + { hornFrameDimension :: Natural, + hornFrameMissingFace :: Natural, + hornFrameFaces :: Map Natural simplex + } + +type Horn :: Type -> Type +newtype Horn simplex = Horn + { hornToFrame :: HornFrame simplex + } + +type IndexedHornFrame :: Nat -> Type -> Type +data IndexedHornFrame (n :: Nat) simplex = IndexedHornFrame + { indexedHornFrameMissingFace :: Fin (n + 2), + indexedHornFrameFaces :: Map Natural simplex + } + +type IndexedHorn :: Nat -> Type -> Type +newtype IndexedHorn (n :: Nat) simplex = IndexedHorn + { indexedHornToFrame :: IndexedHornFrame n simplex + } + +type SomeIndexedHorn :: Type -> Type +data SomeIndexedHorn simplex where + SomeIndexedHorn :: KnownNat n => IndexedHorn n simplex -> SomeIndexedHorn simplex + +type InnerHorn :: Type -> Type +newtype InnerHorn simplex = InnerHorn + { innerHorn :: Horn simplex + } + +data HornFrameError + = HornDimensionZero + | HornMissingFaceOutOfBounds Natural Natural + | HornDuplicateFace Natural + | HornUnexpectedFace Natural Natural + | HornSuppliedMissingFace Natural + | HornMissingRequiredFaces [Natural] + deriving stock (Eq, Show) + +data HornError simplex + = HornFrameInvalid HornFrameError + | HornFaceDimensionMismatch Natural Natural Natural + | HornOverlapUndefined Natural Natural (Maybe simplex) (Maybe simplex) + | HornOverlapMismatch Natural Natural simplex simplex + deriving stock (Eq, Show) + +data InnerHornError + = HornNotInner Natural Natural + deriving stock (Eq, Show) + +data HornIndexError + = HornIndexDimensionMismatch Natural Natural + | HornIndexFaceOutOfBounds Natural + deriving stock (Eq, Show) + +hornDimension :: Horn simplex -> Natural +hornDimension = hornFrameDimension . hornToFrame + +hornMissingFace :: Horn simplex -> Natural +hornMissingFace = hornFrameMissingFace . hornToFrame + +hornFaces :: Horn simplex -> Map Natural simplex +hornFaces = hornFrameFaces . hornToFrame + +indexedHornMissingFace :: IndexedHorn n simplex -> Fin (n + 2) +indexedHornMissingFace = indexedHornFrameMissingFace . indexedHornToFrame + +indexedHornFaces :: IndexedHorn n simplex -> Map Natural simplex +indexedHornFaces = indexedHornFrameFaces . indexedHornToFrame + +faceMultiplicity :: [(Natural, simplex)] -> Map Natural Int +faceMultiplicity = + foldr (Map.alter incrementFaceCount . fst) Map.empty + where + incrementFaceCount :: Maybe Int -> Maybe Int + incrementFaceCount Nothing = Just 1 + incrementFaceCount (Just countValue) = Just (countValue + 1) + +firstDuplicateFace :: [(Natural, simplex)] -> Maybe Natural +firstDuplicateFace indexedFaces = + faceMultiplicity indexedFaces + & Map.filter (> 1) + & Map.keys + & sort + & listToMaybe + +requiredFaceIndices :: Natural -> Natural -> [Natural] +requiredFaceIndices dimensionValue missingFace = + filter (/= missingFace) [0 .. dimensionValue] + +mkHornFrame :: Natural -> Natural -> [(Natural, simplex)] -> Either HornFrameError (HornFrame simplex) +mkHornFrame dimensionValue missingFace indexedFaces + | dimensionValue == 0 = Left HornDimensionZero + | missingFace > dimensionValue = + Left (HornMissingFaceOutOfBounds dimensionValue missingFace) + | Just duplicateFace <- firstDuplicateFace indexedFaces = + Left (HornDuplicateFace duplicateFace) + | otherwise = + let facesMap = Map.fromList indexedFaces + suppliedFaces = Map.keys facesMap + requiredFaces = requiredFaceIndices dimensionValue missingFace + missingRequiredFaces = filter (`Map.notMember` facesMap) requiredFaces + in case find (> dimensionValue) suppliedFaces of + Just unexpectedFace -> + Left (HornUnexpectedFace dimensionValue unexpectedFace) + Nothing + | Map.member missingFace facesMap -> + Left (HornSuppliedMissingFace missingFace) + | not (null missingRequiredFaces) -> + Left (HornMissingRequiredFaces missingRequiredFaces) + | otherwise -> + Right + HornFrame + { hornFrameDimension = dimensionValue, + hornFrameMissingFace = missingFace, + hornFrameFaces = facesMap + } + +compatibleFacePairs :: HornFrame simplex -> [(Natural, Natural, simplex, simplex)] +compatibleFacePairs frameValue = + [ (lowerFace, upperFace, lowerSimplex, upperSimplex) + | (lowerFace, lowerSimplex) <- Map.toAscList (hornFrameFaces frameValue), + (upperFace, upperSimplex) <- Map.toAscList (hornFrameFaces frameValue), + lowerFace < upperFace + ] + +validateHornOverlap :: Eq simplex => (Natural -> Natural -> simplex -> Maybe simplex) -> Natural -> (Natural, Natural, simplex, simplex) -> Either (HornError simplex) () +validateHornOverlap faceAt faceDimension (lowerFace, upperFace, lowerSimplex, upperSimplex) = + case (faceAt faceDimension lowerFace upperSimplex, faceAt faceDimension (upperFace - 1) lowerSimplex) of + (Just leftValue, Just rightValue) + | leftValue == rightValue -> Right () + | otherwise -> + Left (HornOverlapMismatch lowerFace upperFace leftValue rightValue) + (leftValue, rightValue) -> + Left (HornOverlapUndefined lowerFace upperFace leftValue rightValue) + +validateHornFaceDimension :: + (simplex -> Natural) -> + Natural -> + (Natural, simplex) -> + Either (HornError simplex) () +validateHornFaceDimension simplexDimension expectedDimension (faceIndex, simplexValue) = + let actualDimension = simplexDimension simplexValue + in if actualDimension == expectedDimension + then Right () + else Left (HornFaceDimensionMismatch faceIndex expectedDimension actualDimension) + +mkHorn :: Eq simplex => (simplex -> Natural) -> (Natural -> Natural -> simplex -> Maybe simplex) -> Natural -> Natural -> [(Natural, simplex)] -> Either (HornError simplex) (Horn simplex) +mkHorn simplexDimension faceAt dimensionValue missingFace indexedFaces = do + frameValue <- first HornFrameInvalid (mkHornFrame dimensionValue missingFace indexedFaces) + traverse_ (validateHornFaceDimension simplexDimension (dimensionValue - 1)) (Map.toAscList (hornFrameFaces frameValue)) + traverse_ (validateHornOverlap faceAt (dimensionValue - 1)) (compatibleFacePairs frameValue) + Right (Horn frameValue) + +mkIndexedHornFrame :: forall n simplex. KnownNat n => Fin (n + 2) -> [(Fin (n + 2), simplex)] -> Either HornFrameError (IndexedHornFrame n simplex) +mkIndexedHornFrame missingFace indexedFaces = + let dimensionValue = natVal (Proxy @n) + 1 + indexedFaceRows = map (\(faceIndex, simplexValue) -> (finValue faceIndex, simplexValue)) indexedFaces + in do + checkedFrame <- mkHornFrame dimensionValue (finValue missingFace) indexedFaceRows + Right + IndexedHornFrame + { indexedHornFrameMissingFace = missingFace, + indexedHornFrameFaces = hornFrameFaces checkedFrame + } + +mkIndexedHorn :: forall n simplex. (KnownNat n, Eq simplex) => (simplex -> Natural) -> (Natural -> Natural -> simplex -> Maybe simplex) -> Fin (n + 2) -> [(Fin (n + 2), simplex)] -> Either (HornError simplex) (IndexedHorn n simplex) +mkIndexedHorn simplexDimension faceAt missingFace indexedFaces = do + let dimensionValue = natVal (Proxy @n) + 1 + indexedFaceRows = map (\(faceIndex, simplexValue) -> (finValue faceIndex, simplexValue)) indexedFaces + _ <- mkHorn simplexDimension faceAt dimensionValue (finValue missingFace) indexedFaceRows + frameValue <- first HornFrameInvalid (mkIndexedHornFrame missingFace indexedFaces) + Right (IndexedHorn frameValue) + +indexedHornDimension :: forall n simplex. KnownNat n => IndexedHorn n simplex -> Natural +indexedHornDimension _ = natVal (Proxy @n) + 1 + +indexedHornToHorn :: forall n simplex. KnownNat n => IndexedHorn n simplex -> Horn simplex +indexedHornToHorn indexedHornValue = + Horn + HornFrame + { hornFrameDimension = indexedHornDimension indexedHornValue, + hornFrameMissingFace = finValue (indexedHornMissingFace indexedHornValue), + hornFrameFaces = indexedHornFaces indexedHornValue + } + +hornToIndexedHorn :: forall n simplex. KnownNat n => Horn simplex -> Either HornIndexError (IndexedHorn n simplex) +hornToIndexedHorn hornValue = + if hornDimension hornValue == natVal (Proxy @n) + 1 + then do + missingFace <- + maybe + (Left (HornIndexFaceOutOfBounds (hornMissingFace hornValue))) + Right + (mkFinOffset @n @2 (Dimension @n) (hornMissingFace hornValue)) + indexedFaces <- + traverse + (\(faceIndex, simplexValue) -> + maybe + (Left (HornIndexFaceOutOfBounds faceIndex)) + (\finiteFace -> Right (finiteFace, simplexValue)) + (mkFinOffset @n @2 (Dimension @n) faceIndex) + ) + (Map.toAscList (hornFaces hornValue)) + frameValue <- first (const (HornIndexFaceOutOfBounds (hornMissingFace hornValue))) (mkIndexedHornFrame missingFace indexedFaces) + Right (IndexedHorn frameValue) + else + Left (HornIndexDimensionMismatch (natVal (Proxy @n) + 1) (hornDimension hornValue)) + +isInnerHorn :: Horn simplex -> Bool +isInnerHorn hornValue = + hornDimension hornValue > 1 + && hornMissingFace hornValue > 0 + && hornMissingFace hornValue < hornDimension hornValue + +mkInnerHorn :: Horn simplex -> Either InnerHornError (InnerHorn simplex) +mkInnerHorn hornValue = + if isInnerHorn hornValue + then Right (InnerHorn hornValue) + else + Left (HornNotInner (hornDimension hornValue) (hornMissingFace hornValue)) + +type InnerKan :: Type -> Constraint +class InnerKan k where + type InnerSimplex k + fillInnerHorn :: k -> InnerHorn (InnerSimplex k) -> Maybe (InnerSimplex k) + +type KanComplex :: Type -> Constraint +class InnerKan k => KanComplex k where + fillHorn :: k -> Horn (InnerSimplex k) -> Maybe (InnerSimplex k) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Nerve.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Nerve.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Nerve.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | The nerve of a finite composable category: simplices are composable chains, +-- with face and degeneracy structure. +module Moonlight.Category.Pure.Simplicial.Nerve + ( NerveSimplex, + nerveSimplexDimension, + nerveSimplexChain, + nerveSimplexFromChain, + mkNerveSimplex, + Nerve, + nerveCategory, + unNerve, + nerveGenerated, + isNerveSimplexDegenerate, + nerveSimplexFace, + nerveSimplexDegeneracy, + nerveChainVertices, + nerve, + nerveInnerKan, + fillNerveInnerHorn, + fillNerveInnerHornIndexed, + ) +where + +import Control.Monad (guard) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Function ((&)) +import Data.Kind (Type) +import Data.List (genericLength, genericSplitAt, unsnoc) +import Data.Maybe (mapMaybe) +import Data.Map.Strict qualified as Map +import GHC.TypeNats (KnownNat, type (+)) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.FiniteComposable + ( ComposableChain, + FiniteComposableCategory (..), + SizedComposableChain, + chainDimension, + chainMorphisms, + chainStartObject, + mkComposableChain, + sizedChainDimension, + sizedChainValue, + ) +import Moonlight.Core (safeIndexNatural) +import Moonlight.Category.Pure.Simplicial.Kan + ( IndexedHorn, + InnerHorn, + InnerHornError, + InnerKan (..), + hornDimension, + hornFaces, + indexedHornToHorn, + innerHorn, + mkInnerHorn, + ) +import Moonlight.Category.Pure.Simplicial.Set + ( GeneratedSSet, + TruncatedNormalizedSSet, + normalizeGeneratedSSet, + ) +import Moonlight.Category.Pure.Simplicial.Set.Internal (trustedGeneratedSSetWithWitness) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Dimension (..), Fin, finValue) +import Numeric.Natural (Natural) + +type NerveSimplex :: Type -> Type +data NerveSimplex c = NerveSimplex + { nerveSimplexDimension :: Natural, + nerveSimplexChain :: ComposableChain c + } + +instance (Eq (Ob c), Eq (Mor c)) => Eq (NerveSimplex c) where + (==) = sameSimplex + +nerveSimplexFromChain :: ComposableChain c -> NerveSimplex c +nerveSimplexFromChain chainValue = + NerveSimplex (chainDimension chainValue) chainValue + +mkNerveSimplex :: Natural -> ComposableChain c -> Maybe (NerveSimplex c) +mkNerveSimplex dimensionValue chainValue = + if dimensionValue == chainDimension chainValue + then Just (NerveSimplex dimensionValue chainValue) + else Nothing + +type Nerve :: Type -> Type +data Nerve c = Nerve + { nerveCategory :: c, + unNerve :: TruncatedNormalizedSSet (NerveSimplex c) + } + +morphismIsIdentity :: (Category c, Eq (Mor c)) => c -> Mor c -> Bool +morphismIsIdentity categoryValue morphism = + case source categoryValue morphism >>= identity categoryValue of + Right identityMorphism -> morphism == identityMorphism + Left _ -> False + +isNerveSimplexDegenerate :: (Category c, Eq (Mor c)) => c -> Natural -> NerveSimplex c -> Bool +isNerveSimplexDegenerate categoryValue _ simplexValue = + chainMorphisms (nerveSimplexChain simplexValue) + & any (morphismIsIdentity categoryValue) + +nerveGenerated :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Natural -> + GeneratedSSet (NerveSimplex c) +nerveGenerated categoryValue upperBound = + let levelMap = Map.fromAscListWith (<>) (nerveLevels categoryValue upperBound) + in trustedGeneratedSSetWithWitness + upperBound + (\dimensionValue' -> Map.findWithDefault [] dimensionValue' levelMap) + (nerveFace categoryValue) + (nerveDegeneracy categoryValue) + (isNerveSimplexDegenerate categoryValue) + +nerve :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Natural -> + TruncatedNormalizedSSet (NerveSimplex c) +nerve categoryValue upperBound = + normalizeGeneratedSSet + ( trustedGeneratedSSetWithWitness + upperBound + (\dimensionValue' -> Map.findWithDefault [] dimensionValue' closedLevelMap) + (nerveFace categoryValue) + (nerveDegeneracy categoryValue) + (isNerveSimplexDegenerate categoryValue) + ) + where + closedLevelMap = + closeUnderFaces categoryValue upperBound nonDegenerateLevelMap + + nonDegenerateLevelMap = + Map.fromDistinctAscList + ( zipWith + (\dimensionValue' chains -> (dimensionValue', fmap (NerveSimplex dimensionValue') chains)) + [0 ..] + (enumerateNonDegenerateChainsByDimension categoryValue upperBound) + ) + +nerveInnerKan :: + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Natural -> + Nerve c +nerveInnerKan categoryValue upperBound = Nerve categoryValue (nerve categoryValue upperBound) + +nerveLevels :: (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => c -> Natural -> [(Natural, [NerveSimplex c])] +nerveLevels categoryValue upperBound = + Map.toAscList + ( closeUnderFaces + categoryValue + upperBound + (seedNerveLevelMap categoryValue upperBound (\_ _ -> True)) + ) + +seedNerveLevelMap :: + forall c. + (FiniteComposableCategory c, Ord (Ob c), Ord (Mor c)) => + c -> + Natural -> + (Natural -> NerveSimplex c -> Bool) -> + Map.Map Natural [NerveSimplex c] +seedNerveLevelMap categoryValue upperBound keepSimplex = + enumerateComposableChains categoryValue upperBound + & mapMaybe sizedChainEntry + & foldl' insertChainEntry Map.empty + & Map.map (dedupeSimplices . reverse) + where + insertChainEntry :: + Map.Map Natural [NerveSimplex c] -> + (Natural, NerveSimplex c) -> + Map.Map Natural [NerveSimplex c] + insertChainEntry levelMap (dimensionValue, simplexValue) = + Map.insertWith (<>) dimensionValue [simplexValue] levelMap + + sizedChainEntry :: + SizedComposableChain c -> + Maybe (Natural, NerveSimplex c) + sizedChainEntry sizedChain = + let dimensionValue = sizedChainDimension sizedChain + simplexValue = NerveSimplex dimensionValue (sizedChainValue sizedChain) + in if keepSimplex dimensionValue simplexValue + then Just (dimensionValue, simplexValue) + else Nothing + +closeUnderFaces :: + forall c. + (Category c, Ord (Ob c), Ord (Mor c)) => + c -> + Natural -> + Map.Map Natural [NerveSimplex c] -> + Map.Map Natural [NerveSimplex c] +closeUnderFaces categoryValue upperBound simplicesByDimension = + foldr closeDimension + (Map.map dedupeSimplices simplicesByDimension) + [1 .. upperBound] + where + closeDimension :: + Natural -> + Map.Map Natural [NerveSimplex c] -> + Map.Map Natural [NerveSimplex c] + closeDimension dimensionValue simplicesAtDimension = + let simplexFaceRows = + Map.findWithDefault [] dimensionValue simplicesAtDimension + & mapMaybe simplexFacesIfClosed + validSimplices = fmap fst simplexFaceRows + faceSimplices = foldMap snd simplexFaceRows + withValidDimension = Map.insert dimensionValue validSimplices simplicesAtDimension + in Map.insertWith mergeSimplices (dimensionValue - 1) faceSimplices withValidDimension + + simplexFacesIfClosed :: NerveSimplex c -> Maybe (NerveSimplex c, [NerveSimplex c]) + simplexFacesIfClosed simplexValue = + let dimensionValue = nerveSimplexDimension simplexValue + in fmap + (\faceSimplices -> (simplexValue, faceSimplices)) + (traverse (\faceIndex -> faceSimplex dimensionValue faceIndex simplexValue) [0 .. dimensionValue]) + + faceSimplex :: + Natural -> + Natural -> + NerveSimplex c -> + Maybe (NerveSimplex c) + faceSimplex dimensionValue faceIndex simplexValue = + NerveSimplex (dimensionValue - 1) + <$> faceChain categoryValue faceIndex (nerveSimplexChain simplexValue) + +mergeSimplices :: + (Ord (Ob c), Ord (Mor c)) => + [NerveSimplex c] -> + [NerveSimplex c] -> + [NerveSimplex c] +mergeSimplices newSimplices existingSimplices = + dedupeSimplices (existingSimplices <> newSimplices) + +type NerveSimplexKey :: Type -> Type +type NerveSimplexKey c = (Natural, Ob c, [Mor c]) + +nerveSimplexKey :: NerveSimplex c -> NerveSimplexKey c +nerveSimplexKey simplexValue = + ( nerveSimplexDimension simplexValue, + chainStartObject (nerveSimplexChain simplexValue), + chainMorphisms (nerveSimplexChain simplexValue) + ) + +dedupeSimplices :: + forall c. + (Ord (Ob c), Ord (Mor c)) => + [NerveSimplex c] -> + [NerveSimplex c] +dedupeSimplices = + nubOrdOn nerveSimplexKey + +nerveFace :: + forall c n. + (Category c, Eq (Ob c)) => + c -> + Dimension (n + 1) -> + Fin (n + 2) -> + NerveSimplex c -> + Maybe (NerveSimplex c) +nerveFace categoryValue _ faceIndex = + nerveSimplexFace categoryValue (finValue faceIndex) + +nerveDegeneracy :: + forall c n. + (Category c, Eq (Ob c)) => + c -> + Dimension n -> + Fin (n + 1) -> + NerveSimplex c -> + Maybe (NerveSimplex c) +nerveDegeneracy categoryValue _ degeneracyIndex = + nerveSimplexDegeneracy categoryValue (finValue degeneracyIndex) + +nerveSimplexFace :: + (Category c, Eq (Ob c)) => + c -> + Natural -> + NerveSimplex c -> + Maybe (NerveSimplex c) +nerveSimplexFace categoryValue faceIndex simplexValue = do + let currentDimension = nerveSimplexDimension simplexValue + guard (currentDimension > 0) + faceChainValue <- faceChain categoryValue faceIndex (nerveSimplexChain simplexValue) + pure (NerveSimplex (currentDimension - 1) faceChainValue) + +nerveSimplexDegeneracy :: + (Category c, Eq (Ob c)) => + c -> + Natural -> + NerveSimplex c -> + Maybe (NerveSimplex c) +nerveSimplexDegeneracy categoryValue degeneracyIndex simplexValue = do + let currentDimension = nerveSimplexDimension simplexValue + degeneracyChainValue <- degeneracyChain categoryValue degeneracyIndex (nerveSimplexChain simplexValue) + pure (NerveSimplex (currentDimension + 1) degeneracyChainValue) + +nerveChainVertices :: Category c => c -> ComposableChain c -> Either (CategoryError c) [Ob c] +nerveChainVertices categoryValue chainValue = + fmap (chainStartObject chainValue :) (traverse (target categoryValue) (chainMorphisms chainValue)) + +splitAtNatural :: Natural -> [a] -> Maybe ([a], [a]) +splitAtNatural splitIndex values = + let (prefix, suffix) = genericSplitAt splitIndex values + in if genericLength prefix == splitIndex + then Just (prefix, suffix) + else Nothing + +insertAt :: Natural -> a -> [a] -> Maybe [a] +insertAt indexValue inserted values = do + (prefix, suffix) <- splitAtNatural indexValue values + pure (prefix <> (inserted : suffix)) + +faceChain :: (Category c, Eq (Ob c)) => c -> Natural -> ComposableChain c -> Maybe (ComposableChain c) +faceChain categoryValue faceIndex chainValue + | faceIndex > dimensionValue' = Nothing + | otherwise = case morphisms of + [] -> Nothing + firstMorphism : restMorphisms + | faceIndex == 0 -> do + startObject <- either (const Nothing) Just (target categoryValue firstMorphism) + either (const Nothing) Just (mkComposableChain categoryValue startObject restMorphisms) + | faceIndex == dimensionValue' -> do + (prefixMorphisms, _) <- unsnoc morphisms + either (const Nothing) Just (mkComposableChain categoryValue (chainStartObject chainValue) prefixMorphisms) + | otherwise -> do + (leftMorphisms, rightMorphisms) <- splitAtNatural faceIndex morphisms + (leftPrefix, leftMorphism) <- unsnoc leftMorphisms + case rightMorphisms of + [] -> Nothing + rightMorphism : rightSuffix -> do + (composedMorphism, _) <- either (const Nothing) Just (compose categoryValue rightMorphism leftMorphism) + either + (const Nothing) + Just + ( mkComposableChain + categoryValue + (chainStartObject chainValue) + (leftPrefix <> (composedMorphism : rightSuffix)) + ) + where + morphisms = chainMorphisms chainValue + dimensionValue' = chainDimension chainValue + +degeneracyChain :: (Category c, Eq (Ob c)) => c -> Natural -> ComposableChain c -> Maybe (ComposableChain c) +degeneracyChain categoryValue degeneracyIndex chainValue = + let dimensionValue' = chainDimension chainValue + in if degeneracyIndex > dimensionValue' + then Nothing + else do + vertices <- either (const Nothing) Just (nerveChainVertices categoryValue chainValue) + duplicatedObject <- safeIndexNatural degeneracyIndex vertices + identityMorphism <- either (const Nothing) Just (identity categoryValue duplicatedObject) + insertedMorphisms <- insertAt degeneracyIndex identityMorphism (chainMorphisms chainValue) + either (const Nothing) Just (mkComposableChain categoryValue (chainStartObject chainValue) insertedMorphisms) + +sameSimplex :: (Eq (Ob c), Eq (Mor c)) => NerveSimplex c -> NerveSimplex c -> Bool +sameSimplex leftSimplex rightSimplex = + nerveSimplexDimension leftSimplex == nerveSimplexDimension rightSimplex + && chainStartObject (nerveSimplexChain leftSimplex) == chainStartObject (nerveSimplexChain rightSimplex) + && chainMorphisms (nerveSimplexChain leftSimplex) == chainMorphisms (nerveSimplexChain rightSimplex) + +fillNerveInnerHorn :: (Category c, Eq (Ob c), Eq (Mor c)) => c -> InnerHorn (NerveSimplex c) -> Maybe (NerveSimplex c) +fillNerveInnerHorn categoryValue innerHornValue = do + let hornValue = innerHorn innerHornValue + dimensionValue' = hornDimension hornValue + leftOuterFace <- Map.lookup 0 (hornFaces hornValue) + rightOuterFace <- Map.lookup dimensionValue' (hornFaces hornValue) + guard + ( nerveSimplexDimension leftOuterFace == dimensionValue' - 1 + && nerveSimplexDimension rightOuterFace == dimensionValue' - 1 + ) + let leftMorphisms = chainMorphisms (nerveSimplexChain leftOuterFace) + rightMorphisms = chainMorphisms (nerveSimplexChain rightOuterFace) + firstMorphism <- safeIndexNatural 0 rightMorphisms + filledChain <- + either + (const Nothing) + Just + (mkComposableChain categoryValue (chainStartObject (nerveSimplexChain rightOuterFace)) (firstMorphism : leftMorphisms)) + let candidateSimplex = NerveSimplex dimensionValue' filledChain + checks <- + traverse + (\(fi, ef) -> sameSimplex ef . NerveSimplex (dimensionValue' - 1) <$> faceChain categoryValue fi filledChain) + (Map.toAscList (hornFaces hornValue)) + guard (and checks) + pure candidateSimplex + +fillNerveInnerHornIndexed :: + (Category c, Eq (Ob c), Eq (Mor c), KnownNat n) => + c -> + IndexedHorn n (NerveSimplex c) -> + Either InnerHornError (Maybe (NerveSimplex c)) +fillNerveInnerHornIndexed categoryValue indexedHornValue = + fillNerveInnerHorn categoryValue <$> mkInnerHorn (indexedHornToHorn indexedHornValue) + +instance (Category c, Eq (Ob c), Eq (Mor c)) => InnerKan (Nerve c) where + type InnerSimplex (Nerve c) = NerveSimplex c + fillInnerHorn nerveValue = fillNerveInnerHorn (nerveCategory nerveValue) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Ordinal.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Ordinal.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Ordinal.hs @@ -0,0 +1,239 @@ + +-- | Monotone maps between finite ordinals with runtime-validated construction. +module Moonlight.Category.Pure.Simplicial.Ordinal + ( Monotone, + SomeMonotone (..), + mkMonotone, + mkSomeMonotone, + monotoneValues, + monotoneDomainDimension, + monotoneCodomainDimension, + monotoneIdentity, + applyMonotoneAt, + composeMonotone, + composeSomeMonotone, + MonotoneInjection, + mkMonotoneInjection, + monotoneInjectionValues, + MonotoneSurjection, + mkMonotoneSurjection, + monotoneSurjectionValues, + NormalizedMonotone, + SomeNormalizedMonotone (..), + normalizeMonotone, + normalizeSomeMonotone, + denormalizeNormalizedMonotone, + denormalizeSomeNormalizedMonotone, + normalizedSurjectionValues, + normalizedInjectionValues, + monotoneEqualByNormalForm, + someMonotoneEqualByNormalForm, + ) +where + +import Data.Function ((&)) +import Data.Kind (Type) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat, Nat, SomeNat (..), natVal, someNatVal) +import Moonlight.Core (safeIndexNatural) +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Dimension (..)) + +type Monotone :: Nat -> Nat -> Type +data Monotone (m :: Nat) (n :: Nat) where + Monotone :: (KnownNat m, KnownNat n) => [Natural] -> Monotone m n + +type SomeMonotone :: Type +data SomeMonotone where + SomeMonotone :: (KnownNat m, KnownNat n) => Dimension m -> Dimension n -> Monotone m n -> SomeMonotone + +instance Eq (Monotone m n) where + left == right = monotoneValues left == monotoneValues right + +instance Show (Monotone m n) where + show monotone = + "Monotone(domain=" + <> show (monotoneDomainDimension monotone) + <> ", codomain=" + <> show (monotoneCodomainDimension monotone) + <> ", values=" + <> show (monotoneValues monotone) + <> ")" + +monotoneValues :: Monotone m n -> [Natural] +monotoneValues (Monotone values) = values + +monotoneDomainDimension :: forall m n. Monotone m n -> Natural +monotoneDomainDimension (Monotone _) = natVal (Proxy @m) + +monotoneCodomainDimension :: forall m n. Monotone m n -> Natural +monotoneCodomainDimension (Monotone _) = natVal (Proxy @n) + +hasExpectedLength :: Natural -> [a] -> Bool +hasExpectedLength domainDimension values = + fromIntegral (length values) == domainDimension + 1 + +nondecreasing :: [Natural] -> Bool +nondecreasing [] = False +nondecreasing values = and (zipWith (<=) values (drop 1 values)) + +mkMonotone :: forall m n. (KnownNat m, KnownNat n) => [Natural] -> Maybe (Monotone m n) +mkMonotone values = + let domainDimension = natVal (Proxy @m) + codomainDimension = natVal (Proxy @n) + in if hasExpectedLength domainDimension values + && all (<= codomainDimension) values + && nondecreasing values + then Just (Monotone values) + else Nothing + +mkSomeMonotone :: Natural -> Natural -> [Natural] -> Maybe SomeMonotone +mkSomeMonotone domainDimension codomainDimension values = + case (someNatVal domainDimension, someNatVal codomainDimension) of + (SomeNat (_ :: Proxy m), SomeNat (_ :: Proxy n)) -> + SomeMonotone (Dimension @m) (Dimension @n) <$> mkMonotone @m @n values + +monotoneIdentity :: forall n. KnownNat n => Monotone n n +monotoneIdentity = + let dimensionValue = natVal (Proxy @n) + in Monotone [0 .. dimensionValue] + +applyMonotoneAt :: Monotone m n -> Natural -> Maybe Natural +applyMonotoneAt monotone indexValue = + safeIndexNatural indexValue (monotoneValues monotone) + +composeMonotone :: Monotone n p -> Monotone m n -> Maybe (Monotone m p) +composeMonotone (Monotone outerValues) (Monotone innerValues) = + traverse (`safeIndexNatural` outerValues) innerValues + >>= mkMonotone + +composeSomeMonotone :: SomeMonotone -> SomeMonotone -> Maybe SomeMonotone +composeSomeMonotone (SomeMonotone _ _ outer) (SomeMonotone _ _ inner) = + if monotoneDomainDimension outer == monotoneCodomainDimension inner + then do + composedValues <- traverse (`safeIndexNatural` monotoneValues outer) (monotoneValues inner) + mkSomeMonotone + (monotoneDomainDimension inner) + (monotoneCodomainDimension outer) + composedValues + else Nothing + +type MonotoneInjection :: Nat -> Nat -> Type +newtype MonotoneInjection (k :: Nat) (n :: Nat) = MonotoneInjection + { unMonotoneInjection :: Monotone k n + } + +instance Show (MonotoneInjection k n) where + show injection = "MonotoneInjection(" <> show (monotoneInjectionValues injection) <> ")" + +type MonotoneSurjection :: Nat -> Nat -> Type +newtype MonotoneSurjection (m :: Nat) (k :: Nat) = MonotoneSurjection + { unMonotoneSurjection :: Monotone m k + } + +instance Show (MonotoneSurjection m k) where + show surjection = "MonotoneSurjection(" <> show (monotoneSurjectionValues surjection) <> ")" + +strictlyIncreasing :: [Natural] -> Bool +strictlyIncreasing [] = False +strictlyIncreasing values = and (zipWith (<) values (drop 1 values)) + +mkMonotoneInjection :: Monotone k n -> Maybe (MonotoneInjection k n) +mkMonotoneInjection monotone = + if strictlyIncreasing (monotoneValues monotone) + then Just (MonotoneInjection monotone) + else Nothing + +monotoneInjectionValues :: MonotoneInjection k n -> [Natural] +monotoneInjectionValues = monotoneValues . unMonotoneInjection + +coversAllCodomain :: Natural -> [Natural] -> Bool +coversAllCodomain codomainDimension values = + fmap NonEmpty.head (NonEmpty.group values) == [0 .. codomainDimension] + +mkMonotoneSurjection :: Monotone m k -> Maybe (MonotoneSurjection m k) +mkMonotoneSurjection monotone = + if coversAllCodomain (monotoneCodomainDimension monotone) (monotoneValues monotone) + then Just (MonotoneSurjection monotone) + else Nothing + +monotoneSurjectionValues :: MonotoneSurjection m k -> [Natural] +monotoneSurjectionValues = monotoneValues . unMonotoneSurjection + +type NormalizedMonotone :: Nat -> Nat -> Type +data NormalizedMonotone (m :: Nat) (n :: Nat) where + NormalizedMonotone :: KnownNat k => Dimension k -> MonotoneSurjection m k -> MonotoneInjection k n -> NormalizedMonotone m n + +type SomeNormalizedMonotone :: Type +data SomeNormalizedMonotone where + SomeNormalizedMonotone :: (KnownNat m, KnownNat n) => Dimension m -> Dimension n -> NormalizedMonotone m n -> SomeNormalizedMonotone + +instance Show (NormalizedMonotone m n) where + show normalized = + "NormalizedMonotone(surjection=" + <> show (normalizedSurjectionValues normalized) + <> ", injection=" + <> show (normalizedInjectionValues normalized) + <> ")" + +normalizedSurjectionValues :: NormalizedMonotone m n -> [Natural] +normalizedSurjectionValues (NormalizedMonotone _ surjection _) = + monotoneSurjectionValues surjection + +normalizedInjectionValues :: NormalizedMonotone m n -> [Natural] +normalizedInjectionValues (NormalizedMonotone _ _ injection) = + monotoneInjectionValues injection + +normalizeMonotone :: forall m n. Monotone m n -> Maybe (NormalizedMonotone m n) +normalizeMonotone (Monotone values) = + let rankedValueGroups = zip [0 ..] (NonEmpty.group values) + imageValues = fmap (NonEmpty.head . snd) rankedValueGroups + surjectionValues = + rankedValueGroups + & foldMap (\(imageRank, valueGroup) -> fmap (const imageRank) (NonEmpty.toList valueGroup)) + middleDimension = fromIntegral (length imageValues) - 1 + in case someNatVal middleDimension of + SomeNat (_ :: Proxy k) -> do + surjection <- mkMonotone @m @k surjectionValues >>= mkMonotoneSurjection + injection <- mkMonotone @k @n imageValues >>= mkMonotoneInjection + pure (NormalizedMonotone (Dimension @k) surjection injection) + +normalizeSomeMonotone :: SomeMonotone -> Maybe SomeNormalizedMonotone +normalizeSomeMonotone (SomeMonotone domainDimension codomainDimension monotone) = + SomeNormalizedMonotone domainDimension codomainDimension <$> normalizeMonotone monotone + +denormalizeNormalizedMonotone :: NormalizedMonotone m n -> Maybe (Monotone m n) +denormalizeNormalizedMonotone (NormalizedMonotone _ surjection injection) = + composeMonotone (unMonotoneInjection injection) (unMonotoneSurjection surjection) + +denormalizeSomeNormalizedMonotone :: SomeNormalizedMonotone -> Maybe SomeMonotone +denormalizeSomeNormalizedMonotone (SomeNormalizedMonotone domainDimension codomainDimension normalized) = + SomeMonotone domainDimension codomainDimension <$> denormalizeNormalizedMonotone normalized + +monotoneEqualByNormalForm :: Monotone m n -> Monotone m n -> Bool +monotoneEqualByNormalForm left right = + fromMaybe False $ do + leftNormalized <- normalizeMonotone left + rightNormalized <- normalizeMonotone right + pure $ normalizedSurjectionValues leftNormalized == normalizedSurjectionValues rightNormalized + && normalizedInjectionValues leftNormalized == normalizedInjectionValues rightNormalized + +someMonotoneEqualByNormalForm :: SomeMonotone -> SomeMonotone -> Bool +someMonotoneEqualByNormalForm left right + | monotoneDomainDimensionFromSome left /= monotoneDomainDimensionFromSome right = False + | monotoneCodomainDimensionFromSome left /= monotoneCodomainDimensionFromSome right = False + | otherwise = fromMaybe False $ do + SomeNormalizedMonotone _ _ leftNormalized <- normalizeSomeMonotone left + SomeNormalizedMonotone _ _ rightNormalized <- normalizeSomeMonotone right + pure $ normalizedSurjectionValues leftNormalized == normalizedSurjectionValues rightNormalized + && normalizedInjectionValues leftNormalized == normalizedInjectionValues rightNormalized + +monotoneDomainDimensionFromSome :: SomeMonotone -> Natural +monotoneDomainDimensionFromSome (SomeMonotone _ _ monotone) = + monotoneDomainDimension monotone + +monotoneCodomainDimensionFromSome :: SomeMonotone -> Natural +monotoneCodomainDimensionFromSome (SomeMonotone _ _ monotone) = + monotoneCodomainDimension monotone diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Presheaf.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Presheaf.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Presheaf.hs @@ -0,0 +1,121 @@ +-- | Simplicial sets as presheaves on the simplex category: object and morphism +-- maps with identity and composition law checks. +module Moonlight.Category.Pure.Simplicial.Presheaf + ( SimplicialPresheaf, + presheafUpperBound, + presheafObjectMap, + presheafMorphismMap, + generatedAsPresheaf, + applyPresheaf, + presheafIdentityLaw, + presheafCompositionLaw, + ) +where + +import Control.Monad ((<=<), foldM) +import Data.Function ((&)) +import Data.Kind (Type) +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Simplicial.Delta + ( DeltaMorphism, + composeDeltaMorphism, + deltaIdentity, + injectionMissingIndices, + normalCodomainDimension, + normalDomainDimension, + normalInjection, + normalSurjection, + normalizeDeltaMorphism, + surjectionDegeneracyIndices, + ) +import Moonlight.Category.Pure.Simplicial.Set + ( GeneratedSSet, + applyGeneratedDegeneracyAtDimension, + applyGeneratedFaceAtDimension, + generatedSimplicesAtDimension, + generationBound, + ) + +type SimplicialPresheaf :: Type -> Type +data SimplicialPresheaf simplex = SimplicialPresheaf + { presheafUpperBound :: Natural, + presheafObjectMap :: Natural -> [simplex], + presheafMorphismMap :: DeltaMorphism -> simplex -> Maybe simplex + } + +applyPresheaf :: SimplicialPresheaf simplex -> DeltaMorphism -> simplex -> Maybe simplex +applyPresheaf = presheafMorphismMap + +stepFaces :: (Natural -> Natural -> simplex -> Maybe simplex) -> Natural -> [Natural] -> simplex -> Maybe (Natural, simplex) +stepFaces applyFace startDimension faceIndices simplexValue = + foldM + ( \(dimensionValue, currentSimplex) faceIndex -> do + nextSimplex <- applyFace dimensionValue faceIndex currentSimplex + pure (dimensionValue - 1, nextSimplex) + ) + (startDimension, simplexValue) + (reverse faceIndices) + +stepDegeneracies :: (Natural -> Natural -> simplex -> Maybe simplex) -> Natural -> [Natural] -> simplex -> Maybe (Natural, simplex) +stepDegeneracies applyDegeneracy startDimension degeneracyIndices simplexValue = + foldM + ( \(dimensionValue, currentSimplex) degeneracyIndex -> do + nextSimplex <- applyDegeneracy dimensionValue degeneracyIndex currentSimplex + pure (dimensionValue + 1, nextSimplex) + ) + (startDimension, simplexValue) + (reverse degeneracyIndices) + +applyWithGenerators :: + (Natural -> Natural -> simplex -> Maybe simplex) -> + (Natural -> Natural -> simplex -> Maybe simplex) -> + DeltaMorphism -> + simplex -> + Maybe simplex +applyWithGenerators applyFace applyDegeneracy morphism simplexValue = + do + normalForm <- normalizeDeltaMorphism morphism + let missingFaces = + injectionMissingIndices + (normalCodomainDimension normalForm) + (normalInjection normalForm) + degeneracyIndices = surjectionDegeneracyIndices (normalSurjection normalForm) + (middleDimension, afterFaces) <- + stepFaces applyFace (normalCodomainDimension normalForm) missingFaces simplexValue + (resultDimension, afterDegeneracies) <- + stepDegeneracies applyDegeneracy middleDimension degeneracyIndices afterFaces + if resultDimension == normalDomainDimension normalForm + then Just afterDegeneracies + else Nothing + +generatedAsPresheaf :: GeneratedSSet simplex -> SimplicialPresheaf simplex +generatedAsPresheaf generatedSet = + SimplicialPresheaf + { presheafUpperBound = generationBound generatedSet, + presheafObjectMap = generatedSimplicesAtDimension generatedSet, + presheafMorphismMap = + applyWithGenerators + (applyGeneratedFaceAtDimension generatedSet) + (applyGeneratedDegeneracyAtDimension generatedSet) + } + +presheafIdentityLaw :: Eq simplex => SimplicialPresheaf simplex -> Natural -> Bool +presheafIdentityLaw presheaf dimensionValue = + presheafObjectMap presheaf dimensionValue + & all + (\simplexValue -> applyPresheaf presheaf (deltaIdentity dimensionValue) simplexValue == Just simplexValue) + +presheafCompositionLaw :: + Eq simplex => + SimplicialPresheaf simplex -> + DeltaMorphism -> + DeltaMorphism -> + simplex -> + Bool +presheafCompositionLaw presheaf outer inner simplexValue = + let leftAction = + composeDeltaMorphism outer inner + >>= (\composed -> applyPresheaf presheaf composed simplexValue) + rightAction = + (applyPresheaf presheaf inner <=< applyPresheaf presheaf outer) simplexValue + in leftAction == rightAction diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Set.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Set.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Set.hs @@ -0,0 +1,360 @@ +-- | Finite truncated simplicial sets generated from indexed simplices, with +-- typed well-formedness obstructions. +module Moonlight.Category.Pure.Simplicial.Set + ( GeneratedSSet, + generationBound, + GeneratedSSetObstruction (..), + GeneratedSSetCheck, + IndexedSimplex, + unindexSimplex, + SomeIndexedSimplex (..), + indexSimplexIn, + mkGeneratedSSet, + validateGeneratedSSet, + generatedSimplicesAt, + generatedSimplicesAtDimension, + applyGeneratedFaceAtDimension, + applyGeneratedDegeneracyAtDimension, + TruncatedNormalizedSSet, + truncationBound, + TruncatedSSetObstruction (..), + TruncatedSSetCheck, + normalizeGeneratedSSet, + mkTruncatedSSet, + validateTruncatedSSet, + simplicesAt, + simplicesAtDimension, + applyFaceAtDimension, + applyDegeneracyAtDimension, + faceIndexed, + degeneracyIndexed, + ) +where + +import Data.Function ((&)) +import Data.Foldable (toList) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (isNothing) +import qualified Data.Map.Strict as Map +import GHC.TypeNats (KnownNat, Nat, type (+)) +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Simplicial.Validation.Internal + ( SimplicialLawCarrier (..), + SimplicialLawIndices (..), + SimplicialLawObstruction (..), + checkObstructions, + checkSimplicialLawsBy, + dimensionsStrictlyBelow, + simplicialLawEq, + ) +import Moonlight.Category.Pure.Simplicial.Set.Internal + ( GeneratedSSet (..), + TruncatedNormalizedSSet (..), + trustedGeneratedSSet, + trustedTruncatedNormalizedSSet, + ) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Dimension (..), Fin, dimensionValue, withReifiedFinOffset) + +type GeneratedSSetObstruction :: Type -> Type +data GeneratedSSetObstruction simplex + = GeneratedFaceUndefined Natural Natural simplex + | GeneratedFaceOutsideCarrier Natural Natural simplex simplex + | GeneratedDegeneracyUndefined Natural Natural simplex + | GeneratedDegeneracyOutsideCarrier Natural Natural simplex simplex + | GeneratedFaceFaceMismatch Natural simplex Natural Natural (Maybe simplex) (Maybe simplex) + | GeneratedDegeneracyDegeneracyMismatch Natural simplex Natural Natural (Maybe simplex) (Maybe simplex) + | GeneratedFaceDegeneracyMismatch Natural simplex Natural Natural (Maybe simplex) (Maybe simplex) + deriving stock (Eq, Show) + +type GeneratedSSetCheck :: Type -> Type +type GeneratedSSetCheck simplex = Either (NonEmpty (GeneratedSSetObstruction simplex)) () + +type TruncatedSSetObstruction :: Type -> Type +data TruncatedSSetObstruction simplex + = TruncatedRowOutsideBound Natural + | TruncatedFaceUndefined Natural Natural simplex + | TruncatedDegeneracyUndefined Natural Natural simplex + | TruncatedLawViolation (SimplicialLawObstruction simplex) + deriving stock (Eq, Show) + +type TruncatedSSetCheck :: Type -> Type +type TruncatedSSetCheck simplex = Either (NonEmpty (TruncatedSSetObstruction simplex)) () + +type IndexedSimplex :: Nat -> Type -> Type +newtype IndexedSimplex (n :: Nat) simplex = IndexedSimplex + { unindexSimplex :: simplex + } + deriving stock (Eq, Ord, Show) + +type SomeIndexedSimplex :: Type -> Type +data SomeIndexedSimplex simplex where + SomeIndexedSimplex :: KnownNat n => Dimension n -> IndexedSimplex n simplex -> SomeIndexedSimplex simplex + +indexSimplexIn :: (Eq simplex, KnownNat n) => TruncatedNormalizedSSet simplex -> Dimension n -> simplex -> Maybe (IndexedSimplex n simplex) +indexSimplexIn simplicialSet dimensionWitness simplexValue = + if simplexValue `elem` simplicesAt simplicialSet dimensionWitness + then Just (IndexedSimplex simplexValue) + else Nothing + +mkGeneratedSSet :: + Eq simplex => + Natural -> + (Natural -> [simplex]) -> + (forall n. KnownNat n => Dimension (n + 1) -> Fin (n + 2) -> simplex -> Maybe simplex) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + Either (NonEmpty (GeneratedSSetObstruction simplex)) (GeneratedSSet simplex) +mkGeneratedSSet upperBound simplicesFunction faceFunction degeneracyFunction = + let generatedSet = trustedGeneratedSSet upperBound simplicesFunction faceFunction degeneracyFunction + in generatedSet <$ validateGeneratedSSet generatedSet + +validateGeneratedSSet :: Eq simplex => GeneratedSSet simplex -> GeneratedSSetCheck simplex +validateGeneratedSSet generatedSet = + checkObstructions + ( faceClosureObstructions generatedSet + <> degeneracyClosureObstructions generatedSet + <> generatedLawObstructions generatedSet + ) + +generatedSimplicesAt :: forall n simplex. KnownNat n => GeneratedSSet simplex -> Dimension n -> [simplex] +generatedSimplicesAt generatedSet dimensionWitness = + generatedSimplicesAtDimension generatedSet (dimensionValue dimensionWitness) + +generatedSimplicesAtDimension :: GeneratedSSet simplex -> Natural -> [simplex] +generatedSimplicesAtDimension generatedSet dimensionValue' = + if dimensionValue' <= generationBound generatedSet + then generatedSimplicesByDimension generatedSet dimensionValue' + else [] + +applyGeneratedFaceAtDimension :: GeneratedSSet simplex -> Natural -> Natural -> simplex -> Maybe simplex +applyGeneratedFaceAtDimension generatedSet simplexDimension faceIndex simplexValue + | simplexDimension == 0 = Nothing + | simplexDimension > generationBound generatedSet = Nothing + | faceIndex > simplexDimension = Nothing + | otherwise = withReifiedFinOffset @2 (simplexDimension - 1) faceIndex $ \(_ :: Dimension n) finiteIndex -> + generatedFaceMap generatedSet (Dimension @(n + 1)) finiteIndex simplexValue + +applyGeneratedDegeneracyAtDimension :: GeneratedSSet simplex -> Natural -> Natural -> simplex -> Maybe simplex +applyGeneratedDegeneracyAtDimension generatedSet simplexDimension degeneracyIndex simplexValue + | simplexDimension >= generationBound generatedSet = Nothing + | degeneracyIndex > simplexDimension = Nothing + | otherwise = withReifiedFinOffset @1 simplexDimension degeneracyIndex $ \dimensionWitness finiteIndex -> + generatedDegeneracyMap generatedSet dimensionWitness finiteIndex simplexValue + +generatedCarrierContains :: Eq simplex => GeneratedSSet simplex -> Natural -> simplex -> Bool +generatedCarrierContains generatedSet dimensionValue' simplexValue = + simplexValue `elem` generatedSimplicesAtDimension generatedSet dimensionValue' + +faceClosureObstructions :: Eq simplex => GeneratedSSet simplex -> [GeneratedSSetObstruction simplex] +faceClosureObstructions generatedSet = + [ obstruction + | simplexDimension <- [1 .. generationBound generatedSet], + simplexValue <- generatedSimplicesAtDimension generatedSet simplexDimension, + faceIndex <- [0 .. simplexDimension], + obstruction <- + case applyGeneratedFaceAtDimension generatedSet simplexDimension faceIndex simplexValue of + Nothing -> [GeneratedFaceUndefined simplexDimension faceIndex simplexValue] + Just faceValue -> + if generatedCarrierContains generatedSet (simplexDimension - 1) faceValue + then [] + else [GeneratedFaceOutsideCarrier simplexDimension faceIndex simplexValue faceValue] + ] + +degeneracyClosureObstructions :: Eq simplex => GeneratedSSet simplex -> [GeneratedSSetObstruction simplex] +degeneracyClosureObstructions generatedSet = + [ obstruction + | simplexDimension <- dimensionsStrictlyBelow (generationBound generatedSet), + simplexValue <- generatedSimplicesAtDimension generatedSet simplexDimension, + degeneracyIndex <- [0 .. simplexDimension], + obstruction <- + case applyGeneratedDegeneracyAtDimension generatedSet simplexDimension degeneracyIndex simplexValue of + Nothing -> [GeneratedDegeneracyUndefined simplexDimension degeneracyIndex simplexValue] + Just degeneracyValue -> + if generatedCarrierContains generatedSet (simplexDimension + 1) degeneracyValue + then [] + else [GeneratedDegeneracyOutsideCarrier simplexDimension degeneracyIndex simplexValue degeneracyValue] + ] + +generatedLawCarrier :: GeneratedSSet simplex -> SimplicialLawCarrier simplex +generatedLawCarrier generatedSet = + SimplicialLawCarrier + { lawCarrierUpperBound = generationBound generatedSet, + lawCarrierSimplicesAtDimension = generatedSimplicesAtDimension generatedSet, + lawCarrierFaceAtDimension = applyGeneratedFaceAtDimension generatedSet, + lawCarrierDegeneracyAtDimension = applyGeneratedDegeneracyAtDimension generatedSet + } + +generatedLawObstruction :: SimplicialLawObstruction simplex -> GeneratedSSetObstruction simplex +generatedLawObstruction obstruction = + case lawObstructionIndices obstruction of + FaceFaceIndices leftFaceIndex rightFaceIndex -> + GeneratedFaceFaceMismatch + (lawObstructionDimension obstruction) + (lawObstructionSimplex obstruction) + leftFaceIndex + rightFaceIndex + (lawObstructionLeftResult obstruction) + (lawObstructionRightResult obstruction) + DegeneracyDegeneracyIndices leftDegeneracyIndex rightDegeneracyIndex -> + GeneratedDegeneracyDegeneracyMismatch + (lawObstructionDimension obstruction) + (lawObstructionSimplex obstruction) + leftDegeneracyIndex + rightDegeneracyIndex + (lawObstructionLeftResult obstruction) + (lawObstructionRightResult obstruction) + FaceDegeneracyIndices faceIndex degeneracyIndex -> + GeneratedFaceDegeneracyMismatch + (lawObstructionDimension obstruction) + (lawObstructionSimplex obstruction) + faceIndex + degeneracyIndex + (lawObstructionLeftResult obstruction) + (lawObstructionRightResult obstruction) + +generatedLawObstructions :: Eq simplex => GeneratedSSet simplex -> [GeneratedSSetObstruction simplex] +generatedLawObstructions generatedSet = + case checkSimplicialLawsBy simplicialLawEq (generatedLawCarrier generatedSet) of + Right () -> [] + Left obstructions -> generatedLawObstruction <$> toList obstructions + +canonicalizeDimension :: (Natural -> simplex -> Bool) -> Natural -> [simplex] -> [simplex] +canonicalizeDimension isDegenerate dimensionValue' simplices = + simplices + & filter (not . isDegenerate dimensionValue') + +normalizeGeneratedSSet :: GeneratedSSet simplex -> TruncatedNormalizedSSet simplex +normalizeGeneratedSSet generatedSet = + let upperBound = generationBound generatedSet + canonicalRows = + [0 .. upperBound] + & foldr + ( \dimensionValue' -> + let canonicalRow = + canonicalizeDimension + (generatedDegenerateWitness generatedSet) + dimensionValue' + (generatedSimplicesByDimension generatedSet dimensionValue') + in if null canonicalRow + then id + else Map.insert dimensionValue' canonicalRow + ) + Map.empty + in trustedTruncatedNormalizedSSet + upperBound + canonicalRows + (generatedFaceMap generatedSet) + (generatedDegeneracyMap generatedSet) + +mkTruncatedSSet :: + Eq simplex => + Natural -> + [(Natural, [simplex])] -> + (forall n. KnownNat n => Dimension (n + 1) -> Fin (n + 2) -> simplex -> Maybe simplex) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + (Natural -> simplex -> Bool) -> + Either (NonEmpty (TruncatedSSetObstruction simplex)) (TruncatedNormalizedSSet simplex) +mkTruncatedSSet upperBound levelRows faceFunction degeneracyFunction degeneracyWitness = + let checkedRows = + levelRows + & foldr + ( \(dimensionValue', simplices) (outsideBounds, accumulatedLevelMap) -> + if dimensionValue' <= upperBound + then (outsideBounds, Map.insertWith (<>) dimensionValue' simplices accumulatedLevelMap) + else (TruncatedRowOutsideBound dimensionValue' : outsideBounds, accumulatedLevelMap) + ) + ([], Map.empty) + (rowObstructions, levelMap) = checkedRows + canonicalRows = + Map.mapWithKey + (\dimensionValue' -> filter (not . degeneracyWitness dimensionValue')) + levelMap + & Map.filter (not . null) + simplicialSet = trustedTruncatedNormalizedSSet upperBound canonicalRows faceFunction degeneracyFunction + in simplicialSet <$ checkObstructions (rowObstructions <> truncatedValidationObstructions simplicialSet) + +validateTruncatedSSet :: Eq simplex => TruncatedNormalizedSSet simplex -> TruncatedSSetCheck simplex +validateTruncatedSSet = + checkObstructions . truncatedValidationObstructions + +truncatedLawCarrier :: TruncatedNormalizedSSet simplex -> SimplicialLawCarrier simplex +truncatedLawCarrier simplicialSet = + SimplicialLawCarrier + { lawCarrierUpperBound = truncationBound simplicialSet, + lawCarrierSimplicesAtDimension = simplicesAtDimension simplicialSet, + lawCarrierFaceAtDimension = applyFaceAtDimension simplicialSet, + lawCarrierDegeneracyAtDimension = applyDegeneracyAtDimension simplicialSet + } + +truncatedLawObstructions :: Eq simplex => TruncatedNormalizedSSet simplex -> [TruncatedSSetObstruction simplex] +truncatedLawObstructions simplicialSet = + case checkSimplicialLawsBy simplicialLawEq (truncatedLawCarrier simplicialSet) of + Right () -> [] + Left obstructions -> TruncatedLawViolation <$> toList obstructions + +truncatedFaceTotalityObstructions :: TruncatedNormalizedSSet simplex -> [TruncatedSSetObstruction simplex] +truncatedFaceTotalityObstructions simplicialSet = + [ TruncatedFaceUndefined simplexDimension faceIndex simplexValue + | simplexDimension <- [1 .. truncationBound simplicialSet], + simplexValue <- simplicesAtDimension simplicialSet simplexDimension, + faceIndex <- [0 .. simplexDimension], + isNothing (applyFaceAtDimension simplicialSet simplexDimension faceIndex simplexValue) + ] + +truncatedDegeneracyTotalityObstructions :: TruncatedNormalizedSSet simplex -> [TruncatedSSetObstruction simplex] +truncatedDegeneracyTotalityObstructions simplicialSet = + [ TruncatedDegeneracyUndefined simplexDimension degeneracyIndex simplexValue + | simplexDimension <- dimensionsStrictlyBelow (truncationBound simplicialSet), + simplexValue <- simplicesAtDimension simplicialSet simplexDimension, + degeneracyIndex <- [0 .. simplexDimension], + isNothing (applyDegeneracyAtDimension simplicialSet simplexDimension degeneracyIndex simplexValue) + ] + +truncatedValidationObstructions :: Eq simplex => TruncatedNormalizedSSet simplex -> [TruncatedSSetObstruction simplex] +truncatedValidationObstructions simplicialSet = + truncatedFaceTotalityObstructions simplicialSet + <> truncatedDegeneracyTotalityObstructions simplicialSet + <> truncatedLawObstructions simplicialSet + +simplicesAt :: forall n simplex. KnownNat n => TruncatedNormalizedSSet simplex -> Dimension n -> [simplex] +simplicesAt simplicialSet dimensionWitness = + Map.findWithDefault [] (dimensionValue dimensionWitness) (nondegenerateSimplicesByDimension simplicialSet) + +simplicesAtDimension :: TruncatedNormalizedSSet simplex -> Natural -> [simplex] +simplicesAtDimension simplicialSet dimensionValue' = + Map.findWithDefault [] dimensionValue' (nondegenerateSimplicesByDimension simplicialSet) + +applyFaceAtDimension :: TruncatedNormalizedSSet simplex -> Natural -> Natural -> simplex -> Maybe simplex +applyFaceAtDimension simplicialSet simplexDimension faceIndex simplexValue + | simplexDimension == 0 = Nothing + | simplexDimension > truncationBound simplicialSet = Nothing + | faceIndex > simplexDimension = Nothing + | otherwise = withReifiedFinOffset @2 (simplexDimension - 1) faceIndex $ \(_ :: Dimension n) finiteIndex -> + faceMap simplicialSet (Dimension @(n + 1)) finiteIndex simplexValue + +applyDegeneracyAtDimension :: TruncatedNormalizedSSet simplex -> Natural -> Natural -> simplex -> Maybe simplex +applyDegeneracyAtDimension simplicialSet simplexDimension degeneracyIndex simplexValue + | simplexDimension >= truncationBound simplicialSet = Nothing + | degeneracyIndex > simplexDimension = Nothing + | otherwise = withReifiedFinOffset @1 simplexDimension degeneracyIndex $ \dimensionWitness finiteIndex -> + degeneracyMap simplicialSet dimensionWitness finiteIndex simplexValue + +faceIndexed :: + forall n simplex. + KnownNat n => + TruncatedNormalizedSSet simplex -> + Fin (n + 2) -> + IndexedSimplex (n + 1) simplex -> + Maybe (IndexedSimplex n simplex) +faceIndexed simplicialSet faceIndex (IndexedSimplex simplexValue) = + IndexedSimplex <$> faceMap simplicialSet (Dimension @(n + 1)) faceIndex simplexValue + +degeneracyIndexed :: + forall n simplex. + KnownNat n => + TruncatedNormalizedSSet simplex -> + Fin (n + 1) -> + IndexedSimplex n simplex -> + Maybe (IndexedSimplex (n + 1) simplex) +degeneracyIndexed simplicialSet degeneracyIndex (IndexedSimplex simplexValue) = + IndexedSimplex <$> degeneracyMap simplicialSet (Dimension @n) degeneracyIndex simplexValue diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Set/Internal.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Set/Internal.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Set/Internal.hs @@ -0,0 +1,139 @@ +module Moonlight.Category.Pure.Simplicial.Set.Internal + ( GeneratedSSet (..), + TruncatedNormalizedSSet (..), + trustedGeneratedSSet, + trustedGeneratedSSetWithWitness, + trustedTruncatedNormalizedSSet, + ) +where + +import Data.Kind (Type) +import Data.Map.Strict (Map) +import GHC.TypeNats (KnownNat, type (+)) +import Moonlight.Category.Pure.Simplicial.TypeLevel (Dimension (..), Fin, withReifiedFinOffset) +import Numeric.Natural (Natural) + +type GeneratedSSet :: Type -> Type +data GeneratedSSet simplex = GeneratedSSet + { generationBound :: Natural, + generatedSimplicesByDimension :: Natural -> [simplex], + generatedFaceMap :: + forall n. + KnownNat n => + Dimension (n + 1) -> + Fin (n + 2) -> + simplex -> + Maybe simplex, + generatedDegeneracyMap :: + forall n. + KnownNat n => + Dimension n -> + Fin (n + 1) -> + simplex -> + Maybe simplex, + generatedDegenerateWitness :: Natural -> simplex -> Bool + } + +type TruncatedNormalizedSSet :: Type -> Type +data TruncatedNormalizedSSet simplex = TruncatedNormalizedSSet + { truncationBound :: Natural, + nondegenerateSimplicesByDimension :: Map Natural [simplex], + faceMap :: + forall n. + KnownNat n => + Dimension (n + 1) -> + Fin (n + 2) -> + simplex -> + Maybe simplex, + degeneracyMap :: + forall n. + KnownNat n => + Dimension n -> + Fin (n + 1) -> + simplex -> + Maybe simplex + } + +applyDegeneracyFunctionAtDimension :: + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + Natural -> + Natural -> + simplex -> + Maybe simplex +applyDegeneracyFunctionAtDimension degeneracyFunction simplexDimension degeneracyIndex simplexValue + | degeneracyIndex > simplexDimension = Nothing + | otherwise = withReifiedFinOffset @1 simplexDimension degeneracyIndex $ \dimensionWitness finiteIndex -> + degeneracyFunction dimensionWitness finiteIndex simplexValue + +derivedDegenerateWitness :: + Eq simplex => + Natural -> + (Natural -> [simplex]) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + Natural -> + simplex -> + Bool +derivedDegenerateWitness upperBound simplicesFunction degeneracyFunction simplexDimension simplexValue + | simplexDimension == 0 = False + | simplexDimension > upperBound = False + | otherwise = + let sourceDimension = simplexDimension - 1 + in any + ( \sourceSimplex -> + any + ( \degeneracyIndex -> + applyDegeneracyFunctionAtDimension degeneracyFunction sourceDimension degeneracyIndex sourceSimplex + == Just simplexValue + ) + [0 .. sourceDimension] + ) + (simplicesFunction sourceDimension) + +trustedGeneratedSSet :: + Eq simplex => + Natural -> + (Natural -> [simplex]) -> + (forall n. KnownNat n => Dimension (n + 1) -> Fin (n + 2) -> simplex -> Maybe simplex) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + GeneratedSSet simplex +trustedGeneratedSSet upperBound simplicesFunction faceFunction degeneracyFunction = + trustedGeneratedSSetWithWitness + upperBound + simplicesFunction + faceFunction + degeneracyFunction + (derivedDegenerateWitness upperBound simplicesFunction degeneracyFunction) + +trustedGeneratedSSetWithWitness :: + Natural -> + (Natural -> [simplex]) -> + (forall n. KnownNat n => Dimension (n + 1) -> Fin (n + 2) -> simplex -> Maybe simplex) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + (Natural -> simplex -> Bool) -> + GeneratedSSet simplex +trustedGeneratedSSetWithWitness upperBound simplicesFunction faceFunction degeneracyFunction degenerateWitness = + GeneratedSSet + { generationBound = upperBound, + generatedSimplicesByDimension = + \dimensionValue -> + if dimensionValue <= upperBound + then simplicesFunction dimensionValue + else [], + generatedFaceMap = faceFunction, + generatedDegeneracyMap = degeneracyFunction, + generatedDegenerateWitness = degenerateWitness + } + +trustedTruncatedNormalizedSSet :: + Natural -> + Map Natural [simplex] -> + (forall n. KnownNat n => Dimension (n + 1) -> Fin (n + 2) -> simplex -> Maybe simplex) -> + (forall n. KnownNat n => Dimension n -> Fin (n + 1) -> simplex -> Maybe simplex) -> + TruncatedNormalizedSSet simplex +trustedTruncatedNormalizedSSet upperBound levelMap faceFunction degeneracyFunction = + TruncatedNormalizedSSet + { truncationBound = upperBound, + nondegenerateSimplicesByDimension = levelMap, + faceMap = faceFunction, + degeneracyMap = degeneracyFunction + } diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Spaces.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Spaces.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Spaces.hs @@ -0,0 +1,158 @@ + +-- | The standard simplicial spaces: simplices, their boundaries, and horns, +-- as generated simplicial sets. +module Moonlight.Category.Pure.Simplicial.Spaces + ( standardSimplexGenerated, + standardSimplex, + boundarySimplexGenerated, + boundarySimplex, + hornSimplexGenerated, + hornSimplex, + ) +where + +import Data.Function ((&)) +import Data.List (genericSplitAt) +import Data.Map.Strict qualified as Map +import Numeric.Natural (Natural) +import Moonlight.Category.Pure.Simplicial.Delta + ( allDeltaMorphisms, + deltaMapValues, + ) +import Moonlight.Category.Pure.Simplicial.Set + ( GeneratedSSet, + TruncatedNormalizedSSet, + generatedSimplicesAtDimension, + ) +import Moonlight.Category.Pure.Simplicial.Set.Internal + ( GeneratedSSet (generatedDegeneracyMap, generatedFaceMap), + trustedGeneratedSSet, + trustedTruncatedNormalizedSSet, + ) +import Moonlight.Category.Pure.Simplicial.TypeLevel (finValue) + +duplicateAt :: Natural -> [a] -> Maybe [a] +duplicateAt targetIndex values = + case genericSplitAt targetIndex values of + (_, []) -> Nothing + (prefix, x : suffix) -> Just (prefix <> [x, x] <> suffix) + +removeAt :: Natural -> [a] -> Maybe [a] +removeAt targetIndex values = + case genericSplitAt targetIndex values of + (_, []) -> Nothing + (prefix, _ : suffix) -> Just (prefix <> suffix) + + +simplexRows :: Natural -> Natural -> [[Natural]] +simplexRows simplexDimension domainDimension = + deltaMapValues <$> allDeltaMorphisms domainDimension simplexDimension + +availableVertexCount :: Natural -> Natural -> Natural +availableVertexCount lowerBound upperBound = + if lowerBound > upperBound + then 0 + else upperBound - lowerBound + 1 + +strictlyIncreasingRows :: Natural -> Natural -> Natural -> [[Natural]] +strictlyIncreasingRows lowerBound upperBound rowLength + | rowLength == 0 = [[]] + | rowLength > availableVertexCount lowerBound upperBound = [] + | otherwise = + [lowerBound .. upperBound] + & concatMap + ( \headValue -> + strictlyIncreasingRows (headValue + 1) upperBound (rowLength - 1) + & map (headValue :) + ) + +nondegenerateSimplexRows :: Natural -> Natural -> [[Natural]] +nondegenerateSimplexRows simplexDimension domainDimension = + strictlyIncreasingRows 0 simplexDimension (domainDimension + 1) + +nonemptyNondegenerateRows :: Natural -> Natural -> ([Natural] -> Bool) -> Map.Map Natural [[Natural]] +nonemptyNondegenerateRows simplexDimension truncationBound rowPredicate = + [0 .. truncationBound] + & fmap + ( \dimensionValue -> + ( dimensionValue, + nondegenerateSimplexRows simplexDimension dimensionValue + & filter rowPredicate + ) + ) + & filter (not . null . snd) + & Map.fromAscList + +omitsVertex :: Natural -> [Natural] -> Bool +omitsVertex vertexValue simplexValue = + vertexValue `notElem` simplexValue + +belongsToBoundary :: Natural -> [Natural] -> Bool +belongsToBoundary simplexDimension simplexValue = + any (`omitsVertex` simplexValue) [0 .. simplexDimension] + +belongsToHorn :: Natural -> Natural -> [Natural] -> Bool +belongsToHorn simplexDimension missingFaceIndex simplexValue = + [0 .. simplexDimension] + & any + (\vertexValue -> vertexValue /= missingFaceIndex && omitsVertex vertexValue simplexValue) + +standardSimplexGenerated :: Natural -> Natural -> GeneratedSSet [Natural] +standardSimplexGenerated simplexDimension truncationBound = + trustedGeneratedSSet + truncationBound + (simplexRows simplexDimension) + (\_ faceIndex simplexValue -> removeAt (finValue faceIndex) simplexValue) + (\_ degeneracyIndex simplexValue -> duplicateAt (finValue degeneracyIndex) simplexValue) + +standardSimplex :: Natural -> Natural -> TruncatedNormalizedSSet [Natural] +standardSimplex simplexDimension truncationBound = + trustedTruncatedNormalizedSSet + truncationBound + (nonemptyNondegenerateRows simplexDimension truncationBound (const True)) + (\_ faceIndex simplexValue -> removeAt (finValue faceIndex) simplexValue) + (\_ degeneracyIndex simplexValue -> duplicateAt (finValue degeneracyIndex) simplexValue) + +boundarySimplexGenerated :: Natural -> Natural -> GeneratedSSet [Natural] +boundarySimplexGenerated simplexDimension truncationBound = + let baseSet = standardSimplexGenerated simplexDimension truncationBound + in trustedGeneratedSSet + truncationBound + (\dimensionValue' -> filter (belongsToBoundary simplexDimension) (generatedSimplicesAtDimension baseSet dimensionValue')) + (generatedFaceMap baseSet) + (generatedDegeneracyMap baseSet) + +boundarySimplex :: Natural -> Natural -> TruncatedNormalizedSSet [Natural] +boundarySimplex simplexDimension truncationBound = + trustedTruncatedNormalizedSSet + truncationBound + (nonemptyNondegenerateRows simplexDimension truncationBound (belongsToBoundary simplexDimension)) + (\_ faceIndex simplexValue -> removeAt (finValue faceIndex) simplexValue) + (\_ degeneracyIndex simplexValue -> duplicateAt (finValue degeneracyIndex) simplexValue) + +hornSimplexGenerated :: Natural -> Natural -> Natural -> Maybe (GeneratedSSet [Natural]) +hornSimplexGenerated simplexDimension missingFaceIndex truncationBound + | simplexDimension == 0 = Nothing + | missingFaceIndex > simplexDimension = Nothing + | otherwise = + let baseSet = standardSimplexGenerated simplexDimension truncationBound + in Just + ( trustedGeneratedSSet + truncationBound + (\dimensionValue' -> filter (belongsToHorn simplexDimension missingFaceIndex) (generatedSimplicesAtDimension baseSet dimensionValue')) + (generatedFaceMap baseSet) + (generatedDegeneracyMap baseSet) + ) + +hornSimplex :: Natural -> Natural -> Natural -> Maybe (TruncatedNormalizedSSet [Natural]) +hornSimplex simplexDimension missingFaceIndex truncationBound = + if simplexDimension == 0 || missingFaceIndex > simplexDimension + then Nothing + else + Just + ( trustedTruncatedNormalizedSSet + truncationBound + (nonemptyNondegenerateRows simplexDimension truncationBound (belongsToHorn simplexDimension missingFaceIndex)) + (\_ faceIndex simplexValue -> removeAt (finValue faceIndex) simplexValue) + (\_ degeneracyIndex simplexValue -> duplicateAt (finValue degeneracyIndex) simplexValue) + ) diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/TypeLevel.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/TypeLevel.hs @@ -0,0 +1,84 @@ + +{-# LANGUAGE RankNTypes #-} + +-- | Runtime-checked dimension and finite-index types (@Dimension@, @Fin@) +-- shared by the simplicial layer. +module Moonlight.Category.Pure.Simplicial.TypeLevel + ( Dimension (..), + SomeDimension (..), + dimensionValue, + mkSomeDimension, + allDimensionsUpTo, + Fin, + finValue, + mkFin, + mkFinOffset, + withFin, + withReifiedFinOffset, + allFinite, + weakenFin, + ) +where + +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat, Nat, SomeNat (..), natVal, someNatVal, type (+)) +import Numeric.Natural (Natural) + +type Dimension :: Nat -> Type +data Dimension (n :: Nat) = Dimension + +type SomeDimension :: Type +data SomeDimension where + SomeDimension :: KnownNat n => Dimension n -> SomeDimension + +dimensionValue :: forall n. KnownNat n => Dimension n -> Natural +dimensionValue _ = natVal (Proxy @n) + +mkSomeDimension :: Natural -> SomeDimension +mkSomeDimension naturalValue = + case someNatVal naturalValue of + SomeNat (_ :: Proxy n) -> SomeDimension (Dimension :: Dimension n) + +allDimensionsUpTo :: Natural -> [SomeDimension] +allDimensionsUpTo upperBound = + map mkSomeDimension [0 .. upperBound] + +type Fin :: Nat -> Type +newtype Fin (n :: Nat) = Fin Natural + deriving stock (Eq, Ord, Show) + +finValue :: Fin n -> Natural +finValue (Fin naturalValue) = naturalValue + +mkFin :: forall n. KnownNat n => Natural -> Maybe (Fin n) +mkFin candidate = + if candidate < natVal (Proxy @n) + then Just (Fin candidate) + else Nothing + +mkFinOffset :: forall n m. (KnownNat n, KnownNat m) => Dimension n -> Natural -> Maybe (Fin (n + m)) +mkFinOffset _ candidate = + let upperBound = natVal (Proxy @n) + natVal (Proxy @m) + in if candidate < upperBound + then Just (Fin candidate) + else Nothing + +withFin :: forall n result. KnownNat n => Natural -> (Fin n -> result) -> Maybe result +withFin candidate handler = handler <$> mkFin candidate + +allFinite :: forall n. KnownNat n => [Fin n] +allFinite = + let upperBound = natVal (Proxy @n) + in if upperBound == 0 + then [] + else map Fin [0 .. upperBound - 1] + +withReifiedFinOffset :: forall offset a. KnownNat offset + => Natural -> Natural -> (forall n. KnownNat n => Dimension n -> Fin (n + offset) -> Maybe a) -> Maybe a +withReifiedFinOffset dimensionNat indexNat f = + case someNatVal dimensionNat of + SomeNat (_ :: Proxy n) -> mkFinOffset @n @offset (Dimension @n) indexNat >>= f (Dimension @n) + +weakenFin :: Fin n -> Fin (n + 1) +weakenFin (Fin naturalValue) = Fin naturalValue diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation.hs @@ -0,0 +1,82 @@ +-- | Typed obstructions for the simplicial identities: law kinds, indices, and +-- checks reported as values rather than exceptions. +module Moonlight.Category.Pure.Simplicial.Validation + ( SimplicialLawEquality, + simplicialLawEq, + SimplicialLawKind (..), + allSimplicialLawKinds, + SimplicialLawIndices (..), + SimplicialLawObstruction (..), + lawObstructionKind, + SimplicialLawCheck, + checkFaceFaceLawBy, + checkDegeneracyDegeneracyLawBy, + checkFaceDegeneracyLawBy, + checkSimplicialLawsBy, + checkFaceFaceLaw, + checkDegeneracyDegeneracyLaw, + checkFaceDegeneracyLaw, + checkSimplicialLaws, + ) +where + +import Moonlight.Category.Pure.Simplicial.Validation.Internal + ( SimplicialLawCarrier (..), + SimplicialLawCheck, + SimplicialLawEquality, + SimplicialLawIndices (..), + SimplicialLawKind (..), + SimplicialLawObstruction (..), + allSimplicialLawKinds, + lawObstructionKind, + simplicialLawEq, + ) +import qualified Moonlight.Category.Pure.Simplicial.Validation.Internal as ValidationInternal +import Moonlight.Category.Pure.Simplicial.Set + ( TruncatedNormalizedSSet, + applyDegeneracyAtDimension, + applyFaceAtDimension, + simplicesAtDimension, + truncationBound, + ) + +truncatedLawCarrier :: TruncatedNormalizedSSet simplex -> SimplicialLawCarrier simplex +truncatedLawCarrier simplicialSet = + SimplicialLawCarrier + { lawCarrierUpperBound = truncationBound simplicialSet, + lawCarrierSimplicesAtDimension = simplicesAtDimension simplicialSet, + lawCarrierFaceAtDimension = applyFaceAtDimension simplicialSet, + lawCarrierDegeneracyAtDimension = applyDegeneracyAtDimension simplicialSet + } + +checkFaceFaceLawBy :: SimplicialLawEquality simplex -> TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkFaceFaceLawBy areEqual = + ValidationInternal.checkFaceFaceLawBy areEqual . truncatedLawCarrier + +checkDegeneracyDegeneracyLawBy :: SimplicialLawEquality simplex -> TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkDegeneracyDegeneracyLawBy areEqual = + ValidationInternal.checkDegeneracyDegeneracyLawBy areEqual . truncatedLawCarrier + +checkFaceDegeneracyLawBy :: SimplicialLawEquality simplex -> TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkFaceDegeneracyLawBy areEqual = + ValidationInternal.checkFaceDegeneracyLawBy areEqual . truncatedLawCarrier + +checkSimplicialLawsBy :: SimplicialLawEquality simplex -> TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkSimplicialLawsBy areEqual = + ValidationInternal.checkSimplicialLawsBy areEqual . truncatedLawCarrier + +checkFaceFaceLaw :: Eq simplex => TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkFaceFaceLaw = + checkFaceFaceLawBy simplicialLawEq + +checkDegeneracyDegeneracyLaw :: Eq simplex => TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkDegeneracyDegeneracyLaw = + checkDegeneracyDegeneracyLawBy simplicialLawEq + +checkFaceDegeneracyLaw :: Eq simplex => TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkFaceDegeneracyLaw = + checkFaceDegeneracyLawBy simplicialLawEq + +checkSimplicialLaws :: Eq simplex => TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex +checkSimplicialLaws = + checkSimplicialLawsBy simplicialLawEq diff --git a/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation/Internal.hs b/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation/Internal.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Pure/Simplicial/Validation/Internal.hs @@ -0,0 +1,220 @@ +module Moonlight.Category.Pure.Simplicial.Validation.Internal + ( SimplicialLawEquality, + simplicialLawEq, + SimplicialLawKind (..), + allSimplicialLawKinds, + SimplicialLawIndices (..), + SimplicialLawObstruction (..), + lawObstructionKind, + SimplicialLawCarrier (..), + SimplicialLawCheck, + checkObstructions, + dimensionsStrictlyBelow, + checkFaceFaceLawBy, + checkDegeneracyDegeneracyLawBy, + checkFaceDegeneracyLawBy, + checkSimplicialLawsBy, + ) +where + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Numeric.Natural (Natural) + +type SimplicialLawEquality :: Type -> Type +type SimplicialLawEquality simplex = Maybe simplex -> Maybe simplex -> Bool + +simplicialLawEq :: Eq simplex => SimplicialLawEquality simplex +simplicialLawEq = (==) + +type SimplicialLawKind :: Type +data SimplicialLawKind + = FaceFaceLaw + | DegeneracyDegeneracyLaw + | FaceDegeneracyLaw + deriving stock (Eq, Ord, Show, Read, Enum, Bounded) + +allSimplicialLawKinds :: [SimplicialLawKind] +allSimplicialLawKinds = [minBound .. maxBound] + +type SimplicialLawIndices :: Type +data SimplicialLawIndices + = FaceFaceIndices Natural Natural + | DegeneracyDegeneracyIndices Natural Natural + | FaceDegeneracyIndices Natural Natural + deriving stock (Eq, Ord, Show) + +type SimplicialLawObstruction :: Type -> Type +data SimplicialLawObstruction simplex = SimplicialLawObstruction + { lawObstructionDimension :: Natural, + lawObstructionSimplex :: simplex, + lawObstructionIndices :: SimplicialLawIndices, + lawObstructionLeftResult :: Maybe simplex, + lawObstructionRightResult :: Maybe simplex + } + deriving stock (Eq, Show) + +lawIndicesKind :: SimplicialLawIndices -> SimplicialLawKind +lawIndicesKind indices = + case indices of + FaceFaceIndices _ _ -> FaceFaceLaw + DegeneracyDegeneracyIndices _ _ -> DegeneracyDegeneracyLaw + FaceDegeneracyIndices _ _ -> FaceDegeneracyLaw + +lawObstructionKind :: SimplicialLawObstruction simplex -> SimplicialLawKind +lawObstructionKind = + lawIndicesKind . lawObstructionIndices + +type SimplicialLawCarrier :: Type -> Type +data SimplicialLawCarrier simplex = SimplicialLawCarrier + { lawCarrierUpperBound :: Natural, + lawCarrierSimplicesAtDimension :: Natural -> [simplex], + lawCarrierFaceAtDimension :: Natural -> Natural -> simplex -> Maybe simplex, + lawCarrierDegeneracyAtDimension :: Natural -> Natural -> simplex -> Maybe simplex + } + +type SimplicialLawCheck :: Type -> Type +type SimplicialLawCheck simplex = Either (NonEmpty (SimplicialLawObstruction simplex)) () + +checkObstructions :: [obstruction] -> Either (NonEmpty obstruction) () +checkObstructions obstructions = + case obstructions of + [] -> Right () + firstObstruction : remainingObstructions -> Left (firstObstruction :| remainingObstructions) + +dimensionsStrictlyBelow :: Natural -> [Natural] +dimensionsStrictlyBelow upperBound = + if upperBound == 0 + then [] + else [0 .. upperBound - 1] + +dimensionsAtLeastTwoBelowBound :: Natural -> [Natural] +dimensionsAtLeastTwoBelowBound upperBound = + if upperBound < 2 + then [] + else [0 .. upperBound - 2] + +obstructionUnlessEqual :: + SimplicialLawEquality simplex -> + Natural -> + simplex -> + SimplicialLawIndices -> + Maybe simplex -> + Maybe simplex -> + [SimplicialLawObstruction simplex] +obstructionUnlessEqual areEqual dimensionValue simplexValue indices leftResult rightResult = + if areEqual leftResult rightResult + then [] + else + [ SimplicialLawObstruction + { lawObstructionDimension = dimensionValue, + lawObstructionSimplex = simplexValue, + lawObstructionIndices = indices, + lawObstructionLeftResult = leftResult, + lawObstructionRightResult = rightResult + } + ] + +faceFaceLawObstructionsBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> [SimplicialLawObstruction simplex] +faceFaceLawObstructionsBy areEqual carrier = + [ obstruction + | dimensionValue <- [2 .. lawCarrierUpperBound carrier], + simplexValue <- lawCarrierSimplicesAtDimension carrier dimensionValue, + leftFaceIndex <- [0 .. dimensionValue - 1], + rightFaceIndex <- [leftFaceIndex + 1 .. dimensionValue], + let leftResult = + lawCarrierFaceAtDimension carrier (dimensionValue - 1) leftFaceIndex + =<< lawCarrierFaceAtDimension carrier dimensionValue rightFaceIndex simplexValue, + let rightResult = + lawCarrierFaceAtDimension carrier (dimensionValue - 1) (rightFaceIndex - 1) + =<< lawCarrierFaceAtDimension carrier dimensionValue leftFaceIndex simplexValue, + obstruction <- + obstructionUnlessEqual + areEqual + dimensionValue + simplexValue + (FaceFaceIndices leftFaceIndex rightFaceIndex) + leftResult + rightResult + ] + +degeneracyDegeneracyLawObstructionsBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> [SimplicialLawObstruction simplex] +degeneracyDegeneracyLawObstructionsBy areEqual carrier = + [ obstruction + | dimensionValue <- dimensionsAtLeastTwoBelowBound (lawCarrierUpperBound carrier), + simplexValue <- lawCarrierSimplicesAtDimension carrier dimensionValue, + leftDegeneracyIndex <- [0 .. dimensionValue], + rightDegeneracyIndex <- [leftDegeneracyIndex .. dimensionValue], + let leftResult = + lawCarrierDegeneracyAtDimension carrier (dimensionValue + 1) leftDegeneracyIndex + =<< lawCarrierDegeneracyAtDimension carrier dimensionValue rightDegeneracyIndex simplexValue, + let rightResult = + lawCarrierDegeneracyAtDimension carrier (dimensionValue + 1) (rightDegeneracyIndex + 1) + =<< lawCarrierDegeneracyAtDimension carrier dimensionValue leftDegeneracyIndex simplexValue, + obstruction <- + obstructionUnlessEqual + areEqual + dimensionValue + simplexValue + (DegeneracyDegeneracyIndices leftDegeneracyIndex rightDegeneracyIndex) + leftResult + rightResult + ] + +expectedFaceDegeneracy :: + SimplicialLawCarrier simplex -> + Natural -> + simplex -> + Natural -> + Natural -> + Maybe simplex +expectedFaceDegeneracy carrier dimensionValue simplexValue faceIndex degeneracyIndex + | faceIndex < degeneracyIndex = + lawCarrierDegeneracyAtDimension carrier (dimensionValue - 1) (degeneracyIndex - 1) + =<< lawCarrierFaceAtDimension carrier dimensionValue faceIndex simplexValue + | faceIndex == degeneracyIndex = Just simplexValue + | faceIndex == degeneracyIndex + 1 = Just simplexValue + | otherwise = + lawCarrierDegeneracyAtDimension carrier (dimensionValue - 1) degeneracyIndex + =<< lawCarrierFaceAtDimension carrier dimensionValue (faceIndex - 1) simplexValue + +faceDegeneracyLawObstructionsBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> [SimplicialLawObstruction simplex] +faceDegeneracyLawObstructionsBy areEqual carrier = + [ obstruction + | dimensionValue <- dimensionsStrictlyBelow (lawCarrierUpperBound carrier), + simplexValue <- lawCarrierSimplicesAtDimension carrier dimensionValue, + degeneracyIndex <- [0 .. dimensionValue], + faceIndex <- [0 .. dimensionValue + 1], + let leftResult = + lawCarrierFaceAtDimension carrier (dimensionValue + 1) faceIndex + =<< lawCarrierDegeneracyAtDimension carrier dimensionValue degeneracyIndex simplexValue, + let rightResult = expectedFaceDegeneracy carrier dimensionValue simplexValue faceIndex degeneracyIndex, + obstruction <- + obstructionUnlessEqual + areEqual + dimensionValue + simplexValue + (FaceDegeneracyIndices faceIndex degeneracyIndex) + leftResult + rightResult + ] + +checkFaceFaceLawBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> SimplicialLawCheck simplex +checkFaceFaceLawBy areEqual = + checkObstructions . faceFaceLawObstructionsBy areEqual + +checkDegeneracyDegeneracyLawBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> SimplicialLawCheck simplex +checkDegeneracyDegeneracyLawBy areEqual = + checkObstructions . degeneracyDegeneracyLawObstructionsBy areEqual + +checkFaceDegeneracyLawBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> SimplicialLawCheck simplex +checkFaceDegeneracyLawBy areEqual = + checkObstructions . faceDegeneracyLawObstructionsBy areEqual + +checkSimplicialLawsBy :: SimplicialLawEquality simplex -> SimplicialLawCarrier simplex -> SimplicialLawCheck simplex +checkSimplicialLawsBy areEqual carrier = + checkObstructions + ( faceFaceLawObstructionsBy areEqual carrier + <> degeneracyDegeneracyLawObstructionsBy areEqual carrier + <> faceDegeneracyLawObstructionsBy areEqual carrier + ) diff --git a/src-simplicial/Moonlight/Category/Simplicial.hs b/src-simplicial/Moonlight/Category/Simplicial.hs new file mode 100644 --- /dev/null +++ b/src-simplicial/Moonlight/Category/Simplicial.hs @@ -0,0 +1,33 @@ +{-| The public simplicial-category surface. + +This facade exposes the definitional simplicial mathematics owned by the +@simplicial@ sublibrary without making downstream consumers name its +@Pure.Simplicial@ implementation paths. The effectful property harness remains +in @moonlight-category:laws@. +-} +module Moonlight.Category.Simplicial + ( module CategoricalSimplex, + module Delta, + module Homotopy, + module Kan, + module Nerve, + module Ordinal, + module Presheaf, + module Set, + module Spaces, + module TypeLevel, + module Validation, + ) +where + +import Moonlight.Category.Pure.Simplicial.CategoricalSimplex as CategoricalSimplex +import Moonlight.Category.Pure.Simplicial.Delta as Delta +import Moonlight.Category.Pure.Simplicial.Homotopy as Homotopy +import Moonlight.Category.Pure.Simplicial.Kan as Kan +import Moonlight.Category.Pure.Simplicial.Nerve as Nerve +import Moonlight.Category.Pure.Simplicial.Ordinal as Ordinal +import Moonlight.Category.Pure.Simplicial.Presheaf as Presheaf +import Moonlight.Category.Pure.Simplicial.Set as Set +import Moonlight.Category.Pure.Simplicial.Spaces as Spaces +import Moonlight.Category.Pure.Simplicial.TypeLevel as TypeLevel +import Moonlight.Category.Pure.Simplicial.Validation as Validation diff --git a/src-site/Moonlight/Category/Pure/Site.hs b/src-site/Moonlight/Category/Pure/Site.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site.hs @@ -0,0 +1,56 @@ + +-- | The site and path presentation layer (re-export): site manifests, path and thin +-- path categories, quotients, validation, and compilation to a finite category. +module Moonlight.Category.Pure.Site + ( SiteManifest (..), + SiteViolation (..), + SiteFinCatError (..), + ThinSiteKernel, + ThinSitePresentation (..), + SitePathCategory, + SitePathObject, + SitePathMorphism, + PathThinCat, + PathThinObject, + PathThinMorphism, + SitePathQuotient, + SitePathQuotientError (..), + mkSiteManifest, + validateSiteManifest, + thinSiteKernel, + thinSitePresentation, + thinPresentationToFinCat, + sitePathCategory, + sitePathManifest, + mkSitePathObject, + mkSitePathMorphism, + sitePathMorphismsBetween, + pathThinCat, + mkPathThinObject, + mkPathThinMorphism, + quotientPathThinObject, + quotientPathThinMorphism, + pathThinCodomainObject, + pathThinCodomainMorphism, + sitePathQuotient, + quotientMapObject, + quotientMapMorphism, + siteImportsAsFinCat, + siteImportEdges, + siteReachable, + ) +where + +import Moonlight.Category.Pure.Site.Category as X +import Moonlight.Category.Pure.Site.Compile as X + ( ThinSiteKernel, + ThinSitePresentation (..), + siteImportsAsFinCat, + thinPresentationToFinCat, + thinSiteKernel, + thinSitePresentation, + ) +import Moonlight.Category.Pure.Site.Core as X +import Moonlight.Category.Pure.Site.Graph as X (siteImportEdges, siteReachable) +import Moonlight.Category.Pure.Site.Manifest as X +import Moonlight.Category.Pure.Site.Quotient as X diff --git a/src-site/Moonlight/Category/Pure/Site/Category.hs b/src-site/Moonlight/Category/Pure/Site/Category.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Category.hs @@ -0,0 +1,245 @@ +-- | The path category of a site: objects, morphisms-as-paths, and enumeration of the +-- morphisms between two objects. +module Moonlight.Category.Pure.Site.Category + ( SitePathCategory, + SitePathObject, + SitePathMorphism, + sitePathCategory, + sitePathCategoryKernel, + sitePathCategoryCodomain, + sitePathCategoryObjectIds, + sitePathManifest, + sitePathObjectCategory, + sitePathObjectValue, + sitePathObjectCodomain, + sitePathMorphismCategory, + sitePathMorphismNodes, + sitePathMorphismCodomain, + mkSitePathObject, + mkSitePathMorphism, + sitePathMorphismsBetween, + ) +where + +import Data.Kind (Type) +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Tree (foldTree, unfoldTree) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatError, + FinMor, + FinObjectId, + FinObj, + ) +import Moonlight.Core qualified as Aggregate +import Moonlight.Category.Pure.Site.Compile + ( ThinSiteKernel, + thinSiteFinMorphism, + thinSiteFinObject, + thinSiteKernelCodomain, + thinSiteKernelManifest, + thinSiteKernelObjectIds, + ) +import Moonlight.Category.Pure.Site.Core (SiteManifest (..)) +import Moonlight.Category.Pure.Site.Graph (siteImportEdges) + +type SitePathCategory :: Type -> Type +newtype SitePathCategory obj = SitePathCategory + { sitePathCategoryKernel :: ThinSiteKernel obj + } + deriving stock (Eq, Show) + +type SitePathObject :: Type -> Type +data SitePathObject obj = SitePathObject + { sitePathObjectCategory :: SitePathCategory obj, + sitePathObjectValue :: obj, + sitePathObjectCodomain :: FinObj + } + deriving stock (Eq, Show) + +type SitePathMorphism :: Type -> Type +data SitePathMorphism obj = SitePathMorphism + { sitePathMorphismCategory :: SitePathCategory obj, + sitePathMorphismNodes :: NonEmpty obj, + sitePathMorphismCodomain :: FinMor + } + deriving stock (Eq, Show) + +type SitePathCompositor :: Type -> Type +data SitePathCompositor obj + = SitePathCompositor + deriving stock (Eq, Show) + +type SitePathTwoMor :: Type -> Type +data SitePathTwoMor obj + = SitePathTwoMor + deriving stock (Eq, Show) + +type SitePathCategoryError :: Type -> Type +data SitePathCategoryError obj + = SitePathObjectWrongCategory + | SitePathMorphismWrongCategory + | SitePathCodomainError FinCatError + deriving stock (Eq, Show) + +sitePathCategory :: ThinSiteKernel obj -> SitePathCategory obj +sitePathCategory = SitePathCategory + +sitePathCategoryCodomain :: SitePathCategory obj -> FinCat +sitePathCategoryCodomain = thinSiteKernelCodomain . sitePathCategoryKernel + +sitePathCategoryObjectIds :: SitePathCategory obj -> Map obj FinObjectId +sitePathCategoryObjectIds = thinSiteKernelObjectIds . sitePathCategoryKernel + +sitePathManifest :: SitePathCategory obj -> SiteManifest obj +sitePathManifest = thinSiteKernelManifest . sitePathCategoryKernel + +mkSitePathObject :: Ord obj => SitePathCategory obj -> obj -> Maybe (SitePathObject obj) +mkSitePathObject category objectValue = + case thinSiteFinObject (sitePathCategoryKernel category) objectValue of + Left _ -> + Nothing + Right codomainObject -> + Just + SitePathObject + { sitePathObjectCategory = category, + sitePathObjectValue = objectValue, + sitePathObjectCodomain = codomainObject + } + +mkSitePathMorphism :: Ord obj => SitePathCategory obj -> NonEmpty obj -> Maybe (SitePathMorphism obj) +mkSitePathMorphism category nodes = + if validPath category nodes + then sitePathMorphismFromValidatedNodes category nodes + else Nothing + +sitePathMorphismFromValidatedNodes :: Ord obj => SitePathCategory obj -> NonEmpty obj -> Maybe (SitePathMorphism obj) +sitePathMorphismFromValidatedNodes category nodes = do + codomainMorphism <- either (const Nothing) Just (thinSiteFinMorphism (sitePathCategoryKernel category) nodes) + pure + SitePathMorphism + { sitePathMorphismCategory = category, + sitePathMorphismNodes = nodes, + sitePathMorphismCodomain = codomainMorphism + } + +sitePathMorphismsBetween :: + Ord obj => + SitePathCategory obj -> + obj -> + obj -> + [SitePathMorphism obj] +sitePathMorphismsBetween category sourceValue targetValue = + allPathNodes category sourceValue targetValue + & mapMaybe (sitePathMorphismFromValidatedNodes category) + +instance Ord obj => Category (SitePathCategory obj) where + type Ob (SitePathCategory obj) = SitePathObject obj + type Mor (SitePathCategory obj) = SitePathMorphism obj + type TwoMor (SitePathCategory obj) = SitePathTwoMor obj + type Compositor (SitePathCategory obj) = SitePathCompositor obj + type CategoryError (SitePathCategory obj) = SitePathCategoryError obj + + identity category objectValue = + if sitePathObjectCategory objectValue /= category + then Left SitePathObjectWrongCategory + else do + codomainMorphism <- + first SitePathCodomainError + (identity (sitePathCategoryCodomain category) (sitePathObjectCodomain objectValue)) + Right + SitePathMorphism + { sitePathMorphismCategory = category, + sitePathMorphismNodes = sitePathObjectValue objectValue :| [], + sitePathMorphismCodomain = codomainMorphism + } + + compose category left right + | sitePathMorphismCategory left /= category = Left SitePathMorphismWrongCategory + | sitePathMorphismCategory right /= category = Left SitePathMorphismWrongCategory + | otherwise = do + (codomainMorphism, _) <- + first SitePathCodomainError + (compose (sitePathCategoryCodomain category) (sitePathMorphismCodomain left) (sitePathMorphismCodomain right)) + let leftNodes = sitePathMorphismNodes left + rightNodes = sitePathMorphismNodes right + mergedPath = + NonEmpty.head rightNodes + :| (NonEmpty.tail rightNodes <> drop 1 (NonEmpty.toList leftNodes)) + Right + ( SitePathMorphism + { sitePathMorphismCategory = category, + sitePathMorphismNodes = mergedPath, + sitePathMorphismCodomain = codomainMorphism + }, + SitePathCompositor + ) + + source category morphism = + if sitePathMorphismCategory morphism /= category + then Left SitePathMorphismWrongCategory + else do + codomainObject <- + first SitePathCodomainError + (source (sitePathCategoryCodomain category) (sitePathMorphismCodomain morphism)) + Right + SitePathObject + { sitePathObjectCategory = category, + sitePathObjectValue = NonEmpty.head (sitePathMorphismNodes morphism), + sitePathObjectCodomain = codomainObject + } + + target category morphism = + if sitePathMorphismCategory morphism /= category + then Left SitePathMorphismWrongCategory + else do + codomainObject <- + first SitePathCodomainError + (target (sitePathCategoryCodomain category) (sitePathMorphismCodomain morphism)) + Right + SitePathObject + { sitePathObjectCategory = category, + sitePathObjectValue = NonEmpty.last (sitePathMorphismNodes morphism), + sitePathObjectCodomain = codomainObject + } + +validPath :: Ord obj => SitePathCategory obj -> NonEmpty obj -> Bool +validPath category nodes = + let manifest = sitePathManifest category + objects = siteObjects manifest + allNodesPresent = + nodes + & NonEmpty.toList + & all (`Set.member` objects) + importEdges = siteImportEdges manifest + consecutive = + Aggregate.adjacentPairs (NonEmpty.toList nodes) + & all (`Set.member` importEdges) + in allNodesPresent && consecutive + +allPathNodes :: Ord obj => SitePathCategory obj -> obj -> obj -> [NonEmpty obj] +allPathNodes category sourceValue targetValue = + let manifest = sitePathManifest category + imports = siteImports manifest + unfoldPath (current, visited) = + ( current, + if current == targetValue + then [] + else + Map.findWithDefault Set.empty current imports + & Set.toAscList + & filter (`Set.notMember` visited) + & fmap (\next -> (next, Set.insert next visited)) + ) + collectPaths current childPaths + | current == targetValue = [current :| []] + | otherwise = foldMap (fmap (NonEmpty.cons current)) childPaths + in foldTree collectPaths (unfoldTree unfoldPath (sourceValue, Set.singleton sourceValue)) diff --git a/src-site/Moonlight/Category/Pure/Site/Compile.hs b/src-site/Moonlight/Category/Pure/Site/Compile.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Compile.hs @@ -0,0 +1,222 @@ +-- | Compilation of a thin site presentation to a runtime-validated finite category, +-- with object and morphism lookup. +module Moonlight.Category.Pure.Site.Compile + ( ThinSitePresentation (..), + ThinSiteKernel, + thinSiteKernelManifest, + thinSiteKernelCodomain, + thinSiteKernelObjectIds, + ThinSiteLookupError (..), + thinSitePresentation, + thinPresentationToFinCat, + thinSiteKernel, + thinSiteFinObject, + thinSiteFinMorphism, + thinSiteFinMorphismByEndpoints, + siteImportsAsFinCat, + ) +where + +import Data.Kind (Type) +import Data.Bifunctor (first) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import Moonlight.Category.Pure.Category (Category (identity)) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinCatError, + FinCatValidationError, + FinMor, + FinMorphismId (..), + FinObjectId (..), + FinObj, + mkFinCat, + mkFinMorphism, + mkFinObject, + denseThinEndpointMorphismsFromCategory, + finCatExplicitCompositionMapView, + finCatMorphismIdByEndpoints, + trustedDenseThinFinCatFromReachabilityRows, + ) +import Moonlight.Category.Pure.Site.Core (SiteFinCatError (..), SiteManifest) +import Moonlight.Category.Pure.Site.Manifest + ( validateSiteImportManifest, + validateSiteManifestDetailed, + validatedSiteObjectVector, + validatedSiteReachabilityRows, + ) + +type ThinSitePresentation :: Type -> Type +data ThinSitePresentation obj = ThinSitePresentation + { thinPresentationObjectIds :: Map obj FinObjectId, + thinPresentationPairIds :: Map (obj, obj) FinMorphismId, + thinPresentationObjects :: Set FinObjectId, + thinPresentationMorphisms :: Map (FinObjectId, FinObjectId) [FinMorphismId], + thinPresentationComposition :: Map (FinMorphismId, FinMorphismId) FinMorphismId + } + +type ThinSiteKernel :: Type -> Type +data ThinSiteKernel obj = ThinSiteKernel + { thinSiteKernelManifest :: SiteManifest obj, + thinSiteKernelCodomain :: FinCat, + thinSiteKernelObjectIds :: Map obj FinObjectId + } + deriving stock (Eq, Show) + +type ThinSiteLookupError :: Type -> Type +data ThinSiteLookupError obj + = ThinSiteUnknownObject obj + | ThinSiteCodomainObjectMissing FinObjectId + | ThinSiteUnknownMorphismPair obj obj + | ThinSiteCodomainMorphismMissing FinMorphismId + | ThinSiteCodomainMorphismInvalid FinCatError + deriving stock (Eq, Show) + +-- | Builds the explicit presentation, including the materialized composition +-- table via 'finCatExplicitCompositionMapView' — an output-bound @Θ(n³)@ witness +-- for a linear site on @n@ objects, dominating the @Θ(n²/w)@ dense validation +-- that precedes it. The record fields are lazy, so the cubic table is only paid +-- when 'thinPresentationComposition' is forced. Callers that need composition +-- queries rather than the explicit witness should use 'thinSiteKernel', which +-- stays on the dense handle and answers composition in +-- @O(1)@ without materializing. +thinSitePresentation :: ThinSiteKernel obj -> ThinSitePresentation obj +thinSitePresentation kernel = + let objectIds = thinSiteKernelObjectIds kernel + codomain = thinSiteKernelCodomain kernel + objectSet = thinSiteFinObjectSet objectIds + endpointPairIds = denseThinEndpointMorphismsFromCategory codomain + in ThinSitePresentation + { thinPresentationObjectIds = objectIds, + thinPresentationPairIds = thinSitePairIdsFromEndpoints objectIds endpointPairIds, + thinPresentationObjects = objectSet, + thinPresentationMorphisms = thinSiteMorphismMap endpointPairIds, + thinPresentationComposition = finCatExplicitCompositionMapView codomain + } + +thinSitePairIdsFromEndpoints :: Map obj FinObjectId -> Map (FinObjectId, FinObjectId) FinMorphismId -> Map (obj, obj) FinMorphismId +thinSitePairIdsFromEndpoints objectIds endpointPairIds = + objectIds + & Map.toAscList + >>= ( \(sourceObject, sourceId) -> + objectIds + & Map.toAscList + >>= ( \(targetObject, targetId) -> + case Map.lookup (sourceId, targetId) endpointPairIds of + Nothing -> [] + Just morphismId -> [((sourceObject, targetObject), morphismId)] + ) + ) + & Map.fromDistinctAscList + +thinSiteObjectIds :: Ord obj => [obj] -> Map obj FinObjectId +thinSiteObjectIds objects = + objects + & zip [0 ..] + & fmap (\(idx, obj) -> (obj, FinObjectId idx)) + & Map.fromList + +thinSiteFinObjectSet :: Map obj FinObjectId -> Set FinObjectId +thinSiteFinObjectSet objectIds = + objectIds + & Map.elems + & Set.fromList + +thinSiteMorphismMap :: Map (FinObjectId, FinObjectId) FinMorphismId -> Map (FinObjectId, FinObjectId) [FinMorphismId] +thinSiteMorphismMap = + fmap (: []) + +thinPresentationToFinCat :: + ThinSitePresentation obj -> + Either (NonEmpty FinCatValidationError) FinCat +thinPresentationToFinCat presentation = + mkFinCat + (thinPresentationObjects presentation) + (thinPresentationMorphisms presentation) + (thinPresentationComposition presentation) + +thinSiteKernel :: Ord obj => SiteManifest obj -> Either (SiteFinCatError obj) (ThinSiteKernel obj) +thinSiteKernel manifest = + case validateSiteManifestDetailed manifest of + Right validatedManifest -> + let objectIds = thinSiteObjectIds (Vector.toList (validatedSiteObjectVector validatedManifest)) + codomain = + trustedDenseThinFinCatFromReachabilityRows + (thinSiteFinObjectSet objectIds) + (validatedSiteReachabilityRows validatedManifest) + in Right + ThinSiteKernel + { thinSiteKernelManifest = manifest, + thinSiteKernelCodomain = codomain, + thinSiteKernelObjectIds = objectIds + } + Left errors -> + Left (SiteManifestInvalid errors) + +thinSiteFinObject :: Ord obj => ThinSiteKernel obj -> obj -> Either (ThinSiteLookupError obj) FinObj +thinSiteFinObject kernel objectValue = + case Map.lookup objectValue (thinSiteKernelObjectIds kernel) of + Nothing -> + Left (ThinSiteUnknownObject objectValue) + Just objectId -> + case mkFinObject (thinSiteKernelCodomain kernel) objectId of + Left _ -> + Left (ThinSiteCodomainObjectMissing objectId) + Right finObject -> + Right finObject + +thinSiteFinMorphism :: Ord obj => ThinSiteKernel obj -> NonEmpty obj -> Either (ThinSiteLookupError obj) FinMor +thinSiteFinMorphism kernel nodes = + thinSiteFinMorphismByEndpoints + kernel + (NonEmpty.head nodes) + (NonEmpty.last nodes) + +thinSiteFinMorphismByEndpoints :: + Ord obj => + ThinSiteKernel obj -> + obj -> + obj -> + Either (ThinSiteLookupError obj) FinMor +thinSiteFinMorphismByEndpoints kernel sourceValue targetValue = + if sourceValue == targetValue + then do + sourceObject <- thinSiteFinObject kernel sourceValue + first ThinSiteCodomainMorphismInvalid (identity (thinSiteKernelCodomain kernel) sourceObject) + else + case thinSiteMorphismIdByEndpoints kernel sourceValue targetValue of + Nothing -> + Left (ThinSiteUnknownMorphismPair sourceValue targetValue) + Just morId -> + case mkFinMorphism (thinSiteKernelCodomain kernel) morId of + Left _ -> + Left (ThinSiteCodomainMorphismMissing morId) + Right finMorphism -> + Right finMorphism + +thinSiteMorphismIdByEndpoints :: Ord obj => ThinSiteKernel obj -> obj -> obj -> Maybe FinMorphismId +thinSiteMorphismIdByEndpoints kernel sourceValue targetValue = do + sourceId <- Map.lookup sourceValue (thinSiteKernelObjectIds kernel) + targetId <- Map.lookup targetValue (thinSiteKernelObjectIds kernel) + finCatMorphismIdByEndpoints (thinSiteKernelCodomain kernel) sourceId targetId + +-- | Compile only the import category. Cover axioms are deliberately outside this +-- boundary; use 'thinSiteKernel' when a validated site is required. +siteImportsAsFinCat :: Ord obj => SiteManifest obj -> Either (SiteFinCatError obj) FinCat +siteImportsAsFinCat manifest = + case validateSiteImportManifest manifest of + Right validatedManifest -> + let objectIds = thinSiteObjectIds (Vector.toList (validatedSiteObjectVector validatedManifest)) + in Right + ( trustedDenseThinFinCatFromReachabilityRows + (thinSiteFinObjectSet objectIds) + (validatedSiteReachabilityRows validatedManifest) + ) + Left errors -> + Left (SiteManifestInvalid errors) diff --git a/src-site/Moonlight/Category/Pure/Site/Core.hs b/src-site/Moonlight/Category/Pure/Site/Core.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Core.hs @@ -0,0 +1,38 @@ +-- | Core site types: the t'SiteManifest' (objects, imports, covers) and the +-- 'SiteViolation'/'SiteFinCatError' diagnostics. +module Moonlight.Category.Pure.Site.Core + ( SiteManifest (..), + SiteViolation (..), + SiteFinCatError (..), + ) +where + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.Set (Set) + +type SiteManifest :: Type -> Type +data SiteManifest obj = SiteManifest + { siteObjects :: Set obj, + siteImports :: Map obj (Set obj), + siteCovers :: Map obj (Set obj) + } + deriving stock (Eq, Show) + +type SiteViolation :: Type -> Type +data SiteViolation obj + = MissingCover obj + | UnknownImportTarget obj + | UnknownImportedObject obj obj + | UnknownCoverTarget obj + | UnknownCoveredObject obj obj + | CoverOutsideReachable obj (Set obj) + | CoverNotClosed obj obj (Set obj) + | ImportCycleDetected (NonEmpty obj) + deriving stock (Eq, Show) + +type SiteFinCatError :: Type -> Type +data SiteFinCatError obj + = SiteManifestInvalid (NonEmpty (SiteViolation obj)) + deriving stock (Eq, Show) diff --git a/src-site/Moonlight/Category/Pure/Site/Graph.hs b/src-site/Moonlight/Category/Pure/Site/Graph.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Graph.hs @@ -0,0 +1,63 @@ +-- | Import-graph queries over a site manifest: edges, reachable closure, and +-- import-cycle detection. Reachability and cycle reporting both run on the +-- shared dense closure kernel +-- ("Moonlight.Category.Pure.Finite.DenseReachability"). +module Moonlight.Category.Pure.Site.Graph + ( siteImportEdges, + siteReachable, + reachableClosure, + importCycles, + ) +where + +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import Moonlight.Category.Pure.Site.Core (SiteManifest (..)) +import Moonlight.Category.Pure.Finite.DenseReachability + ( denseClosureCycleComponents, + denseClosureReachabilityRows, + denseReachabilityWithCycles, + objectComponentsFromIndices, + objectIndexOf, + objectSetFromBits, + relationBitRows, + relationUniverse, + ) + +siteImportEdges :: Ord obj => SiteManifest obj -> Set (obj, obj) +siteImportEdges manifest = + siteImports manifest + & Map.foldMapWithKey + (\targetObject sources -> Set.map (\sourceObject -> (targetObject, sourceObject)) sources) + +siteReachable :: Ord obj => SiteManifest obj -> obj -> Set obj +siteReachable manifest start = + Map.findWithDefault Set.empty start (reachableClosure (siteImports manifest)) + +reachableClosure :: Ord obj => Map obj (Set obj) -> Map obj (Set obj) +reachableClosure adjacency = + let objectVector = Vector.fromList (Set.toAscList (relationUniverse adjacency)) + objectIndex = objectIndexOf objectVector + closureRows = + denseClosureReachabilityRows + (denseReachabilityWithCycles (relationBitRows objectIndex objectVector adjacency)) + reachableSet objectValue = + maybe + Set.empty + (objectSetFromBits objectVector) + (Map.lookup objectValue objectIndex >>= (closureRows Vector.!?)) + in Map.mapWithKey (\objectValue _ -> reachableSet objectValue) adjacency + +importCycles :: Ord obj => SiteManifest obj -> [NonEmpty obj] +importCycles manifest = + let objectVector = Vector.fromList (Set.toAscList (siteObjects manifest)) + objectIndex = objectIndexOf objectVector + closure = + denseReachabilityWithCycles + (relationBitRows objectIndex objectVector (siteImports manifest)) + in objectComponentsFromIndices objectVector (denseClosureCycleComponents closure) diff --git a/src-site/Moonlight/Category/Pure/Site/Manifest.hs b/src-site/Moonlight/Category/Pure/Site/Manifest.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Manifest.hs @@ -0,0 +1,203 @@ +-- | Site manifest construction and validation on the shared dense reachability +-- kernel. Full-site and import-category compilation consume these same validated +-- sections; diagnostics therefore have one owner rather than two approximate ones. +module Moonlight.Category.Pure.Site.Manifest + ( ValidatedSiteManifest, + validatedSiteObjectVector, + validatedSiteReachabilityRows, + mkSiteManifest, + validateSiteManifest, + validateSiteManifestDetailed, + validateSiteImportManifest, + ) +where + +import Data.Bits ((.|.)) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Moonlight.Category.Pure.Site.Core (SiteManifest (..), SiteViolation (..)) +import Moonlight.Category.Pure.Finite.DenseReachability + ( bitsDifference, + bitsToAscList, + denseClosureCycleComponents, + denseClosureReachabilityRows, + denseReachabilityWithCycles, + intListBits, + objectComponentsFromIndices, + objectIndexOf, + objectSetFromBits, + ) + +data ValidatedSiteManifest obj = ValidatedSiteManifest + { validatedSiteObjectVector :: !(Vector obj), + validatedSiteReachabilityRows :: !(Vector Integer) + } + deriving stock (Eq, Show) + +data DenseRelationRows obj = DenseRelationRows + { denseRelationRowVector :: !(Vector Integer), + denseRelationUnknownTargets :: ![obj], + denseRelationUnknownMembers :: ![(obj, obj)] + } + deriving stock (Eq, Show) + +mkSiteManifest :: Ord obj => Set obj -> Map obj (Set obj) -> Map obj (Set obj) -> Either [SiteViolation obj] (SiteManifest obj) +mkSiteManifest objects imports covers = + let manifest = SiteManifest objects imports covers + in case validateSiteManifestDetailed manifest of + Left errors -> Left (NonEmpty.toList errors) + Right _ -> Right manifest + +validateSiteManifest :: Ord obj => SiteManifest obj -> [SiteViolation obj] +validateSiteManifest = + either NonEmpty.toList (const []) . validateSiteManifestDetailed + +validateSiteManifestDetailed :: Ord obj => SiteManifest obj -> Either (NonEmpty (SiteViolation obj)) (ValidatedSiteManifest obj) +validateSiteManifestDetailed = + validateSiteManifestWith denseCoverErrors + +validateSiteImportManifest :: Ord obj => SiteManifest obj -> Either (NonEmpty (SiteViolation obj)) (ValidatedSiteManifest obj) +validateSiteImportManifest manifest = + let objectVector = Vector.fromList (Set.toAscList (siteObjects manifest)) + objectIndex = objectIndexOf objectVector + importRows = denseRelationRows objectIndex objectVector (siteImports manifest) + importClosure = denseReachabilityWithCycles (denseRelationRowVector importRows) + validationErrors = + denseImportRelationErrors importRows + <> denseImportCycleViolations objectVector (denseClosureCycleComponents importClosure) + in validatedSiteFromErrors objectVector (denseClosureReachabilityRows importClosure) validationErrors + +validateSiteManifestWith :: + Ord obj => + (Vector obj -> Vector Integer -> Vector Integer -> [SiteViolation obj]) -> + SiteManifest obj -> + Either (NonEmpty (SiteViolation obj)) (ValidatedSiteManifest obj) +validateSiteManifestWith coverErrorsForRows manifest = + let objectVector = Vector.fromList (Set.toAscList (siteObjects manifest)) + objectIndex = objectIndexOf objectVector + importRows = denseRelationRows objectIndex objectVector (siteImports manifest) + coverRows = denseRelationRows objectIndex objectVector (siteCovers manifest) + importClosure = denseReachabilityWithCycles (denseRelationRowVector importRows) + reachabilityRows = denseClosureReachabilityRows importClosure + validationErrors = + denseImportRelationErrors importRows + <> denseCoverRelationErrors coverRows + <> missingCoverErrors objectVector (siteCovers manifest) + <> denseImportCycleViolations objectVector (denseClosureCycleComponents importClosure) + <> coverErrorsForRows objectVector reachabilityRows (denseRelationRowVector coverRows) + in validatedSiteFromErrors objectVector reachabilityRows validationErrors + +validatedSiteFromErrors :: Vector obj -> Vector Integer -> [SiteViolation obj] -> Either (NonEmpty (SiteViolation obj)) (ValidatedSiteManifest obj) +validatedSiteFromErrors objectVector reachabilityRows validationErrors = + case NonEmpty.nonEmpty validationErrors of + Nothing -> Right (ValidatedSiteManifest objectVector reachabilityRows) + Just errors -> Left errors + +denseImportRelationErrors :: DenseRelationRows obj -> [SiteViolation obj] +denseImportRelationErrors relationRows = + fmap UnknownImportTarget (denseRelationUnknownTargets relationRows) + <> fmap (uncurry UnknownImportedObject) (denseRelationUnknownMembers relationRows) + +denseCoverRelationErrors :: DenseRelationRows obj -> [SiteViolation obj] +denseCoverRelationErrors relationRows = + fmap UnknownCoverTarget (denseRelationUnknownTargets relationRows) + <> fmap (uncurry UnknownCoveredObject) (denseRelationUnknownMembers relationRows) + +missingCoverErrors :: Ord obj => Vector obj -> Map obj (Set obj) -> [SiteViolation obj] +missingCoverErrors objectVector covers = + objectVector + & Vector.toList + & filter (`Map.notMember` covers) + & fmap MissingCover + +denseRelationRows :: Ord obj => Map obj Int -> Vector obj -> Map obj (Set obj) -> DenseRelationRows obj +denseRelationRows objectIndex objectVector relation = + DenseRelationRows + { denseRelationRowVector = + objectVector + & Vector.map + ( \objectValue -> + Map.findWithDefault Set.empty objectValue relation + & Set.toAscList + & mapMaybe (`Map.lookup` objectIndex) + & intListBits + ), + denseRelationUnknownTargets = + relation + & Map.keys + & filter (`Map.notMember` objectIndex), + denseRelationUnknownMembers = + relation + & Map.toAscList + >>= ( \(targetObject, sources) -> + sources + & Set.toAscList + & filter (`Map.notMember` objectIndex) + & fmap (\sourceObject -> (targetObject, sourceObject)) + ) + } + +denseImportCycleViolations :: Ord obj => Vector obj -> [NonEmpty Int] -> [SiteViolation obj] +denseImportCycleViolations objectVector components = + objectComponentsFromIndices objectVector components + & fmap ImportCycleDetected + +denseCoverErrors :: + Ord obj => + Vector obj -> + Vector Integer -> + Vector Integer -> + [SiteViolation obj] +denseCoverErrors objectVector reachabilityRows coverRows + | coverRows == reachabilityRows = [] + | otherwise = coverOutsideReachable <> coverClosureViolations + where + objectCount = Vector.length objectVector + + coverOutsideReachable = + Vector.zip3 objectVector reachabilityRows coverRows + & Vector.toList + >>= ( \(targetObject, reachableBits, coverBits) -> + let outsideBits = bitsDifference coverBits reachableBits + in if outsideBits == 0 + then [] + else [CoverOutsideReachable targetObject (objectSetFromBits objectVector outsideBits)] + ) + + coverClosureViolations = + Vector.zip objectVector coverRows + & Vector.toList + >>= ( \(targetObject, coverBits) -> + let closureMissingBits = bitsDifference (rowsUnionForBits objectCount coverRows coverBits) coverBits + in if closureMissingBits == 0 + then [] + else denseCoverClosureViolationsForTarget objectVector coverRows targetObject coverBits + ) + +denseCoverClosureViolationsForTarget :: Ord obj => Vector obj -> Vector Integer -> obj -> Integer -> [SiteViolation obj] +denseCoverClosureViolationsForTarget objectVector coverRows targetObject coverBits = + bitsToAscList (Vector.length objectVector) coverBits + >>= ( \coveredIndex -> + case (objectVector Vector.!? coveredIndex, coverRows Vector.!? coveredIndex) of + (Just covered, Just coveredCoverBits) -> + let + missingBits = bitsDifference coveredCoverBits coverBits + in if missingBits == 0 + then [] + else [CoverNotClosed targetObject covered (objectSetFromBits objectVector missingBits)] + _ -> [] + ) + +rowsUnionForBits :: Int -> Vector Integer -> Integer -> Integer +rowsUnionForBits objectCount rows bits = + bitsToAscList objectCount bits + & mapMaybe (rows Vector.!?) + & foldr (.|.) 0 diff --git a/src-site/Moonlight/Category/Pure/Site/Quotient.hs b/src-site/Moonlight/Category/Pure/Site/Quotient.hs new file mode 100644 --- /dev/null +++ b/src-site/Moonlight/Category/Pure/Site/Quotient.hs @@ -0,0 +1,316 @@ +-- | The path-thin quotient of a site path category: quotient objects and morphisms, +-- and the quotient maps from the path category. +module Moonlight.Category.Pure.Site.Quotient + ( PathThinCat (..), + PathThinObject (..), + PathThinMorphism (..), + SitePathQuotient, + sitePathQuotientDomain, + sitePathQuotientCodomain, + sitePathQuotientObjectIds, + SitePathQuotientError (..), + pathThinCat, + mkPathThinObject, + mkPathThinMorphism, + quotientPathThinObject, + quotientPathThinMorphism, + pathThinCodomainObject, + pathThinCodomainMorphism, + sitePathQuotient, + quotientMapObject, + quotientMapMorphism, + ) +where + +import Data.Kind (Type) +import Data.Bifunctor (first) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Pure.FinCat + ( FinCat, + FinMor, + FinMorphismId, + FinObjectId, + FinObj, + ) +import Moonlight.Category.Pure.Site.Category + ( SitePathCategory, + SitePathMorphism, + SitePathObject, + mkSitePathObject, + sitePathCategoryCodomain, + sitePathCategoryKernel, + sitePathCategoryObjectIds, + sitePathManifest, + sitePathMorphismCategory, + sitePathMorphismCodomain, + sitePathMorphismNodes, + sitePathObjectCategory, + sitePathObjectCodomain, + sitePathObjectValue, + ) +import Moonlight.Category.Pure.Site.Compile + ( ThinSiteKernel, + ThinSiteLookupError (..), + thinSiteFinMorphismByEndpoints, + thinSiteFinObject, + ) +import Moonlight.Category.Pure.Site.Core (SiteManifest (..)) + +type PathThinCat :: Type -> Type +newtype PathThinCat obj = PathThinCat + { pathThinDomain :: SitePathCategory obj + } + deriving stock (Eq, Show) + +type PathThinObject :: Type -> Type +data PathThinObject obj = PathThinObject + { pathThinObjectCategory :: PathThinCat obj, + pathThinObjectValue :: obj, + pathThinObjectCodomain :: FinObj + } + deriving stock (Eq, Show) + +type PathThinMorphism :: Type -> Type +data PathThinMorphism obj = PathThinMorphism + { pathThinMorphismCategory :: PathThinCat obj, + pathThinMorphismSourceValue :: obj, + pathThinMorphismTargetValue :: obj, + pathThinMorphismWitness :: SitePathMorphism obj, + pathThinMorphismCodomain :: FinMor + } + deriving stock (Show) + +instance Eq obj => Eq (PathThinMorphism obj) where + left == right = + pathThinMorphismCategory left == pathThinMorphismCategory right + && pathThinMorphismSourceValue left == pathThinMorphismSourceValue right + && pathThinMorphismTargetValue left == pathThinMorphismTargetValue right + +type PathThinCompositor :: Type -> Type +data PathThinCompositor obj + = PathThinCompositor + deriving stock (Eq, Show) + +type PathThinTwoMor :: Type -> Type +data PathThinTwoMor obj + = PathThinTwoMor + deriving stock (Eq, Show) + +type PathThinCategoryError :: Type -> Type +data PathThinCategoryError obj + = PathThinObjectWrongCategory + | PathThinMorphismWrongCategory + | PathThinMorphismNotComposable + | PathThinInvalidIdentity + | PathThinInvalidComposite + | PathThinInvalidSourceTarget + deriving stock (Eq, Show) + +type SitePathQuotient :: Type -> Type +newtype SitePathQuotient obj = SitePathQuotient + { sitePathQuotientDomain :: SitePathCategory obj + } + +sitePathQuotientCodomain :: SitePathQuotient obj -> FinCat +sitePathQuotientCodomain = sitePathCategoryCodomain . sitePathQuotientDomain + +sitePathQuotientObjectIds :: SitePathQuotient obj -> Map obj FinObjectId +sitePathQuotientObjectIds = sitePathCategoryObjectIds . sitePathQuotientDomain + +type SitePathQuotientError :: Type -> Type +data SitePathQuotientError obj + = QuotientUnknownObject obj + | QuotientCodomainObjectMissing FinObjectId + | QuotientUnknownMorphismPair obj obj + | QuotientCodomainMorphismMissing FinMorphismId + | QuotientCodomainMorphismInvalid + | QuotientObjectWrongDomain + | QuotientMorphismWrongDomain + deriving stock (Eq, Show) + +pathThinCat :: SitePathCategory obj -> PathThinCat obj +pathThinCat = PathThinCat + +mkPathThinObject :: Ord obj => PathThinCat obj -> obj -> Maybe (PathThinObject obj) +mkPathThinObject category objectValue = do + siteObject <- mkSitePathObject (pathThinDomain category) objectValue + pure + PathThinObject + { pathThinObjectCategory = category, + pathThinObjectValue = objectValue, + pathThinObjectCodomain = sitePathObjectCodomain siteObject + } + +mkPathThinMorphism :: + Ord obj => + PathThinCat obj -> + SitePathMorphism obj -> + Maybe (PathThinMorphism obj) +mkPathThinMorphism category witness = + if sitePathMorphismCategory witness == pathThinDomain category + then + let sourceValue = NonEmpty.head (sitePathMorphismNodes witness) + targetValue = NonEmpty.last (sitePathMorphismNodes witness) + in Just + PathThinMorphism + { pathThinMorphismCategory = category, + pathThinMorphismSourceValue = sourceValue, + pathThinMorphismTargetValue = targetValue, + pathThinMorphismWitness = witness, + pathThinMorphismCodomain = sitePathMorphismCodomain witness + } + else Nothing + +quotientPathThinObject :: SitePathObject obj -> PathThinObject obj +quotientPathThinObject objectValue = + PathThinObject + { pathThinObjectCategory = pathThinCat (sitePathObjectCategory objectValue), + pathThinObjectValue = sitePathObjectValue objectValue, + pathThinObjectCodomain = sitePathObjectCodomain objectValue + } + +quotientPathThinMorphism :: SitePathMorphism obj -> PathThinMorphism obj +quotientPathThinMorphism morphism = + PathThinMorphism + { pathThinMorphismCategory = pathThinCat (sitePathMorphismCategory morphism), + pathThinMorphismSourceValue = NonEmpty.head (sitePathMorphismNodes morphism), + pathThinMorphismTargetValue = NonEmpty.last (sitePathMorphismNodes morphism), + pathThinMorphismWitness = morphism, + pathThinMorphismCodomain = sitePathMorphismCodomain morphism + } + +pathThinCodomainObject :: PathThinObject obj -> FinObj +pathThinCodomainObject = + pathThinObjectCodomain + +pathThinCodomainMorphism :: PathThinMorphism obj -> FinMor +pathThinCodomainMorphism = + pathThinMorphismCodomain + +sitePathQuotient :: SitePathCategory obj -> SitePathQuotient obj +sitePathQuotient = SitePathQuotient + +sameSitePathDomain :: Ord obj => SitePathCategory obj -> SitePathQuotient obj -> Bool +sameSitePathDomain category quotient = + let categoryManifest = sitePathManifest category + quotientManifest = sitePathManifest (sitePathQuotientDomain quotient) + in siteObjects categoryManifest == siteObjects quotientManifest + && siteImports categoryManifest == siteImports quotientManifest + +quotientMapObject :: + Ord obj => + SitePathQuotient obj -> + SitePathObject obj -> + Either (SitePathQuotientError obj) FinObj +quotientMapObject quotient objectValue + | not (sameSitePathDomain (sitePathObjectCategory objectValue) quotient) = + Left QuotientObjectWrongDomain + | otherwise = + first fromThinSiteLookupError + ( thinSiteFinObject + (sitePathQuotientKernel quotient) + (sitePathObjectValue objectValue) + ) + +quotientMapMorphism :: + Ord obj => + SitePathQuotient obj -> + SitePathMorphism obj -> + Either (SitePathQuotientError obj) FinMor +quotientMapMorphism quotient morphism + | not (sameSitePathDomain (sitePathMorphismCategory morphism) quotient) = + Left QuotientMorphismWrongDomain + | otherwise = + first fromThinSiteLookupError + ( thinSiteFinMorphismByEndpoints + (sitePathQuotientKernel quotient) + (NonEmpty.head (sitePathMorphismNodes morphism)) + (NonEmpty.last (sitePathMorphismNodes morphism)) + ) + +instance Ord obj => Category (PathThinCat obj) where + type Ob (PathThinCat obj) = PathThinObject obj + type Mor (PathThinCat obj) = PathThinMorphism obj + type TwoMor (PathThinCat obj) = PathThinTwoMor obj + type Compositor (PathThinCat obj) = PathThinCompositor obj + type CategoryError (PathThinCat obj) = PathThinCategoryError obj + + identity category objectValue = + if pathThinObjectCategory objectValue /= category + then Left PathThinObjectWrongCategory + else + case mkSitePathObject (pathThinDomain category) (pathThinObjectValue objectValue) of + Nothing -> Left PathThinInvalidIdentity + Just siteObject -> do + witness <- first (const PathThinInvalidIdentity) (identity (pathThinDomain category) siteObject) + codomain <- first (const PathThinInvalidIdentity) (identity (sitePathCategoryCodomain (pathThinDomain category)) (pathThinObjectCodomain objectValue)) + Right + PathThinMorphism + { pathThinMorphismCategory = category, + pathThinMorphismSourceValue = pathThinObjectValue objectValue, + pathThinMorphismTargetValue = pathThinObjectValue objectValue, + pathThinMorphismWitness = witness, + pathThinMorphismCodomain = codomain + } + + compose category left right + | pathThinMorphismCategory left /= category = Left PathThinMorphismWrongCategory + | pathThinMorphismCategory right /= category = Left PathThinMorphismWrongCategory + | pathThinMorphismTargetValue right /= pathThinMorphismSourceValue left = Left PathThinMorphismNotComposable + | otherwise = do + (witnessComposed, _) <- + first + (const PathThinInvalidComposite) + (compose (pathThinDomain category) (pathThinMorphismWitness left) (pathThinMorphismWitness right)) + case mkPathThinMorphism category witnessComposed of + Nothing -> Left PathThinInvalidComposite + Just morphism -> Right (morphism, PathThinCompositor) + + source category morphism = + if pathThinMorphismCategory morphism /= category + then Left PathThinMorphismWrongCategory + else do + codomainObject <- + first + (const PathThinInvalidSourceTarget) + (source (sitePathCategoryCodomain (pathThinDomain category)) (pathThinMorphismCodomain morphism)) + Right + PathThinObject + { pathThinObjectCategory = category, + pathThinObjectValue = pathThinMorphismSourceValue morphism, + pathThinObjectCodomain = codomainObject + } + + target category morphism = + if pathThinMorphismCategory morphism /= category + then Left PathThinMorphismWrongCategory + else do + codomainObject <- + first + (const PathThinInvalidSourceTarget) + (target (sitePathCategoryCodomain (pathThinDomain category)) (pathThinMorphismCodomain morphism)) + Right + PathThinObject + { pathThinObjectCategory = category, + pathThinObjectValue = pathThinMorphismTargetValue morphism, + pathThinObjectCodomain = codomainObject + } + +sitePathQuotientKernel :: SitePathQuotient obj -> ThinSiteKernel obj +sitePathQuotientKernel = sitePathCategoryKernel . sitePathQuotientDomain + +fromThinSiteLookupError :: ThinSiteLookupError obj -> SitePathQuotientError obj +fromThinSiteLookupError lookupError = + case lookupError of + ThinSiteUnknownObject objectValue -> + QuotientUnknownObject objectValue + ThinSiteCodomainObjectMissing objectId -> + QuotientCodomainObjectMissing objectId + ThinSiteUnknownMorphismPair sourceValue targetValue -> + QuotientUnknownMorphismPair sourceValue targetValue + ThinSiteCodomainMorphismMissing morId -> + QuotientCodomainMorphismMissing morId + ThinSiteCodomainMorphismInvalid _ -> + QuotientCodomainMorphismInvalid 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,24 @@ +module AbstractTests + ( tests, + ) +where + +import qualified AdhesiveSpec +import qualified CoveringProductSpec +import qualified DecoratedPresentationSpec +import qualified DoubleCategorySpec +import qualified FiniteComposableSpec +import qualified PolynomialFunctorWitnessSpec +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "abstract" + [ AdhesiveSpec.tests, + CoveringProductSpec.tests, + DecoratedPresentationSpec.tests, + DoubleCategorySpec.tests, + FiniteComposableSpec.tests, + PolynomialFunctorWitnessSpec.tests + ] diff --git a/test/abstract/AdhesiveSpec.hs b/test/abstract/AdhesiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/AdhesiveSpec.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module AdhesiveSpec + ( tests, + ) +where + +import Data.List (isInfixOf) +import Data.Foldable (traverse_) +import Moonlight.Category + ( AdhesiveCategory (..), + Category (..), + HasPullbacks (..), + HasPushouts (..), + MonicMatchComponents (..), + PBPOAdhesiveCategory (..), + PBPOComplementComponents (..), + PushoutComplementComponents (..), + monicMatchArrow, + pbpoComplement, + pbpoComplementBorrowedLeg, + pbpoComplementMonicMatch, + pbpoComplementPullbackObject, + pbpoComplementPullbackToBorrowed, + pbpoComplementPullbackToMatch, + pbpoComplementPushoutFromComplement, + pbpoComplementPushoutFromMatch, + pbpoComplementPushoutObject, + pbpoComplementResidualLeg, + pbpoComplementRuleLeg, + pbpoPullbackSquareCommutes, + pbpoPushoutSquareCommutes, + pushoutComplement, + pushoutComplementSquareCommutes, + composeMor, + witnessMonic, + ) +import Moonlight.Category.Effect.Harness.Adhesive qualified as AdhesiveHarness +import Moonlight.Category.Effect.Harness.Category qualified as CategoryHarness +import Moonlight.Category.Effect.Harness.Core (CategoryLaws (categoryAssociativity)) +import Moonlight.Category.Effect.Harness.Limits qualified as LimitsHarness +import Moonlight.Category.Pure.Adhesive + ( denseIntSetInterval, + denseIntSetMember, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase) + +data TestCategory = TestCategory + +data NativePBPOCategory = NativePBPOCategory + +data MissingMediatorCategory = MissingMediatorCategory + +data BrokenCompositionCategory = BrokenCompositionCategory + +data TestObject + = ObjectK + | ObjectL + | ObjectD + | ObjectG + | ObjectP + | ObjectQ + | ObjectNativePullback + | ObjectNativePushout + deriving stock (Eq, Show) + +data TestMorphism = TestMorphism + { testMorphismSource :: !TestObject, + testMorphismTarget :: !TestObject + } + deriving stock (Eq, Show) + +data TestTwoMor + +data TestCompositor = TestCompositor + +newtype BrokenObject = BrokenObject TestObject + deriving stock (Eq, Show) + +data BrokenMorphism = BrokenMorphism + { brokenMorphismSource :: !BrokenObject, + brokenMorphismTarget :: !BrokenObject + } + deriving stock (Eq, Show) + +data BrokenTwoMor + +data BrokenCompositor + +newtype NativeObject = NativeObject TestObject + deriving stock (Eq, Show) + +data NativeMorphism = NativeMorphism + { nativeMorphismSource :: !NativeObject, + nativeMorphismTarget :: !NativeObject + } + deriving stock (Eq, Show) + +data NativeTwoMor + +data NativeCompositor = NativeCompositor + +newtype MissingMediatorObject = MissingMediatorObject TestObject + deriving stock (Eq, Show) + +data MissingMediatorMorphism = MissingMediatorMorphism + { missingMediatorMorphismSource :: !MissingMediatorObject, + missingMediatorMorphismTarget :: !MissingMediatorObject + } + deriving stock (Eq, Show) + +data MissingMediatorTwoMor + +data MissingMediatorCompositor = MissingMediatorCompositor + +instance Category TestCategory where + type Ob TestCategory = TestObject + type Mor TestCategory = TestMorphism + type TwoMor TestCategory = TestTwoMor + type Compositor TestCategory = TestCompositor + + identity _ objectValue = + Right (TestMorphism objectValue objectValue) + + compose _ leftMorphism rightMorphism + | testMorphismTarget rightMorphism == testMorphismSource leftMorphism = + Right (TestMorphism (testMorphismSource rightMorphism) (testMorphismTarget leftMorphism), TestCompositor) + | otherwise = + Left () + + source _ = + Right . testMorphismSource + + target _ = + Right . testMorphismTarget + +instance Category BrokenCompositionCategory where + type Ob BrokenCompositionCategory = BrokenObject + type Mor BrokenCompositionCategory = BrokenMorphism + type TwoMor BrokenCompositionCategory = BrokenTwoMor + type Compositor BrokenCompositionCategory = BrokenCompositor + + identity _ objectValue = Right (BrokenMorphism objectValue objectValue) + compose _ _ _ = Left () + source _ = Right . brokenMorphismSource + target _ = Right . brokenMorphismTarget + +instance HasPullbacks TestCategory where + pullback _ leftMorphism rightMorphism + | testMorphismTarget leftMorphism == testMorphismTarget rightMorphism = + Just + ( ObjectP, + TestMorphism ObjectP (testMorphismSource leftMorphism), + TestMorphism ObjectP (testMorphismSource rightMorphism) + ) + | otherwise = + Nothing + + pullbackMediator _ leftMorphism rightMorphism coneLeft coneRight + | testMorphismTarget leftMorphism == testMorphismTarget rightMorphism + && testMorphismTarget coneLeft == testMorphismSource leftMorphism + && testMorphismTarget coneRight == testMorphismSource rightMorphism + && testMorphismSource coneLeft == testMorphismSource coneRight + && composeMor @TestCategory TestCategory leftMorphism coneLeft == composeMor @TestCategory TestCategory rightMorphism coneRight = + Just (TestMorphism (testMorphismSource coneLeft) ObjectP) + | otherwise = + Nothing + +instance HasPushouts TestCategory where + pushout _ leftMorphism rightMorphism + | testMorphismSource leftMorphism == testMorphismSource rightMorphism = + Just + ( ObjectQ, + TestMorphism (testMorphismTarget leftMorphism) ObjectQ, + TestMorphism (testMorphismTarget rightMorphism) ObjectQ + ) + | otherwise = + Nothing + +instance AdhesiveCategory TestCategory where + monicMatchComponents _ morphism = + Just (MonicMatchComponents morphism) + + pushoutComplementComponents _ _ _ = + Just + PushoutComplementComponents + { pushoutComplementComponentObject = ObjectD, + pushoutComplementComponentBorrowedLeg = TestMorphism ObjectD ObjectG, + pushoutComplementComponentResidualLeg = TestMorphism ObjectK ObjectD + } + +instance PBPOAdhesiveCategory TestCategory + +instance Category NativePBPOCategory where + type Ob NativePBPOCategory = NativeObject + type Mor NativePBPOCategory = NativeMorphism + type TwoMor NativePBPOCategory = NativeTwoMor + type Compositor NativePBPOCategory = NativeCompositor + + identity _ objectValue = + Right (NativeMorphism objectValue objectValue) + + compose _ leftMorphism rightMorphism + | nativeMorphismTarget rightMorphism == nativeMorphismSource leftMorphism = + Right (NativeMorphism (nativeMorphismSource rightMorphism) (nativeMorphismTarget leftMorphism), NativeCompositor) + | otherwise = + Left () + + source _ = + Right . nativeMorphismSource + + target _ = + Right . nativeMorphismTarget + +instance HasPullbacks NativePBPOCategory where + pullback _ _ _ = + Nothing + + pullbackMediator _ _ _ _ _ = + Nothing + +instance HasPushouts NativePBPOCategory where + pushout _ _ _ = + Nothing + +instance AdhesiveCategory NativePBPOCategory where + monicMatchComponents _ morphism = + Just (MonicMatchComponents morphism) + + pushoutComplementComponents _ _ _ = + Nothing + +instance PBPOAdhesiveCategory NativePBPOCategory where + pbpoComplementComponents _ _ _ = + Just + PBPOComplementComponents + { pbpoComplementComponentPullbackObject = NativeObject ObjectNativePullback, + pbpoComplementComponentPullbackToBorrowed = NativeMorphism (NativeObject ObjectNativePullback) (NativeObject ObjectD), + pbpoComplementComponentPullbackToMatch = NativeMorphism (NativeObject ObjectNativePullback) (NativeObject ObjectL), + pbpoComplementComponentPushoutObject = NativeObject ObjectNativePushout, + pbpoComplementComponentPushoutFromComplement = NativeMorphism (NativeObject ObjectD) (NativeObject ObjectNativePushout), + pbpoComplementComponentPushoutFromMatch = NativeMorphism (NativeObject ObjectL) (NativeObject ObjectNativePushout), + pbpoComplementComponentBorrowedLeg = NativeMorphism (NativeObject ObjectD) (NativeObject ObjectG), + pbpoComplementComponentResidualLeg = NativeMorphism (NativeObject ObjectK) (NativeObject ObjectD) + } + +instance Category MissingMediatorCategory where + type Ob MissingMediatorCategory = MissingMediatorObject + type Mor MissingMediatorCategory = MissingMediatorMorphism + type TwoMor MissingMediatorCategory = MissingMediatorTwoMor + type Compositor MissingMediatorCategory = MissingMediatorCompositor + + identity _ objectValue = + Right (MissingMediatorMorphism objectValue objectValue) + + compose _ leftMorphism rightMorphism + | missingMediatorMorphismTarget rightMorphism == missingMediatorMorphismSource leftMorphism = + Right + ( MissingMediatorMorphism + (missingMediatorMorphismSource rightMorphism) + (missingMediatorMorphismTarget leftMorphism), + MissingMediatorCompositor + ) + | otherwise = + Left () + + source _ = + Right . missingMediatorMorphismSource + + target _ = + Right . missingMediatorMorphismTarget + +instance HasPullbacks MissingMediatorCategory where + pullback _ leftMorphism rightMorphism + | missingMediatorMorphismTarget leftMorphism == missingMediatorMorphismTarget rightMorphism = + Just + ( MissingMediatorObject ObjectP, + MissingMediatorMorphism (MissingMediatorObject ObjectP) (missingMediatorMorphismSource leftMorphism), + MissingMediatorMorphism (MissingMediatorObject ObjectP) (missingMediatorMorphismSource rightMorphism) + ) + | otherwise = + Nothing + + pullbackMediator _ _ _ _ _ = + Nothing + +tests :: TestTree +tests = + testGroup + "Adhesive" + [ testCase "PBPO complement carries pullback and pushout squares" testPBPOComplement, + testCase "PBPO complement can be native rather than DPO-derived" testNativePBPOComplement, + testCase "pushout complement witness square commutes" testPushoutComplementSquare, + testCase "pullback mediator law rejects missing mediators for valid cones" testPullbackMediatorLawRejectsMissingMediator, + testCase "pullback law rejects a missing construction on a valid cospan" testPullbackLawRejectsMissingConstruction, + testCase "associativity law rejects failed composition on valid boundaries" testAssociativityLawRejectsFailedComposition, + testCase "dense interval rejects overflowing bounds" testDenseIntervalRejectsOverflow, + testCase "public adhesive surface keeps witness constructors opaque" testWitnessSurfaceOpaque + ] + +testDenseIntervalRejectsOverflow :: IO () +testDenseIntervalRejectsOverflow = do + denseIntSetInterval 512 maxBound 2 @?= Nothing + denseIntSetInterval 512 511 2 @?= Nothing + case denseIntSetInterval 512 510 2 of + Nothing -> assertFailure "expected the final two in-range elements" + Just interval -> do + denseIntSetMember 510 interval @?= True + denseIntSetMember 511 interval @?= True + +testPBPOComplement :: IO () +testPBPOComplement = + let ruleLeg = TestMorphism ObjectK ObjectL + matchArrow = TestMorphism ObjectL ObjectG + in case witnessMonic @TestCategory TestCategory matchArrow >>= pbpoComplement @TestCategory TestCategory ruleLeg of + Nothing -> + assertFailure "expected PBPO complement witness" + Just witness -> do + pbpoComplementRuleLeg witness @?= ruleLeg + monicMatchArrow (pbpoComplementMonicMatch witness) @?= matchArrow + pbpoComplementPullbackObject witness @?= ObjectP + pbpoComplementPullbackToBorrowed witness @?= TestMorphism ObjectP ObjectD + pbpoComplementPullbackToMatch witness @?= TestMorphism ObjectP ObjectL + pbpoComplementPushoutObject witness @?= ObjectQ + pbpoComplementPushoutFromComplement witness @?= TestMorphism ObjectD ObjectQ + pbpoComplementPushoutFromMatch witness @?= TestMorphism ObjectL ObjectQ + pbpoComplementBorrowedLeg witness @?= TestMorphism ObjectD ObjectG + pbpoComplementResidualLeg witness @?= TestMorphism ObjectK ObjectD + pbpoPullbackSquareCommutes TestCategory witness @?= True + pbpoPushoutSquareCommutes TestCategory witness @?= True + +testNativePBPOComplement :: IO () +testNativePBPOComplement = + let ruleLeg = NativeMorphism (NativeObject ObjectK) (NativeObject ObjectL) + matchArrow = NativeMorphism (NativeObject ObjectL) (NativeObject ObjectG) + in case witnessMonic @NativePBPOCategory NativePBPOCategory matchArrow >>= pbpoComplement @NativePBPOCategory NativePBPOCategory ruleLeg of + Nothing -> + assertFailure "expected native PBPO complement witness" + Just witness -> do + pbpoComplementPullbackObject witness @?= NativeObject ObjectNativePullback + pbpoComplementPushoutObject witness @?= NativeObject ObjectNativePushout + +testPushoutComplementSquare :: IO () +testPushoutComplementSquare = + let ruleLeg = TestMorphism ObjectK ObjectL + matchArrow = TestMorphism ObjectL ObjectG + in case witnessMonic @TestCategory TestCategory matchArrow >>= pushoutComplement @TestCategory TestCategory ruleLeg of + Nothing -> + assertFailure "expected pushout complement witness" + Just witness -> + pushoutComplementSquareCommutes TestCategory witness @?= True + +testPullbackMediatorLawRejectsMissingMediator :: IO () +testPullbackMediatorLawRejectsMissingMediator = + let objectValue = + MissingMediatorObject + morphismValue sourceValue targetValue = + MissingMediatorMorphism (objectValue sourceValue) (objectValue targetValue) + leftBase = morphismValue ObjectL ObjectG + rightBase = morphismValue ObjectD ObjectG + coneLeft = morphismValue ObjectK ObjectL + coneRight = morphismValue ObjectK ObjectD + in AdhesiveHarness.pullbackMediatorCommutes @MissingMediatorCategory MissingMediatorCategory leftBase rightBase coneLeft coneRight + @?= False + +testPullbackLawRejectsMissingConstruction :: IO () +testPullbackLawRejectsMissingConstruction = + let targetObject = NativeObject ObjectG + leftMorphism = NativeMorphism (NativeObject ObjectL) targetObject + rightMorphism = NativeMorphism (NativeObject ObjectD) targetObject + in LimitsHarness.pullbackCommutative @NativePBPOCategory NativePBPOCategory leftMorphism rightMorphism + @?= False + +testAssociativityLawRejectsFailedComposition :: IO () +testAssociativityLawRejectsFailedComposition = + let laws = CategoryHarness.mkCategoryLaws @BrokenCompositionCategory BrokenCompositionCategory + objectValue = BrokenObject + morphismValue sourceValue targetValue = + BrokenMorphism (objectValue sourceValue) (objectValue targetValue) + firstMorphism = morphismValue ObjectK ObjectL + secondMorphism = morphismValue ObjectL ObjectD + thirdMorphism = morphismValue ObjectD ObjectG + in categoryAssociativity laws firstMorphism secondMorphism thirdMorphism + @?= False + +testWitnessSurfaceOpaque :: IO () +testWitnessSurfaceOpaque = do + sourceText <- readFile "src-abstract/Moonlight/Category/Pure/Adhesive.hs" + traverse_ + (\forbidden -> assertBool ("public surface contains " <> forbidden) (not (forbidden `isInfixOf` sourceText))) + [ "MonicMatchWitness (..)", + "PushoutComplementWitness (..)", + "PBPOComplementWitness (..)", + "data MonicMatchWitness c = MonicMatchWitness\n {", + "data PushoutComplementWitness c = PushoutComplementWitness\n {", + "data PBPOComplementWitness c = PBPOComplementWitness\n {" + ] diff --git a/test/abstract/CoveringProductSpec.hs b/test/abstract/CoveringProductSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/CoveringProductSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module CoveringProductSpec + ( tests, + ) +where + +import Data.Kind (Type) +import Moonlight.Category + ( CoveringProduct, + adjustCoveringProduct, + indexCoveringProduct, + replaceCoveringProduct, + restrictCoveringProduct, + tabulateCoveringProduct, + ) +import Moonlight.Category.Test.CoveringFixture + ( DemoField, + DemoFieldWitness (..), + DemoSubsetWitness (..), + embedDemoSubsetWitness, + sameDemoFieldWitness, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +type DemoValue :: DemoField -> Type +newtype DemoValue (field :: DemoField) = DemoValue + { unDemoValue :: String + } + deriving stock (Eq, Show) + +demoProduct :: CoveringProduct DemoFieldWitness DemoValue +demoProduct = + tabulateCoveringProduct + ( \witness -> + case witness of + AlphaFieldWitness -> DemoValue "alpha" + BetaFieldWitness -> DemoValue "beta" + GammaFieldWitness -> DemoValue "gamma" + ) + +tests :: TestTree +tests = + testGroup + "CoveringProduct" + [ testCase "restrictCoveringProduct projects a witness-indexed subset" $ + let restrictedProduct = + restrictCoveringProduct embedDemoSubsetWitness demoProduct + in do + unDemoValue (indexCoveringProduct restrictedProduct AlphaSubsetWitness) @?= "alpha" + unDemoValue (indexCoveringProduct restrictedProduct GammaSubsetWitness) @?= "gamma", + testCase "adjustCoveringProduct updates exactly the targeted witness" $ + let adjustedProduct = + adjustCoveringProduct + sameDemoFieldWitness + BetaFieldWitness + (\(DemoValue value) -> DemoValue (value <> "-adjusted")) + demoProduct + in do + unDemoValue (indexCoveringProduct adjustedProduct AlphaFieldWitness) @?= "alpha" + unDemoValue (indexCoveringProduct adjustedProduct BetaFieldWitness) @?= "beta-adjusted" + unDemoValue (indexCoveringProduct adjustedProduct GammaFieldWitness) @?= "gamma", + testCase "replaceCoveringProduct delegates through typed witness equality" $ + let replacedProduct = + replaceCoveringProduct + sameDemoFieldWitness + GammaFieldWitness + (DemoValue "gamma-replaced") + demoProduct + in do + unDemoValue (indexCoveringProduct replacedProduct AlphaFieldWitness) @?= "alpha" + unDemoValue (indexCoveringProduct replacedProduct BetaFieldWitness) @?= "beta" + unDemoValue (indexCoveringProduct replacedProduct GammaFieldWitness) @?= "gamma-replaced" + ] diff --git a/test/abstract/DecoratedPresentationSpec.hs b/test/abstract/DecoratedPresentationSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/DecoratedPresentationSpec.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE TypeFamilies #-} + +module DecoratedPresentationSpec + ( tests, + ) +where + +import Data.Kind (Type) +import Moonlight.Category + ( Category (..), + CompositionResult (..), + HasPushouts (..), + StructuredCompositionAlgebra (..), + StructuredCospanError (..), + compileDecoratedPresentation, + compileDecoratedPresentationStructured, + composeStructuredCospan, + mkStructuredCospan, + presentationGlue, + presentationLeaf, + structuredDecoration, + structuredLeftLeg, + structuredRightLeg, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), Assertion, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "DecoratedPresentation" + [ testCase "plain decorated presentation accumulates obligations compositionally" testCompileDecoratedPresentation, + testCase "structured decorated presentation composes through the shared algebra" testCompileStructuredPresentation, + testCase "structured cospan composition rejects boundary mismatches before pushout" testStructuredCospanBoundaryMismatchRejectedBeforePushout + ] + +testCompileDecoratedPresentation :: Assertion +testCompileDecoratedPresentation = + let presentation = + presentationGlue + "outer" + (presentationLeaf "alpha" ["a"]) + ( presentationGlue + "inner" + (presentationLeaf "beta" ["b"]) + (presentationLeaf "gamma" ["c"]) + ) + result = + compileDecoratedPresentation + (<>) + (\boundary (leftIr, _) (rightIr, _) -> (leftIr <> "|" <> rightIr, [boundary])) + presentation + in result + @?= CompositionResult + { composedIR = "alpha|beta|gamma", + composedObligations = ["inner", "outer"], + composedDecoration = ["a", "b", "c"] + } + +testCompileStructuredPresentation :: Assertion +testCompileStructuredPresentation = + let compositionAlgebra = + StructuredCompositionAlgebra + { toStructuredBoundary = + \_ (_, decoration) -> + either (const Nothing) Just (mkStructuredCospan TestCat leftBoundaryLeg rightBoundaryLeg decoration), + fromStructuredComposition = + \boundary (leftIr, _) (rightIr, _) structuredBoundary -> + ( leftIr <> "+" <> rightIr, + [boundary <> ":" <> testDecorationTag (structuredDecoration structuredBoundary)] + ) + } + presentation = + presentationGlue + "seam" + (presentationLeaf "left" (TestDecoration "left" ["l"])) + (presentationLeaf "right" (TestDecoration "right" ["r"])) + in case compileDecoratedPresentationStructured TestCat compositionAlgebra mergeTestDecorations presentation of + Right result -> + result + @?= CompositionResult + { composedIR = "left+right", + composedObligations = ["seam:left-right"], + composedDecoration = TestDecoration "left-right" ["l", "r"] + } + Left _ -> + assertFailure "expected structured decorated presentation to compile" + +testStructuredCospanBoundaryMismatchRejectedBeforePushout :: Assertion +testStructuredCospanBoundaryMismatchRejectedBeforePushout = do + leftCospan <- + expectStructuredCospan + ( mkStructuredCospan + TestCat + (testMor "left-input" outerLeft leftApex) + (testMor "left-output" sharedBoundary leftApex) + "left" + ) + validRightCospan <- + expectStructuredCospan + ( mkStructuredCospan + TestCat + (testMor "right-input" sharedBoundary rightApex) + (testMor "right-output" outerRight rightApex) + "right" + ) + mismatchedRightCospan <- + expectStructuredCospan + ( mkStructuredCospan + TestCat + (testMor "right-input" wrongBoundary rightApex) + (testMor "right-output" outerRight rightApex) + "right" + ) + + case composeStructuredCospan TestCat (<>) leftCospan validRightCospan of + Right composed -> do + structuredDecoration composed @?= "leftright" + structuredLeftLeg composed @?= testMor "pushout-left.left-input" outerLeft pushoutObject + structuredRightLeg composed @?= testMor "pushout-right.right-output" outerRight pushoutObject + Left _ -> + assertFailure "expected matching structured cospan boundaries to compose" + + case composeStructuredCospan TestCat (<>) leftCospan mismatchedRightCospan of + Left (StructuredCospanBoundaryMismatch leftOutput rightInput) -> do + leftOutput @?= sharedBoundary + rightInput @?= wrongBoundary + other -> + assertFailure + ( "expected boundary mismatch before a pushout is requested, got " + <> describeStructuredCospanResult other + ) + +type TestCat :: Type +data TestCat = TestCat + +type TestObj :: Type +data TestObj = TestObj String + deriving stock (Eq, Show) + +type TestMor :: Type +data TestMor = TestMor + { testMorName :: String, + testMorSource :: TestObj, + testMorTarget :: TestObj + } + deriving stock (Eq, Show) + +type TestDecoration :: Type +data TestDecoration = TestDecoration + { testDecorationTag :: String, + testDecorationPayload :: [String] + } + deriving stock (Eq, Show) + +mergeTestDecorations :: TestDecoration -> TestDecoration -> TestDecoration +mergeTestDecorations leftDecoration rightDecoration = + TestDecoration + { testDecorationTag = + testDecorationTag leftDecoration <> "-" <> testDecorationTag rightDecoration, + testDecorationPayload = + testDecorationPayload leftDecoration <> testDecorationPayload rightDecoration + } + +instance Category TestCat where + type Ob TestCat = TestObj + type Mor TestCat = TestMor + + identity _ objectValue = Right (testMor ("id:" <> show objectValue) objectValue objectValue) + compose _ leftMorphism rightMorphism + | testMorTarget rightMorphism == testMorSource leftMorphism = + Right + ( testMor + (testMorName leftMorphism <> "." <> testMorName rightMorphism) + (testMorSource rightMorphism) + (testMorTarget leftMorphism), + () + ) + | otherwise = Left () + source _ = Right . testMorSource + target _ = Right . testMorTarget + +instance HasPushouts TestCat where + pushout _ leftMorphism rightMorphism + | testMorSource leftMorphism == testMorSource rightMorphism = + Just + ( pushoutObject, + testMor "pushout-left" (testMorTarget leftMorphism) pushoutObject, + testMor "pushout-right" (testMorTarget rightMorphism) pushoutObject + ) + | otherwise = Nothing + +testMor :: String -> TestObj -> TestObj -> TestMor +testMor = TestMor + +leftBoundaryLeg :: TestMor +leftBoundaryLeg = + testMor "left-boundary" sharedBoundary sharedBoundary + +rightBoundaryLeg :: TestMor +rightBoundaryLeg = + testMor "right-boundary" sharedBoundary sharedBoundary + +outerLeft :: TestObj +outerLeft = + TestObj "outer-left" + +outerRight :: TestObj +outerRight = + TestObj "outer-right" + +sharedBoundary :: TestObj +sharedBoundary = + TestObj "shared-boundary" + +wrongBoundary :: TestObj +wrongBoundary = + TestObj "wrong-boundary" + +leftApex :: TestObj +leftApex = + TestObj "left-apex" + +rightApex :: TestObj +rightApex = + TestObj "right-apex" + +pushoutObject :: TestObj +pushoutObject = + TestObj "pushout" + +expectStructuredCospan :: Either (StructuredCospanError TestCat) value -> IO value +expectStructuredCospan result = + case result of + Left _ -> assertFailure ("expected structured cospan, got " <> describeStructuredCospanResult result) + Right value -> pure value + +describeStructuredCospanResult :: Either (StructuredCospanError TestCat) a -> String +describeStructuredCospanResult result = + case result of + Right _ -> + "Right " + Left (StructuredCospanCategoryError _) -> + "Left StructuredCospanCategoryError" + Left (StructuredCospanBoundaryMismatch leftOutput rightInput) -> + "Left (StructuredCospanBoundaryMismatch " <> show leftOutput <> " " <> show rightInput <> ")" + Left (StructuredCospanPushoutMissing leftLeg rightLeg) -> + "Left (StructuredCospanPushoutMissing " <> show leftLeg <> " " <> show rightLeg <> ")" diff --git a/test/abstract/DoubleCategorySpec.hs b/test/abstract/DoubleCategorySpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/DoubleCategorySpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module DoubleCategorySpec + ( tests, + ) +where + +import Data.Proxy (Proxy (..)) +import Moonlight.Category (DoubleCategory (..), interchangeLaw) +import Moonlight.Category.Test.DoubleFixture + ( SymbolicDouble, + SymbolicHorizontal (..), + SymbolicObject (..), + SymbolicSquare (..), + SymbolicVertical (..), + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +tests :: TestTree +tests = + testGroup + "DoubleCategory" + [ testCase "interchange law holds for a symbolic 2x2 grid" testInterchangeLaw, + testCase "typed identities are neutral on symbolic morphisms" testIdentity + ] + +horizontalArrow :: String -> SymbolicHorizontal String source target +horizontalArrow labelValue = SymbolicHorizontal [labelValue] + +verticalArrow :: String -> SymbolicVertical String source target +verticalArrow labelValue = SymbolicVertical [labelValue] + +northWestSquare :: SymbolicSquare String 'ObjectA 'ObjectB 'ObjectD 'ObjectE +northWestSquare = + SymbolicSquare + { symbolicSquareTop = horizontalArrow "top-west", + symbolicSquareBottom = horizontalArrow "middle-west", + symbolicSquareLeft = verticalArrow "left-north", + symbolicSquareRight = verticalArrow "middle-north" + } + +northEastSquare :: SymbolicSquare String 'ObjectB 'ObjectC 'ObjectE 'ObjectF +northEastSquare = + SymbolicSquare + { symbolicSquareTop = horizontalArrow "top-east", + symbolicSquareBottom = horizontalArrow "middle-east", + symbolicSquareLeft = verticalArrow "middle-north", + symbolicSquareRight = verticalArrow "right-north" + } + +southWestSquare :: SymbolicSquare String 'ObjectD 'ObjectE 'ObjectG 'ObjectH +southWestSquare = + SymbolicSquare + { symbolicSquareTop = horizontalArrow "middle-west", + symbolicSquareBottom = horizontalArrow "bottom-west", + symbolicSquareLeft = verticalArrow "left-south", + symbolicSquareRight = verticalArrow "middle-south" + } + +southEastSquare :: SymbolicSquare String 'ObjectE 'ObjectF 'ObjectH 'ObjectI +southEastSquare = + SymbolicSquare + { symbolicSquareTop = horizontalArrow "middle-east", + symbolicSquareBottom = horizontalArrow "bottom-east", + symbolicSquareLeft = verticalArrow "middle-south", + symbolicSquareRight = verticalArrow "right-south" + } + +testInterchangeLaw :: IO () +testInterchangeLaw = + interchangeLaw @SymbolicObject @(SymbolicDouble String) northWestSquare northEastSquare southWestSquare southEastSquare + @?= Just True + +testIdentity :: IO () +testIdentity = do + composeHorizontal @SymbolicObject @(SymbolicDouble String) (horizontalIdentity @SymbolicObject @(SymbolicDouble String) (Proxy @'ObjectB)) (horizontalArrow "edge" :: SymbolicHorizontal String 'ObjectA 'ObjectB) + @?= Just (horizontalArrow "edge") + composeVertical @SymbolicObject @(SymbolicDouble String) (verticalIdentity @SymbolicObject @(SymbolicDouble String) (Proxy @'ObjectB)) (verticalArrow "edge" :: SymbolicVertical String 'ObjectA 'ObjectB) + @?= Just (verticalArrow "edge") diff --git a/test/abstract/FiniteComposableSpec.hs b/test/abstract/FiniteComposableSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/FiniteComposableSpec.hs @@ -0,0 +1,59 @@ +module FiniteComposableSpec + ( tests, + ) +where + +import Moonlight.Category.Pure.Category (Category (..)) +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Pure.FinCat + ( FinObjectId (..), + finCatHomMorphism, + finObjectIdentityMor, + mkFinObject, + ) +import Moonlight.Category.Pure.FiniteComposable + ( FiniteComposableCategory (..), + chainDimension, + chainMorphisms, + chainTerminalObject, + mkComposableChain, + ) +import Moonlight.Pale.Test.Assertions (expectRightWithLabel, expectSome) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "FiniteComposable" + [ testCase "checked chains cache their terminal without changing their morphisms" testCheckedChain, + testCase "Natural dimension bounds do not overflow through Int" testNaturalDimensionBound, + testCase "identity construction requires a validated object" testCheckedIdentity + ] + +testCheckedChain :: Assertion +testCheckedChain = do + object0 <- expectRightWithLabel "object 0" (mkFinObject sampleFinCat (FinObjectId 0)) + object2 <- expectRightWithLabel "object 2" (mkFinObject sampleFinCat (FinObjectId 2)) + morphism01 <- expectSome "morphism 0 -> 1" (finCatHomMorphism sampleFinCat (FinObjectId 0) (FinObjectId 1)) + morphism12 <- expectSome "morphism 1 -> 2" (finCatHomMorphism sampleFinCat (FinObjectId 1) (FinObjectId 2)) + case mkComposableChain sampleFinCat object0 [morphism01, morphism12] of + Left _ -> assertFailure "expected a composable chain" + Right chainValue -> do + chainDimension chainValue @?= 2 + chainTerminalObject chainValue @?= object2 + chainMorphisms chainValue @?= [morphism01, morphism12] + +testNaturalDimensionBound :: Assertion +testNaturalDimensionBound = + assertBool + "a valid enormous Natural bound must retain the dimension-zero chains" + (not (null (take 1 (enumerateComposableChains sampleFinCat (fromIntegral (maxBound :: Int)))))) + +testCheckedIdentity :: Assertion +testCheckedIdentity = do + case mkFinObject sampleFinCat (FinObjectId 99) of + Left _ -> pure () + Right _ -> assertFailure "an undeclared raw object id crossed the validated boundary" + object0 <- expectRightWithLabel "object 0" (mkFinObject sampleFinCat (FinObjectId 0)) + identity sampleFinCat object0 @?= Right (finObjectIdentityMor object0) 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 qualified AbstractTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain AbstractTests.tests diff --git a/test/abstract/PolynomialFunctorWitnessSpec.hs b/test/abstract/PolynomialFunctorWitnessSpec.hs new file mode 100644 --- /dev/null +++ b/test/abstract/PolynomialFunctorWitnessSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +module PolynomialFunctorWitnessSpec + ( tests, + ) +where + +import Moonlight.Category + ( Direction, + Exists (..), + ParameterizedDirection, + ParameterizedPolynomialFunctor (..), + PolynomialFunctor (..), + ) +import Moonlight.Category.Test.PolynomialFixture + ( BranchPosition, + DemoParameterizedPolynomial, + DemoPolynomial, + FullSliceBranchPosition, + FullSliceRootPosition, + RootPosition, + TrimmedSliceRootPosition, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +rootDirectionWitness :: Direction DemoPolynomial RootPosition +rootDirectionWitness = True + +branchDirectionWitness :: Direction DemoPolynomial BranchPosition +branchDirectionWitness = Just False + +fullSliceRootDirectionWitness :: ParameterizedDirection DemoParameterizedPolynomial FullSliceRootPosition +fullSliceRootDirectionWitness = True + +fullSliceBranchDirectionWitness :: ParameterizedDirection DemoParameterizedPolynomial FullSliceBranchPosition +fullSliceBranchDirectionWitness = Just True + +trimmedSliceRootDirectionWitness :: ParameterizedDirection DemoParameterizedPolynomial TrimmedSliceRootPosition +trimmedSliceRootDirectionWitness = () + +tests :: TestTree +tests = + testGroup + "PolynomialFunctor" + [ testGroup + "closed witness families" + [ testCase "position witnesses enumerate the polynomial support" $ + length demoPositions @?= 2, + testCase "root positions admit the indexed direction carrier" $ + rootDirectionWitness @?= True, + testCase "branch positions admit a distinct indexed direction carrier" $ + branchDirectionWitness @?= Just False + ], + testGroup + "parameterized witness families" + [ testCase "positionsAt enumerates the requested slice" $ + ( length (demoParameterizedPositions True), + length (demoParameterizedPositions False) + ) + @?= (2, 1), + testCase "parameterized positions admit slice-specific directions" $ + ( fullSliceRootDirectionWitness, + fullSliceBranchDirectionWitness, + trimmedSliceRootDirectionWitness + ) + @?= (True, Just True, ()) + ] + ] + +demoPositions :: [Exists (Position DemoPolynomial)] +demoPositions = allPositions + +demoParameterizedPositions :: Bool -> [Exists (ParameterizedPosition DemoParameterizedPolynomial)] +demoParameterizedPositions = positionsAt diff --git a/test/coherence/Main.hs b/test/coherence/Main.hs new file mode 100644 --- /dev/null +++ b/test/coherence/Main.hs @@ -0,0 +1,15 @@ +-- | Compile every focused test section against their dependency union. Empty +-- imports retain module and instance coherence without executing the focused +-- behavioral suites a second time. +module Main (main) where + +import AbstractTests () +import FacadeTests () +import FiniteTests () +import IndexedTests () +import Moonlight.Category.Effect.Laws () +import SimplicialTests () +import SiteTests () + +main :: IO () +main = pure () diff --git a/test/facade/FacadeTests.hs b/test/facade/FacadeTests.hs new file mode 100644 --- /dev/null +++ b/test/facade/FacadeTests.hs @@ -0,0 +1,13 @@ +module FacadeTests + ( tests, + ) +where + +import qualified NotationSpec +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "facade" + [NotationSpec.tests] diff --git a/test/facade/Main.hs b/test/facade/Main.hs new file mode 100644 --- /dev/null +++ b/test/facade/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified FacadeTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain FacadeTests.tests diff --git a/test/facade/NotationSpec.hs b/test/facade/NotationSpec.hs new file mode 100644 --- /dev/null +++ b/test/facade/NotationSpec.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeFamilies #-} + +module NotationSpec + ( tests, + ) +where + +import Moonlight.Category + ( Category (..), + FinCat, + FinObjectId (..), + finMorId, + mkFinObject, + ) +import Moonlight.Category.Notation + ( cod, + codObj, + composeIn, + dom, + domObj, + hom, + idOf, + reachableIn, + ) +import Moonlight.Category.Presentation + ( FinCatBuildError, + after, + arrow, + below, + equate, + finCategory, + object, + objects, + ) +import Moonlight.Pale.Test.Assertions (expectRightWithLabel, expectSome, withResult) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Notation" + [ testCase "dom and cod agree with the category's source and target" testDomCodAgreeWithCategory, + testCase "composeIn realises the categorical composite" testComposeInRealisesComposite, + testCase "reachableIn reads a preorder, identities included" testReachableInPreorder, + testCase "idOf is the identity morphism the category provides" testIdOfIsIdentity + ] + +triangle :: Either FinCatBuildError FinCat +triangle = + finCategory $ do + a <- object "A" + b <- object "B" + c <- object "C" + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow a c "h" + equate (g `after` f) h + +chain :: Either FinCatBuildError FinCat +chain = + finCategory $ do + [x, y, z] <- objects ["x", "y", "z"] + below x y + below y z + +testDomCodAgreeWithCategory :: Assertion +testDomCodAgreeWithCategory = + withResult triangle $ \category -> do + f <- expectSome "the morphism 0 -> 1" (hom category (FinObjectId 0) (FinObjectId 1)) + dom f @?= FinObjectId 0 + cod f @?= FinObjectId 1 + source category f @?= Right (domObj f) + target category f @?= Right (codObj f) + +testComposeInRealisesComposite :: Assertion +testComposeInRealisesComposite = + withResult triangle $ \category -> do + f <- expectSome "the morphism 0 -> 1" (hom category (FinObjectId 0) (FinObjectId 1)) + g <- expectSome "the morphism 1 -> 2" (hom category (FinObjectId 1) (FinObjectId 2)) + h <- expectSome "the morphism 0 -> 2" (hom category (FinObjectId 0) (FinObjectId 2)) + fmap finMorId (composeIn category g f) @?= Right (finMorId h) + +testReachableInPreorder :: Assertion +testReachableInPreorder = + withResult chain $ \category -> do + assertBool "0 reaches 2 transitively" (reachableIn category (FinObjectId 0) (FinObjectId 2)) + assertBool "2 does not reach 0" (not (reachableIn category (FinObjectId 2) (FinObjectId 0))) + assertBool "0 reaches 0 via the identity" (reachableIn category (FinObjectId 0) (FinObjectId 0)) + +testIdOfIsIdentity :: Assertion +testIdOfIsIdentity = + withResult triangle $ \category -> do + object0 <- expectRightWithLabel "the object 0" (mkFinObject category (FinObjectId 0)) + let identityMorphism = idOf object0 + dom identityMorphism @?= FinObjectId 0 + cod identityMorphism @?= FinObjectId 0 + Right identityMorphism @?= identity category object0 diff --git a/test/finite/DenseReachabilitySpec.hs b/test/finite/DenseReachabilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/finite/DenseReachabilitySpec.hs @@ -0,0 +1,181 @@ +module DenseReachabilitySpec + ( tests, + ) +where + +import Data.Bits (bit, testBit, (.&.), (.|.)) +import qualified Data.IntSet as IntSet +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Moonlight.Category.Pure.Finite.DenseReachability + ( DenseClosure (..), + denseReachabilityRows, + denseReachabilityWithCycles, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, testCase) + +tests :: TestTree +tests = + testGroup + "DenseReachability" + (denseClosureCase <$> adversarialCases <> pseudoRandomCases) + +data GraphCase = GraphCase String (Vector Integer) + +adversarialCases :: [GraphCase] +adversarialCases = + [ GraphCase "empty graph has no rows, cycles, or components" (edgeRows 0 []), + GraphCase "one vertex without an edge stays acyclic" (edgeRows 1 []), + GraphCase "singleton self-loop is reported as a cyclic component" (edgeRows 1 [(0, 0)]), + GraphCase "two vertices reaching each other form one cyclic component" (edgeRows 2 [(0, 1), (1, 0)]), + GraphCase "sixty-five vertex chain crosses bit-word boundaries without false cycles" (edgeRows 65 [(source, source + 1) | source <- [0 .. 63]]), + GraphCase "forty vertex complete digraph closes to one cyclic component" (edgeRows 40 [(source, target) | source <- [0 .. 39], target <- [0 .. 39], source /= target]), + GraphCase "stray bits above the vertex count are masked before closure" (Vector.fromList [bit 1 .|. bit 99, bit 2, bit 80]), + GraphCase "two bridged cycles remain separate cyclic components" (edgeRows 6 [(0, 1), (1, 0), (1, 2), (2, 3), (3, 4), (4, 2), (4, 5)]), + GraphCase "a singleton self-loop between larger components is preserved" (edgeRows 5 [(0, 1), (1, 0), (1, 2), (2, 2), (2, 3), (3, 4), (4, 3)]) + ] + +pseudoRandomCases :: [GraphCase] +pseudoRandomCases = + [ GraphCase ("deterministic pseudo-random graph seed " <> show seed <> " size " <> show vertexCount) (pseudoRandomRows vertexCount seed) + | (vertexCount, seed) <- [(0, 17), (1, 19), (2, 23), (5, 29), (9, 31), (16, 37), (33, 41), (67, 43)] + ] + +denseClosureCase :: GraphCase -> TestTree +denseClosureCase (GraphCase caseName inputRows) = + testCase caseName (assertDenseClosureMatchesReference caseName inputRows) + +assertDenseClosureMatchesReference :: String -> Vector Integer -> Assertion +assertDenseClosureMatchesReference caseName inputRows = do + let actualClosure = denseReachabilityWithCycles inputRows + actualRows = denseClosureReachabilityRows actualClosure + actualComponents = denseClosureCycleComponents actualClosure + expectedRows = warshallRows inputRows + expectedComponents = referenceCycleComponents inputRows + expectedComponentCount = referenceComponentCount inputRows + assertEqual (caseName <> ": denseReachabilityWithCycles rows match Warshall closure") expectedRows actualRows + assertEqual (caseName <> ": denseReachabilityRows matches the same Warshall closure") expectedRows (denseReachabilityRows inputRows) + assertEqual (caseName <> ": cycle components match mutual-reachability extraction") expectedComponents actualComponents + assertEqual (caseName <> ": component count includes acyclic singleton SCCs") expectedComponentCount (denseClosureComponentCount actualClosure) + assertEqual (caseName <> ": diagonal bits are exactly the reported cyclic vertices") (diagonalVertices actualRows) (componentVertices actualComponents) + +warshallRows :: Vector Integer -> Vector Integer +warshallRows inputRows = + List.foldl' closeOverPivot maskedRows [0 .. vertexCount - 1] + where + vertexCount :: Int + vertexCount = Vector.length inputRows + + maskedRows :: Vector Integer + maskedRows = Vector.map (.&. finiteBitMask vertexCount) inputRows + + closeOverPivot :: Vector Integer -> Int -> Vector Integer + closeOverPivot rows pivot = + Vector.imap + (\_source row -> + if testBit row pivot + then row .|. rowAt rows pivot + else row + ) + rows + +referenceCycleComponents :: Vector Integer -> [NonEmpty Int] +referenceCycleComponents inputRows = + filterCyclic (warshallRows inputRows) (mutualReachabilityClasses inputRows) + +referenceComponentCount :: Vector Integer -> Int +referenceComponentCount = + length . mutualReachabilityClasses + +mutualReachabilityClasses :: Vector Integer -> [NonEmpty Int] +mutualReachabilityClasses inputRows = + buildClasses 0 IntSet.empty [] + where + closureRows :: Vector Integer + closureRows = warshallRows inputRows + + vertexCount :: Int + vertexCount = Vector.length inputRows + + buildClasses :: Int -> IntSet.IntSet -> [NonEmpty Int] -> [NonEmpty Int] + buildClasses candidate seen reversedClasses + | candidate >= vertexCount = reverse reversedClasses + | candidate `IntSet.member` seen = buildClasses (candidate + 1) seen reversedClasses + | otherwise = + let members = candidate : filter (mutuallyReachable candidate) [candidate + 1 .. vertexCount - 1] + seenWithMembers = List.foldl' (flip IntSet.insert) seen members + in case NonEmpty.nonEmpty members of + Nothing -> buildClasses (candidate + 1) seenWithMembers reversedClasses + Just component -> buildClasses (candidate + 1) seenWithMembers (component : reversedClasses) + + mutuallyReachable :: Int -> Int -> Bool + mutuallyReachable left right = + testBit (rowAt closureRows left) right && testBit (rowAt closureRows right) left + +filterCyclic :: Vector Integer -> [NonEmpty Int] -> [NonEmpty Int] +filterCyclic closureRows = + filter componentIsCyclic + where + componentIsCyclic :: NonEmpty Int -> Bool + componentIsCyclic (single :| []) = testBit (rowAt closureRows single) single + componentIsCyclic (_first :| _rest) = True + +diagonalVertices :: Vector Integer -> [Int] +diagonalVertices rows = + [vertex | vertex <- [0 .. Vector.length rows - 1], testBit (rowAt rows vertex) vertex] + +componentVertices :: [NonEmpty Int] -> [Int] +componentVertices = + List.sort . foldMap NonEmpty.toList + +edgeRows :: Int -> [(Int, Int)] -> Vector Integer +edgeRows vertexCount edges = + Vector.generate vertexCount rowForSource + where + rowForSource :: Int -> Integer + rowForSource source = + List.foldl' (addEdgeFrom source) 0 edges + + addEdgeFrom :: Int -> Integer -> (Int, Int) -> Integer + addEdgeFrom source row (edgeSource, target) + | source == edgeSource && 0 <= target && target < vertexCount = row .|. bit target + | otherwise = row + +pseudoRandomRows :: Int -> Integer -> Vector Integer +pseudoRandomRows vertexCount seed = + Vector.generate vertexCount rowForSource + where + rowForSource :: Int -> Integer + rowForSource source = + List.foldl' + (\row target -> + if pseudoRandomEdge seed vertexCount source target + then row .|. bit target + else row + ) + 0 + [0 .. vertexCount - 1] + +pseudoRandomEdge :: Integer -> Int -> Int -> Int -> Bool +pseudoRandomEdge seed vertexCount source target = + lcg mixed `mod` 11 <= 2 + where + mixed :: Integer + mixed = seed + 97 * fromIntegral vertexCount + 104_729 * fromIntegral (source + 1) + 13_007 * fromIntegral (target + 1) + +lcg :: Integer -> Integer +lcg value = + (1_103_515_245 * value + 12_345) `mod` 2_147_483_647 + +rowAt :: Vector Integer -> Int -> Integer +rowAt rows index = + maybe 0 id (rows Vector.!? index) + +finiteBitMask :: Int -> Integer +finiteBitMask vertexCount + | vertexCount <= 0 = 0 + | otherwise = bit vertexCount - 1 diff --git a/test/finite/FinPresentationSpec.hs b/test/finite/FinPresentationSpec.hs new file mode 100644 --- /dev/null +++ b/test/finite/FinPresentationSpec.hs @@ -0,0 +1,774 @@ +module FinPresentationSpec + ( tests, + ) +where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Moonlight.Category + ( FinCatValidationError (..), + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + composeMor, + finCatNonIdentityMorphismCount, + objectCount, + finMorId, + mkFinCat, + mkFinObject, + ) +import Moonlight.Category.Pure.FinCat + ( trustedFinCatWithGeneratorBasis, + ) +import Moonlight.Category.Pure.Thin + ( composeThinMorphismBy, + mkThinMorphismBy, + thinMorphismSource, + thinMorphismTarget, + ) +import Moonlight.Category.Pure.Poset + ( PosetCat (..), + mkPosetMor, + posetSource, + posetTarget, + ) +import Moonlight.Category.Notation + ( composeIn, + hom, + idOf, + reachableIn, + ) +import Moonlight.Category.Presentation + ( FinCat, + FinBuilder, + FinCatBuildError (..), + after, + arrow, + below, + equate, + finCategory, + identityAt, + object, + objects, + ) +import Moonlight.Pale.Test.Assertions (expectRight) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion, + assertBool, + assertFailure, + testCase, + (@?=), + ) +import Test.Tasty.QuickCheck qualified as QC + +data SmallEndomorphismTable = SmallEndomorphismTable + { smallEndomorphismMorphisms :: [FinMorphismId], + smallEndomorphismComposition :: Map (FinMorphismId, FinMorphismId) FinMorphismId + } + deriving stock (Show) + +instance QC.Arbitrary SmallEndomorphismTable where + arbitrary = do + morphismCount <- QC.chooseInt (0, 4) + let morphismIds = + FinGeneratorMorphismId . FinGeneratorId <$> [0 .. morphismCount - 1] + resultIds = + FinIdentityId unitObjectId : morphismIds + composablePairs = + morphismIds >>= (\right -> fmap (\left -> (left, right)) morphismIds) + compositionKeys <- QC.sublistOf composablePairs + compositionResults <- traverse (const (QC.elements resultIds)) compositionKeys + pure (SmallEndomorphismTable morphismIds (Map.fromList (zip compositionKeys compositionResults))) + + shrink _ = + [] + +tests :: TestTree +tests = + testGroup + "FinPresentation" + [ testCase + "a strict-order presentation compiles to the dense representation" + testPosetChainIsDense, + testCase + "dense thin composition returns the morphism for the composite endpoints" + testDenseThinCompositionUsesCompositeEndpointId, + testCase + "mkFinCat rejects dense thin composition results with wrong endpoints" + testDenseThinCompositionResultEndpointMismatchRejected, + testCase + "thin morphism smart constructors reject invalid relations and compose defensively" + testThinMorphismSmartConstructorsAndDefensiveCompose, + testCase + "poset smart constructors compose through the Category instance" + testPosetSmartConstructorsCompose, + testCase + "a fully enumerated presentation realises its composite" + testTriangleIsThinWithComposite, + testCase + "a longer path is lowered after its intermediate composites resolve" + testLongPathEquation, + testCase + "identity equations present a two-object groupoid" + testIdentityEquations, + testCase + "identity equations must agree with the unit laws" + testIdentityEquationMismatchRejected, + testCase + "mixing strict-order and general modes is rejected" + testMixedModesRejected, + testCase + "a cyclic strict-order presentation is rejected" + testCyclicStrictOrderRejected, + testCase + "an incomplete general presentation is rejected by validation" + testIncompletePresentationRejected, + testCase + "an unresolved proper subpath is reported" + testUnresolvedCompositeRejected, + testCase + "a noncomposable path is rejected before FinCat validation" + testNonComposablePathRejected, + testCase + "a nonparallel equation is rejected" + testNonParallelEquationRejected, + testCase + "conflicting composition claims are rejected rather than overwritten" + testConflictingCompositionRejected, + testCase + "an equality of distinct declared morphisms is not mistaken for a quotient" + testUnsupportedEquationRejected, + testCase + "a reflexive atomic equation is harmless" + testReflexiveEquationAccepted, + testCase + "a generator-backed non-thin presentation accepts an associative table" + testGeneratorBackedAssociativePresentation, + testCase + "a generator-backed non-thin presentation rejects associativity violations" + testGeneratorBackedAssociativityRejected, + testCase + "raw mkFinCat rejects associativity violations after generator reduction" + testRawMkFinCatStillRejectsAssociativityViolation, + QC.testProperty + "mkFinCat generator validation agrees with exhaustive validation on small explicit tables" + (QC.withNumTests 200 testMkFinCatMatchesExhaustiveValidator), + testCase + "mkFinCat catches a non-generator middle associativity violation" + testNonGeneratorMiddleViolationRejected, + testCase + "a duplicate object name is rejected" + testDuplicateObjectRejected + ] + +chainPoset :: Either FinCatBuildError FinCat +chainPoset = + finCategory $ do + [x, y, z] <- objects ["x", "y", "z"] + below x y + below y z + +denseChainObjects :: Set FinObjectId +denseChainObjects = + Set.fromList [FinObjectId 0, FinObjectId 1, FinObjectId 2] + +denseChainMorphismMap :: Map (FinObjectId, FinObjectId) [FinMorphismId] +denseChainMorphismMap = + Map.fromList + [ ((FinObjectId 0, FinObjectId 1), [denseChain01]), + ((FinObjectId 0, FinObjectId 2), [denseChain02]), + ((FinObjectId 1, FinObjectId 2), [denseChain12]) + ] + +denseChainComposition :: FinMorphismId -> Map (FinMorphismId, FinMorphismId) FinMorphismId +denseChainComposition compositeId = + Map.singleton (denseChain12, denseChain01) compositeId + +denseChain01 :: FinMorphismId +denseChain01 = + FinGeneratorMorphismId (FinGeneratorId 0) + +denseChain02 :: FinMorphismId +denseChain02 = + FinGeneratorMorphismId (FinGeneratorId 1) + +denseChain12 :: FinMorphismId +denseChain12 = + FinGeneratorMorphismId (FinGeneratorId 2) + +testDenseThinCompositionUsesCompositeEndpointId :: Assertion +testDenseThinCompositionUsesCompositeEndpointId = + case mkFinCat denseChainObjects denseChainMorphismMap (denseChainComposition denseChain02) of + Left validationErrors -> + assertFailure ("expected the dense thin chain to validate, got " <> show validationErrors) + Right category -> do + representationTag category @?= "DenseThinFinCat" + case + ( hom category (FinObjectId 0) (FinObjectId 1), + hom category (FinObjectId 1) (FinObjectId 2), + hom category (FinObjectId 0) (FinObjectId 2) + ) + of + (Just leftStep, Just rightStep, Just expectedComposite) -> do + composite <- expectRight (composeIn category rightStep leftStep) + finMorId composite @?= finMorId expectedComposite + finMorId composite @?= denseChain02 + _ -> + assertFailure "expected the dense chain to expose all non-identity morphisms" + +testDenseThinCompositionResultEndpointMismatchRejected :: Assertion +testDenseThinCompositionResultEndpointMismatchRejected = + case mkFinCat denseChainObjects denseChainMorphismMap (denseChainComposition denseChain01) of + Left validationErrors + | any (== CompositionResultEndpointMismatch denseChain12 denseChain01 denseChain01) validationErrors -> + pure () + other -> + assertFailure + ( "expected a composition-result endpoint mismatch for the dense chain, got " + <> show other + ) + +testThinMorphismSmartConstructorsAndDefensiveCompose :: Assertion +testThinMorphismSmartConstructorsAndDefensiveCompose = do + mkThinMorphismBy (<=) (3 :: Int) 1 @?= Nothing + case (mkThinMorphismBy (<=) (1 :: Int) 2, mkThinMorphismBy (<=) (2 :: Int) 4) of + (Just firstStep, Just secondStep) -> do + case composeThinMorphismBy (<=) secondStep firstStep of + Just composite -> do + thinMorphismSource composite @?= 1 + thinMorphismTarget composite @?= 4 + Nothing -> + assertFailure "expected valid thin morphisms to compose" + _ -> + assertFailure "expected monotone thin morphisms to construct" + case (mkThinMorphismBy (<=) (2 :: Int) 3, mkThinMorphismBy (\_ _ -> True) (4 :: Int) 2) of + (Just validLeft, Just staleRight) -> + composeThinMorphismBy (<=) validLeft staleRight @?= Nothing + _ -> + assertFailure "expected the permissive relation to build the stale morphism" + +testPosetSmartConstructorsCompose :: Assertion +testPosetSmartConstructorsCompose = do + mkPosetMor (3 :: Int) 1 @?= Nothing + case (mkPosetMor (0 :: Int) 1, mkPosetMor (1 :: Int) 3) of + (Just firstStep, Just secondStep) -> + case composeMor (PosetCat :: PosetCat Int) secondStep firstStep of + Right composite -> do + posetSource composite @?= 0 + posetTarget composite @?= 3 + Left () -> + assertFailure "expected comparable poset morphisms to compose" + _ -> + assertFailure "expected comparable poset morphisms to construct" + +triangleGeneral :: Either FinCatBuildError FinCat +triangleGeneral = + finCategory $ do + a <- object "A" + b <- object "B" + c <- object "C" + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow a c "h" + equate (g `after` f) h + +longPathGeneral :: Either FinCatBuildError FinCat +longPathGeneral = + finCategory $ do + a <- object "A" + b <- object "B" + c <- object "C" + d <- object "D" + + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow c d "h" + gf <- arrow a c "gf" + hg <- arrow b d "hg" + hgf <- arrow a d "hgf" + + -- Deliberately first: elaboration must not depend on declaration order. + equate (h `after` g `after` f) hgf + equate (g `after` f) gf + equate (h `after` g) hg + equate (hg `after` f) hgf + +inversePairGeneral :: Either FinCatBuildError FinCat +inversePairGeneral = + finCategory $ do + a <- object "A" + b <- object "B" + f <- arrow a b "f" + g <- arrow b a "g" + + equate (g `after` f) (identityAt a) + equate (f `after` g) (identityAt b) + +representationTag :: FinCat -> String +representationTag = + takeWhile (/= ' ') . show + +testPosetChainIsDense :: Assertion +testPosetChainIsDense = + case chainPoset of + Left buildError -> + assertFailure + ("expected a dense category, got " <> show buildError) + Right category -> do + representationTag category @?= "DenseThinFinCat" + objectCount category @?= 3 + finCatNonIdentityMorphismCount category @?= 3 + assertBool + "transitive closure provides the morphism 0 -> 2" + ( reachableIn + category + (FinObjectId 0) + (FinObjectId 2) + ) + assertBool + "the strict order is directional" + ( not + ( reachableIn + category + (FinObjectId 2) + (FinObjectId 0) + ) + ) + +testTriangleIsThinWithComposite :: Assertion +testTriangleIsThinWithComposite = + case triangleGeneral of + Left buildError -> + assertFailure + ("expected the triangle to compile, got " <> show buildError) + Right category -> do + representationTag category @?= "ThinFinCat" + objectCount category @?= 3 + finCatNonIdentityMorphismCount category @?= 3 + case + ( hom category (FinObjectId 0) (FinObjectId 1), + hom category (FinObjectId 1) (FinObjectId 2), + hom category (FinObjectId 0) (FinObjectId 2) + ) + of + (Just f, Just g, Just h) -> do + composite <- + expectRight (composeIn category g f) + finMorId composite @?= finMorId h + _ -> + assertFailure "expected all three triangle morphisms" + +testLongPathEquation :: Assertion +testLongPathEquation = + case longPathGeneral of + Left buildError -> + assertFailure + ( "expected the length-three presentation to compile, got " + <> show buildError + ) + Right category -> + case + ( hom category (FinObjectId 0) (FinObjectId 2), + hom category (FinObjectId 2) (FinObjectId 3), + hom category (FinObjectId 0) (FinObjectId 3) + ) + of + (Just gf, Just h, Just hgf) -> do + composite <- + expectRight (composeIn category h gf) + finMorId composite @?= finMorId hgf + _ -> + assertFailure "expected gf, h, and hgf" + +testIdentityEquations :: Assertion +testIdentityEquations = + case inversePairGeneral of + Left buildError -> + assertFailure + ("expected the inverse pair to compile, got " <> show buildError) + Right category -> + case + ( hom category (FinObjectId 0) (FinObjectId 1), + hom category (FinObjectId 1) (FinObjectId 0) + ) + of + (Just f, Just g) -> do + object0 <- + expectRight (mkFinObject category (FinObjectId 0)) + object1 <- + expectRight (mkFinObject category (FinObjectId 1)) + sourceIdentity <- + expectRight (composeIn category g f) + targetIdentity <- + expectRight (composeIn category f g) + + finMorId sourceIdentity + @?= finMorId + (idOf object0) + + finMorId targetIdentity + @?= finMorId + (idOf object1) + _ -> + assertFailure "expected both inverse morphisms" + +testIdentityEquationMismatchRejected :: Assertion +testIdentityEquationMismatchRejected = + case finCategory badIdentityPresentation of + Left (IdentityEquationMismatch _ _ _) -> + pure () + other -> + assertFailure + ("expected IdentityEquationMismatch, got " <> show other) + where + badIdentityPresentation = do + a <- object "A" + b <- object "B" + f <- arrow a b "f" + k <- arrow a b "k" + + equate (identityAt b `after` f) k + +testMixedModesRejected :: Assertion +testMixedModesRejected = + finCategory mixedPresentation @?= Left MixedPresentationModes + where + mixedPresentation = do + a <- object "A" + b <- object "B" + _ <- arrow a b "f" + below a b + +testCyclicStrictOrderRejected :: Assertion +testCyclicStrictOrderRejected = + case finCategory cyclicPresentation of + Left (CyclicStrictOrder objectIds) -> + assertBool + "the cycle names some object" + (not (null objectIds)) + other -> + assertFailure + ("expected CyclicStrictOrder, got " <> show other) + where + cyclicPresentation = do + a <- object "A" + b <- object "B" + below a b + below b a + +testIncompletePresentationRejected :: Assertion +testIncompletePresentationRejected = + case finCategory incompletePresentation of + Left (InvalidPresentation _) -> + pure () + other -> + assertFailure + ("expected InvalidPresentation, got " <> show other) + where + incompletePresentation = do + a <- object "A" + b <- object "B" + c <- object "C" + _ <- arrow a b "f" + _ <- arrow b c "g" + pure () + +testUnresolvedCompositeRejected :: Assertion +testUnresolvedCompositeRejected = + case finCategory unresolvedPresentation of + Left (UnresolvedComposite _) -> + pure () + other -> + assertFailure + ("expected UnresolvedComposite, got " <> show other) + where + unresolvedPresentation = do + a <- object "A" + b <- object "B" + c <- object "C" + d <- object "D" + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow c d "h" + hgf <- arrow a d "hgf" + + equate (h `after` g `after` f) hgf + +testNonComposablePathRejected :: Assertion +testNonComposablePathRejected = + case finCategory badPathPresentation of + Left (NonComposablePath _ _ _ _) -> + pure () + other -> + assertFailure + ("expected NonComposablePath, got " <> show other) + where + badPathPresentation = do + a <- object "A" + b <- object "B" + c <- object "C" + d <- object "D" + f <- arrow a b "f" + g <- arrow c d "g" + h <- arrow a d "h" + + equate (g `after` f) h + +testNonParallelEquationRejected :: Assertion +testNonParallelEquationRejected = + case finCategory nonParallelPresentation of + Left (NonParallelEquation _ _ _ _) -> + pure () + other -> + assertFailure + ("expected NonParallelEquation, got " <> show other) + where + nonParallelPresentation = do + a <- object "A" + b <- object "B" + c <- object "C" + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow b c "h" + + equate (g `after` f) h + +testConflictingCompositionRejected :: Assertion +testConflictingCompositionRejected = + case finCategory conflictingPresentation of + Left (ConflictingComposition _ _ _ _) -> + pure () + other -> + assertFailure + ("expected ConflictingComposition, got " <> show other) + where + conflictingPresentation = do + a <- object "A" + b <- object "B" + c <- object "C" + f <- arrow a b "f" + g <- arrow b c "g" + h <- arrow a c "h" + k <- arrow a c "k" + + equate (g `after` f) h + equate (g `after` f) k + +testUnsupportedEquationRejected :: Assertion +testUnsupportedEquationRejected = + case finCategory quotientPresentation of + Left (UnsupportedEquation _ _) -> + pure () + other -> + assertFailure + ("expected UnsupportedEquation, got " <> show other) + where + quotientPresentation = do + a <- object "A" + b <- object "B" + f <- arrow a b "f" + g <- arrow a b "g" + + equate f g + +testReflexiveEquationAccepted :: Assertion +testReflexiveEquationAccepted = + case finCategory reflexivePresentation of + Left buildError -> + assertFailure + ( "expected a reflexive equation to be ignored, got " + <> show buildError + ) + Right category -> do + objectCount category @?= 2 + finCatNonIdentityMorphismCount category @?= 1 + where + reflexivePresentation = do + a <- object "A" + b <- object "B" + f <- arrow a b "f" + + equate f f + +testGeneratorBackedAssociativePresentation :: Assertion +testGeneratorBackedAssociativePresentation = + case finCategory cyclicGroupPresentation of + Left buildError -> + assertFailure + ( "expected the associative endomorphism table to compile, got " + <> show buildError + ) + Right category -> do + representationTag category @?= "FinCat" + objectCount category @?= 1 + finCatNonIdentityMorphismCount category @?= 2 + where + cyclicGroupPresentation = do + x <- object "A" + a <- arrow x x "a" + b <- arrow x x "b" + + equate (a `after` a) b + equate (a `after` b) (identityAt x) + equate (b `after` a) (identityAt x) + equate (b `after` b) a + +testGeneratorBackedAssociativityRejected :: Assertion +testGeneratorBackedAssociativityRejected = + case finCategory nonAssociativePresentation of + Left (InvalidPresentation errors) + | containsAssociativityViolation errors -> + pure () + other -> + assertFailure + ( "expected InvalidPresentation with AssociativityViolation, got " + <> show other + ) + +testRawMkFinCatStillRejectsAssociativityViolation :: Assertion +testRawMkFinCatStillRejectsAssociativityViolation = + case + mkFinCat + unitObjectSet + unitEndomorphismMap + nonAssociativeCompositionTable + of + Left errors + | containsAssociativityViolation errors -> + pure () + other -> + assertFailure + ( "expected raw mkFinCat to reject the non-associative table, got " + <> show other + ) + +testMkFinCatMatchesExhaustiveValidator :: SmallEndomorphismTable -> QC.Property +testMkFinCatMatchesExhaustiveValidator (SmallEndomorphismTable morphismIds compositionMap) = + let morphismMap = + smallEndomorphismMorphismMap morphismIds + reducedResult = + mkFinCat unitObjectSet morphismMap compositionMap + exhaustiveResult = + trustedFinCatWithGeneratorBasis (Set.fromList morphismIds) unitObjectSet morphismMap compositionMap + in QC.checkCoverage + $ QC.cover 10 (acceptsFinCat reducedResult) "valid explicit tables" + $ QC.cover 20 (not (acceptsFinCat reducedResult)) "invalid explicit tables" + $ QC.counterexample + ( "reduced=" + <> show reducedResult + <> "\nexhaustive=" + <> show exhaustiveResult + <> "\ncomposition=" + <> show compositionMap + ) + $ acceptsFinCat reducedResult == acceptsFinCat exhaustiveResult + +smallEndomorphismMorphismMap :: [FinMorphismId] -> Map (FinObjectId, FinObjectId) [FinMorphismId] +smallEndomorphismMorphismMap morphismIds = + case morphismIds of + [] -> Map.empty + _ -> Map.singleton (unitObjectId, unitObjectId) morphismIds + +acceptsFinCat :: Either errorValue value -> Bool +acceptsFinCat = + either (const False) (const True) + +testNonGeneratorMiddleViolationRejected :: Assertion +testNonGeneratorMiddleViolationRejected = do + Map.lookup (aMorphismId, aMorphismId) nonGeneratorMiddleViolationTable @?= Just bMorphismId + ( composeUnitEndomorphism nonGeneratorMiddleViolationTable aMorphismId bMorphismId + >>= (\composed -> composeUnitEndomorphism nonGeneratorMiddleViolationTable composed aMorphismId) + ) + @?= Just (FinIdentityId unitObjectId) + ( composeUnitEndomorphism nonGeneratorMiddleViolationTable bMorphismId aMorphismId + >>= composeUnitEndomorphism nonGeneratorMiddleViolationTable aMorphismId + ) + @?= Just aMorphismId + case mkFinCat unitObjectSet unitEndomorphismMap nonGeneratorMiddleViolationTable of + Left errors + | containsAssociativityViolation errors -> + pure () + other -> + assertFailure + ( "expected generator validation to reject the non-generator-middle violation, got " + <> show other + ) + +nonGeneratorMiddleViolationTable :: Map (FinMorphismId, FinMorphismId) FinMorphismId +nonGeneratorMiddleViolationTable = + Map.fromList + [ ((aMorphismId, aMorphismId), bMorphismId), + ((aMorphismId, bMorphismId), bMorphismId), + ((bMorphismId, aMorphismId), FinIdentityId unitObjectId), + ((bMorphismId, bMorphismId), bMorphismId) + ] + +composeUnitEndomorphism :: Map (FinMorphismId, FinMorphismId) FinMorphismId -> FinMorphismId -> FinMorphismId -> Maybe FinMorphismId +composeUnitEndomorphism compositionMap left right + | left == FinIdentityId unitObjectId = Just right + | right == FinIdentityId unitObjectId = Just left + | otherwise = Map.lookup (left, right) compositionMap + +nonAssociativePresentation :: FinBuilder () +nonAssociativePresentation = do + x <- object "A" + a <- arrow x x "a" + b <- arrow x x "b" + + equate (a `after` a) a + equate (a `after` b) a + equate (b `after` a) b + equate (b `after` b) a + +unitObjectId :: FinObjectId +unitObjectId = + FinObjectId 0 + +unitObjectSet :: Set FinObjectId +unitObjectSet = + Set.singleton unitObjectId + +aMorphismId :: FinMorphismId +aMorphismId = + FinGeneratorMorphismId (FinGeneratorId 0) + +bMorphismId :: FinMorphismId +bMorphismId = + FinGeneratorMorphismId (FinGeneratorId 1) + +unitEndomorphismMap :: Map (FinObjectId, FinObjectId) [FinMorphismId] +unitEndomorphismMap = + Map.singleton (unitObjectId, unitObjectId) [aMorphismId, bMorphismId] + +nonAssociativeCompositionTable :: Map (FinMorphismId, FinMorphismId) FinMorphismId +nonAssociativeCompositionTable = + Map.fromList + [ ((aMorphismId, aMorphismId), aMorphismId), + ((aMorphismId, bMorphismId), aMorphismId), + ((bMorphismId, aMorphismId), bMorphismId), + ((bMorphismId, bMorphismId), aMorphismId) + ] + +containsAssociativityViolation :: NonEmpty FinCatValidationError -> Bool +containsAssociativityViolation = + any isAssociativityViolation . NonEmpty.toList + where + isAssociativityViolation validationError = + case validationError of + AssociativityViolation {} -> True + _ -> False + +testDuplicateObjectRejected :: Assertion +testDuplicateObjectRejected = + finCategory duplicatePresentation + @?= Left (DuplicateObjectName "A") + where + duplicatePresentation = do + _ <- object "A" + _ <- object "A" + pure () diff --git a/test/finite/FinThinFunctorSpec.hs b/test/finite/FinThinFunctorSpec.hs new file mode 100644 --- /dev/null +++ b/test/finite/FinThinFunctorSpec.hs @@ -0,0 +1,116 @@ +module FinThinFunctorSpec + ( tests, + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category.Pure.FinCat + ( FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + mkFinCat, + ) +import Moonlight.Category.Pure.FinCat.Functor + ( FinThinFunctorApplicationError (..), + FinThinFunctorValidationError (..), + applyFinThinFunctor, + mkFinThinFunctor, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "finite thin functor" + [ testCase "retains a validated total object action" testIdentityObjectAction, + testCase "reports domain and codomain obstructions" testObjectMapObstructions, + testCase "reports the first order obstruction" testOrderObstruction, + testCase "rejects a non-thin source" testNonThinSource + ] + +identityObjectMap :: Map.Map FinObjectId FinObjectId +identityObjectMap = + Map.fromList + [ (FinObjectId 0, FinObjectId 0), + (FinObjectId 1, FinObjectId 1), + (FinObjectId 2, FinObjectId 2) + ] + +testIdentityObjectAction :: Assertion +testIdentityObjectAction = + case mkFinThinFunctor sampleFinCat sampleFinCat identityObjectMap of + Left validationError -> + assertFailure ("expected identity object action to validate: " <> show validationError) + Right functorValue -> do + applyFinThinFunctor functorValue (FinObjectId 1) @?= Right (FinObjectId 1) + applyFinThinFunctor functorValue (FinObjectId 99) + @?= Left (FinThinFunctorUnknownSourceObject (FinObjectId 99)) + +testObjectMapObstructions :: Assertion +testObjectMapObstructions = do + assertValidationError + (FinThinFunctorMissingSourceObject (FinObjectId 2)) + (mkFinThinFunctor sampleFinCat sampleFinCat (Map.delete (FinObjectId 2) identityObjectMap)) + assertValidationError + (FinThinFunctorTargetObjectAbsent (FinObjectId 0) (FinObjectId 99)) + ( mkFinThinFunctor + sampleFinCat + sampleFinCat + (Map.insert (FinObjectId 0) (FinObjectId 99) identityObjectMap) + ) + +testOrderObstruction :: Assertion +testOrderObstruction = + assertValidationError + ( FinThinFunctorOrderNotPreserved + (FinObjectId 0) + (FinObjectId 1) + (FinObjectId 2) + (FinObjectId 1) + ) + ( mkFinThinFunctor + sampleFinCat + sampleFinCat + ( Map.fromList + [ (FinObjectId 0, FinObjectId 2), + (FinObjectId 1, FinObjectId 1), + (FinObjectId 2, FinObjectId 0) + ] + ) + ) + +testNonThinSource :: Assertion +testNonThinSource = + case + mkFinCat + (Set.fromList [FinObjectId 0, FinObjectId 1]) + ( Map.singleton + (FinObjectId 0, FinObjectId 1) + [ FinGeneratorMorphismId (FinGeneratorId 20), + FinGeneratorMorphismId (FinGeneratorId 21) + ] + ) + Map.empty + of + Left validationErrors -> + assertFailure ("expected the parallel-pair fixture to be a category: " <> show validationErrors) + Right nonThinCategory -> + assertValidationError + FinThinFunctorSourceNotThin + ( mkFinThinFunctor + nonThinCategory + sampleFinCat + (Map.fromList [(FinObjectId 0, FinObjectId 0), (FinObjectId 1, FinObjectId 1)]) + ) + +assertValidationError :: + FinThinFunctorValidationError -> + Either FinThinFunctorValidationError functorValue -> + Assertion +assertValidationError expected result = + case result of + Left actual -> actual @?= expected + Right _ -> assertFailure ("expected finite-thin-functor obstruction: " <> show expected) diff --git a/test/finite/FiniteTests.hs b/test/finite/FiniteTests.hs new file mode 100644 --- /dev/null +++ b/test/finite/FiniteTests.hs @@ -0,0 +1,20 @@ +module FiniteTests + ( tests, + ) +where + +import qualified DenseReachabilitySpec +import qualified FinPresentationSpec +import qualified FinThinFunctorSpec +import qualified InvertibilitySpec +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "finite" + [ FinPresentationSpec.tests, + FinThinFunctorSpec.tests, + InvertibilitySpec.tests, + DenseReachabilitySpec.tests + ] diff --git a/test/finite/InvertibilitySpec.hs b/test/finite/InvertibilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/finite/InvertibilitySpec.hs @@ -0,0 +1,672 @@ +module InvertibilitySpec + ( tests, + ) +where + +import Control.Monad ((>=>)) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.Kind (Type) +import Data.List (mapAccumL) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Sum (..)) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category + ( FinCat, + FinCatError (..), + FinCatValidationError (..), + FinGeneratorId (..), + FinMor, + FinMorphismId (..), + FinObjectId (..), + allMorphisms, + allMorphismsFrom, + allObjects, + automorphismGroupAt, + automorphismGroupoid, + automorphismGroupoidFromIndex, + automorphismGroupoidObjects, + composeMor, + coreGroupoid, + coreGroupoidFromIndex, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + coreGroupoidObjects, + finCatExplicitMorphismMapView, + finCatMorphismCountFrom, + finCatMorphismCountTo, + finObjId, + finMorId, + finMorSourceId, + finMorTargetId, + foldMapFinMorphismsFrom, + foldMapFinMorphismsTo, + forgetAutomorphismGroupoidMorphism, + identity, + invertibilityIndex, + mkFinCat, + mkFinMorphism, + mkFinObject, + mkFinTwoMor, + source, + target, + vCompose, + ) +import Moonlight.Category.Notation (cod, composeIn, dom, hom) +import Moonlight.Category.Presentation + ( FinCatBuildError, + below, + finCategory, + objects, + ) +import Moonlight.Pale.Test.Assertions (withResult) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) +import Test.Tasty.QuickCheck qualified as QC + +type GeneratedComponent :: Type +data GeneratedComponent + = ThinChainComponent Int + | PairGroupoidComponent Int + deriving stock (Eq, Show) + +type GeneratedFiniteCategory :: Type +newtype GeneratedFiniteCategory = GeneratedFiniteCategory + { unGeneratedFiniteCategory :: FinCat + } + deriving stock (Eq, Show) + +type ComponentData :: Type +data ComponentData = ComponentData + { cdObjects :: Set.Set FinObjectId, + cdMorphisms :: Map.Map (FinObjectId, FinObjectId) [FinMorphismId], + cdComposition :: Map.Map (FinMorphismId, FinMorphismId) FinMorphismId + } + +objectId :: Int -> FinObjectId +objectId = FinObjectId + +generatorMorphismId :: Int -> FinMorphismId +generatorMorphismId = FinGeneratorMorphismId . FinGeneratorId + +identityMorphismId :: Int -> FinMorphismId +identityMorphismId = FinIdentityId . objectId + +instance QC.Arbitrary GeneratedComponent where + arbitrary = + QC.oneof + [ ThinChainComponent <$> QC.chooseInt (1, 4), + PairGroupoidComponent <$> QC.chooseInt (1, 4) + ] + + shrink componentValue = + case componentValue of + ThinChainComponent sizeValue -> + QC.shrink sizeValue + >>= (\nextSize -> if nextSize >= 1 then [ThinChainComponent nextSize] else []) + PairGroupoidComponent sizeValue -> + QC.shrink sizeValue + >>= (\nextSize -> if nextSize >= 1 then [PairGroupoidComponent nextSize] else []) + +instance QC.Arbitrary GeneratedFiniteCategory where + arbitrary = + QC.suchThatMap + (QC.chooseInt (1, 3) >>= (\componentCount -> QC.vectorOf componentCount QC.arbitrary)) + (buildGeneratedFiniteCategory >=> (Just . GeneratedFiniteCategory)) + + shrink _ = [] + +buildGeneratedFiniteCategory :: [GeneratedComponent] -> Maybe FinCat +buildGeneratedFiniteCategory components = + let (_, builtComponents) = mapAccumL buildComponent (0, 0) components + componentObjects = + builtComponents + & foldMap cdObjects + allMorphismBuckets = + builtComponents + & fmap cdMorphisms + & Map.unions + allCompositions = + builtComponents + & fmap cdComposition + & Map.unions + in either (const Nothing) Just (mkFinCat componentObjects allMorphismBuckets allCompositions) + +componentCategory :: ComponentData -> Either (NonEmpty FinCatValidationError) FinCat +componentCategory component = + mkFinCat (cdObjects component) (cdMorphisms component) (cdComposition component) + +thinChainCategory :: Int -> Either (NonEmpty FinCatValidationError) FinCat +thinChainCategory sizeValue = + componentCategory (snd (buildThinChainComponent 0 100 sizeValue)) + +pairGroupoidCategory :: Int -> Either (NonEmpty FinCatValidationError) FinCat +pairGroupoidCategory sizeValue = + componentCategory (snd (buildPairGroupoidComponent 0 100 sizeValue)) + +buildComponent :: (Int, Int) -> GeneratedComponent -> ((Int, Int), ComponentData) +buildComponent (nextObjectId, nextGeneratorId) componentValue = + case componentValue of + ThinChainComponent sizeValue -> + buildThinChainComponent nextObjectId nextGeneratorId sizeValue + PairGroupoidComponent sizeValue -> + buildPairGroupoidComponent nextObjectId nextGeneratorId sizeValue + +buildThinChainComponent :: Int -> Int -> Int -> ((Int, Int), ComponentData) +buildThinChainComponent nextObjectId nextGeneratorId sizeValue = + let rawObjectIds = take sizeValue [nextObjectId ..] + generatorPairs = + rawObjectIds + >>= (\sourceObject -> + rawObjectIds + >>= (\targetObject -> + if sourceObject < targetObject + then [(sourceObject, targetObject)] + else [] + ) + ) + pairToGenerator = + zip generatorPairs [nextGeneratorId ..] + & fmap (\(objectPair, generatorKey) -> (objectPair, generatorMorphismId generatorKey)) + & Map.fromList + compositionMap = + rawObjectIds + >>= (\sourceObject -> + rawObjectIds + >>= (\middleObject -> + rawObjectIds + >>= (\targetObject -> + if sourceObject < middleObject && middleObject < targetObject + then compositionEntry pairToGenerator sourceObject middleObject targetObject + else [] + ) + ) + ) + & Map.fromList + nextState = (nextObjectId + sizeValue, nextGeneratorId + length generatorPairs) + in (nextState, componentData rawObjectIds pairToGenerator compositionMap) + +buildPairGroupoidComponent :: Int -> Int -> Int -> ((Int, Int), ComponentData) +buildPairGroupoidComponent nextObjectId nextGeneratorId sizeValue = + let rawObjectIds = take sizeValue [nextObjectId ..] + generatorPairs = + rawObjectIds + >>= (\sourceObject -> + rawObjectIds + >>= (\targetObject -> + if sourceObject /= targetObject + then [(sourceObject, targetObject)] + else [] + ) + ) + pairToGenerator = + zip generatorPairs [nextGeneratorId ..] + & fmap (\(objectPair, generatorKey) -> (objectPair, generatorMorphismId generatorKey)) + & Map.fromList + compositionMap = + rawObjectIds + >>= (\sourceObject -> + rawObjectIds + >>= (\middleObject -> + rawObjectIds + >>= (\targetObject -> + if sourceObject /= middleObject && middleObject /= targetObject + then groupoidCompositionEntry pairToGenerator sourceObject middleObject targetObject + else [] + ) + ) + ) + & Map.fromList + nextState = (nextObjectId + sizeValue, nextGeneratorId + length generatorPairs) + in (nextState, componentData rawObjectIds pairToGenerator compositionMap) + +componentData :: [Int] -> Map.Map (Int, Int) FinMorphismId -> Map.Map (FinMorphismId, FinMorphismId) FinMorphismId -> ComponentData +componentData rawObjectIds pairToGenerator compositionMap = + ComponentData + { cdObjects = Set.fromList (fmap objectId rawObjectIds), + cdMorphisms = + pairToGenerator + & Map.toList + & fmap (\((sourceObject, targetObject), generatorId) -> ((objectId sourceObject, objectId targetObject), [generatorId])) + & Map.fromList, + cdComposition = compositionMap + } + +compositionEntry :: Map.Map (Int, Int) FinMorphismId -> Int -> Int -> Int -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +compositionEntry pairToGenerator sourceObject middleObject targetObject = + case + ( Map.lookup (middleObject, targetObject) pairToGenerator, + Map.lookup (sourceObject, middleObject) pairToGenerator, + Map.lookup (sourceObject, targetObject) pairToGenerator + ) + of + (Just leftGeneratorId, Just rightGeneratorId, Just composedGeneratorId) -> + [((leftGeneratorId, rightGeneratorId), composedGeneratorId)] + _ -> [] + +groupoidCompositionEntry :: Map.Map (Int, Int) FinMorphismId -> Int -> Int -> Int -> [((FinMorphismId, FinMorphismId), FinMorphismId)] +groupoidCompositionEntry pairToGenerator sourceObject middleObject targetObject = + case + ( Map.lookup (middleObject, targetObject) pairToGenerator, + Map.lookup (sourceObject, middleObject) pairToGenerator, + if sourceObject == targetObject + then Just (identityMorphismId sourceObject) + else Map.lookup (sourceObject, targetObject) pairToGenerator + ) + of + (Just leftGeneratorId, Just rightGeneratorId, Just composedGeneratorId) -> + [((leftGeneratorId, rightGeneratorId), composedGeneratorId)] + _ -> [] + +allPairs :: [a] -> [(a, a)] +allPairs values = + values + >>= (\leftValue -> + values + >>= (\rightValue -> [(leftValue, rightValue)]) + ) + +allTriples :: [a] -> [(a, a, a)] +allTriples values = + values + >>= (\firstValue -> + values + >>= (\secondValue -> + values + >>= (\thirdValue -> [(firstValue, secondValue, thirdValue)]) + ) + ) + +coreGroupoidIdentityClosureHolds :: GeneratedFiniteCategory -> Bool +coreGroupoidIdentityClosureHolds (GeneratedFiniteCategory categoryValue) = + let groupoidValue = coreGroupoid categoryValue + in coreGroupoidObjects groupoidValue + & all + ( \objectValue -> + case identity groupoidValue objectValue of + Right identityMorphism -> + identityMorphism `elem` coreGroupoidMorphismsBetween groupoidValue objectValue objectValue + Left _ -> False + ) + +coreGroupoidCompositionClosureHolds :: GeneratedFiniteCategory -> Bool +coreGroupoidCompositionClosureHolds (GeneratedFiniteCategory categoryValue) = + let groupoidValue = coreGroupoid categoryValue + morphismPairs = + allPairs (coreGroupoidMorphisms groupoidValue) + & filter (\(leftMorphism, rightMorphism) -> target groupoidValue rightMorphism == source groupoidValue leftMorphism) + in morphismPairs + & all + ( \(leftMorphism, rightMorphism) -> + case composeMor groupoidValue leftMorphism rightMorphism of + Right composedMorphism -> + case (source groupoidValue rightMorphism, target groupoidValue leftMorphism) of + (Right sourceObject, Right targetObject) -> + composedMorphism + `elem` coreGroupoidMorphismsBetween + groupoidValue + sourceObject + targetObject + _ -> False + Left _ -> False + ) + +coreGroupoidAssociativityHolds :: GeneratedFiniteCategory -> Bool +coreGroupoidAssociativityHolds (GeneratedFiniteCategory categoryValue) = + let groupoidValue = coreGroupoid categoryValue + morphismTriples = + allTriples (coreGroupoidMorphisms groupoidValue) + & filter + ( \(leftMorphism, middleMorphism, rightMorphism) -> + target groupoidValue rightMorphism == source groupoidValue middleMorphism + && target groupoidValue middleMorphism == source groupoidValue leftMorphism + ) + in morphismTriples + & all + ( \(leftMorphism, middleMorphism, rightMorphism) -> + let leftAssociated = + composeMor groupoidValue middleMorphism rightMorphism + >>= composeMor groupoidValue leftMorphism + rightAssociated = + composeMor groupoidValue leftMorphism middleMorphism + >>= (\composedMorphism -> composeMor groupoidValue composedMorphism rightMorphism) + in leftAssociated == rightAssociated + ) + +isomorphicPairCategory :: FinCat +isomorphicPairCategory = + case + mkFinCat + (Set.fromList [objectId 0, objectId 1]) + ( Map.fromList + [ ((objectId 0, objectId 1), [generatorMorphismId 10]), + ((objectId 1, objectId 0), [generatorMorphismId 11]) + ] + ) + ( Map.fromList + [ ((generatorMorphismId 11, generatorMorphismId 10), identityMorphismId 0), + ((generatorMorphismId 10, generatorMorphismId 11), identityMorphismId 1) + ] + ) of + Right categoryValue -> categoryValue + Left _ -> sampleFinCat + +parallelObjectIds :: Set.Set FinObjectId +parallelObjectIds = + Set.fromList [objectId 0, objectId 1] + +parallelSourceId :: FinObjectId +parallelSourceId = objectId 0 + +parallelTargetId :: FinObjectId +parallelTargetId = objectId 1 + +parallelFId :: FinMorphismId +parallelFId = generatorMorphismId 20 + +parallelGId :: FinMorphismId +parallelGId = generatorMorphismId 21 + +parallelGPrimeId :: FinMorphismId +parallelGPrimeId = generatorMorphismId 22 + +parallelHId :: FinMorphismId +parallelHId = generatorMorphismId 23 + +parallelCategory :: [FinMorphismId] -> Either (NonEmpty FinCatValidationError) FinCat +parallelCategory morphismIds = + mkFinCat + parallelObjectIds + (Map.fromList [((parallelSourceId, parallelTargetId), morphismIds)]) + Map.empty + +withParallelMorphisms :: (FinCat -> FinMor -> FinMor -> FinMor -> FinMor -> Assertion) -> Assertion +withParallelMorphisms assertion = + withResult (parallelCategory [parallelFId, parallelGId, parallelGPrimeId, parallelHId]) $ \backgroundCategory -> + withResult (traverse (mkFinMorphism backgroundCategory) [parallelFId, parallelGId, parallelGPrimeId, parallelHId]) $ \backgroundMorphisms -> + case backgroundMorphisms of + [f, g, gPrime, h] -> assertion backgroundCategory f g gPrime h + _ -> assertFailure "expected four parallel morphisms from the finite-category fixture" + +canonicalHomBucketOrderIsIdentityInvariant :: Assertion +canonicalHomBucketOrderIsIdentityInvariant = + let firstPresentation = parallelCategory [parallelGId, parallelFId] + secondPresentation = parallelCategory [parallelFId, parallelGId] + expectedMorphismOrder = [identityMorphismId 0, identityMorphismId 1, parallelFId, parallelGId] + in withResult firstPresentation $ \firstCategory -> + withResult secondPresentation $ \restatedCategory -> do + assertEqual "hom-bucket order must not change category identity" firstCategory restatedCategory + assertEqual "morphism enumeration follows canonical category identity" expectedMorphismOrder (fmap finMorId (allMorphisms firstCategory)) + assertEqual "restated morphism enumeration follows the same canonical order" expectedMorphismOrder (fmap finMorId (allMorphisms restatedCategory)) + +explicitEmptyBucketIsPresentationNoise :: Assertion +explicitEmptyBucketIsPresentationNoise = + let objectIds = Set.fromList [objectId 0, objectId 1] + omittedBucket = mkFinCat objectIds Map.empty Map.empty + explicitBucket = mkFinCat objectIds (Map.fromList [((objectId 0, objectId 1), [])]) Map.empty + in withResult omittedBucket $ \firstCategory -> + withResult explicitBucket $ \restatedCategory -> do + assertEqual "valid empty hom-buckets canonicalize away" firstCategory restatedCategory + assertEqual "stored category presentation prunes empty buckets" Map.empty (finCatExplicitMorphismMapView restatedCategory) + +invalidEmptyBucketEndpointIsRejected :: Assertion +invalidEmptyBucketEndpointIsRejected = + case mkFinCat (Set.singleton (objectId 0)) (Map.fromList [((objectId 0, objectId 1), [])]) Map.empty of + Left failures -> + assertBool + "endpoint validation still sees invalid empty buckets" + (MorphismEndpointOutsideObjects (objectId 0) (objectId 1) `elem` failures) + Right _ -> assertFailure "expected invalid empty bucket endpoint to be rejected" + +identityCompositionTableKeysAreRejected :: Assertion +identityCompositionTableKeysAreRejected = + let morphismId = generatorMorphismId 30 + objectIds = Set.fromList [objectId 0, objectId 1] + morphismMap = Map.fromList [((objectId 0, objectId 1), [morphismId])] + compositionMap = Map.fromList [((identityMorphismId 1, morphismId), morphismId)] + in case mkFinCat objectIds morphismMap compositionMap of + Left failures -> + assertBool + "identity-keyed composition entries are dead table surface and must be rejected" + (CompositionTableUsesIdentityKey (identityMorphismId 1) morphismId `elem` failures) + Right _ -> assertFailure "expected identity-keyed composition entry to be rejected" + +verticalCompositionRejectsNonSharedMiddleEdge :: Assertion +verticalCompositionRejectsNonSharedMiddleEdge = + withParallelMorphisms $ \backgroundCategory f g gPrime h -> + withResult (mkFinTwoMor f gPrime) $ \rightCell -> + withResult (mkFinTwoMor g h) $ \topCell -> + assertEqual + "vertical composition requires equal shared 1-cell, not merely parallel object boundaries" + (Left (FinCatTwoMorphismNotVerticallyComposable topCell rightCell)) + (vCompose backgroundCategory topCell rightCell) + +verticalCompositionAcceptsSharedMiddleEdge :: Assertion +verticalCompositionAcceptsSharedMiddleEdge = + withParallelMorphisms $ \backgroundCategory f g _ h -> + withResult (mkFinTwoMor f g) $ \rightCell -> + withResult (mkFinTwoMor g h) $ \topCell -> + withResult (mkFinTwoMor f h) $ \resultCell -> + assertEqual + "vertical composition glues along the exact shared 1-cell" + (Right resultCell) + (vCompose backgroundCategory topCell rightCell) + +wrongCategoryTwoCellBoundaryIsRejectedBeforeVerticalGluing :: Assertion +wrongCategoryTwoCellBoundaryIsRejectedBeforeVerticalGluing = + withParallelMorphisms $ \backgroundCategory f g _ _ -> + withResult (mkFinTwoMor f g) $ \rightCell -> + withResult (parallelCategory [parallelGId, parallelHId]) $ \foreignCategory -> + withResult (traverse (mkFinMorphism foreignCategory) [parallelGId, parallelHId]) $ \foreignMorphisms -> + case foreignMorphisms of + [foreignG, foreignH] -> + withResult (mkFinTwoMor foreignG foreignH) $ \foreignTopCell -> + case vCompose backgroundCategory foreignTopCell rightCell of + Left (FinCatMorphismWrongCategory _ _ wrongMorphismId) -> + assertEqual "wrong-category source boundary is rejected first" (finMorId foreignG) wrongMorphismId + Left otherFailure -> assertFailure ("expected wrong-category obstruction, got " <> show otherFailure) + Right _ -> assertFailure "expected wrong-category 2-cell boundary to be rejected" + _ -> assertFailure "expected two foreign parallel morphisms" + +assertSourceBucketsMatchEnumeration :: FinCat -> Assertion +assertSourceBucketsMatchEnumeration categoryValue = + traverse_ + ( \objectValue -> + assertEqual + "source-bucket query must be the source-filtered carrier enumeration" + (filter ((== finObjId objectValue) . finMorSourceId) (allMorphisms categoryValue)) + (allMorphismsFrom categoryValue objectValue) + ) + (allObjects categoryValue) + +explicitSourceBucketsMatchEnumeration :: Assertion +explicitSourceBucketsMatchEnumeration = + withResult (parallelCategory [parallelFId, parallelGId, parallelGPrimeId, parallelHId]) assertSourceBucketsMatchEnumeration + +thinSourceBucketsMatchEnumeration :: Assertion +thinSourceBucketsMatchEnumeration = + assertSourceBucketsMatchEnumeration sampleFinCat + +linearFinPresentation :: Int -> Either FinCatBuildError FinCat +linearFinPresentation objectCount = + finCategory $ do + declaredObjects <- objects (fmap (\index -> "x" <> show index) [0 .. objectCount - 1]) + traverse_ (uncurry below) (zip declaredObjects (drop 1 declaredObjects)) + +denseEndpointLookupMatchesMorphismConstruction :: Assertion +denseEndpointLookupMatchesMorphismConstruction = + withResult (linearFinPresentation 4) $ \categoryValue -> + case hom categoryValue (objectId 0) (objectId 3) of + Nothing -> assertFailure "expected dense endpoint morphism from 0 to 3" + Just morphism -> do + assertEqual "dense endpoint lookup returns a morphism with source 0" (objectId 0) (dom morphism) + assertEqual "dense endpoint lookup returns a morphism with target 3" (objectId 3) (cod morphism) + +residentSourceAndTargetCountsAgreeWithFolds :: Assertion +residentSourceAndTargetCountsAgreeWithFolds = + withResult (linearFinPresentation 5) $ \categoryValue -> do + withResult (mkFinObject categoryValue (objectId 0)) $ \sourceObject -> + assertEqual + "resident source count agrees with the derived source enumeration" + (length (allMorphismsFrom categoryValue sourceObject)) + (finCatMorphismCountFrom categoryValue (objectId 0)) + assertEqual + "resident source count agrees with the resident source fold" + (getSum (foldMapFinMorphismsFrom (const (Sum (1 :: Int))) categoryValue (objectId 0))) + (finCatMorphismCountFrom categoryValue (objectId 0)) + assertEqual + "resident target count agrees with source-filtered full enumeration" + (length (filter ((== objectId 4) . finMorTargetId) (allMorphisms categoryValue))) + (finCatMorphismCountTo categoryValue (objectId 4)) + assertEqual + "resident target count agrees with the resident target fold" + (getSum (foldMapFinMorphismsTo (const (Sum (1 :: Int))) categoryValue (objectId 4))) + (finCatMorphismCountTo categoryValue (objectId 4)) + +denseThinCompositionIsEndpointComposition :: Assertion +denseThinCompositionIsEndpointComposition = + withResult (linearFinPresentation 4) $ \categoryValue -> + case + ( hom categoryValue (objectId 1) (objectId 3), + hom categoryValue (objectId 0) (objectId 1), + hom categoryValue (objectId 0) (objectId 3) + ) of + (Just leftMorphism, Just rightMorphism, Just expectedMorphism) -> + withResult (composeIn categoryValue leftMorphism rightMorphism) $ \composedMorphism -> + assertEqual "dense thin composition is endpoint composition" (finMorId expectedMorphism) (finMorId composedMorphism) + _ -> assertFailure "expected dense endpoint morphisms for 1->3, 0->1, and 0->3" + +mkFinCatThinTotalOrderComposesByEndpoint :: Assertion +mkFinCatThinTotalOrderComposesByEndpoint = + withResult (thinChainCategory 4) $ \categoryValue -> + case + ( hom categoryValue (objectId 1) (objectId 3), + hom categoryValue (objectId 0) (objectId 1), + hom categoryValue (objectId 0) (objectId 3) + ) of + (Just leftMorphism, Just rightMorphism, Just expectedMorphism) -> + withResult (composeIn categoryValue leftMorphism rightMorphism) $ \composedMorphism -> + assertEqual "checked thin total order composes by endpoint" (finMorId expectedMorphism) (finMorId composedMorphism) + _ -> assertFailure "expected checked thin endpoint morphisms for 1->3, 0->1, and 0->3" + +mkFinCatPairGroupoidComposesInversesToIdentities :: Assertion +mkFinCatPairGroupoidComposesInversesToIdentities = + withResult (pairGroupoidCategory 3) $ \categoryValue -> + case + ( hom categoryValue (objectId 0) (objectId 1), + hom categoryValue (objectId 1) (objectId 0) + ) of + (Just forward, Just backward) -> do + withResult (composeIn categoryValue backward forward) $ \leftIdentity -> + assertEqual "backward after forward is the source identity" (identityMorphismId 0) (finMorId leftIdentity) + withResult (composeIn categoryValue forward backward) $ \rightIdentity -> + assertEqual "forward after backward is the target identity" (identityMorphismId 1) (finMorId rightIdentity) + _ -> assertFailure "expected inverse endpoint morphisms between 0 and 1" + +thinShapeMissingCompositionIsRejected :: Assertion +thinShapeMissingCompositionIsRejected = + let component = snd (buildThinChainComponent 0 100 3) + in case Map.toAscList (cdComposition component) of + [] -> assertFailure "expected a thin-chain composition entry" + (((leftMorphism, rightMorphism), _) : _) -> + case mkFinCat (cdObjects component) (cdMorphisms component) (Map.delete (leftMorphism, rightMorphism) (cdComposition component)) of + Left failures -> + assertBool + "checked thin validation reports the missing composite" + (MissingCompositionForPair leftMorphism rightMorphism `elem` failures) + Right _ -> assertFailure "expected missing thin composition to be rejected" + +thinShapeWrongEndpointCompositionIsRejected :: Assertion +thinShapeWrongEndpointCompositionIsRejected = + let component = snd (buildThinChainComponent 0 100 3) + maybeWrongResult = + case Map.lookup (objectId 0, objectId 1) (cdMorphisms component) of + Just [morphismId] -> Just morphismId + _ -> Nothing + in case (Map.toAscList (cdComposition component), maybeWrongResult) of + (((leftMorphism, rightMorphism), _) : _, Just wrongResult) -> + case mkFinCat (cdObjects component) (cdMorphisms component) (Map.insert (leftMorphism, rightMorphism) wrongResult (cdComposition component)) of + Left failures -> + assertBool + "basic composition validation reports the wrong result endpoint" + (CompositionResultEndpointMismatch leftMorphism rightMorphism wrongResult `elem` failures) + Right _ -> assertFailure "expected wrong-endpoint thin composition to be rejected" + _ -> assertFailure "expected a thin-chain composition entry and wrong-result morphism" + +tests :: TestTree +tests = + testGroup + "Invertibility" + [ testCase "FinCat canonicalizes hom-bucket order into category identity" canonicalHomBucketOrderIsIdentityInvariant, + testCase "FinCat treats valid explicit empty buckets as presentation noise" explicitEmptyBucketIsPresentationNoise, + testCase "FinCat rejects invalid empty bucket endpoints" invalidEmptyBucketEndpointIsRejected, + testCase "FinCat rejects identity-keyed composition table entries" identityCompositionTableKeysAreRejected, + testCase "FinCat vertical composition rejects non-shared middle 1-cells" verticalCompositionRejectsNonSharedMiddleEdge, + testCase "FinCat vertical composition accepts exact shared middle 1-cells" verticalCompositionAcceptsSharedMiddleEdge, + testCase "FinCat vertical composition rejects wrong-category boundaries before gluing" wrongCategoryTwoCellBoundaryIsRejectedBeforeVerticalGluing, + testCase "FinCat explicit source buckets agree with carrier enumeration" explicitSourceBucketsMatchEnumeration, + testCase "FinCat thin source buckets agree with carrier enumeration" thinSourceBucketsMatchEnumeration, + testCase "FinCat dense endpoint lookup agrees with morphism construction" denseEndpointLookupMatchesMorphismConstruction, + testCase "FinCat dense resident incident counts agree with folds" residentSourceAndTargetCountsAgreeWithFolds, + testCase "FinCat dense thin composition is endpoint composition" denseThinCompositionIsEndpointComposition, + testCase "mkFinCat checked thin total order composes by endpoint" mkFinCatThinTotalOrderComposesByEndpoint, + testCase "mkFinCat checked pair groupoid composes inverses to identities" mkFinCatPairGroupoidComposesInversesToIdentities, + testCase "mkFinCat checked thin validation rejects missing composition" thinShapeMissingCompositionIsRejected, + testCase "mkFinCat checked thin validation rejects wrong endpoint composition" thinShapeWrongEndpointCompositionIsRejected, + testCase "core groupoid from index matches direct core groupoid" $ + let indexValue = invertibilityIndex isomorphicPairCategory + indexedGroupoid = coreGroupoidFromIndex isomorphicPairCategory indexValue + directGroupoid = coreGroupoid isomorphicPairCategory + in assertEqual + "indexed and direct core groupoid morphisms should agree" + (coreGroupoidMorphisms directGroupoid) + (coreGroupoidMorphisms indexedGroupoid), + testCase "core groupoid carries the whole invertible surface" $ + let groupoidValue = coreGroupoid isomorphicPairCategory + bucketedMorphisms = + coreGroupoidObjects groupoidValue + >>= (\sourceObject -> + coreGroupoidObjects groupoidValue + >>= (\targetObject -> + coreGroupoidMorphismsBetween groupoidValue sourceObject targetObject + ) + ) + in assertEqual + "core groupoid morphisms should agree with their endpoint decomposition" + (coreGroupoidMorphisms groupoidValue) + bucketedMorphisms, + testCase "automorphism groupoid from index matches direct automorphism groupoid" $ + let indexValue = invertibilityIndex sampleFinCat + indexedGroupoid = automorphismGroupoidFromIndex sampleFinCat indexValue + directGroupoid = automorphismGroupoid sampleFinCat + in assertEqual + "indexed and direct automorphism groupoid objects should agree" + (automorphismGroupoidObjects directGroupoid) + (automorphismGroupoidObjects indexedGroupoid), + testCase "core groupoid endpoint query isolates the directed isomorphism bucket" $ + case coreGroupoidObjects (coreGroupoid isomorphicPairCategory) of + sourceObject : targetObject : _ -> + let groupoidValue = coreGroupoid isomorphicPairCategory + in assertEqual + "expected exactly one forward invertible morphism in the core groupoid" + 1 + (length (coreGroupoidMorphismsBetween groupoidValue sourceObject targetObject)) + _ -> assertBool "expected two objects in isomorphic pair category" False, + testCase "automorphism groupoid isolates object-local invertibles" $ + case automorphismGroupoidObjects (automorphismGroupoid sampleFinCat) of + baseObject : _ -> + let automorphismGroupoidValue = automorphismGroupoid sampleFinCat + in assertEqual + "expected exactly one object-local automorphism in the automorphism groupoid" + 1 + (length (fmap forgetAutomorphismGroupoidMorphism (automorphismGroupAt automorphismGroupoidValue baseObject))) + [] -> assertBool "expected sample category to have at least one object" False, + QC.testProperty "core groupoid contains identities for generated finite categories" $ + QC.withNumTests 100 coreGroupoidIdentityClosureHolds, + QC.testProperty "core groupoid is closed under composition for generated finite categories" $ + QC.withNumTests 100 coreGroupoidCompositionClosureHolds, + QC.testProperty "core groupoid composition is associative for generated finite categories" $ + QC.withNumTests 100 coreGroupoidAssociativityHolds + ] diff --git a/test/finite/Main.hs b/test/finite/Main.hs new file mode 100644 --- /dev/null +++ b/test/finite/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified FiniteTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain FiniteTests.tests diff --git a/test/indexed/IndexedSpec.hs b/test/indexed/IndexedSpec.hs new file mode 100644 --- /dev/null +++ b/test/indexed/IndexedSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TypeApplications #-} + +module IndexedSpec + ( tests, + ) +where + +import qualified Moonlight.Category.Indexed as Indexed +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +tests :: TestTree +tests = + testGroup + "indexed-category" + [ testCase "identity functor maps typed arrows" $ do + let mapped = Indexed.Id @(->) Indexed.% ((+ 1) :: Int -> Int) + mapped 1 @?= 2, + testCase "identity natural transformation exposes typed components" $ do + let naturalIdentity = Indexed.natId (Indexed.Id @(->)) + component = naturalIdentity Indexed.! (id :: Int -> Int) + component 7 @?= 7, + testCase "identity adjunction derives a typed unit" $ do + let unit = Indexed.adjunctionUnit (Indexed.idAdj @(->)) + component = unit Indexed.! (id :: Int -> Int) + component 11 @?= 11 + ] diff --git a/test/indexed/IndexedTests.hs b/test/indexed/IndexedTests.hs new file mode 100644 --- /dev/null +++ b/test/indexed/IndexedTests.hs @@ -0,0 +1,16 @@ +module IndexedTests + ( tests, + ) +where + +import qualified IndexedSpec +import qualified SimplexSpec +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "indexed" + [ IndexedSpec.tests, + SimplexSpec.tests + ] diff --git a/test/indexed/Main.hs b/test/indexed/Main.hs new file mode 100644 --- /dev/null +++ b/test/indexed/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified IndexedTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain IndexedTests.tests diff --git a/test/indexed/SimplexSpec.hs b/test/indexed/SimplexSpec.hs new file mode 100644 --- /dev/null +++ b/test/indexed/SimplexSpec.hs @@ -0,0 +1,142 @@ +module SimplexSpec + ( tests, + ) +where + +import Prelude hiding ((.)) + +import qualified Moonlight.Category.Indexed as Indexed +import Moonlight.Category.Indexed (Category ((.), src, tgt)) +import Moonlight.Category.Test.IndexedSimplexFixture + ( One, + Three, + Two, + Zero, + codegeneracy0At0, + codegeneracy0At1, + codegeneracy0At2, + codegeneracy1At1, + codegeneracy1At2, + codegeneracy2At2, + coface0At0, + coface0At1, + coface0At2, + coface1At0, + coface1At1, + coface1At2, + coface2At1, + coface2At2, + coface3At2, + one, + two, + zero, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +three :: Indexed.Simplex Three Three +three = Indexed.simplexSucc two + +firstVertex01 :: Indexed.Simplex Zero One +firstVertex01 = Indexed.cofaceLast zero + +lastVertex01 :: Indexed.Simplex Zero One +lastVertex01 = Indexed.cofaceFirst zero + +collapse10 :: Indexed.Simplex One Zero +collapse10 = Indexed.codegeneracyFirst zero + +lastFace12 :: Indexed.Simplex One Two +lastFace12 = Indexed.cofaceFirst one + +collapse20 :: Indexed.Simplex Two Zero +collapse20 = Indexed.simplexCollapse two + +standardZero :: Indexed.StandardSimplex Zero +standardZero = Indexed.Hom_X zero + +standardZeroIdentity :: Indexed.SSet (Indexed.StandardSimplex Zero) (Indexed.StandardSimplex Zero) +standardZeroIdentity = Indexed.natId standardZero + +tests :: TestTree +tests = + testGroup + "Indexed Simplex" + [ testCase "src and tgt return object identities" $ do + src lastVertex01 @?= zero + tgt lastVertex01 @?= one + src collapse10 @?= one + tgt collapse10 @?= zero, + testCase "identity laws hold for concrete simplex arrows" $ do + lastVertex01 . src lastVertex01 @?= lastVertex01 + tgt lastVertex01 . lastVertex01 @?= lastVertex01 + collapse10 . src collapse10 @?= collapse10 + tgt collapse10 . collapse10 @?= collapse10, + testCase "composition is associative on concrete simplex arrows" $ do + (collapse10 . lastVertex01) . zero @?= collapse10 . (lastVertex01 . zero) + (collapse20 . lastFace12) . firstVertex01 @?= collapse20 . (lastFace12 . firstVertex01), + testCase "forgetful functor maps arrows to finite-ordinal functions" $ do + let firstVertexMap = Indexed.ForgetSimplex Indexed.% firstVertex01 + lastVertexMap = Indexed.ForgetSimplex Indexed.% lastVertex01 + collapseMap = Indexed.ForgetSimplex Indexed.% collapse10 + firstVertexMap Indexed.Fz @?= Indexed.Fz + lastVertexMap Indexed.Fz @?= Indexed.Fs Indexed.Fz + collapseMap Indexed.Fz @?= Indexed.Fz + collapseMap (Indexed.Fs Indexed.Fz) @?= Indexed.Fz, + testCase "simplexValues decodes monotone maps" $ do + Indexed.simplexValues zero @?= [0] + Indexed.simplexValues one @?= [0, 1] + Indexed.simplexValues two @?= [0, 1, 2] + Indexed.simplexValues three @?= [0, 1, 2, 3] + Indexed.simplexValues firstVertex01 @?= [0] + Indexed.simplexValues lastVertex01 @?= [1] + Indexed.simplexValues collapse10 @?= [0, 0] + Indexed.simplexValues lastFace12 @?= [1, 2], + testCase "coface constructors decode to classical skipped-index maps" $ do + Indexed.simplexValues coface0At0 @?= [1] + Indexed.simplexValues coface1At0 @?= [0] + Indexed.simplexValues coface0At1 @?= [1, 2] + Indexed.simplexValues coface1At1 @?= [0, 2] + Indexed.simplexValues coface2At1 @?= [0, 1] + Indexed.simplexValues coface0At2 @?= [1, 2, 3] + Indexed.simplexValues coface1At2 @?= [0, 2, 3] + Indexed.simplexValues coface2At2 @?= [0, 1, 3] + Indexed.simplexValues coface3At2 @?= [0, 1, 2], + testCase "codegeneracy constructors decode to classical repeated-index maps" $ do + Indexed.simplexValues codegeneracy0At0 @?= [0, 0] + Indexed.simplexValues codegeneracy0At1 @?= [0, 0, 1] + Indexed.simplexValues codegeneracy1At1 @?= [0, 1, 1] + Indexed.simplexValues codegeneracy0At2 @?= [0, 0, 1, 2] + Indexed.simplexValues codegeneracy1At2 @?= [0, 1, 1, 2] + Indexed.simplexValues codegeneracy2At2 @?= [0, 1, 2, 2], + testCase "coface/coface cosimplicial identity holds concretely" $ do + coface1At1 . coface0At0 @?= coface0At1 . coface0At0 + coface2At1 . coface0At0 @?= coface0At1 . coface1At0 + coface2At1 . coface1At0 @?= coface1At1 . coface1At0, + testCase "codegeneracy/codegeneracy cosimplicial identity holds concretely" $ do + codegeneracy0At0 . codegeneracy0At1 @?= codegeneracy0At0 . codegeneracy1At1 + codegeneracy0At1 . codegeneracy0At2 @?= codegeneracy0At1 . codegeneracy1At2 + codegeneracy1At1 . codegeneracy0At2 @?= codegeneracy0At1 . codegeneracy2At2 + codegeneracy1At1 . codegeneracy1At2 @?= codegeneracy1At1 . codegeneracy2At2, + testCase "mixed left cosimplicial identity holds concretely" $ do + codegeneracy1At1 . coface0At1 @?= coface0At0 . codegeneracy0At0 + codegeneracy2At2 . coface0At2 @?= coface0At1 . codegeneracy1At1 + codegeneracy2At2 . coface1At2 @?= coface1At1 . codegeneracy1At1, + testCase "mixed identity cosimplicial cases hold concretely" $ do + codegeneracy0At0 . coface0At0 @?= zero + codegeneracy0At0 . coface1At0 @?= zero + codegeneracy0At1 . coface0At1 @?= one + codegeneracy0At1 . coface1At1 @?= one + codegeneracy1At1 . coface1At1 @?= one + codegeneracy1At1 . coface2At1 @?= one, + testCase "mixed right cosimplicial identity holds concretely" $ do + codegeneracy0At1 . coface2At1 @?= coface1At0 . codegeneracy0At0 + codegeneracy0At2 . coface2At2 @?= coface1At1 . codegeneracy0At1 + codegeneracy0At2 . coface3At2 @?= coface2At1 . codegeneracy0At1 + codegeneracy1At2 . coface3At2 @?= coface2At1 . codegeneracy1At1, + testCase "domain extension preserves the lower endpoint" $ do + Indexed.simplexExtendDomain lastVertex01 @?= one, + testCase "representable standard simplex inhabits SSet" $ do + let component = standardZeroIdentity Indexed.! Indexed.Op zero + component zero @?= zero + ] diff --git a/test/laws/Main.hs b/test/laws/Main.hs new file mode 100644 --- /dev/null +++ b/test/laws/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified Moonlight.Category.Effect.Laws as Laws +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain Laws.tests diff --git a/test/simplicial/CategoricalSimplexSpec.hs b/test/simplicial/CategoricalSimplexSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/CategoricalSimplexSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module CategoricalSimplexSpec + ( tests, + ) +where + +import Data.Kind (Type) +import GHC.TypeNats (KnownNat) +import qualified Moonlight.Category.Indexed as Indexed +import Moonlight.Category.Indexed (Category ((.))) +import Moonlight.Category.Simplicial + ( Coface (..), + Codegeneracy (..), + DeltaMorphism, + Dimension (..), + categoricalSimplexToDeltaMorphism, + cofaceMorphism, + codegeneracyMorphism, + composeDeltaMorphism, + mkFinOffset, + ) +import Moonlight.Category.Test.IndexedSimplexFixture + ( codegeneracy0At0, + codegeneracy0At1, + codegeneracy0At2, + codegeneracy1At1, + codegeneracy1At2, + codegeneracy2At2, + coface0At0, + coface0At1, + coface0At2, + coface1At0, + coface1At1, + coface1At2, + coface2At1, + coface2At2, + coface3At2, + ) +import Numeric.Natural (Natural) +import Prelude hiding ((.)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +operationalCoface :: forall n. KnownNat n => Dimension n -> Natural -> Maybe DeltaMorphism +operationalCoface dimension indexValue = + cofaceMorphism . CofaceMap <$> mkFinOffset @n @2 dimension indexValue + +operationalCodegeneracy :: forall n. KnownNat n => Dimension n -> Natural -> Maybe DeltaMorphism +operationalCodegeneracy dimension indexValue = + codegeneracyMorphism . CodegeneracyMap <$> mkFinOffset @n @1 dimension indexValue + +assertLowering :: String -> Maybe DeltaMorphism -> DeltaMorphism -> IO () +assertLowering label expected actual = + case expected of + Nothing -> assertFailure ("expected operational generator for " <> label) + Just expectedMorphism -> actual @?= expectedMorphism + +assertLoweredComposition :: + Indexed.Simplex (b :: Type) (c :: Type) -> + Indexed.Simplex (a :: Type) b -> + IO () +assertLoweredComposition outer inner = + composeDeltaMorphism + (categoricalSimplexToDeltaMorphism outer) + (categoricalSimplexToDeltaMorphism inner) + @?= Just (categoricalSimplexToDeltaMorphism (outer . inner)) + +tests :: TestTree +tests = + testGroup + "CategoricalSimplex" + [ testCase "categorical cofaces lower to operational cofaces for dimensions 0, 1, and 2" $ do + assertLowering "δ0[0]" (operationalCoface (Dimension @0) 0) (categoricalSimplexToDeltaMorphism coface0At0) + assertLowering "δ1[0]" (operationalCoface (Dimension @0) 1) (categoricalSimplexToDeltaMorphism coface1At0) + assertLowering "δ0[1]" (operationalCoface (Dimension @1) 0) (categoricalSimplexToDeltaMorphism coface0At1) + assertLowering "δ1[1]" (operationalCoface (Dimension @1) 1) (categoricalSimplexToDeltaMorphism coface1At1) + assertLowering "δ2[1]" (operationalCoface (Dimension @1) 2) (categoricalSimplexToDeltaMorphism coface2At1) + assertLowering "δ0[2]" (operationalCoface (Dimension @2) 0) (categoricalSimplexToDeltaMorphism coface0At2) + assertLowering "δ1[2]" (operationalCoface (Dimension @2) 1) (categoricalSimplexToDeltaMorphism coface1At2) + assertLowering "δ2[2]" (operationalCoface (Dimension @2) 2) (categoricalSimplexToDeltaMorphism coface2At2) + assertLowering "δ3[2]" (operationalCoface (Dimension @2) 3) (categoricalSimplexToDeltaMorphism coface3At2), + testCase "categorical codegeneracies lower to operational codegeneracies for dimensions 0, 1, and 2" $ do + assertLowering "σ0[0]" (operationalCodegeneracy (Dimension @0) 0) (categoricalSimplexToDeltaMorphism codegeneracy0At0) + assertLowering "σ0[1]" (operationalCodegeneracy (Dimension @1) 0) (categoricalSimplexToDeltaMorphism codegeneracy0At1) + assertLowering "σ1[1]" (operationalCodegeneracy (Dimension @1) 1) (categoricalSimplexToDeltaMorphism codegeneracy1At1) + assertLowering "σ0[2]" (operationalCodegeneracy (Dimension @2) 0) (categoricalSimplexToDeltaMorphism codegeneracy0At2) + assertLowering "σ1[2]" (operationalCodegeneracy (Dimension @2) 1) (categoricalSimplexToDeltaMorphism codegeneracy1At2) + assertLowering "σ2[2]" (operationalCodegeneracy (Dimension @2) 2) (categoricalSimplexToDeltaMorphism codegeneracy2At2), + testCase "lowering preserves representative categorical composition" $ do + assertLoweredComposition coface1At1 coface0At0 + assertLoweredComposition codegeneracy0At1 coface2At1 + assertLoweredComposition codegeneracy0At0 codegeneracy1At1 + ] diff --git a/test/simplicial/DeltaSpec.hs b/test/simplicial/DeltaSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/DeltaSpec.hs @@ -0,0 +1,168 @@ + +module DeltaSpec + ( tests, + ) +where + +import Data.List (sort) +import Data.Function ((&)) +import GHC.TypeNats (KnownNat) +import Numeric.Natural (Natural) +import Moonlight.Category.Simplicial + ( Coface (..), + Codegeneracy (..), + DeltaMorphism, + allDeltaMorphisms, + cofaceMorphism, + codegeneracyMorphism, + composeDeltaMorphism, + deltaIdentity, + deltaDomainDimension, + deltaCodomainDimension, + deltaMapValues, + denormalizeDeltaNormalForm, + deltaMorphismEqual, + injectionMissingIndices, + mkDeltaMorphism, + normalizeDeltaMorphism, + surjectionDegeneracyIndices, + ) +import Moonlight.Category.Simplicial (Dimension (..), mkFinOffset) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import qualified Test.Tasty.QuickCheck as QC + +genDeltaMorphism :: QC.Gen DeltaMorphism +genDeltaMorphism = do + domainDimension <- QC.chooseInt (0, 4) + codomainDimension <- QC.chooseInt (0, 4) + sampledRow <- QC.vectorOf (domainDimension + 1) (QC.chooseInt (0, codomainDimension)) + let monotoneRow = sampledRow & sort & map fromIntegral + case mkDeltaMorphism (fromIntegral domainDimension) (fromIntegral codomainDimension) monotoneRow of + Nothing -> genDeltaMorphism + Just morphism -> pure morphism + +genComposableTriple :: QC.Gen (DeltaMorphism, DeltaMorphism, DeltaMorphism) +genComposableTriple = do + nValue <- QC.chooseInt (0, 3) + mValue <- QC.chooseInt (0, 3) + kValue <- QC.chooseInt (0, 3) + lValue <- QC.chooseInt (0, 3) + case (allDeltaMorphisms (fromIntegral nValue) (fromIntegral mValue), allDeltaMorphisms (fromIntegral mValue) (fromIntegral kValue), allDeltaMorphisms (fromIntegral kValue) (fromIntegral lValue)) of + ([], _, _) -> genComposableTriple + (_, [], _) -> genComposableTriple + (_, _, []) -> genComposableTriple + (fCandidates, gCandidates, hCandidates) -> do + fMorphism <- QC.elements fCandidates + gMorphism <- QC.elements gCandidates + hMorphism <- QC.elements hCandidates + pure (hMorphism, gMorphism, fMorphism) + +identityLawHolds :: DeltaMorphism -> Bool +identityLawHolds morphism = + composeDeltaMorphism (deltaIdentity (deltaCodomainDimension morphism)) morphism == Just morphism + && composeDeltaMorphism morphism (deltaIdentity (deltaDomainDimension morphism)) == Just morphism + +associativityLawHolds :: (DeltaMorphism, DeltaMorphism, DeltaMorphism) -> Bool +associativityLawHolds (outer, middle, inner) = + let leftComposed = composeDeltaMorphism outer =<< composeDeltaMorphism middle inner + rightComposed = (\composed -> composeDeltaMorphism composed inner) =<< composeDeltaMorphism outer middle + in case (leftComposed, rightComposed) of + (Just leftValue, Just rightValue) -> deltaMorphismEqual leftValue rightValue + (Nothing, Nothing) -> True + _ -> False + +normalizationRoundtripHolds :: DeltaMorphism -> Bool +normalizationRoundtripHolds morphism = + case normalizeDeltaMorphism morphism >>= denormalizeDeltaNormalForm of + Nothing -> False + Just reconstructed -> deltaMorphismEqual morphism reconstructed + + +cofaceAt :: forall n. KnownNat n => Dimension n -> Natural -> Maybe DeltaMorphism +cofaceAt _ faceIndex = + cofaceMorphism . CofaceMap <$> mkFinOffset @n @2 (Dimension @n) faceIndex + +codegeneracyAt :: forall n. KnownNat n => Dimension n -> Natural -> Maybe DeltaMorphism +codegeneracyAt _ degeneracyIndex = + codegeneracyMorphism . CodegeneracyMap <$> mkFinOffset @n @1 (Dimension @n) degeneracyIndex + +composeMaybeDelta :: Maybe DeltaMorphism -> Maybe DeltaMorphism -> Maybe DeltaMorphism +composeMaybeDelta maybeOuter maybeInner = do + outer <- maybeOuter + inner <- maybeInner + composeDeltaMorphism outer inner + +assertDeltaCompositionEqual :: String -> Maybe DeltaMorphism -> Maybe DeltaMorphism -> IO () +assertDeltaCompositionEqual label left right = + assertEqual label left right + +cofaceExample :: Maybe DeltaMorphism +cofaceExample = + cofaceAt (Dimension @2) 1 + +codegeneracyExample :: Maybe DeltaMorphism +codegeneracyExample = + codegeneracyAt (Dimension @2) 1 + +tests :: TestTree +tests = + testGroup + "Delta" + [ testCase "coface generator maps into the next simplex dimension" $ + case cofaceExample of + Nothing -> assertBool "expected coface morphism" False + Just morphism -> do + assertEqual "coface domain" 2 (deltaDomainDimension morphism) + assertEqual "coface codomain" 3 (deltaCodomainDimension morphism) + assertEqual "coface map" [0, 2, 3] (deltaMapValues morphism), + testCase "codegeneracy generator collapses adjacent index" $ + case codegeneracyExample of + Nothing -> assertBool "expected codegeneracy morphism" False + Just morphism -> do + assertEqual "codegeneracy domain" 3 (deltaDomainDimension morphism) + assertEqual "codegeneracy codomain" 2 (deltaCodomainDimension morphism) + assertEqual "codegeneracy map" [0, 1, 1, 2] (deltaMapValues morphism), + testCase "coface generators satisfy the coface/coface identity" $ + assertDeltaCompositionEqual + "δ₂δ₀ = δ₀δ₁" + (composeMaybeDelta (cofaceAt (Dimension @2) 2) (cofaceAt (Dimension @1) 0)) + (composeMaybeDelta (cofaceAt (Dimension @2) 0) (cofaceAt (Dimension @1) 1)), + testCase "codegeneracy generators satisfy the codegeneracy/codegeneracy identity" $ + assertDeltaCompositionEqual + "σ₀σ₀ = σ₀σ₁" + (composeMaybeDelta (codegeneracyAt (Dimension @1) 0) (codegeneracyAt (Dimension @2) 0)) + (composeMaybeDelta (codegeneracyAt (Dimension @1) 0) (codegeneracyAt (Dimension @2) 1)), + testCase "mixed generators satisfy the left relation" $ + assertDeltaCompositionEqual + "σ₁δ₀ = δ₀σ₀" + (composeMaybeDelta (codegeneracyAt (Dimension @2) 1) (cofaceAt (Dimension @2) 0)) + (composeMaybeDelta (cofaceAt (Dimension @1) 0) (codegeneracyAt (Dimension @1) 0)), + testCase "mixed generators collapse matching adjacent faces to identity" $ do + assertDeltaCompositionEqual + "σ₁δ₁ = id" + (composeMaybeDelta (codegeneracyAt (Dimension @2) 1) (cofaceAt (Dimension @2) 1)) + (Just (deltaIdentity 2)) + assertDeltaCompositionEqual + "σ₁δ₂ = id" + (composeMaybeDelta (codegeneracyAt (Dimension @2) 1) (cofaceAt (Dimension @2) 2)) + (Just (deltaIdentity 2)), + testCase "mixed generators satisfy the right relation" $ + assertDeltaCompositionEqual + "σ₀δ₂ = δ₁σ₀" + (composeMaybeDelta (codegeneracyAt (Dimension @2) 0) (cofaceAt (Dimension @2) 2)) + (composeMaybeDelta (cofaceAt (Dimension @1) 1) (codegeneracyAt (Dimension @1) 0)), + testCase "mkDeltaMorphism rejects invalid length" $ + assertEqual "invalid length rejected" Nothing (mkDeltaMorphism 2 3 [0, 1]), + testCase "mkDeltaMorphism rejects out-of-bounds values" $ + assertEqual "out-of-bounds value rejected" Nothing (mkDeltaMorphism 2 1 [0, 1, 2]), + testCase "mkDeltaMorphism rejects non-monotone values" $ + assertEqual "non-monotone value rejected" Nothing (mkDeltaMorphism 2 3 [0, 2, 1]), + testCase "degeneracy indices retain run positions for arbitrary rows" $ + assertEqual "run positions" [0, 2] (surjectionDegeneracyIndices [0, 0, 1, 0, 0]), + testCase "injection complements ignore input order and duplicates" $ + assertEqual "missing indices" [0, 2, 4] (injectionMissingIndices 4 [3, 1, 1]), + QC.testProperty "identity law for Delta morphisms" (QC.withNumTests 400 (QC.forAll genDeltaMorphism identityLawHolds)), + QC.testProperty "associativity law for Delta morphism composition" (QC.withNumTests 400 (QC.forAll genComposableTriple associativityLawHolds)), + QC.testProperty "normalization roundtrip preserves Delta morphism" (QC.withNumTests 400 (QC.forAll genDeltaMorphism normalizationRoundtripHolds)) + ] diff --git a/test/simplicial/HomotopySpec.hs b/test/simplicial/HomotopySpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/HomotopySpec.hs @@ -0,0 +1,104 @@ +module HomotopySpec + ( tests, + ) +where + +import Data.Containers.ListUtils (nubOrd) +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category + ( FinCat, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + mkFinCat, + ) +import Moonlight.Category.Simplicial + ( automorphismGroupAt, + automorphismGroupoidOfNerve, + automorphismGroupoidObjects, + coreGroupoidObjects, + coreGroupoidMorphisms, + coreGroupoidMorphismsBetween, + coreGroupoidOfNerve, + forgetAutomorphismGroupoidMorphism, + forgetCoreGroupoidMorphism, + pi0Nerve, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +disconnectedCategory :: FinCat +disconnectedCategory = + case mkFinCat (Set.fromList [FinObjectId 0, FinObjectId 1]) Map.empty Map.empty of + Right categoryValue -> categoryValue + Left _ -> sampleFinCat + +generatorMorphismId :: Int -> FinMorphismId +generatorMorphismId = FinGeneratorMorphismId . FinGeneratorId + +identityMorphismId :: Int -> FinMorphismId +identityMorphismId = FinIdentityId . FinObjectId + +isomorphicPairCategory :: FinCat +isomorphicPairCategory = + case + mkFinCat + (Set.fromList [FinObjectId 0, FinObjectId 1]) + (Map.fromList [((FinObjectId 0, FinObjectId 1), [generatorMorphismId 10]), ((FinObjectId 1, FinObjectId 0), [generatorMorphismId 11])]) + (Map.fromList [((generatorMorphismId 11, generatorMorphismId 10), identityMorphismId 0), ((generatorMorphismId 10, generatorMorphismId 11), identityMorphismId 1)]) of + Right categoryValue -> categoryValue + Left _ -> sampleFinCat + +tests :: TestTree +tests = + testGroup + "Homotopy" + [ testCase "pi0 for sample category is connected" $ + assertEqual "sample pi0 components" 1 (length (pi0Nerve sampleFinCat)), + testCase "pi0 separates disconnected category" $ + assertEqual "disconnected pi0 components" 2 (length (pi0Nerve disconnectedCategory)), + testCase "invertible morphisms detect isomorphism pair" $ + let invertibles = + coreGroupoidMorphisms (coreGroupoidOfNerve isomorphicPairCategory) + & fmap forgetCoreGroupoidMorphism + in assertBool "expected at least two non-identity invertibles" (length invertibles >= 4), + testCase "invertible morphisms are unique" $ + let invertibles = + coreGroupoidMorphisms (coreGroupoidOfNerve isomorphicPairCategory) + & fmap forgetCoreGroupoidMorphism + in assertEqual "invertible morphisms should not repeat" invertibles (nubOrd invertibles), + testCase "core groupoid of nerve agrees with its endpoint decomposition" $ + let coreGroupoidValue = coreGroupoidOfNerve isomorphicPairCategory + bucketedMorphisms = + coreGroupoidObjects coreGroupoidValue + >>= (\sourceObject -> + coreGroupoidObjects coreGroupoidValue + >>= (\targetObject -> + coreGroupoidMorphismsBetween coreGroupoidValue sourceObject targetObject + ) + ) + in assertEqual + "core groupoid morphisms should be the union of endpoint buckets" + (coreGroupoidMorphisms coreGroupoidValue) + (nubOrd bucketedMorphisms), + testCase "core groupoid endpoint query isolates directed isomorphisms" $ + case coreGroupoidObjects (coreGroupoidOfNerve isomorphicPairCategory) of + sourceObject : targetObject : _ -> + let coreGroupoidValue = coreGroupoidOfNerve isomorphicPairCategory + forwardMorphisms = + coreGroupoidMorphismsBetween coreGroupoidValue sourceObject targetObject + in assertEqual "expected exactly one forward invertible generator" 1 (length forwardMorphisms) + _ -> assertBool "expected two objects in isomorphic pair category" False, + testCase "automorphism groupoid on sample category is identity loop" $ + case automorphismGroupoidObjects (automorphismGroupoidOfNerve sampleFinCat) of + [] -> assertBool "expected base object" False + baseObject : _ -> + let automorphismGroupoidValue = automorphismGroupoidOfNerve sampleFinCat + in assertEqual + "sample core automorphism size" + 1 + (length (fmap forgetAutomorphismGroupoidMorphism (automorphismGroupAt automorphismGroupoidValue baseObject))) + ] diff --git a/test/simplicial/KanSpec.hs b/test/simplicial/KanSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/KanSpec.hs @@ -0,0 +1,117 @@ +module KanSpec + ( tests, + ) +where + +import Data.List (genericSplitAt) +import Moonlight.Category.Simplicial + ( Horn, + HornError (..), + HornFrameError (..), + HornIndexError (..), + InnerHornError (..), + hornToIndexedHorn, + mkHorn, + mkHornFrame, + mkInnerHorn, + ) +import Numeric.Natural (Natural) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +removeAt :: Natural -> [a] -> Maybe [a] +removeAt targetIndex values = + case genericSplitAt targetIndex values of + (_, []) -> Nothing + (prefix, _ : suffix) -> Just (prefix <> suffix) + +listFaceAt :: Natural -> Natural -> [Natural] -> Maybe [Natural] +listFaceAt _ = removeAt + +undefinedFaceAt :: Natural -> Natural -> [Natural] -> Maybe [Natural] +undefinedFaceAt _ _ _ = Nothing + +listSimplexDimension :: [Natural] -> Natural +listSimplexDimension values = + case values of + [] -> 0 + _ : _ -> fromIntegral (length values - 1) + +validInnerHorn :: Either (HornError [Natural]) (Horn [Natural]) +validInnerHorn = + mkHorn listSimplexDimension listFaceAt 2 1 [(0, [5, 6]), (2, [7, 5])] + +validOuterHorn :: Either (HornError [Natural]) (Horn [Natural]) +validOuterHorn = + mkHorn listSimplexDimension listFaceAt 2 0 [(1, [0, 0]), (2, [0, 0])] + +tests :: TestTree +tests = + testGroup + "Kan" + [ testCase "mkHornFrame rejects dimension zero" $ + assertEqual + "dimension zero" + (Left HornDimensionZero) + (() <$ mkHornFrame 0 0 ([] :: [(Natural, ())])), + testCase "mkHornFrame rejects out-of-bounds missing face" $ + assertEqual + "missing face out of bounds" + (Left (HornMissingFaceOutOfBounds 2 3)) + (() <$ mkHornFrame 2 3 ([] :: [(Natural, ())])), + testCase "mkHornFrame rejects duplicate supplied faces" $ + assertEqual + "duplicate face" + (Left (HornDuplicateFace 0)) + (() <$ mkHornFrame 2 1 [(0, ()), (0, ()), (2, ())]), + testCase "mkHornFrame rejects unexpected face indices" $ + assertEqual + "unexpected face" + (Left (HornUnexpectedFace 2 3)) + (() <$ mkHornFrame 2 1 [(0, ()), (2, ()), (3, ())]), + testCase "mkHornFrame rejects the supplied missing face" $ + assertEqual + "supplied missing face" + (Left (HornSuppliedMissingFace 1)) + (() <$ mkHornFrame 2 1 [(0, ()), (1, ()), (2, ())]), + testCase "mkHornFrame reports missing required faces" $ + assertEqual + "missing required face" + (Left (HornMissingRequiredFaces [2])) + (() <$ mkHornFrame 2 1 [(0, ())]), + testCase "mkHorn rejects undefined overlaps" $ + assertEqual + "overlap undefined" + (Left (HornOverlapUndefined 0 2 Nothing Nothing)) + (() <$ mkHorn listSimplexDimension undefinedFaceAt 2 1 [(0, [0, 1]), (2, [1, 2])]), + testCase "mkHorn rejects mismatched overlaps" $ + assertEqual + "overlap mismatch" + (Left (HornOverlapMismatch 0 2 [2] [0])) + (() <$ mkHorn listSimplexDimension listFaceAt 2 1 [(0, [0, 1]), (2, [1, 2])]), + testCase "mkHorn rejects faces in the wrong dimension" $ + assertEqual + "face dimension mismatch" + (Left (HornFaceDimensionMismatch 0 1 2)) + (() <$ mkHorn listSimplexDimension listFaceAt 2 1 [(0, [0, 1, 2]), (2, [1, 2])]), + testCase "mkInnerHorn accepts compatible inner horns" $ + case validInnerHorn of + Left obstruction -> assertEqual "expected valid horn" Nothing (Just obstruction) + Right hornValue -> assertEqual "inner horn" True (either (const False) (const True) (mkInnerHorn hornValue)), + testCase "mkInnerHorn rejects outer horns" $ + case validOuterHorn of + Left obstruction -> assertEqual "expected valid outer horn" Nothing (Just obstruction) + Right hornValue -> + assertEqual + "outer horn rejected" + (Left (HornNotInner 2 0)) + (() <$ mkInnerHorn hornValue), + testCase "hornToIndexedHorn rejects dimension mismatch" $ + case validInnerHorn of + Left obstruction -> assertEqual "expected valid horn" Nothing (Just obstruction) + Right hornValue -> + assertEqual + "dimension mismatch" + (Left (HornIndexDimensionMismatch 3 2)) + (() <$ hornToIndexedHorn @2 hornValue) + ] diff --git a/test/simplicial/Laws/Registry.hs b/test/simplicial/Laws/Registry.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/Laws/Registry.hs @@ -0,0 +1,39 @@ +module Laws.Registry + ( carrierTestSuites, + lawfulCarrierSpecs, + ) +where + +import Moonlight.Pale.Test.Laws.Suite (LawSuite) +import Test.Tasty (TestTree) +import qualified CategoricalSimplexSpec +import qualified DeltaSpec +import qualified HomotopySpec +import qualified KanSpec +import qualified NerveSpec +import qualified OrdinalSpec +import qualified PresheafSpec +import qualified SpacesSpec + +additionalTestSuites :: [TestTree] +additionalTestSuites = + [ CategoricalSimplexSpec.tests, + DeltaSpec.tests, + OrdinalSpec.tests, + PresheafSpec.tests, + HomotopySpec.tests, + KanSpec.tests + ] + +carrierTestSuites :: [TestTree] +carrierTestSuites = + [ NerveSpec.carrierTests, + SpacesSpec.carrierTests + ] + <> additionalTestSuites + +lawfulCarrierSpecs :: [LawSuite] +lawfulCarrierSpecs = + [ NerveSpec.lawfulCarrierSpec, + SpacesSpec.lawfulCarrierSpec + ] diff --git a/test/simplicial/Laws/Suite.hs b/test/simplicial/Laws/Suite.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/Laws/Suite.hs @@ -0,0 +1,122 @@ +module Laws.Suite + ( LawSuiteConfig (..), + mkLawfulCarrierSpec, + simplicialLawSuite, + lawfulCarrierSuite, + ) +where + +import Data.Kind (Type) +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Pale.Test.Laws.Suite + ( LawSuite, + lawGroup, + quickCheckLaw, + renderLawSuite, + ) +import Moonlight.Category.Simplicial + ( SimplicialLawCheck, + SimplicialLawEquality, + SimplicialLawIndices (..), + SimplicialLawObstruction (..), + checkDegeneracyDegeneracyLawBy, + checkFaceDegeneracyLawBy, + checkFaceFaceLawBy, + checkSimplicialLawsBy, + lawObstructionKind, + ) +import Moonlight.Category.Simplicial (TruncatedNormalizedSSet) +import Test.Tasty (TestTree) +import qualified Test.Tasty.QuickCheck as QC + +type LawSuiteConfig :: Type -> Type -> Type +data LawSuiteConfig carrier simplex = LawSuiteConfig + { lawSuiteName :: String, + lawSuiteMaxSuccess :: Int, + lawSuiteCarrierToSSet :: carrier -> TruncatedNormalizedSSet simplex, + lawSuiteEquality :: SimplicialLawEquality simplex, + lawSuiteRenderSimplex :: simplex -> String + } + +mkLawfulCarrierSpec :: + (QC.Arbitrary carrier, Show carrier) => + String -> + LawSuiteConfig carrier simplex -> + LawSuite +mkLawfulCarrierSpec carrierName config = + lawGroup carrierName [simplicialLawSuite config] + +renderMaybeSimplex :: (simplex -> String) -> Maybe simplex -> String +renderMaybeSimplex renderSimplex maybeSimplex = + case maybeSimplex of + Nothing -> "Nothing" + Just simplexValue -> "Just " <> renderSimplex simplexValue + +renderIndices :: SimplicialLawIndices -> String +renderIndices indices = + case indices of + FaceFaceIndices leftFaceIndex rightFaceIndex -> + "leftFace=" <> show leftFaceIndex <> ", rightFace=" <> show rightFaceIndex + DegeneracyDegeneracyIndices leftDegeneracyIndex rightDegeneracyIndex -> + "leftDegeneracy=" <> show leftDegeneracyIndex <> ", rightDegeneracy=" <> show rightDegeneracyIndex + FaceDegeneracyIndices faceIndex degeneracyIndex -> + "face=" <> show faceIndex <> ", degeneracy=" <> show degeneracyIndex + +renderObstruction :: (simplex -> String) -> SimplicialLawObstruction simplex -> String +renderObstruction renderSimplex obstruction = + unlines + [ "law=" <> show (lawObstructionKind obstruction), + "dimension=" <> show (lawObstructionDimension obstruction), + "indices=" <> renderIndices (lawObstructionIndices obstruction), + "source=" <> renderSimplex (lawObstructionSimplex obstruction), + "left=" <> renderMaybeSimplex renderSimplex (lawObstructionLeftResult obstruction), + "right=" <> renderMaybeSimplex renderSimplex (lawObstructionRightResult obstruction) + ] + +renderCheckFailure :: (simplex -> String) -> NonEmpty.NonEmpty (SimplicialLawObstruction simplex) -> String +renderCheckFailure renderSimplex obstructions = + unlines + [ "simplicial law obstruction count=" <> show (length (NonEmpty.toList obstructions)), + "first obstruction:", + renderObstruction renderSimplex (NonEmpty.head obstructions) + ] + +lawCheckProperty :: + (simplex -> String) -> + SimplicialLawCheck simplex -> + QC.Property +lawCheckProperty renderSimplex lawCheck = + case lawCheck of + Right () -> QC.property True + Left obstructions -> QC.counterexample (renderCheckFailure renderSimplex obstructions) False + +simplicialLawSuite :: + (QC.Arbitrary carrier, Show carrier) => + LawSuiteConfig carrier simplex -> + LawSuite +simplicialLawSuite config = + let runLaw lawCheck carrierValue = + lawCheckProperty + (lawSuiteRenderSimplex config) + ( lawCheck + (lawSuiteEquality config) + (lawSuiteCarrierToSSet config carrierValue) + ) + lawProperty propertyName lawCheck = + quickCheckLaw + propertyName + (QC.withNumTests (lawSuiteMaxSuccess config) (runLaw lawCheck)) + bundledLaws :: [(String, SimplicialLawEquality simplex -> TruncatedNormalizedSSet simplex -> SimplicialLawCheck simplex)] + bundledLaws = + [ ("face-face: d_i d_j = d_{j-1} d_i (i < j)", checkFaceFaceLawBy), + ("degeneracy-degeneracy: s_i s_j = s_{j+1} s_i (i <= j)", checkDegeneracyDegeneracyLawBy), + ("mixed: d_i s_j cases", checkFaceDegeneracyLawBy), + ("all simplicial identities", checkSimplicialLawsBy) + ] + in lawGroup + (lawSuiteName config) + (map (uncurry lawProperty) bundledLaws) + +lawfulCarrierSuite :: [LawSuite] -> TestTree +lawfulCarrierSuite carrierSpecs = + renderLawSuite (lawGroup "lawful carriers" carrierSpecs) diff --git a/test/simplicial/Main.hs b/test/simplicial/Main.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified SimplicialTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain SimplicialTests.tests diff --git a/test/simplicial/NerveSpec.hs b/test/simplicial/NerveSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/NerveSpec.hs @@ -0,0 +1,225 @@ + +module NerveSpec + ( carrierTests, + lawfulCarrierSpec, + ) +where + +import Data.Kind (Type) +import Data.Function ((&)) +import Data.List (find) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Numeric.Natural (Natural) +import Moonlight.Category.Effect.Fixture.FinCat (sampleFinCat) +import Moonlight.Category + ( ComposableChain, + FinCat, + FinGeneratorId (..), + FinMorphismId (..), + FinObjectId (..), + allObjects, + chainMorphisms, + chainStartObject, + chainsOfDimension, + finMorId, + finObjId, + mkFinCat + ) +import Moonlight.Category.Simplicial + ( NerveSimplex, + applyFaceAtDimension, + fillNerveInnerHorn, + generatedSimplicesAtDimension, + mkHorn, + mkInnerHorn, + nerve, + nerveGenerated, + nerveSimplexChain, + nerveSimplexDimension, + nerveSimplexFromChain, + simplicesAtDimension, + ) +import Laws.Suite (LawSuiteConfig (..), mkLawfulCarrierSpec) +import Moonlight.Pale.Test.Laws.Suite (LawSuite) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import qualified Test.Tasty.QuickCheck as QC + +type GeneratedFiniteCategory :: Type +data GeneratedFiniteCategory = GeneratedFiniteCategory + { generatedCategory :: FinCat, + generatedTruncation :: Natural + } + +instance Show GeneratedFiniteCategory where + show generatedValue = + "GeneratedFiniteCategory(objects=" + <> show (length (allObjects (generatedCategory generatedValue))) + <> ", truncation=" + <> show (generatedTruncation generatedValue) + <> ")" + +instance QC.Arbitrary GeneratedFiniteCategory where + arbitrary = do + objectCount <- QC.chooseInt (1, 5) + let objectIds = [0 .. objectCount - 1] + candidatePairs = [(sourceId, targetId) | sourceId <- objectIds, targetId <- objectIds, sourceId < targetId] + pairFlags <- QC.vectorOf (length candidatePairs) QC.arbitrary + let chosenPairs = + zip candidatePairs pairFlags + & filter snd + & map fst + closurePairs = transitiveClosure (Set.fromList chosenPairs) + morphismMap = buildMorphismMap closurePairs + compositionMap = buildCompositionMap closurePairs + categoryValue = + case mkFinCat (Set.fromList (fmap objectId objectIds)) morphismMap compositionMap of + Right validCategory -> validCategory + Left _ -> sampleFinCat + truncationValue <- QC.chooseInt (2, 4) + pure + ( GeneratedFiniteCategory + { generatedCategory = categoryValue, + generatedTruncation = fromIntegral truncationValue + } + ) + +pairCode :: Int -> Int -> Int +pairCode sourceId targetId = sourceId * 1024 + targetId + +objectId :: Int -> FinObjectId +objectId = FinObjectId + +generatorMorphismId :: Int -> FinMorphismId +generatorMorphismId = FinGeneratorMorphismId . FinGeneratorId + +pairGenerator :: Int -> Int -> FinMorphismId +pairGenerator sourceId targetId = generatorMorphismId (pairCode sourceId targetId) + +transitiveClosure :: Set.Set (Int, Int) -> Set.Set (Int, Int) +transitiveClosure relation = + let composedPairs = + Set.toList relation + >>= (\(sourceId, middleId) -> Set.toList relation & filter (\(middleId', _) -> middleId == middleId') & map (\(_, targetId) -> (sourceId, targetId))) + & Set.fromList + nextRelation = Set.union relation composedPairs + in if nextRelation == relation + then relation + else transitiveClosure nextRelation + +buildMorphismMap :: Set.Set (Int, Int) -> Map.Map (FinObjectId, FinObjectId) [FinMorphismId] +buildMorphismMap relation = + Set.toAscList relation + & map (\(sourceId, targetId) -> ((objectId sourceId, objectId targetId), [pairGenerator sourceId targetId])) + & Map.fromList + +buildCompositionMap :: Set.Set (Int, Int) -> Map.Map (FinMorphismId, FinMorphismId) FinMorphismId +buildCompositionMap relation = + let relationList = Set.toAscList relation + compositionRows = + relationList + >>= ( \(sourceId, middleId) -> + relationList + & filter (\(middleId', _) -> middleId == middleId') + & map + (\(_, targetId) -> ((pairGenerator middleId targetId, pairGenerator sourceId middleId), pairGenerator sourceId targetId)) + ) + in Map.fromList compositionRows + +singleMorphismId :: ComposableChain FinCat -> Maybe FinMorphismId +singleMorphismId chainValue = + case chainMorphisms chainValue of + [morphism] -> Just (finMorId morphism) + _ -> Nothing + +lookupSingleMorphismChain :: FinMorphismId -> [ComposableChain FinCat] -> Maybe (ComposableChain FinCat) +lookupSingleMorphismChain morphismId chains = + find (\chainValue -> singleMorphismId chainValue == Just morphismId) chains + +simplexFingerprint :: NerveSimplex FinCat -> (Natural, FinObjectId, [FinMorphismId]) +simplexFingerprint simplexValue = + let chainValue = nerveSimplexChain simplexValue + in ( nerveSimplexDimension simplexValue, + finObjId (chainStartObject chainValue), + map finMorId (chainMorphisms chainValue) + ) + +sameSimplex :: Maybe (NerveSimplex FinCat) -> Maybe (NerveSimplex FinCat) -> Bool +sameSimplex leftSimplex rightSimplex = + case (leftSimplex, rightSimplex) of + (Nothing, Nothing) -> True + (Just leftValue, Just rightValue) -> simplexFingerprint leftValue == simplexFingerprint rightValue + _ -> False + +innerHornFillMatchesSimplex :: GeneratedFiniteCategory -> Bool +innerHornFillMatchesSimplex generatedValue = + let simplicialSet = nerve (generatedCategory generatedValue) (generatedTruncation generatedValue) + in and + [ case mkHorn nerveSimplexDimension (applyFaceAtDimension simplicialSet) simplexDimension missingFace faceEntries of + Left _ -> False + Right hornValue -> + case mkInnerHorn hornValue of + Left _ -> False + Right innerHornValue -> + sameSimplex + (fillNerveInnerHorn (generatedCategory generatedValue) innerHornValue) + (Just simplexValue) + | simplexDimension <- [2 .. generatedTruncation generatedValue], + simplexValue <- simplicesAtDimension simplicialSet simplexDimension, + missingFace <- [1 .. simplexDimension - 1], + let faceEntries = + [ (faceIndex, faceSimplex) + | faceIndex <- [0 .. simplexDimension], + faceIndex /= missingFace, + faceSimplex <- maybe [] pure (applyFaceAtDimension simplicialSet simplexDimension faceIndex simplexValue) + ], + fromIntegral (length faceEntries) == simplexDimension + ] + +lawfulCarrierSpec :: LawSuite +lawfulCarrierSpec = + mkLawfulCarrierSpec + "nerve" + LawSuiteConfig + { lawSuiteName = "nerve simplicial laws", + lawSuiteMaxSuccess = 300, + lawSuiteCarrierToSSet = \generatedValue -> nerve (generatedCategory generatedValue) (generatedTruncation generatedValue), + lawSuiteEquality = sameSimplex, + lawSuiteRenderSimplex = show . simplexFingerprint + } + +carrierTests :: TestTree +carrierTests = + testGroup + "Nerve" + [ testCase "generated and normalized carriers separate degenerate simplices" $ do + let generatedSet = nerveGenerated sampleFinCat 1 + simplicialSet = nerve sampleFinCat 1 + assertEqual "generated 0-simplices" 3 (length (generatedSimplicesAtDimension generatedSet 0)) + assertEqual "generated 1-simplices" 6 (length (generatedSimplicesAtDimension generatedSet 1)) + assertEqual "normalized 0-simplices" 3 (length (simplicesAtDimension simplicialSet 0)) + assertEqual "normalized 1-simplices" 3 (length (simplicesAtDimension simplicialSet 1)), + testCase "inner horn filler reconstructs a composable 2-simplex" $ do + let oneChains = chainsOfDimension sampleFinCat 1 + maybeFirst = lookupSingleMorphismChain (generatorMorphismId 10) oneChains + maybeSecond = lookupSingleMorphismChain (generatorMorphismId 11) oneChains + case (maybeFirst, maybeSecond) of + (Just firstChain, Just secondChain) -> + let simplicialSet = nerve sampleFinCat 2 + hornEntries = [(2, nerveSimplexFromChain firstChain), (0, nerveSimplexFromChain secondChain)] + in case mkHorn nerveSimplexDimension (applyFaceAtDimension simplicialSet) 2 1 hornEntries of + Left _ -> assertBool "expected a compatible inner horn" False + Right hornValue -> + case mkInnerHorn hornValue of + Left _ -> assertBool "expected an inner horn" False + Right innerHornValue -> + case fillNerveInnerHorn sampleFinCat innerHornValue of + Nothing -> assertBool "expected horn filler for nerve of sample category" False + Just simplexValue -> do + assertEqual "filled simplex dimension" 2 (nerveSimplexDimension simplexValue) + assertEqual "filled simplex chain length" 2 (length (chainMorphisms (nerveSimplexChain simplexValue))) + _ -> assertBool "expected generator chains in dimension 1" False, + QC.testProperty "inner horns reconstruct original simplex in generated nerves" $ + QC.withNumTests 200 innerHornFillMatchesSimplex + ] diff --git a/test/simplicial/OrdinalSpec.hs b/test/simplicial/OrdinalSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/OrdinalSpec.hs @@ -0,0 +1,130 @@ +module OrdinalSpec + ( tests, + ) +where + +import Data.Function ((&)) +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Moonlight.Category.Simplicial + ( SomeMonotone (..), + SomeNormalizedMonotone (..), + composeSomeMonotone, + denormalizeSomeNormalizedMonotone, + mkSomeMonotone, + monotoneCodomainDimension, + monotoneDomainDimension, + monotoneValues, + normalizeSomeMonotone, + normalizedInjectionValues, + normalizedSurjectionValues, + someMonotoneEqualByNormalForm, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import qualified Test.Tasty.QuickCheck as QC + +someMonotoneSignature :: SomeMonotone -> (Integer, Integer, [Integer]) +someMonotoneSignature (SomeMonotone _ _ monotone) = + ( fromIntegral (monotoneDomainDimension monotone), + fromIntegral (monotoneCodomainDimension monotone), + monotoneValues monotone & map fromIntegral + ) + +someMonotoneEqualByShape :: SomeMonotone -> SomeMonotone -> Bool +someMonotoneEqualByShape left right = + someMonotoneSignature left == someMonotoneSignature right + +genSomeMonotoneWithDimensions :: Integer -> Integer -> QC.Gen SomeMonotone +genSomeMonotoneWithDimensions domainDimension codomainDimension = do + sampledRow <- QC.vectorOf (fromIntegral domainDimension + 1) (QC.chooseInt (0, fromIntegral codomainDimension)) + let monotoneRow = sampledRow & sort & map fromIntegral + case mkSomeMonotone (fromIntegral domainDimension) (fromIntegral codomainDimension) monotoneRow of + Nothing -> genSomeMonotoneWithDimensions domainDimension codomainDimension + Just morphism -> pure morphism + +genSomeMonotone :: QC.Gen SomeMonotone +genSomeMonotone = do + domainDimension <- QC.chooseInteger (0, 4) + codomainDimension <- QC.chooseInteger (0, 4) + genSomeMonotoneWithDimensions domainDimension codomainDimension + +genComposableTriple :: QC.Gen (SomeMonotone, SomeMonotone, SomeMonotone) +genComposableTriple = do + sourceDimension <- QC.chooseInteger (0, 3) + middleLeftDimension <- QC.chooseInteger (0, 3) + middleRightDimension <- QC.chooseInteger (0, 3) + targetDimension <- QC.chooseInteger (0, 3) + inner <- genSomeMonotoneWithDimensions sourceDimension middleLeftDimension + middle <- genSomeMonotoneWithDimensions middleLeftDimension middleRightDimension + outer <- genSomeMonotoneWithDimensions middleRightDimension targetDimension + pure (outer, middle, inner) + +identitySomeMonotone :: Integer -> Maybe SomeMonotone +identitySomeMonotone dimensionValue = + mkSomeMonotone + (fromIntegral dimensionValue) + (fromIntegral dimensionValue) + [0 .. fromIntegral dimensionValue] + +identityLawHolds :: SomeMonotone -> Bool +identityLawHolds morphism = + case someMonotoneSignature morphism of + (domainDimension, codomainDimension, _) -> + case (identitySomeMonotone codomainDimension, identitySomeMonotone domainDimension) of + (Just leftIdentity, Just rightIdentity) -> + case (composeSomeMonotone leftIdentity morphism, composeSomeMonotone morphism rightIdentity) of + (Just leftComposed, Just rightComposed) -> + someMonotoneEqualByShape leftComposed morphism + && someMonotoneEqualByShape rightComposed morphism + _ -> False + _ -> False + +associativityLawHolds :: (SomeMonotone, SomeMonotone, SomeMonotone) -> Bool +associativityLawHolds (outer, middle, inner) = + let leftComposed = composeSomeMonotone outer =<< composeSomeMonotone middle inner + rightComposed = (`composeSomeMonotone` inner) =<< composeSomeMonotone outer middle + in case (leftComposed, rightComposed) of + (Just leftValue, Just rightValue) -> someMonotoneEqualByShape leftValue rightValue + (Nothing, Nothing) -> True + _ -> False + +normalizationRoundtripHolds :: SomeMonotone -> Bool +normalizationRoundtripHolds monotone = + case normalizeSomeMonotone monotone >>= denormalizeSomeNormalizedMonotone of + Nothing -> False + Just reconstructed -> + someMonotoneEqualByShape monotone reconstructed + && someMonotoneEqualByNormalForm monotone reconstructed + +normalizationCanonicalRanksHold :: SomeMonotone -> Bool +normalizationCanonicalRanksHold monotone@(SomeMonotone _ _ monotoneValue) = + case normalizeSomeMonotone monotone of + Nothing -> False + Just (SomeNormalizedMonotone _ _ normalized) -> + let imageValues = + monotoneValues monotoneValue + & Set.fromList + & Set.toAscList + imageRanks = Map.fromList (zip imageValues [0 ..]) + in normalizedInjectionValues normalized == imageValues + && traverse (`Map.lookup` imageRanks) (monotoneValues monotoneValue) + == Just (normalizedSurjectionValues normalized) + +tests :: TestTree +tests = + testGroup + "Ordinal" + [ testCase "normalization roundtrip for a coface-style morphism" $ + case mkSomeMonotone 2 3 [0, 2, 3] of + Nothing -> assertBool "expected valid monotone" False + Just monotone -> + case normalizeSomeMonotone monotone >>= denormalizeSomeNormalizedMonotone of + Nothing -> assertBool "expected normal form roundtrip" False + Just reconstructed -> assertEqual "roundtrip" (someMonotoneSignature monotone) (someMonotoneSignature reconstructed), + QC.testProperty "identity law for monotone ordinal maps" (QC.withNumTests 400 (QC.forAllBlind genSomeMonotone identityLawHolds)), + QC.testProperty "associativity for typed monotone composition" (QC.withNumTests 400 (QC.forAllBlind genComposableTriple associativityLawHolds)), + QC.testProperty "normalization roundtrip preserves monotone map" (QC.withNumTests 400 (QC.forAllBlind genSomeMonotone normalizationRoundtripHolds)), + QC.testProperty "normalization retains canonical image ranks" (QC.withNumTests 400 (QC.forAllBlind genSomeMonotone normalizationCanonicalRanksHold)) + ] diff --git a/test/simplicial/PresheafSpec.hs b/test/simplicial/PresheafSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/PresheafSpec.hs @@ -0,0 +1,49 @@ +module PresheafSpec + ( tests, + ) +where + +import Numeric.Natural (Natural) +import Moonlight.Category.Simplicial (allDeltaMorphisms) +import Moonlight.Category.Simplicial + ( presheafObjectMap, + generatedAsPresheaf, + presheafCompositionLaw, + presheafIdentityLaw, + ) +import Moonlight.Category.Simplicial (standardSimplexGenerated) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) + +identityLawsHoldForRange :: Natural -> Bool +identityLawsHoldForRange upperBound = + let generatedPresheaf = generatedAsPresheaf (standardSimplexGenerated 3 upperBound) + in and + [ presheafIdentityLaw generatedPresheaf dimensionValue + | dimensionValue <- [0 .. upperBound] + ] + +compositionLawsHoldForRange :: Natural -> Bool +compositionLawsHoldForRange upperBound = + let generatedPresheaf = generatedAsPresheaf (standardSimplexGenerated 3 upperBound) + compositionHoldsFor presheaf = + and + [ presheafCompositionLaw presheaf outer inner simplexValue + | innerDomain <- [0 .. upperBound], + innerCodomain <- [0 .. upperBound], + outerCodomain <- [0 .. upperBound], + inner <- allDeltaMorphisms innerDomain innerCodomain, + outer <- allDeltaMorphisms innerCodomain outerCodomain, + simplexValue <- presheafObjectMap presheaf outerCodomain + ] + in compositionHoldsFor generatedPresheaf + +tests :: TestTree +tests = + testGroup + "Presheaf" + [ testCase "generated presheaf satisfies identity" $ + assertBool "identity law failed" (identityLawsHoldForRange 3), + testCase "generated presheaf satisfies composition" $ + assertBool "composition law failed" (compositionLawsHoldForRange 3) + ] diff --git a/test/simplicial/SimplicialTests.hs b/test/simplicial/SimplicialTests.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/SimplicialTests.hs @@ -0,0 +1,16 @@ +module SimplicialTests + ( tests, + ) +where + +import qualified Laws.Registry as LawRegistry +import Laws.Suite (lawfulCarrierSuite) +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "simplicial" + ( LawRegistry.carrierTestSuites + <> [lawfulCarrierSuite LawRegistry.lawfulCarrierSpecs] + ) diff --git a/test/simplicial/SpacesSpec.hs b/test/simplicial/SpacesSpec.hs new file mode 100644 --- /dev/null +++ b/test/simplicial/SpacesSpec.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DerivingStrategies #-} + +module SpacesSpec + ( carrierTests, + lawfulCarrierSpec, + ) +where + +import Data.Kind (Type) +import Data.Foldable (traverse_) +import Data.List.NonEmpty qualified as NonEmpty +import Moonlight.Category.Simplicial + ( Dimension (..), + GeneratedSSetObstruction (..), + TruncatedNormalizedSSet, + boundarySimplex, + boundarySimplexGenerated, + checkSimplicialLaws, + generatedSimplicesAtDimension, + hornSimplex, + hornSimplexGenerated, + indexSimplexIn, + mkGeneratedSSet, + normalizeGeneratedSSet, + simplicialLawEq, + simplicesAtDimension, + standardSimplex, + standardSimplexGenerated, + unindexSimplex, + validateGeneratedSSet, + ) +import Laws.Suite (LawSuiteConfig (..), mkLawfulCarrierSpec) +import Moonlight.Pale.Test.Laws.Suite (LawSuite) +import Numeric.Natural (Natural) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase) +import qualified Test.Tasty.QuickCheck as QC + +type GeneratedStandardSimplex :: Type +data GeneratedStandardSimplex = GeneratedStandardSimplex + { generatedSimplexDimension :: Natural, + generatedTruncationBound :: Natural + } + deriving stock (Eq, Show) + +instance QC.Arbitrary GeneratedStandardSimplex where + arbitrary = do + simplexDimension <- QC.chooseInt (0, 4) + truncationBound <- QC.chooseInt (max 0 simplexDimension, 5) + pure + GeneratedStandardSimplex + { generatedSimplexDimension = fromIntegral simplexDimension, + generatedTruncationBound = fromIntegral truncationBound + } + +carrierToSSet :: GeneratedStandardSimplex -> TruncatedNormalizedSSet [Natural] +carrierToSSet generatedValue = + standardSimplex + (generatedSimplexDimension generatedValue) + (generatedTruncationBound generatedValue) + +standardSimplexLawsHold :: GeneratedStandardSimplex -> QC.Property +standardSimplexLawsHold generatedValue = + case checkSimplicialLaws (carrierToSSet generatedValue) of + Right () -> QC.property True + Left obstructions -> + QC.counterexample + ( "simplicial law obstruction count=" + <> show (length (NonEmpty.toList obstructions)) + <> "\nfirst obstruction=" + <> show (NonEmpty.head obstructions) + ) + False + +assertMaybeGeneratedSetValid :: String -> Maybe generated -> (generated -> Either obstructions ()) -> IO () +assertMaybeGeneratedSetValid label generatedResult validateGenerated = + case generatedResult of + Nothing -> + assertFailure (label <> " constructor rejected valid dimensions") + Just generatedSet -> + case validateGenerated generatedSet of + Right () -> pure () + Left _ -> assertFailure (label <> " failed generated-set validation") + +assertNormalizedLawsValid :: String -> TruncatedNormalizedSSet [Natural] -> IO () +assertNormalizedLawsValid label simplicialSet = + case checkSimplicialLaws simplicialSet of + Right () -> pure () + Left obstructions -> + assertFailure (label <> " failed simplicial laws: " <> show (NonEmpty.head obstructions)) + +assertNormalizedRowsEqual :: String -> Natural -> TruncatedNormalizedSSet [Natural] -> TruncatedNormalizedSSet [Natural] -> IO () +assertNormalizedRowsEqual label upperBound expected actual = + traverse_ + ( \dimensionValue -> + assertEqual + (label <> " dimension " <> show dimensionValue) + (simplicesAtDimension expected dimensionValue) + (simplicesAtDimension actual dimensionValue) + ) + [0 .. upperBound] + +pointRows :: Natural -> [[Natural]] +pointRows dimensionValue = + case dimensionValue of + 0 -> [[0]] + 1 -> [[0, 0]] + _ -> [] + +brokenPointRows :: Natural -> [[Natural]] +brokenPointRows dimensionValue = + case dimensionValue of + 0 -> [[0]] + _ -> [] + +pointFace :: dimension -> finite -> [Natural] -> Maybe [Natural] +pointFace _ _ simplexValue = + case simplexValue of + [0, 0] -> Just [0] + _ -> Nothing + +pointDegeneracy :: dimension -> finite -> [Natural] -> Maybe [Natural] +pointDegeneracy _ _ simplexValue = + case simplexValue of + [0] -> Just [0, 0] + _ -> Nothing + +lawfulCarrierSpec :: LawSuite +lawfulCarrierSpec = + mkLawfulCarrierSpec + "standard-simplex" + LawSuiteConfig + { lawSuiteName = "standard simplex simplicial laws", + lawSuiteMaxSuccess = 300, + lawSuiteCarrierToSSet = carrierToSSet, + lawSuiteEquality = simplicialLawEq, + lawSuiteRenderSimplex = show + } + +carrierTests :: TestTree +carrierTests = + testGroup + "Spaces" + [ testCase "mkGeneratedSSet derives degenerates from degeneracy images" $ + case mkGeneratedSSet 1 pointRows pointFace pointDegeneracy of + Left obstruction -> assertFailure ("expected checked generated set, got " <> show obstruction) + Right generatedSet -> + assertEqual + "degenerate edge is removed by derived witness" + [] + (simplicesAtDimension (normalizeGeneratedSSet generatedSet) 1), + testCase "mkGeneratedSSet rejects degeneracy images outside the carrier" $ + case mkGeneratedSSet 1 brokenPointRows pointFace pointDegeneracy of + Left obstruction -> + assertEqual + "degeneracy closure obstruction" + (GeneratedDegeneracyOutsideCarrier 0 0 [0] [0, 0]) + (NonEmpty.head obstruction) + Right _ -> assertFailure "expected generated-set construction obstruction", + testCase "indexSimplexIn only tags simplices present at that dimension" $ do + let simplex = standardSimplex 1 1 + case indexSimplexIn simplex (Dimension @1) [0, 1] of + Nothing -> assertFailure "expected edge to index at dimension 1" + Just indexed -> assertEqual "indexed edge" [0, 1] (unindexSimplex indexed) + assertEqual + "vertex is not a 1-simplex" + Nothing + (unindexSimplex <$> indexSimplexIn simplex (Dimension @1) [0]), + testCase "standard 2-simplex has combinatorial simplex counts" $ do + let generatedSet = standardSimplexGenerated 2 2 + simplex = standardSimplex 2 2 + assertEqual "generated 0-simplices" 3 (length (generatedSimplicesAtDimension generatedSet 0)) + assertEqual "generated 1-simplices" 6 (length (generatedSimplicesAtDimension generatedSet 1)) + assertEqual "generated 2-simplices" 10 (length (generatedSimplicesAtDimension generatedSet 2)) + assertEqual "normalized 0-simplices" 3 (length (simplicesAtDimension simplex 0)) + assertEqual "normalized 1-simplices" 3 (length (simplicesAtDimension simplex 1)) + assertEqual "normalized 2-simplices" 1 (length (simplicesAtDimension simplex 2)), + testCase "standard simplex direct constructor matches generated normalization on small cases" $ + traverse_ + ( \(simplexDimension, truncationBound) -> + assertNormalizedRowsEqual + ("standard simplex " <> show simplexDimension <> " <= " <> show truncationBound) + truncationBound + (normalizeGeneratedSSet (standardSimplexGenerated simplexDimension truncationBound)) + (standardSimplex simplexDimension truncationBound) + ) + [(0, 0), (1, 2), (2, 2), (3, 3), (4, 3)], + testCase "standard 6-simplex direct constructor keeps only nondegenerate rows" $ do + let simplex = standardSimplex 6 4 + assertEqual + "nondegenerate row counts" + [7, 21, 35, 35, 21] + (length . simplicesAtDimension simplex <$> [0 .. 4]), + testCase "boundary 2-simplex removes top nondegenerate triangle" $ do + let simplex = boundarySimplex 2 2 + assertEqual "boundary 0-simplices" 3 (length (simplicesAtDimension simplex 0)) + assertEqual "boundary 1-simplices" 3 (length (simplicesAtDimension simplex 1)) + assertEqual "boundary 2-simplices" 0 (length (simplicesAtDimension simplex 2)), + testCase "boundary simplex direct constructor matches generated normalization on small cases" $ + traverse_ + ( \(simplexDimension, truncationBound) -> + assertNormalizedRowsEqual + ("boundary simplex " <> show simplexDimension <> " <= " <> show truncationBound) + truncationBound + (normalizeGeneratedSSet (boundarySimplexGenerated simplexDimension truncationBound)) + (boundarySimplex simplexDimension truncationBound) + ) + [(0, 0), (1, 2), (2, 2), (3, 3)], + testCase "boundary 3-simplex direct constructor excludes the top identity simplex" $ do + let simplex = boundarySimplex 3 3 + assertEqual "boundary 2-faces" 4 (length (simplicesAtDimension simplex 2)) + assertEqual "boundary 3-simplices" [] (simplicesAtDimension simplex 3) + assertBool "top identity is absent" ([0, 1, 2, 3] `notElem` simplicesAtDimension simplex 3), + testCase "boundary generated rows are closed by image omission beyond top dimension" $ do + let boundaryOne = boundarySimplexGenerated 1 2 + boundaryTwo = boundarySimplexGenerated 2 3 + boundaryOneRows = generatedSimplicesAtDimension boundaryOne 2 + boundaryTwoRows = generatedSimplicesAtDimension boundaryTwo 3 + assertEqual "degenerate rows over boundary vertices" [[0, 0, 0], [1, 1, 1]] boundaryOneRows + assertBool "boundary excludes degeneracies whose image hits every vertex" ([0, 0, 1, 2] `notElem` boundaryTwoRows) + assertBool "boundary excludes second all-vertex degeneracy" ([0, 1, 1, 2] `notElem` boundaryTwoRows) + assertBool "boundary excludes third all-vertex degeneracy" ([0, 1, 2, 2] `notElem` boundaryTwoRows) + assertBool "boundary keeps rows omitting a vertex" ([0, 0, 1, 1] `elem` boundaryTwoRows) + assertBool "boundary keeps rows omitting middle vertex" ([0, 0, 2, 2] `elem` boundaryTwoRows), + testCase "horn removes one boundary face" $ + case hornSimplex 2 1 1 of + Nothing -> assertBool "expected horn in dimension 2" False + Just simplex -> do + assertEqual "horn 0-simplices" 3 (length (simplicesAtDimension simplex 0)) + assertEqual "horn 1-simplices" 2 (length (simplicesAtDimension simplex 1)), + testCase "horn simplex direct constructor matches generated normalization on small cases" $ + traverse_ + ( \(simplexDimension, missingFaceIndex, truncationBound) -> + case (hornSimplexGenerated simplexDimension missingFaceIndex truncationBound, hornSimplex simplexDimension missingFaceIndex truncationBound) of + (Just generatedSet, Just simplex) -> + assertNormalizedRowsEqual + ("horn simplex " <> show simplexDimension <> " missing " <> show missingFaceIndex <> " <= " <> show truncationBound) + truncationBound + (normalizeGeneratedSSet generatedSet) + simplex + _ -> assertFailure "expected valid generated and normalized horn" + ) + [(2, 0, 2), (2, 1, 2), (3, 1, 3)], + testCase "horn 3-simplex direct constructor excludes exactly the missing face" $ + case hornSimplex 3 1 2 of + Nothing -> assertFailure "expected horn in dimension 3" + Just simplex -> do + let twoFaces = simplicesAtDimension simplex 2 + assertBool "face opposite vertex 0 is retained" ([1, 2, 3] `elem` twoFaces) + assertBool "face opposite vertex 2 is retained" ([0, 1, 3] `elem` twoFaces) + assertBool "face opposite vertex 3 is retained" ([0, 1, 2] `elem` twoFaces) + assertBool "missing face opposite vertex 1 is absent" ([0, 2, 3] `notElem` twoFaces), + testCase "horn generated rows are the union of all non-missing faces in every dimension" $ + case hornSimplexGenerated 2 1 2 of + Nothing -> assertBool "expected generated horn in dimension 2" False + Just simplex -> do + let edgeRows = generatedSimplicesAtDimension simplex 1 + triangleRows = generatedSimplicesAtDimension simplex 2 + assertBool "horn keeps face opposite vertex 0" ([1, 2] `elem` edgeRows) + assertBool "horn keeps face opposite vertex 2" ([0, 1] `elem` edgeRows) + assertBool "horn removes the missing face" ([0, 2] `notElem` edgeRows) + assertBool "horn excludes degeneracy over the missing face" ([0, 0, 2] `notElem` triangleRows) + assertBool "horn excludes the other degeneracy over the missing face" ([0, 2, 2] `notElem` triangleRows) + assertBool "horn keeps degeneracy over retained face" ([0, 0, 1] `elem` triangleRows), + testCase "exported generated spaces validate through the checked generated-set boundary" $ do + case validateGeneratedSSet (standardSimplexGenerated 3 3) of + Right () -> pure () + Left obstruction -> assertFailure ("standard simplex failed validation: " <> show (NonEmpty.head obstruction)) + case validateGeneratedSSet (boundarySimplexGenerated 3 3) of + Right () -> pure () + Left obstruction -> assertFailure ("boundary simplex failed validation: " <> show (NonEmpty.head obstruction)) + assertMaybeGeneratedSetValid + "horn simplex" + (hornSimplexGenerated 3 1 3) + validateGeneratedSSet, + testCase "boundary and horn normalized spaces satisfy simplicial identities" $ do + assertNormalizedLawsValid "boundary simplex" (boundarySimplex 3 3) + case hornSimplex 3 1 3 of + Nothing -> assertFailure "expected horn in dimension 3" + Just simplex -> assertNormalizedLawsValid "horn simplex" simplex, + testCase "hornSimplex rejects dimension 0" $ + case hornSimplex 0 0 0 of + Nothing -> pure () + Just _ -> assertBool "expected hornSimplex to reject dimension 0" False, + testCase "hornSimplex rejects out-of-bounds missing face" $ + case hornSimplex 2 3 2 of + Nothing -> pure () + Just _ -> assertBool "expected hornSimplex to reject out-of-bounds face index" False, + testCase "hornSimplexGenerated rejects dimension 0" $ + case hornSimplexGenerated 0 0 0 of + Nothing -> pure () + Just _ -> assertBool "expected hornSimplexGenerated to reject dimension 0" False, + QC.testProperty "standard simplices satisfy simplicial identities" $ + QC.withNumTests 200 + standardSimplexLawsHold + ] diff --git a/test/site/Main.hs b/test/site/Main.hs new file mode 100644 --- /dev/null +++ b/test/site/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified SiteTests +import Test.Tasty (defaultMain) + +main :: IO () +main = + defaultMain SiteTests.tests diff --git a/test/site/PathQuotientSpec.hs b/test/site/PathQuotientSpec.hs new file mode 100644 --- /dev/null +++ b/test/site/PathQuotientSpec.hs @@ -0,0 +1,140 @@ +module PathQuotientSpec + ( tests, + ) +where + +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Category + ( SiteManifest (..), + SitePathCategory, + SitePathMorphism, + SitePathObject, + SitePathQuotient, + SitePathQuotientError (..), + mkSitePathMorphism, + mkSitePathObject, + quotientMapMorphism, + quotientMapObject, + siteObjects, + sitePathCategory, + sitePathQuotient, + thinSiteKernel, + ) +import qualified Moonlight.Category.Effect.PathQuotientHarness as PathQuotientHarness +import Moonlight.Category.Effect.SiteGen (diamondManifest) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) + +diamondPathCategory :: Either () (SitePathCategory Int) +diamondPathCategory = + case thinSiteKernel diamondManifest of + Left _ -> Left () + Right kernel -> Right (sitePathCategory kernel) + +tests :: TestTree +tests = + case diamondPathCategory of + Left _ -> + testGroup + "path-quotient" + [ testCase "diamond manifest yields a path category" (assertFailure "diamond manifest should admit a site path category") + ] + Right category -> + let objects = Set.toList (siteObjects diamondManifest) + objectPairs = liftA2 (,) objects objects + in testGroup + "path-quotient" + [ testCase + "quotient uniqueness per endpoint" + ( assertBool + "quotient should identify all endpoint-equal paths" + (all (\(sourceValue, targetValue) -> PathQuotientHarness.quotientUniquenessPerEndpoint @Int category sourceValue targetValue) objectPairs) + ), + testCase + "path-thin codomain faithful" + (assertBool "path-thin codomain map should be faithful" (PathQuotientHarness.pathThinCodomainFaithful @Int category)), + testCase + "interpreter coherence" + (assertBool "quotient interpreter should agree with the codomain map" (PathQuotientHarness.quotientInterpreterCoherence @Int category)), + testCase + "quotientMapObject rejects objects from a different path domain" + testQuotientMapObjectRejectsWrongDomain, + testCase + "quotientMapMorphism rejects morphisms from a different path domain" + testQuotientMapMorphismRejectsWrongDomain + ] + +testQuotientMapObjectRejectsWrongDomain :: Assertion +testQuotientMapObjectRejectsWrongDomain = + case wrongDomainFixture of + Left message -> + assertFailure message + Right (leftQuotient, rightObject, _) -> + quotientMapObject leftQuotient rightObject @?= Left QuotientObjectWrongDomain + +testQuotientMapMorphismRejectsWrongDomain :: Assertion +testQuotientMapMorphismRejectsWrongDomain = + case wrongDomainFixture of + Left message -> + assertFailure message + Right (leftQuotient, _, rightMorphism) -> + quotientMapMorphism leftQuotient rightMorphism @?= Left QuotientMorphismWrongDomain + +wrongDomainFixture :: Either String (SitePathQuotient Int, SitePathObject Int, SitePathMorphism Int) +wrongDomainFixture = do + leftKernel <- first (("left site kernel rejected: " <>) . show) (thinSiteKernel leftManifest) + rightKernel <- first (("right site kernel rejected: " <>) . show) (thinSiteKernel rightManifest) + let leftCategory = sitePathCategory leftKernel + rightCategory = sitePathCategory rightKernel + leftQuotient = sitePathQuotient leftCategory + rightObject <- + maybe + (Left "right path object was not constructible") + Right + (mkSitePathObject rightCategory 0) + rightMorphism <- + maybe + (Left "right identity path morphism was not constructible") + Right + (mkSitePathMorphism rightCategory (0 :| [2])) + pure (leftQuotient, rightObject, rightMorphism) + + +leftManifest :: SiteManifest Int +leftManifest = + SiteManifest + { siteObjects = Set.fromList [0, 1, 2], + siteImports = + Map.fromList + [ (0, Set.singleton 1), + (1, Set.singleton 2), + (2, Set.empty) + ], + siteCovers = + Map.fromList + [ (0, Set.fromList [1, 2]), + (1, Set.singleton 2), + (2, Set.empty) + ] + } + +rightManifest :: SiteManifest Int +rightManifest = + SiteManifest + { siteObjects = Set.fromList [0, 1, 2], + siteImports = + Map.fromList + [ (0, Set.fromList [1, 2]), + (1, Set.singleton 2), + (2, Set.empty) + ], + siteCovers = + Map.fromList + [ (0, Set.fromList [1, 2]), + (1, Set.singleton 2), + (2, Set.empty) + ] + } diff --git a/test/site/SiteSpec.hs b/test/site/SiteSpec.hs new file mode 100644 --- /dev/null +++ b/test/site/SiteSpec.hs @@ -0,0 +1,158 @@ +module SiteSpec + ( tests, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Moonlight.Category.Pure.Site.Compile (thinSiteKernel) +import Moonlight.Category.Pure.Site.Core (SiteFinCatError (..), SiteManifest (..), SiteViolation (..)) +import Moonlight.Category.Pure.Site.Graph (importCycles, reachableClosure) +import Moonlight.Category.Pure.Site.Manifest (validateSiteManifest) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Site" + [ testCase + "reachableClosure computes the transitive imports of an acyclic DAG" + testReachableClosureClosesAcyclicDag, + testCase + "importCycles reports a singleton self-loop" + testImportCyclesReportsSingletonSelfLoop, + testCase + "importCycles reports disjoint SCCs sorted by least object" + testImportCyclesReportsDisjointComponentsInLeastObjectOrder, + testCase + "validateSiteManifest reports import cycles between declared objects" + testValidateSiteManifestReportsDeclaredObjectCycle, + testCase + "thinSiteKernel rejects cyclic manifests before presentation" + testThinSiteKernelRejectsDeclaredObjectCycle, + testCase + "manifest validation and kernel compilation share diagnostics" + testManifestValidationAndKernelDiagnosticsAgree, + testCase + "validateSiteManifest reports cover sets that are not closed under covered covers" + testValidateSiteManifestReportsCoverClosureViolation + ] + +testReachableClosureClosesAcyclicDag :: Assertion +testReachableClosureClosesAcyclicDag = + reachableClosure imports + @?= Map.fromList + [ ("api", set ["core"]), + ("app", set ["api", "core", "ui"]), + ("core", Set.empty), + ("ui", set ["core"]) + ] + where + imports :: Map String (Set String) + imports = + Map.fromList + [ ("api", set ["core"]), + ("app", set ["api", "ui"]), + ("core", Set.empty), + ("ui", set ["core"]) + ] + +testImportCyclesReportsSingletonSelfLoop :: Assertion +testImportCyclesReportsSingletonSelfLoop = + importCycles manifest @?= ["root" :| []] + where + manifest :: SiteManifest String + manifest = + SiteManifest + { siteObjects = set ["root"], + siteImports = Map.singleton "root" (set ["root"]), + siteCovers = Map.empty + } + +testImportCyclesReportsDisjointComponentsInLeastObjectOrder :: Assertion +testImportCyclesReportsDisjointComponentsInLeastObjectOrder = + importCycles manifest @?= ["a" :| ["b"], "c" :| ["d"]] + where + manifest :: SiteManifest String + manifest = + SiteManifest + { siteObjects = set ["a", "b", "c", "d", "x"], + siteImports = + Map.fromList + [ ("c", set ["d"]), + ("x", Set.empty), + ("a", set ["b"]), + ("d", set ["c"]), + ("b", set ["a"]) + ], + siteCovers = Map.empty + } + +testValidateSiteManifestReportsDeclaredObjectCycle :: Assertion +testValidateSiteManifestReportsDeclaredObjectCycle = + validateSiteManifest declaredCycleManifest @?= [ImportCycleDetected ("domain" :| ["service"])] + +testThinSiteKernelRejectsDeclaredObjectCycle :: Assertion +testThinSiteKernelRejectsDeclaredObjectCycle = + case thinSiteKernel declaredCycleManifest of + Left (SiteManifestInvalid violations) -> + NonEmpty.toList violations @?= validateSiteManifest declaredCycleManifest + Right _ -> assertFailure "cyclic manifest produced a validated site kernel" + +testManifestValidationAndKernelDiagnosticsAgree :: Assertion +testManifestValidationAndKernelDiagnosticsAgree = + case thinSiteKernel invalidCoverManifest of + Left (SiteManifestInvalid violations) -> + NonEmpty.toList violations @?= validateSiteManifest invalidCoverManifest + Right _ -> assertFailure "invalid cover produced a validated site kernel" + +declaredCycleManifest :: SiteManifest String +declaredCycleManifest = + let objects = set ["domain", "service"] + in SiteManifest + { siteObjects = objects, + siteImports = + Map.fromList + [ ("domain", set ["service"]), + ("service", set ["domain"]) + ], + siteCovers = Map.fromList [("domain", objects), ("service", objects)] + } + +invalidCoverManifest :: SiteManifest Int +invalidCoverManifest = + SiteManifest + { siteObjects = Set.singleton 0, + siteImports = Map.singleton 0 Set.empty, + siteCovers = Map.singleton 0 (Set.singleton 1) + } + +testValidateSiteManifestReportsCoverClosureViolation :: Assertion +testValidateSiteManifestReportsCoverClosureViolation = + validateSiteManifest manifest @?= [CoverNotClosed "root" "leaf" (set ["support"])] + where + manifest :: SiteManifest String + manifest = + SiteManifest + { siteObjects = set ["root", "leaf", "support"], + siteImports = + Map.fromList + [ ("root", set ["leaf"]), + ("leaf", set ["support"]), + ("support", Set.empty) + ], + siteCovers = + Map.fromList + [ ("root", set ["leaf"]), + ("leaf", set ["support"]), + ("support", Set.empty) + ] + } + +set :: Ord a => [a] -> Set a +set = Set.fromList diff --git a/test/site/SiteTests.hs b/test/site/SiteTests.hs new file mode 100644 --- /dev/null +++ b/test/site/SiteTests.hs @@ -0,0 +1,16 @@ +module SiteTests + ( tests, + ) +where + +import qualified PathQuotientSpec +import qualified SiteSpec +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "site" + [ SiteSpec.tests, + PathQuotientSpec.tests + ] diff --git a/test/support/Moonlight/Category/Test/CoveringFixture.hs b/test/support/Moonlight/Category/Test/CoveringFixture.hs new file mode 100644 --- /dev/null +++ b/test/support/Moonlight/Category/Test/CoveringFixture.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Moonlight.Category.Test.CoveringFixture + ( DemoField (..), + DemoFieldWitness (..), + DemoSubsetWitness (..), + embedDemoSubsetWitness, + sameDemoFieldWitness, + ) +where + +import Data.Kind (Type) +import Data.Type.Equality ((:~:) (Refl)) +import Moonlight.Category.Pure.CoveringFamily (CoveringFamily (..), Exists (..)) + +type DemoField :: Type +data DemoField + = AlphaField + | BetaField + | GammaField + +type DemoFieldWitness :: DemoField -> Type +data DemoFieldWitness field where + AlphaFieldWitness :: DemoFieldWitness 'AlphaField + BetaFieldWitness :: DemoFieldWitness 'BetaField + GammaFieldWitness :: DemoFieldWitness 'GammaField + +type DemoSubsetWitness :: DemoField -> Type +data DemoSubsetWitness field where + AlphaSubsetWitness :: DemoSubsetWitness 'AlphaField + GammaSubsetWitness :: DemoSubsetWitness 'GammaField + +instance CoveringFamily DemoFieldWitness where + allMembers = + [ Exists AlphaFieldWitness, + Exists BetaFieldWitness, + Exists GammaFieldWitness + ] + +instance CoveringFamily DemoSubsetWitness where + allMembers = + [ Exists AlphaSubsetWitness, + Exists GammaSubsetWitness + ] + +sameDemoFieldWitness :: + DemoFieldWitness left -> + DemoFieldWitness right -> + Maybe (left :~: right) +sameDemoFieldWitness leftWitness rightWitness = + case (leftWitness, rightWitness) of + (AlphaFieldWitness, AlphaFieldWitness) -> Just Refl + (BetaFieldWitness, BetaFieldWitness) -> Just Refl + (GammaFieldWitness, GammaFieldWitness) -> Just Refl + _ -> Nothing + +embedDemoSubsetWitness :: + DemoSubsetWitness field -> + DemoFieldWitness field +embedDemoSubsetWitness subsetWitness = + case subsetWitness of + AlphaSubsetWitness -> AlphaFieldWitness + GammaSubsetWitness -> GammaFieldWitness diff --git a/test/support/Moonlight/Category/Test/DoubleFixture.hs b/test/support/Moonlight/Category/Test/DoubleFixture.hs new file mode 100644 --- /dev/null +++ b/test/support/Moonlight/Category/Test/DoubleFixture.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Category.Test.DoubleFixture + ( SymbolicDouble, + SymbolicHorizontal (..), + SymbolicObject (..), + SymbolicSquare (..), + SymbolicVertical (..), + ) +where + +import Data.Kind (Type) +import Data.Proxy (Proxy) +import Moonlight.Category.Pure.DoubleCategory (DoubleCategory (..)) + +type SymbolicObject :: Type +data SymbolicObject + = ObjectA + | ObjectB + | ObjectC + | ObjectD + | ObjectE + | ObjectF + | ObjectG + | ObjectH + | ObjectI + +type SymbolicHorizontal :: Type -> SymbolicObject -> SymbolicObject -> Type +newtype SymbolicHorizontal label source target = SymbolicHorizontal + { symbolicHorizontalTrace :: [label] + } + deriving stock (Eq, Show) + +type SymbolicVertical :: Type -> SymbolicObject -> SymbolicObject -> Type +newtype SymbolicVertical label source target = SymbolicVertical + { symbolicVerticalTrace :: [label] + } + deriving stock (Eq, Show) + +type SymbolicSquare :: + Type -> + SymbolicObject -> + SymbolicObject -> + SymbolicObject -> + SymbolicObject -> + Type +data SymbolicSquare label northWest northEast southWest southEast = SymbolicSquare + { symbolicSquareTop :: SymbolicHorizontal label northWest northEast, + symbolicSquareBottom :: SymbolicHorizontal label southWest southEast, + symbolicSquareLeft :: SymbolicVertical label northWest southWest, + symbolicSquareRight :: SymbolicVertical label northEast southEast + } + deriving stock (Eq, Show) + +type SymbolicDouble :: Type -> Type +data SymbolicDouble label + +instance DoubleCategory SymbolicObject (SymbolicDouble label) where + type ObjectWitness SymbolicObject (SymbolicDouble label) = Proxy + type HorizontalMor SymbolicObject (SymbolicDouble label) = SymbolicHorizontal label + type VerticalMor SymbolicObject (SymbolicDouble label) = SymbolicVertical label + type Square SymbolicObject (SymbolicDouble label) = SymbolicSquare label + + horizontalIdentity _ = SymbolicHorizontal [] + verticalIdentity _ = SymbolicVertical [] + composeHorizontal leftHorizontal rightHorizontal = + Just + SymbolicHorizontal + { symbolicHorizontalTrace = symbolicHorizontalTrace rightHorizontal <> symbolicHorizontalTrace leftHorizontal + } + composeVertical lowerVertical upperVertical = + Just + SymbolicVertical + { symbolicVerticalTrace = symbolicVerticalTrace upperVertical <> symbolicVerticalTrace lowerVertical + } + squareTop = symbolicSquareTop + squareBottom = symbolicSquareBottom + squareLeft = symbolicSquareLeft + squareRight = symbolicSquareRight + composeSquaresHorizontal eastSquare westSquare = + Just + SymbolicSquare + { symbolicSquareTop = + SymbolicHorizontal + { symbolicHorizontalTrace = + symbolicHorizontalTrace (symbolicSquareTop westSquare) + <> symbolicHorizontalTrace (symbolicSquareTop eastSquare) + }, + symbolicSquareBottom = + SymbolicHorizontal + { symbolicHorizontalTrace = + symbolicHorizontalTrace (symbolicSquareBottom westSquare) + <> symbolicHorizontalTrace (symbolicSquareBottom eastSquare) + }, + symbolicSquareLeft = symbolicSquareLeft westSquare, + symbolicSquareRight = symbolicSquareRight eastSquare + } + composeSquaresVertical southSquare northSquare = + Just + SymbolicSquare + { symbolicSquareTop = symbolicSquareTop northSquare, + symbolicSquareBottom = symbolicSquareBottom southSquare, + symbolicSquareLeft = + SymbolicVertical + { symbolicVerticalTrace = + symbolicVerticalTrace (symbolicSquareLeft northSquare) + <> symbolicVerticalTrace (symbolicSquareLeft southSquare) + }, + symbolicSquareRight = + SymbolicVertical + { symbolicVerticalTrace = + symbolicVerticalTrace (symbolicSquareRight northSquare) + <> symbolicVerticalTrace (symbolicSquareRight southSquare) + } + } diff --git a/test/support/Moonlight/Category/Test/IndexedSimplexFixture.hs b/test/support/Moonlight/Category/Test/IndexedSimplexFixture.hs new file mode 100644 --- /dev/null +++ b/test/support/Moonlight/Category/Test/IndexedSimplexFixture.hs @@ -0,0 +1,89 @@ +module Moonlight.Category.Test.IndexedSimplexFixture + ( Zero, + One, + Two, + Three, + zero, + one, + two, + coface0At0, + coface1At0, + coface0At1, + coface1At1, + coface2At1, + coface0At2, + coface1At2, + coface2At2, + coface3At2, + codegeneracy0At0, + codegeneracy0At1, + codegeneracy1At1, + codegeneracy0At2, + codegeneracy1At2, + codegeneracy2At2, + ) +where + +import Moonlight.Category.Indexed qualified as Indexed + +type Zero = Indexed.Z + +type One = Indexed.S Zero + +type Two = Indexed.S One + +type Three = Indexed.S Two + +zero :: Indexed.Simplex Zero Zero +zero = Indexed.simplexZero + +one :: Indexed.Simplex One One +one = Indexed.simplexSucc zero + +two :: Indexed.Simplex Two Two +two = Indexed.simplexSucc one + +coface0At0 :: Indexed.Simplex Zero One +coface0At0 = Indexed.cofaceFirst zero + +coface1At0 :: Indexed.Simplex Zero One +coface1At0 = Indexed.cofaceLast zero + +coface0At1 :: Indexed.Simplex One Two +coface0At1 = Indexed.cofaceFirst one + +coface1At1 :: Indexed.Simplex One Two +coface1At1 = Indexed.cofaceSucc coface0At0 + +coface2At1 :: Indexed.Simplex One Two +coface2At1 = Indexed.cofaceLast one + +coface0At2 :: Indexed.Simplex Two Three +coface0At2 = Indexed.cofaceFirst two + +coface1At2 :: Indexed.Simplex Two Three +coface1At2 = Indexed.cofaceSucc coface0At1 + +coface2At2 :: Indexed.Simplex Two Three +coface2At2 = Indexed.cofaceSucc coface1At1 + +coface3At2 :: Indexed.Simplex Two Three +coface3At2 = Indexed.cofaceLast two + +codegeneracy0At0 :: Indexed.Simplex One Zero +codegeneracy0At0 = Indexed.codegeneracyFirst zero + +codegeneracy0At1 :: Indexed.Simplex Two One +codegeneracy0At1 = Indexed.codegeneracyFirst one + +codegeneracy1At1 :: Indexed.Simplex Two One +codegeneracy1At1 = Indexed.codegeneracyLast one + +codegeneracy0At2 :: Indexed.Simplex Three Two +codegeneracy0At2 = Indexed.codegeneracyFirst two + +codegeneracy1At2 :: Indexed.Simplex Three Two +codegeneracy1At2 = Indexed.codegeneracySucc codegeneracy0At1 + +codegeneracy2At2 :: Indexed.Simplex Three Two +codegeneracy2At2 = Indexed.codegeneracyLast two diff --git a/test/support/Moonlight/Category/Test/PolynomialFixture.hs b/test/support/Moonlight/Category/Test/PolynomialFixture.hs new file mode 100644 --- /dev/null +++ b/test/support/Moonlight/Category/Test/PolynomialFixture.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +module Moonlight.Category.Test.PolynomialFixture + ( BranchPosition, + DemoParameterizedPolynomial, + DemoPolynomial, + FullSliceBranchPosition, + FullSliceRootPosition, + ParameterizedPosition + ( FullSliceBranchWitness, + FullSliceRootWitness, + TrimmedSliceRootWitness + ), + Position (BranchWitness, RootWitness), + RootPosition, + TrimmedSliceRootPosition, + ) +where + +import Data.Kind (Type) +import Moonlight.Category.Pure.CoveringFamily (Exists (..)) +import Moonlight.Category.Pure.PolynomialFunctor + ( ParameterizedPolynomialFunctor (..), + PolynomialFunctor (..), + ) + +type DemoPolynomial :: Type +data DemoPolynomial + +type RootPosition :: Type +data RootPosition + +type BranchPosition :: Type +data BranchPosition + +type DemoParameterizedPolynomial :: Type +data DemoParameterizedPolynomial + +type FullSliceRootPosition :: Type +data FullSliceRootPosition + +type FullSliceBranchPosition :: Type +data FullSliceBranchPosition + +type TrimmedSliceRootPosition :: Type +data TrimmedSliceRootPosition + +instance PolynomialFunctor DemoPolynomial where + data Position DemoPolynomial position where + RootWitness :: Position DemoPolynomial RootPosition + BranchWitness :: Position DemoPolynomial BranchPosition + type Direction DemoPolynomial RootPosition = Bool + type Direction DemoPolynomial BranchPosition = Maybe Bool + allPositions = [Exists RootWitness, Exists BranchWitness] + +instance ParameterizedPolynomialFunctor DemoParameterizedPolynomial where + type PolynomialParameter DemoParameterizedPolynomial = Bool + + data ParameterizedPosition DemoParameterizedPolynomial position where + FullSliceRootWitness :: ParameterizedPosition DemoParameterizedPolynomial FullSliceRootPosition + FullSliceBranchWitness :: ParameterizedPosition DemoParameterizedPolynomial FullSliceBranchPosition + TrimmedSliceRootWitness :: ParameterizedPosition DemoParameterizedPolynomial TrimmedSliceRootPosition + + type ParameterizedDirection DemoParameterizedPolynomial FullSliceRootPosition = Bool + type ParameterizedDirection DemoParameterizedPolynomial FullSliceBranchPosition = Maybe Bool + type ParameterizedDirection DemoParameterizedPolynomial TrimmedSliceRootPosition = () + + positionsAt includeBranch = + if includeBranch + then [Exists FullSliceRootWitness, Exists FullSliceBranchWitness] + else [Exists TrimmedSliceRootWitness]