packages feed

moonlight-category (empty) → 0.1.0.0

raw patch · 162 files changed

+23211/−0 lines, 162 filesdep +QuickCheckdep +algebraic-graphsdep +base

Dependencies added: QuickCheck, algebraic-graphs, base, bytestring, containers, deepseq, hedgehog, moonlight-category, moonlight-core, moonlight-pale, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+> <https://arxiv.org/abs/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).
+ THIRD_PARTY_NOTICES.md view
@@ -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. <https://arxiv.org/abs/2106.04703>+  (Topos Institute; Universiteit Utrecht, Mathematics Department; University of+  Florida, Computer & Information Science & Engineering.)+- AlgebraicJulia: <https://www.algebraicjulia.org/>++Thank you to Evan Patterson, Owen Lynch, James Fairbanks, and the AlgebraicJulia+community.
+ bench/abstract/AbstractBench.hs view
@@ -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+    ]
+ bench/abstract/AbstractFixtures.hs view
@@ -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
+ bench/abstract/Adhesive/Graph.hs view
@@ -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
+ bench/abstract/Adhesive/Subset.hs view
@@ -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)
+ bench/abstract/Adhesive/Suite.hs view
@@ -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+    ]
+ bench/abstract/Adhesive/Symbolic.hs view
@@ -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)
+ bench/abstract/Algebraic/Decorated.hs view
@@ -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]
+ bench/abstract/Algebraic/Double.hs view
@@ -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
+ bench/abstract/Algebraic/Galois.hs view
@@ -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+      )
+ bench/abstract/Algebraic/Polynomial.hs view
@@ -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
+ bench/abstract/Algebraic/StructuredCospan.hs view
@@ -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
+ bench/abstract/Algebraic/Suite.hs view
@@ -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+    ]
+ bench/abstract/Covering.hs view
@@ -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
+ bench/abstract/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import AbstractBench (abstractBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [abstractBenchmarks]
+ bench/aggregate/Main.hs view
@@ -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+    ]
+ bench/finite/FinCat.hs view
@@ -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
+ bench/finite/FiniteBench.hs view
@@ -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+    ]
+ bench/finite/Invertibility.hs view
@@ -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
+ bench/finite/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import FiniteBench (finiteBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [finiteBenchmarks]
+ bench/indexed/IndexedBench.hs view
@@ -0,0 +1,13 @@+module IndexedBench+  ( indexedBenchmarks,+  )+where++import Simplex (indexedSimplexBenchmarks)+import Test.Tasty.Bench (Benchmark, bgroup)++indexedBenchmarks :: Benchmark+indexedBenchmarks =+  bgroup+    "indexed"+    [indexedSimplexBenchmarks]
+ bench/indexed/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import IndexedBench (indexedBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [indexedBenchmarks]
+ bench/indexed/Simplex.hs view
@@ -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
+ bench/simplicial/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import SimplicialBench (simplicialBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [simplicialBenchmarks]
+ bench/simplicial/SimplicialBench.hs view
@@ -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+    ]
+ bench/simplicial/SimplicialDelta.hs view
@@ -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)
+ bench/simplicial/SimplicialNerve.hs view
@@ -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
+ bench/simplicial/SimplicialSpaces.hs view
@@ -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)
+ bench/simplicial/SimplicialWeight.hs view
@@ -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
+ bench/site/Main.hs view
@@ -0,0 +1,11 @@+module Main+  ( main,+  )+where++import SiteBench (siteBenchmarks)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main =+  defaultMain [siteBenchmarks]
+ bench/site/SiteBench.hs view
@@ -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+        ]+    ]
+ bench/site/SiteCases.hs view
@@ -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
+ bench/site/SiteManifest.hs view
@@ -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
+ bench/site/SitePathQuotient.hs view
@@ -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)
+ bench/support/BenchSupport.hs view
@@ -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 #-}
+ moonlight-category.cabal view
@@ -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
+ src-abstract/Moonlight/Category/Pure/Adhesive.hs view
@@ -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
+ src-abstract/Moonlight/Category/Pure/Category.hs view
@@ -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 #-}
+ src-abstract/Moonlight/Category/Pure/CoveringFamily.hs view
@@ -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
+ src-abstract/Moonlight/Category/Pure/CoveringProduct.hs view
@@ -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)
+ src-abstract/Moonlight/Category/Pure/DecoratedComposition.hs view
@@ -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
+ src-abstract/Moonlight/Category/Pure/DecoratedPresentation.hs view
@@ -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+      }
+ src-abstract/Moonlight/Category/Pure/DoubleCategory.hs view
@@ -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)
+ src-abstract/Moonlight/Category/Pure/FiniteComposable.hs view
@@ -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))+      )
+ src-abstract/Moonlight/Category/Pure/Galois.hs view
@@ -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)]
+ src-abstract/Moonlight/Category/Pure/Higher.hs view
@@ -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
+ src-abstract/Moonlight/Category/Pure/Limits.hs view
@@ -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)
+ src-abstract/Moonlight/Category/Pure/PolynomialFunctor.hs view
@@ -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)]
+ src-abstract/Moonlight/Category/Pure/Poset.hs view
@@ -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)
+ src-abstract/Moonlight/Category/Pure/StructuredCospan.hs view
@@ -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 #-}
+ src-abstract/Moonlight/Category/Pure/Thin.hs view
@@ -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
+ src-abstract/Moonlight/Category/Pure/Unit.hs view
@@ -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
+ src-finite/Moonlight/Category/Pure/FinCat.hs view
@@ -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
+ src-finite/Moonlight/Category/Pure/FinCat/Functor.hs view
@@ -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)
+ src-finite/Moonlight/Category/Pure/FinCat/Opposite.hs view
@@ -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
+ src-finite/Moonlight/Category/Pure/FinPresentation.hs view
@@ -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+    )+    []
+ src-finite/Moonlight/Category/Pure/Finite/DenseReachability.hs view
@@ -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 #-}
+ src-finite/Moonlight/Category/Pure/Invertibility.hs view
@@ -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
+ src-indexed/Moonlight/Category/Pure/Indexed/Adjunction.hs view
@@ -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))
+ src-indexed/Moonlight/Category/Pure/Indexed/Category.hs view
@@ -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
+ src-indexed/Moonlight/Category/Pure/Indexed/Coproduct.hs view
@@ -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
+ src-indexed/Moonlight/Category/Pure/Indexed/Functor.hs view
@@ -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)
+ src-indexed/Moonlight/Category/Pure/Indexed/KanExtension.hs view
@@ -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))
+ src-indexed/Moonlight/Category/Pure/Indexed/Limit.hs view
@@ -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
+ src-indexed/Moonlight/Category/Pure/Indexed/NaturalTransformation.hs view
@@ -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 #-}
+ src-indexed/Moonlight/Category/Pure/Indexed/Product.hs view
@@ -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)
+ src-indexed/Moonlight/Category/Pure/Indexed/Simplex.hs view
@@ -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))
+ src-indexed/Moonlight/Category/Pure/Indexed/Unit.hs view
@@ -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
+ src-indexed/Moonlight/Category/Pure/Indexed/Void.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Fixture/FinCat.hs view
@@ -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))+        ]+    )
+ src-laws/Moonlight/Category/Effect/Harness.hs view
@@ -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)
+ src-laws/Moonlight/Category/Effect/Harness/Adhesive.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Harness/Algebra.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Harness/Category.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Harness/Core.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Harness/Higher.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Harness/Limits.hs view
@@ -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)
+ src-laws/Moonlight/Category/Effect/Harness/Site.hs view
@@ -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)+      )
+ src-laws/Moonlight/Category/Effect/LawNames.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Laws.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/Laws/Adhesive.hs view
@@ -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+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Algebra.hs view
@@ -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+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Category.hs view
@@ -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+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Generators.hs view
@@ -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)+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Higher.hs view
@@ -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+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Limits.hs view
@@ -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+      ]+  ]
+ src-laws/Moonlight/Category/Effect/Laws/Site.hs view
@@ -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)+      ]+  ]
+ src-laws/Moonlight/Category/Effect/PathQuotientHarness.hs view
@@ -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
+ src-laws/Moonlight/Category/Effect/SiteGen.hs view
@@ -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)+          ]+    }
+ src-laws/Moonlight/Category/Effect/SitePathEnumeration.hs view
@@ -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)
+ src-public/Moonlight/Category.hs view
@@ -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 (..),+  )
+ src-public/Moonlight/Category/Indexed.hs view
@@ -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
+ src-public/Moonlight/Category/Notation.hs view
@@ -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 #-}
+ src-public/Moonlight/Category/Presentation.hs view
@@ -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,+  )
+ src-simplicial/Moonlight/Category/Pure/Simplicial/CategoricalSimplex.hs view
@@ -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)
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Delta.hs view
@@ -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)
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Delta/Types.hs view
@@ -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)
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Homotopy.hs view
@@ -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))+    )
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Kan.hs view
@@ -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)
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Nerve.hs view
@@ -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)
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Ordinal.hs view
@@ -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
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Presheaf.hs view
@@ -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
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Set.hs view
@@ -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
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Set/Internal.hs view
@@ -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+    }
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Spaces.hs view
@@ -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)+        )
+ src-simplicial/Moonlight/Category/Pure/Simplicial/TypeLevel.hs view
@@ -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
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Validation.hs view
@@ -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
+ src-simplicial/Moonlight/Category/Pure/Simplicial/Validation/Internal.hs view
@@ -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+    )
+ src-simplicial/Moonlight/Category/Simplicial.hs view
@@ -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
+ src-site/Moonlight/Category/Pure/Site.hs view
@@ -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
+ src-site/Moonlight/Category/Pure/Site/Category.hs view
@@ -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))
+ src-site/Moonlight/Category/Pure/Site/Compile.hs view
@@ -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)
+ src-site/Moonlight/Category/Pure/Site/Core.hs view
@@ -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)
+ src-site/Moonlight/Category/Pure/Site/Graph.hs view
@@ -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)
+ src-site/Moonlight/Category/Pure/Site/Manifest.hs view
@@ -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
+ src-site/Moonlight/Category/Pure/Site/Quotient.hs view
@@ -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
+ test/abstract/AbstractTests.hs view
@@ -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+    ]
+ test/abstract/AdhesiveSpec.hs view
@@ -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  {"+    ]
+ test/abstract/CoveringProductSpec.hs view
@@ -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"+    ]
+ test/abstract/DecoratedPresentationSpec.hs view
@@ -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 <structured-cospan>"+    Left (StructuredCospanCategoryError _) ->+      "Left StructuredCospanCategoryError"+    Left (StructuredCospanBoundaryMismatch leftOutput rightInput) ->+      "Left (StructuredCospanBoundaryMismatch " <> show leftOutput <> " " <> show rightInput <> ")"+    Left (StructuredCospanPushoutMissing leftLeg rightLeg) ->+      "Left (StructuredCospanPushoutMissing " <> show leftLeg <> " " <> show rightLeg <> ")"
+ test/abstract/DoubleCategorySpec.hs view
@@ -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")
+ test/abstract/FiniteComposableSpec.hs view
@@ -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)
+ test/abstract/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified AbstractTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain AbstractTests.tests
+ test/abstract/PolynomialFunctorWitnessSpec.hs view
@@ -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
+ test/coherence/Main.hs view
@@ -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 ()
+ test/facade/FacadeTests.hs view
@@ -0,0 +1,13 @@+module FacadeTests+  ( tests,+  )+where++import qualified NotationSpec+import Test.Tasty (TestTree, testGroup)++tests :: TestTree+tests =+  testGroup+    "facade"+    [NotationSpec.tests]
+ test/facade/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified FacadeTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain FacadeTests.tests
+ test/facade/NotationSpec.hs view
@@ -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
+ test/finite/DenseReachabilitySpec.hs view
@@ -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
+ test/finite/FinPresentationSpec.hs view
@@ -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 ()
+ test/finite/FinThinFunctorSpec.hs view
@@ -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)
+ test/finite/FiniteTests.hs view
@@ -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+    ]
+ test/finite/InvertibilitySpec.hs view
@@ -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+    ]
+ test/finite/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified FiniteTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain FiniteTests.tests
+ test/indexed/IndexedSpec.hs view
@@ -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+    ]
+ test/indexed/IndexedTests.hs view
@@ -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+    ]
+ test/indexed/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified IndexedTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain IndexedTests.tests
+ test/indexed/SimplexSpec.hs view
@@ -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+    ]
+ test/laws/Main.hs view
@@ -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
+ test/simplicial/CategoricalSimplexSpec.hs view
@@ -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+    ]
+ test/simplicial/DeltaSpec.hs view
@@ -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))+    ]
+ test/simplicial/HomotopySpec.hs view
@@ -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)))+    ]
+ test/simplicial/KanSpec.hs view
@@ -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)+    ]
+ test/simplicial/Laws/Registry.hs view
@@ -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+  ]
+ test/simplicial/Laws/Suite.hs view
@@ -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)
+ test/simplicial/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified SimplicialTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain SimplicialTests.tests
+ test/simplicial/NerveSpec.hs view
@@ -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+    ]
+ test/simplicial/OrdinalSpec.hs view
@@ -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))+    ]
+ test/simplicial/PresheafSpec.hs view
@@ -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)+    ]
+ test/simplicial/SimplicialTests.hs view
@@ -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]+    )
+ test/simplicial/SpacesSpec.hs view
@@ -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+    ]
+ test/site/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified SiteTests+import Test.Tasty (defaultMain)++main :: IO ()+main =+  defaultMain SiteTests.tests
+ test/site/PathQuotientSpec.hs view
@@ -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)+          ]+    }
+ test/site/SiteSpec.hs view
@@ -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
+ test/site/SiteTests.hs view
@@ -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+    ]
+ test/support/Moonlight/Category/Test/CoveringFixture.hs view
@@ -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
+ test/support/Moonlight/Category/Test/DoubleFixture.hs view
@@ -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)+              }+        }
+ test/support/Moonlight/Category/Test/IndexedSimplexFixture.hs view
@@ -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
+ test/support/Moonlight/Category/Test/PolynomialFixture.hs view
@@ -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]