├── .github ├── dependabot.yml └── workflows │ ├── agda.yml │ └── regenerate-everything.yaml ├── .gitignore ├── Dockerfile ├── Makefile ├── README.md ├── agda-mugen.agda-lib └── src └── Mugen ├── Algebra ├── Displacement.agda ├── Displacement │ ├── Action.agda │ ├── Instances │ │ ├── Constant.agda │ │ ├── Endomorphism.agda │ │ ├── Fractal.agda │ │ ├── IndexedProduct.agda │ │ ├── Int.agda │ │ ├── Lexicographic.agda │ │ ├── Nat.agda │ │ ├── NearlyConstant.agda │ │ ├── NonPositive.agda │ │ ├── Opposite.agda │ │ ├── Prefix.agda │ │ ├── Product.agda │ │ ├── README.md │ │ ├── Support.agda │ │ └── WeirdFractal.agda │ └── Subalgebra.agda └── OrderedMonoid.agda ├── Cat ├── HierarchyTheory.agda ├── HierarchyTheory │ ├── McBride.agda │ ├── Traditional.agda │ ├── Universality.agda │ └── Universality │ │ ├── EndomorphismEmbedding.agda │ │ ├── EndomorphismEmbeddingNaturality.agda │ │ └── SubcategoryEmbedding.agda ├── Instances │ ├── Displacements.agda │ ├── Endomorphisms.agda │ ├── Indexed.agda │ └── StrictOrders.agda ├── Monad.agda └── README.md ├── Data ├── List.agda ├── NonEmpty.agda └── README.md ├── Everything.agda ├── Order ├── Instances │ ├── BasedSupport.agda │ ├── Copower.agda │ ├── Endomorphism.agda │ ├── Fractal.agda │ ├── Int.agda │ ├── LeftInvariantRightCentered.agda │ ├── Lexicographic.agda │ ├── Lift.agda │ ├── Nat.agda │ ├── NonPositive.agda │ ├── Opposite.agda │ ├── Pointwise.agda │ ├── Prefix.agda │ ├── Product.agda │ └── Support.agda ├── Lattice.agda ├── README.md ├── Reasoning.agda └── StrictOrder.agda └── Prelude.agda /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "weekly" 7 | groups: 8 | github-actions: 9 | update-types: 10 | - "major" 11 | - "minor" 12 | - "patch" 13 | - package-ecosystem: "docker" 14 | directory: "/" 15 | schedule: 16 | interval: "weekly" 17 | groups: 18 | docker-dependencies: 19 | update-types: 20 | - "major" 21 | - "minor" 22 | - "patch" 23 | -------------------------------------------------------------------------------- /.github/workflows/agda.yml: -------------------------------------------------------------------------------- 1 | name: Docker 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - name: Set up Docker Buildx 🐋 12 | uses: docker/setup-buildx-action@v3 13 | - name: Build Docker ⚒️ 14 | uses: docker/build-push-action@v5 15 | with: 16 | load: true 17 | tags: agda-mugen:edge 18 | cache-from: type=gha 19 | cache-to: type=gha,mode=max 20 | - name: Check agda-mugen 🔍 21 | run: docker run agda-mugen:edge 22 | -------------------------------------------------------------------------------- /.github/workflows/regenerate-everything.yaml: -------------------------------------------------------------------------------- 1 | name: Make 2 | 3 | on: 4 | push: 5 | branches: ["main"] 6 | pull_request: 7 | 8 | permissions: 9 | contents: read 10 | 11 | jobs: 12 | everything: 13 | name: Everything.agda 14 | runs-on: ubuntu-latest 15 | steps: 16 | - name: Check out the repository ⬇️ 17 | uses: actions/checkout@v4 18 | with: 19 | persist-credentials: false 20 | - name: Run `make Everything.agda` 🏃 21 | run: make Everything.agda 22 | - name: Check if any files are changed 🔍 23 | run: | 24 | if ! git diff --quiet; then 25 | echo "Please run 'make Everything.agda' to regenerate files" 26 | exit 1 27 | fi 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | #################################################################################################### 2 | # Stage 1: building everything except agda-mugen 3 | #################################################################################################### 4 | 5 | ARG GHC_VERSION=9.4.7 6 | FROM fossa/haskell-static-alpine:ghc-${GHC_VERSION} AS agda 7 | 8 | WORKDIR /build/agda 9 | ARG AGDA_VERSION=403ee4263e0f14222956e398d2610ae1a4f05467 10 | RUN \ 11 | git init && \ 12 | git remote add origin https://github.com/agda/agda.git && \ 13 | git fetch --depth 1 origin "${AGDA_VERSION}" && \ 14 | git checkout FETCH_HEAD 15 | 16 | # We build Agda and place it in /dist along with its data files. 17 | # We explicitly use v1-install because v2-install does not support --datadir and --bindir 18 | # to relocate executables and data files yet. 19 | RUN \ 20 | mkdir -p /dist && \ 21 | cabal update && \ 22 | cabal v1-install alex happy && \ 23 | cabal v1-install --bindir=/dist --datadir=/dist --datasubdir=/dist/data --enable-executable-static 24 | 25 | #################################################################################################### 26 | # Stage 2: Download 1lab (everything except agda-mugan) 27 | #################################################################################################### 28 | 29 | FROM alpine AS onelab 30 | 31 | RUN apk add --no-cache git 32 | 33 | WORKDIR /dist/1lab 34 | ARG ONELAB_VERSION=a3feb5b6ff900829e63a80abc1af18e9d8a35c46 35 | RUN \ 36 | git init && \ 37 | git remote add origin https://github.com/plt-amy/1lab && \ 38 | git fetch --depth 1 origin "${ONELAB_VERSION}" && \ 39 | git checkout FETCH_HEAD 40 | RUN echo "/dist/1lab/1lab.agda-lib" > /dist/libraries 41 | 42 | ############################################################################################################### 43 | 44 | FROM scratch 45 | 46 | COPY --from=agda /dist /dist 47 | COPY --from=onelab /dist /dist 48 | 49 | WORKDIR /build/agda-mugen 50 | COPY ["src", "/build/agda-mugen/src"] 51 | COPY ["Makefile", "/build/agda-mugen/Makefile"] 52 | COPY ["agda-mugen.agda-lib", "/build/agda-mugen/agda-mugen.agda-lib"] 53 | 54 | CMD ["/dist/agda", "-i=.", "--library-file=/dist/libraries", "src/Mugen/Everything.agda"] 55 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: Everything.agda build clean 2 | 3 | EVERYTHING_PATH=./src/Mugen/Everything.agda 4 | 5 | build: Everything.agda 6 | agda -i=. ${EVERYTHING_PATH} 7 | 8 | Everything.agda: 9 | echo > ${EVERYTHING_PATH} 10 | echo "-- DO NOT EDIT THIS FILE!" >> ${EVERYTHING_PATH} 11 | echo "-- THIS FILE IS AUTOMATICALLY GENERATED BY 'make Everything.agda'" >> ${EVERYTHING_PATH} 12 | echo >> ${EVERYTHING_PATH} 13 | echo "module Mugen.Everything where" >> ${EVERYTHING_PATH} 14 | find ./src -name "*.agda" | sed -e 's|^./src/[/]*|import |' -e 's|/|.|g' -e 's/.agda//' -e '/import Mugen.Everything/d' | LC_COLLATE='C' sort >> ${EVERYTHING_PATH} 15 | 16 | clean: 17 | rm -rf ${EVERYTHING_PATH} 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # ♾ mugen 無限 in Agda 4 | 5 | This is a formalization of the displacement algebras, their properties, and part of meta-theoretic analysis found in our POPL 2023 paper [“An Order-Theoretic Analysis of Universe Polymorphism”.](https://favonia.org/files/mugen.pdf) The accompanying OCaml implementation is at . 6 | 7 | 🚧 This repository is under major rewrites and cleanups. See version 0.1.0 for the code that matches the POPL 2023 paper. 8 | 9 | ## Mechanized Results 10 | 11 | ### Displacement Algebras 12 | 13 | 🚧 The links are currently broken. 14 | 15 | | Displacements | Paper Section | Agda Module | OCaml Module(s) | 16 | | :------------------------------------ | :--------------- | :----------------------------------------------------------------------------- | :------------------------------------------------------------------------------------------------------------------------------------------------------------------ | 17 | | Natural numbers | 3.3.1 | [Nat](src/Mugen/Algebra/Displacement/Instances/Nat.agda) | [Nat](https://redprl.org/mugen/mugen/Mugen/Shift/Nat) and [Nat](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/Nat) | 18 | | Integers | 3.3.1 | [Int](src/Mugen/Algebra/Displacement/Instances/Int.agda) | [Int](https://redprl.org/mugen/mugen/Mugen/Shift/Int) and [Int](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/Int) | 19 | | Non-positive integers | 3.3.1 | [NonPositive](src/Mugen/Algebra/Displacement/Instances/NonPositive.agda) | [NonPositive](https://redprl.org/mugen/mugen/Mugen/Shift/NonPositive) and [NonPositive](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/NonPositive) | 20 | | Constant displacements | 3.3.2 | [Constant](src/Mugen/Algebra/Displacement/Instances/Constant.agda) | [Constant](https://redprl.org/mugen/mugen/Mugen/Shift/Constant) | 21 | | Binary products | 3.3.3 | [Product](src/Mugen/Algebra/Displacement/Instances/Product.agda) | [Product](https://redprl.org/mugen/mugen/Mugen/Shift/Product) and [Product](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/Product) | 22 | | Lexicographic binary products | 3.3.4 | [Lexicographic](src/Mugen/Algebra/Displacement/Instances/Lexicographic.agda) | [Lexicographic](https://redprl.org/mugen/mugen/Mugen/Shift/Lexicographic) and [Lexicographic](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/Lexicographic) | 23 | | Indexed products | 3.3.5 | [IndexedProduct](src/Mugen/Algebra/Displacement/Instances/IndexedProduct.agda) | _(not implementable)_ | 24 | | Nearly constant infinite products | 3.3.5 | [NearlyConstant](src/Mugen/Algebra/Displacement/Instances/NearlyConstant.agda) | [NearlyConstant](https://redprl.org/mugen/mugen/Mugen/Shift/NearlyConstant) and [NearlyConstant](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/NearlyConstant) | 25 | | Infinite products with finite support | 3.3.5 | [FiniteSupport](src/Mugen/Algebra/Displacement/Instances/FiniteSupport.agda) | [FiniteSupport](https://redprl.org/mugen/mugen/Mugen/Shift/FiniteSupport) and [FiniteSupport](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin/FiniteSupport) | 26 | | Prefix order | 3.3.6 | [Prefix](src/Mugen/Algebra/Displacement/Instances/Prefix.agda) | [Prefix](https://redprl.org/mugen/mugen/Mugen/Shift/Prefix) | 27 | | Fractal displacements | 3.3.7 | [Fractal](src/Mugen/Algebra/Displacement/Instances/Fractal.agda) | [Fractal](https://redprl.org/mugen/mugen/Mugen/Shift/Fractal) | 28 | | Opposite displacements | 3.3.8 | [Opposite](src/Mugen/Algebra/Displacement/Instances/Opposite.agda) | [Opposite](https://redprl.org/mugen/mugen/Mugen/Shift/Opposite) | 29 | | Weird fractal displacements | 3.3.9 (JFP only) | [WeirdFractal](src/Mugen/Algebra/Displacement/Instances/WeirdFractal.agda) | [Fractal](https://redprl.org/mugen/mugen/Mugen/Shift/Fractal) | 30 | | Endomorphisms | 3.4 (Lemma 3.7) | [Endomorphism](src/Mugen/Algebra/Displacement/Instances/Endomorphism.agda) | _(not implementable)_ | 31 | 32 | ### Other Theorems 33 | 34 | | Theorems | Paper Section | Agda Module | 35 | | :------------------------------------ | :----------------- | :----------------------------------------------------------------------------------------------- | 36 | | Traditional level polymorphism | 2.2 | [Traditional](./src/Mugen/Cat/HierarchyTheory/Traditional.agda) | 37 | | Validity of McBride monads | 3.1 | [McBride](./src/Mugen/Cat/HierarchyTheory/McBride.agda) | 38 | | Embedding of endomorphisms | 3.4 (Lemma 3.8) | [EndomorphismEmbedding](./src/Mugen/Cat/HierarchyTheory/Universality/EndomorphismEmbedding.agda) | 39 | | Embedding of small hierarchy theories | 3.4 (Lemma 3.9) | [SubcategoryEmbedding](./src/Mugen/Cat/HierarchyTheory/Universality/SubcategoryEmbedding.agda) | 40 | | Universality of McBride monads | 3.4 (Theorem 3.10) | [Universality](./src/Mugen/Cat/HierarchyTheory/Universality.agda) | 41 | 42 | ## Building 43 | 44 | Run the following command to check formalization. 45 | 46 | ```sh 47 | docker build -t agda-mugen:edge . 48 | docker run agda-mugen:edge 49 | ``` 50 | -------------------------------------------------------------------------------- /agda-mugen.agda-lib: -------------------------------------------------------------------------------- 1 | name: agda-mugen 2 | depend: 1lab 3 | include: 4 | src 5 | wip 6 | flags: 7 | --cubical 8 | --no-load-primitives 9 | --postfix-projections 10 | --rewriting 11 | --guardedness 12 | -WnoUnsupportedIndexedMatch -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement where 2 | 3 | open import Algebra.Magma 4 | open import Algebra.Monoid 5 | open import Algebra.Semigroup 6 | 7 | open import Mugen.Prelude 8 | open import Mugen.Algebra.OrderedMonoid 9 | open import Mugen.Order.StrictOrder 10 | 11 | import Mugen.Order.Reasoning as Reasoning 12 | 13 | private variable 14 | o o' o'' r r' r'' : Level 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Displacement Algebras 18 | -- 19 | -- Like ordered monoids, we view displacement algebras as structures 20 | -- over an order. 21 | 22 | record is-displacement 23 | (A : Poset o r) 24 | (ε : ⌞ A ⌟) (_⊗_ : ⌞ A ⌟ → ⌞ A ⌟ → ⌞ A ⌟) 25 | : Type (o ⊔ r) 26 | where 27 | no-eta-equality 28 | open Reasoning A 29 | field 30 | has-is-monoid : is-monoid ε _⊗_ 31 | 32 | -- This formulation is constructively MUCH NICER than 33 | -- ∀ {x y z} → y < z → (x ⊗ y) < (x ⊗ z) 34 | -- The reason is that the second part of '_<_' is a negation, 35 | -- and a function between two negated types '(A → ⊥) → (B → ⊥)' 36 | -- is not constructively sufficient for proving that an indexed 37 | -- product is a displacement algebra. What will work is the 38 | -- slightly more "constructive" version, 'B → A'. 39 | -- 40 | -- Note: we did not /prove/ that the naive formulation is not 41 | -- constructively working. 42 | left-strict-invariant : ∀ {x y z} → y ≤ z → (x ⊗ y) ≤[ y ≡ z ] (x ⊗ z) 43 | 44 | abstract 45 | left-invariant : ∀ {x y z} → y ≤ z → (x ⊗ y) ≤ (x ⊗ z) 46 | left-invariant y≤z = left-strict-invariant y≤z .fst 47 | 48 | injectiver-on-related : ∀ {x y z} → y ≤ z → (x ⊗ y) ≡ (x ⊗ z) → y ≡ z 49 | injectiver-on-related y≤z = left-strict-invariant y≤z .snd 50 | 51 | open is-monoid has-is-monoid hiding (has-is-set) public 52 | 53 | record Displacement-on (A : Poset o r) : Type (o ⊔ lsuc r) where 54 | field 55 | ε : ⌞ A ⌟ 56 | _⊗_ : ⌞ A ⌟ → ⌞ A ⌟ → ⌞ A ⌟ 57 | has-is-displacement : is-displacement A ε _⊗_ 58 | 59 | open is-displacement has-is-displacement public 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Homomorphisms of Displacement Algebras 63 | 64 | module _ 65 | {A : Poset o r} {B : Poset o' r'} 66 | (X : Displacement-on A) (Y : Displacement-on B) 67 | where 68 | 69 | private 70 | module A = Reasoning A 71 | module B = Reasoning B 72 | module X = Displacement-on X 73 | module Y = Displacement-on Y 74 | 75 | record is-displacement-hom (f : Strictly-monotone A B) : Type (o ⊔ o') where 76 | no-eta-equality 77 | open Strictly-monotone f 78 | field 79 | pres-ε : hom X.ε ≡ Y.ε 80 | pres-⊗ : ∀ {x y : ⌞ A ⌟} → hom (x X.⊗ y) ≡ (hom x Y.⊗ hom y) 81 | 82 | abstract 83 | is-displacement-hom-is-prop 84 | : (f : Strictly-monotone A B) 85 | → is-prop (is-displacement-hom f) 86 | is-displacement-hom-is-prop f = 87 | Iso→is-hlevel 1 eqv $ 88 | Σ-is-hlevel 1 (B.Ob-is-set _ _) λ _ → 89 | Π-is-hlevel' 1 λ _ → Π-is-hlevel' 1 λ _ → B.Ob-is-set _ _ 90 | where unquoteDecl eqv = declare-record-iso eqv (quote is-displacement-hom) 91 | 92 | abstract instance 93 | H-Level-is-displacement : ∀ {n} 94 | {A : Poset o r} {B : Poset o' r'} 95 | {X : Displacement-on A} {Y : Displacement-on B} 96 | {f : Strictly-monotone A B} → 97 | H-Level (is-displacement-hom X Y f) (suc n) 98 | H-Level-is-displacement {X = X} {Y} {f} = prop-instance (is-displacement-hom-is-prop X Y f) 99 | 100 | id-is-displacement-hom 101 | : {A : Poset o r} (X : Displacement-on A) 102 | → is-displacement-hom X X strictly-monotone-id 103 | id-is-displacement-hom X .is-displacement-hom.pres-ε = refl 104 | id-is-displacement-hom X .is-displacement-hom.pres-⊗ = refl 105 | 106 | ∘-is-displacement-hom 107 | : {A : Poset o r} {B : Poset o' r'} {C : Poset o'' r''} 108 | {X : Displacement-on A} {Y : Displacement-on B} {Z : Displacement-on C} 109 | {f : Strictly-monotone B C} {g : Strictly-monotone A B} 110 | → is-displacement-hom Y Z f 111 | → is-displacement-hom X Y g 112 | → is-displacement-hom X Z (strictly-monotone-∘ f g) 113 | ∘-is-displacement-hom {f = f} f-disp g-disp .is-displacement-hom.pres-ε = 114 | ap# f (g-disp .is-displacement-hom.pres-ε) ∙ f-disp .is-displacement-hom.pres-ε 115 | ∘-is-displacement-hom {f = f} {g = g} f-disp g-disp .is-displacement-hom.pres-⊗ {x} {y} = 116 | ap# f (g-disp .is-displacement-hom.pres-⊗ {x} {y}) ∙ f-disp .is-displacement-hom.pres-⊗ {g # x} {g # y} 117 | 118 | -------------------------------------------------------------------------------- 119 | -- Some Properties of Displacement Algebras 120 | 121 | module _ 122 | (A : Poset o r) 123 | {ε : ⌞ A ⌟} {_⊗_ : ⌞ A ⌟ → ⌞ A ⌟ → ⌞ A ⌟} 124 | (𝒟 : is-displacement A ε _⊗_) 125 | where 126 | private 127 | module A = Poset A 128 | module 𝒟 = is-displacement 𝒟 129 | 130 | is-right-invariant-displacement→is-ordered-monoid 131 | : (∀ {x y z} → x A.≤ y → (x ⊗ z) A.≤ (y ⊗ z)) 132 | → is-ordered-monoid A ε _⊗_ 133 | is-right-invariant-displacement→is-ordered-monoid right-invariant = om where 134 | om : is-ordered-monoid A ε _⊗_ 135 | om .is-ordered-monoid.has-is-monoid = 𝒟.has-is-monoid 136 | om .is-ordered-monoid.invariant w≤y x≤z = 137 | A.≤-trans (right-invariant w≤y) (𝒟.left-invariant x≤z) 138 | 139 | module _ {A : Poset o r} (𝒟 : Displacement-on A) where 140 | open Reasoning A 141 | open Displacement-on 𝒟 142 | 143 | -- Ordered Monoids 144 | has-ordered-monoid : Type (o ⊔ r) 145 | has-ordered-monoid = is-ordered-monoid A ε _⊗_ 146 | 147 | right-invariant→has-ordered-monoid : (∀ {x y z} → x ≤ y → (x ⊗ z) ≤ (y ⊗ z)) → has-ordered-monoid 148 | right-invariant→has-ordered-monoid = 149 | is-right-invariant-displacement→is-ordered-monoid A has-is-displacement 150 | 151 | -------------------------------------------------------------------------------- 152 | -- Builders 153 | 154 | record make-displacement (A : Poset o r) : Type (o ⊔ r) where 155 | no-eta-equality 156 | open Reasoning A 157 | field 158 | ε : ⌞ A ⌟ 159 | _⊗_ : ⌞ A ⌟ → ⌞ A ⌟ → ⌞ A ⌟ 160 | idl : ∀ {x} → ε ⊗ x ≡ x 161 | idr : ∀ {x} → x ⊗ ε ≡ x 162 | associative : ∀ {x y z} → x ⊗ (y ⊗ z) ≡ (x ⊗ y) ⊗ z 163 | left-strict-invariant : ∀ {x y z} → y ≤ z → (x ⊗ y) ≤[ y ≡ z ] (x ⊗ z) 164 | 165 | module _ {A : Poset o r} where 166 | open Displacement-on 167 | open is-displacement 168 | open make-displacement 169 | 170 | to-displacement-on : make-displacement A → Displacement-on A 171 | to-displacement-on mk .ε = mk .ε 172 | to-displacement-on mk ._⊗_ = mk ._⊗_ 173 | to-displacement-on mk .has-is-displacement .has-is-monoid .has-is-semigroup .has-is-magma .is-magma.has-is-set = Poset.Ob-is-set A 174 | to-displacement-on mk .has-is-displacement .has-is-monoid .has-is-semigroup .associative = mk .associative 175 | to-displacement-on mk .has-is-displacement .has-is-monoid .idl = mk .idl 176 | to-displacement-on mk .has-is-displacement .has-is-monoid .idr = mk .idr 177 | to-displacement-on mk .has-is-displacement .left-strict-invariant = mk .left-strict-invariant 178 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Action.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Action where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Algebra.Displacement 5 | 6 | import Mugen.Order.Reasoning as Reasoning 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Right Displacement Actions 10 | 11 | record Right-displacement-action 12 | {o r o' r'} (A : Poset o r) {B : Poset o' r'} (Y : Displacement-on B) 13 | : Type (o ⊔ r ⊔ o' ⊔ r') 14 | where 15 | private 16 | module A = Reasoning A 17 | module B = Reasoning B 18 | module Y = Displacement-on Y 19 | field 20 | _⋆_ : ⌞ A ⌟ → ⌞ B.Ob ⌟ → ⌞ A ⌟ 21 | identity : ∀ {a} → a ⋆ Y.ε ≡ a 22 | compatible : ∀ {a x y} → a ⋆ (x Y.⊗ y) ≡ (a ⋆ x) ⋆ y 23 | strict-invariant : ∀ {a x y} → x B.≤ y → (a ⋆ x) A.≤[ x ≡ y ] (a ⋆ y) 24 | 25 | abstract 26 | invariant : ∀ {a x y} → x B.≤ y → (a ⋆ x) A.≤ (a ⋆ y) 27 | invariant {a} {x} {y} x≤y = strict-invariant {a} {x} {y} x≤y .fst 28 | 29 | injectiver-on-related : ∀ {a x y} → x B.≤ y → (a ⋆ x) ≡ (a ⋆ y) → x ≡ y 30 | injectiver-on-related {a} {x} {y} x≤y = strict-invariant {a} {x} {y} x≤y .snd 31 | 32 | module _ where 33 | open Right-displacement-action 34 | 35 | opaque 36 | Right-displacement-action-path 37 | : ∀ {o r o' r'} 38 | → {A : Poset o r} {B : Poset o' r'} {Y : Displacement-on B} 39 | → (α β : Right-displacement-action A Y) 40 | → (∀ {a b} → (α ._⋆_ a b) ≡ (β ._⋆_ a b)) 41 | → α ≡ β 42 | Right-displacement-action-path α β p i ._⋆_ a b = p {a} {b} i 43 | Right-displacement-action-path α β p i .identity = 44 | is-prop→pathp (λ i → hlevel 2 (p i) _) (α .identity) (β .identity) i 45 | Right-displacement-action-path α β p i .compatible = 46 | is-prop→pathp (λ i → hlevel 2 (p i) (p {p i} i)) (α .compatible) (β .compatible) i 47 | Right-displacement-action-path {A = A} α β p i .strict-invariant q = 48 | let module A = Reasoning A in 49 | is-prop→pathp 50 | (λ i → A.≤[]-is-hlevel {x = p i} {y = p i} 0 $ hlevel 1) 51 | (α .strict-invariant q) (β .strict-invariant q) i 52 | 53 | instance 54 | Right-actionlike-displacement-action 55 | : ∀ {o r o' r'} 56 | → Right-actionlike λ (A : Poset o r) (B : Σ (Poset o' r') Displacement-on) → 57 | Right-displacement-action A (B .snd) 58 | Right-actionlike.⟦ Right-actionlike-displacement-action ⟧ʳ = 59 | Right-displacement-action._⋆_ 60 | Right-actionlike-displacement-action .Right-actionlike.extʳ = 61 | Right-displacement-action-path _ _ 62 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Constant.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Constant where 2 | 3 | open import Order.Instances.Coproduct 4 | open import Mugen.Prelude hiding (Const) 5 | 6 | open import Mugen.Algebra.Displacement 7 | open import Mugen.Algebra.Displacement.Action 8 | open import Mugen.Algebra.OrderedMonoid 9 | 10 | import Mugen.Order.Reasoning as Reasoning 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Constant Displacements 14 | -- Section 3.3.2 15 | -- 16 | -- Given a strict order 'A', a displacement algebra 'B', and a right displacement 17 | -- action 'α : A → B → A', we can construct a displacement algebra whose carrier 18 | -- is 'A ⊎ B'. Multiplication of an 'inl a' and 'inr b' uses the 'α' to have 19 | -- 'b' act upon 'a'. 20 | 21 | Constant 22 | : ∀ {o r} {A B : Poset o r} {Y : Displacement-on B} 23 | → Right-displacement-action A Y 24 | → Displacement-on (A ⊎ᵖ B) 25 | Constant {A = A} {B = B} {Y = Y} α = to-displacement-on mk where 26 | module A = Poset A 27 | module B = Reasoning B 28 | module Y = Displacement-on Y 29 | module α = Right-displacement-action α 30 | open Reasoning (A ⊎ᵖ B) 31 | 32 | _⊗_ : ⌞ A ⌟ ⊎ ⌞ B ⌟ → ⌞ A ⌟ ⊎ ⌞ B ⌟ → ⌞ A ⌟ ⊎ ⌞ B ⌟ 33 | _ ⊗ inl a = inl a 34 | inl a ⊗ inr x = inl (⟦ α ⟧ʳ a x) 35 | inr x ⊗ inr y = inr (x Y.⊗ y) 36 | 37 | ε : ⌞ A ⌟ ⊎ ⌞ B ⌟ 38 | ε = inr Y.ε 39 | 40 | associative : ∀ (x y z : ⌞ A ⌟ ⊎ ⌞ B ⌟) → (x ⊗ (y ⊗ z)) ≡ ((x ⊗ y) ⊗ z) 41 | associative _ _ (inl _) = refl 42 | associative _ (inl _) (inr _) = refl 43 | associative (inl a) (inr y) (inr z) = ap inl α.compatible 44 | associative (inr x) (inr y) (inr z) = ap inr Y.associative 45 | 46 | idl : ∀ (x : ⌞ A ⌟ ⊎ ⌞ B ⌟) → (ε ⊗ x) ≡ x 47 | idl (inl x) = refl 48 | idl (inr x) = ap inr Y.idl 49 | 50 | idr : ∀ (x : ⌞ A ⌟ ⊎ ⌞ B ⌟) → (x ⊗ ε) ≡ x 51 | idr (inl x) = ap inl α.identity 52 | idr (inr x) = ap inr Y.idr 53 | 54 | left-invariant : ∀ (x y z : ⌞ A ⌟ ⊎ ⌞ B ⌟) → y ≤ z → (x ⊗ y) ≤ (x ⊗ z) 55 | left-invariant _ (inl y) (inl z) y≤z = y≤z 56 | left-invariant (inl x) (inr y) (inr z) (lift y≤z) = lift $ α.invariant y≤z 57 | left-invariant (inr x) (inr y) (inr z) (lift y≤z) = lift $ Y.left-invariant y≤z 58 | 59 | injectiver-on-related : ∀ (x y z : ⌞ A ⌟ ⊎ ⌞ B ⌟) → y ≤ z → (x ⊗ y) ≡ (x ⊗ z) → y ≡ z 60 | injectiver-on-related _ (inl y) (inl z) _ p = p 61 | injectiver-on-related (inl x) (inr y) (inr z) (lift y≤z) p = 62 | ap inr $ α.injectiver-on-related y≤z (inl-inj p) 63 | injectiver-on-related (inr x) (inr y) (inr z) (lift y≤z) p = 64 | ap inr $ Y.injectiver-on-related y≤z (inr-inj p) 65 | 66 | mk : make-displacement (A ⊎ᵖ B) 67 | mk .make-displacement.ε = ε 68 | mk .make-displacement._⊗_ = _⊗_ 69 | mk .make-displacement.idl {x} = idl x 70 | mk .make-displacement.idr {x} = idr x 71 | mk .make-displacement.associative {x} {y} {z} = associative x y z 72 | mk .make-displacement.left-strict-invariant {x} {y} {z} p .fst = left-invariant x y z p 73 | mk .make-displacement.left-strict-invariant {x} {y} {z} p .snd = injectiver-on-related x y z p 74 | 75 | module _ 76 | {o r} {A B : Poset o r} {Y : Displacement-on B} 77 | (α : Right-displacement-action A Y) where 78 | private 79 | module A = Poset A 80 | module B = Poset B 81 | module Y = Displacement-on Y 82 | open Reasoning (A ⊎ᵖ B) 83 | open Displacement-on (Constant α) 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Ordered Monoid 87 | 88 | Constant-has-ordered-monoid 89 | : has-ordered-monoid Y 90 | → (∀ {x y : ⌞ A ⌟} {z : ⌞ B ⌟} → x A.≤ y → ⟦ α ⟧ʳ x z A.≤ ⟦ α ⟧ʳ y z) 91 | → has-ordered-monoid (Constant α) 92 | Constant-has-ordered-monoid B-ordered-monoid α-right-invariant = 93 | let module B-ordered-monoid = is-ordered-monoid B-ordered-monoid in 94 | right-invariant→has-ordered-monoid (Constant α) λ where 95 | {x} {y} {inl z} x≤y → ≤-refl {inl z} 96 | {inl x} {inl y} {inr z} (lift x≤y) → lift $ α-right-invariant x≤y 97 | {inr x} {inr y} {inr z} (lift x≤y) → lift $ B-ordered-monoid.right-invariant x≤y 98 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Endomorphism.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | module Mugen.Algebra.Displacement.Instances.Endomorphism where 3 | 4 | open import Algebra.Magma 5 | open import Algebra.Monoid 6 | open import Algebra.Semigroup 7 | 8 | open import Cat.Diagram.Monad 9 | import Cat.Reasoning as Cat 10 | 11 | open import Mugen.Prelude 12 | 13 | open import Mugen.Algebra.Displacement 14 | open import Mugen.Cat.Monad 15 | open import Mugen.Cat.Instances.StrictOrders 16 | open import Mugen.Order.StrictOrder 17 | open import Mugen.Order.Instances.Endomorphism 18 | renaming (Endomorphism to Endomorphism-poset) 19 | 20 | import Mugen.Order.Reasoning as Reasoning 21 | 22 | private variable 23 | o r : Level 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Endomorphism Displacements 27 | -- Section 3.4 28 | -- 29 | -- Given a Monad 'H' on the category of strict orders, we can construct a displacement 30 | -- algebra whose carrier set is the set of endomorphisms 'Free H Δ → Free H Δ' between 31 | -- free H-algebras in the Eilenberg-Moore category. 32 | open Algebra-hom 33 | 34 | module _ (H : Monad (Strict-orders o r)) (Δ : Poset o r) where 35 | private 36 | module H = Monad H 37 | module EM = Cat (Eilenberg-Moore (Strict-orders o r) H) 38 | module Endo = Reasoning (Endomorphism-poset H Δ) 39 | 40 | Fᴴ⟨Δ⟩ : Algebra (Strict-orders o r) H 41 | Fᴴ⟨Δ⟩ = Functor.F₀ (Free (Strict-orders o r) H) Δ 42 | 43 | Endomorphism-type : Type (lsuc o ⊔ lsuc r) 44 | Endomorphism-type = EM.Hom Fᴴ⟨Δ⟩ Fᴴ⟨Δ⟩ 45 | 46 | -------------------------------------------------------------------------------- 47 | -- Left Invariance 48 | 49 | ∘-left-strict-invariant : ∀ (σ δ τ : Endomorphism-type) 50 | → δ Endo.≤ τ → σ EM.∘ δ Endo.≤[ δ ≡ τ ] σ EM.∘ τ 51 | ∘-left-strict-invariant σ δ τ δ≤τ = 52 | (λ α → Strictly-monotone.pres-≤ (σ .morphism) (δ≤τ α)) , 53 | λ p → free-algebra-hom-path H $ ext λ α → 54 | Strictly-monotone.injective-on-related (σ .morphism) (δ≤τ α) (p #ₚ (H.unit.η Δ # α)) 55 | 56 | -------------------------------------------------------------------------------- 57 | -- Bundles 58 | -- 59 | -- We do this with copatterns for performance reasons. 60 | 61 | open Displacement-on 62 | 63 | Endomorphism : Displacement-on (Endomorphism-poset H Δ) 64 | Endomorphism .ε = EM.id 65 | Endomorphism ._⊗_ = EM._∘_ 66 | Endomorphism .has-is-displacement .is-displacement.has-is-monoid .has-is-semigroup .has-is-magma .has-is-set = Endo.Ob-is-set 67 | Endomorphism .has-is-displacement .is-displacement.has-is-monoid .has-is-semigroup .associative = EM.assoc _ _ _ 68 | Endomorphism .has-is-displacement .is-displacement.has-is-monoid .idl = EM.idl _ 69 | Endomorphism .has-is-displacement .is-displacement.has-is-monoid .idr = EM.idr _ 70 | Endomorphism .has-is-displacement .is-displacement.left-strict-invariant {σ} {δ} {τ} = ∘-left-strict-invariant σ δ τ 71 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Fractal.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Fractal where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Algebra.Displacement 5 | open import Mugen.Data.NonEmpty 6 | open import Mugen.Order.Instances.Fractal 7 | 8 | import Mugen.Order.Reasoning as Reasoning 9 | 10 | variable 11 | o r : Level 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Fractal Displacements 15 | -- Section 3.3.7 16 | 17 | module _ {A : Poset o r} (𝒟 : Displacement-on A) where 18 | private 19 | module A = Reasoning A 20 | module F = Reasoning (Fractal A) 21 | module 𝒟 = Displacement-on 𝒟 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Algebra 25 | 26 | _⊗_ : List⁺ ⌞ A ⌟ → List⁺ ⌞ A ⌟ → List⁺ ⌞ A ⌟ 27 | [ x ] ⊗ [ y ] = [ x 𝒟.⊗ y ] 28 | [ x ] ⊗ (y ∷ ys) = (x 𝒟.⊗ y) ∷ ys 29 | (x ∷ xs) ⊗ ys = x ∷ (xs ⊗ ys) 30 | 31 | ε : List⁺ ⌞ A ⌟ 32 | ε = [ 𝒟.ε ] 33 | 34 | abstract 35 | associative : (xs ys zs : List⁺ ⌞ A ⌟) → (xs ⊗ (ys ⊗ zs)) ≡ ((xs ⊗ ys) ⊗ zs) 36 | associative [ x ] [ y ] [ z ] = ap [_] 𝒟.associative 37 | associative [ x ] [ y ] (z ∷ zs) = ap (_∷ zs) 𝒟.associative 38 | associative [ x ] (y ∷ ys) zs = refl 39 | associative (x ∷ xs) ys zs = ap (x ∷_) $ associative xs ys zs 40 | 41 | idl : (xs : List⁺ ⌞ A ⌟) → (ε ⊗ xs) ≡ xs 42 | idl [ x ] = ap [_] 𝒟.idl 43 | idl (x ∷ xs) = ap (_∷ xs) 𝒟.idl 44 | 45 | idr : (xs : List⁺ ⌞ A ⌟) → (xs ⊗ ε) ≡ xs 46 | idr [ x ] = ap [_] 𝒟.idr 47 | idr (x ∷ xs) = ap (x ∷_) $ idr xs 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Left Invariance 51 | 52 | abstract 53 | left-invariant : (xs ys zs : List⁺ ⌞ A ⌟) → ys F.≤ zs → (xs ⊗ ys) F.≤ (xs ⊗ zs) 54 | left-invariant [ x ] [ y ] [ z ] (single≤ y≤z) = 55 | single≤ (𝒟.left-invariant y≤z) 56 | left-invariant [ x ] (y ∷ ys) (z ∷ zs) (tail≤ y≤z ys≤zs) = 57 | tail≤ (𝒟.left-invariant y≤z) λ xy=xz → ys≤zs (𝒟.injectiver-on-related y≤z xy=xz) 58 | left-invariant (x ∷ xs) ys zs ys≤zs = 59 | tail≤ A.≤-refl λ _ → left-invariant xs ys zs ys≤zs 60 | 61 | injectiver-on-related : (xs ys zs : List⁺ ⌞ A ⌟) → ys F.≤ zs → xs ⊗ ys ≡ xs ⊗ zs → ys ≡ zs 62 | injectiver-on-related [ x ] [ y ] [ z ] (single≤ y≤z) p = 63 | ap [_] $ 𝒟.injectiver-on-related y≤z $ []-inj p 64 | injectiver-on-related [ x ] (y ∷ ys) (z ∷ zs) (tail≤ y≤z _) p = 65 | ap₂ _∷_ (𝒟.injectiver-on-related y≤z (∷-head-inj p)) (∷-tail-inj p) 66 | injectiver-on-related (x ∷ xs) ys zs ys≤zs p = 67 | injectiver-on-related xs ys zs ys≤zs (∷-tail-inj p) 68 | 69 | -------------------------------------------------------------------------------- 70 | -- Displacement Algebra 71 | 72 | Fractal-displacement : Displacement-on (Fractal A) 73 | Fractal-displacement = to-displacement-on mk where 74 | mk : make-displacement (Fractal A) 75 | mk .make-displacement.ε = ε 76 | mk .make-displacement._⊗_ = _⊗_ 77 | mk .make-displacement.idl = idl _ 78 | mk .make-displacement.idr = idr _ 79 | mk .make-displacement.associative = associative _ _ _ 80 | mk .make-displacement.left-strict-invariant p = 81 | left-invariant _ _ _ p , injectiver-on-related _ _ _ p 82 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/IndexedProduct.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.IndexedProduct where 2 | 3 | open import Order.Instances.Pointwise 4 | 5 | open import Mugen.Prelude 6 | open import Mugen.Order.Instances.Pointwise 7 | open import Mugen.Algebra.Displacement 8 | open import Mugen.Algebra.OrderedMonoid 9 | 10 | import Mugen.Order.Reasoning as Reasoning 11 | 12 | private variable 13 | o o' r r' : Level 14 | 15 | -------------------------------------------------------------------------------- 16 | -- Product of Indexed Displacements 17 | -- POPL 2023 Section 3.3.5 discussed the special case where I = Nat and 𝒟 is a constant family 18 | -- 19 | -- The product of indexed displacement algebras consists 20 | -- of functions '(i : I) → 𝒟 i'. Multiplication is performed pointwise, 21 | -- and ordering is given by 'f ≤ g' if '∀ i. f i ≤ g i'. 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Displacement Algebra 25 | 26 | module _ (I : Type o) {A : I → Poset o' r'} (𝒟 : (i : I) → Displacement-on (A i)) where 27 | private 28 | module 𝒟 (i : I) = Displacement-on (𝒟 i) 29 | 30 | IndexedProduct : Displacement-on (Pointwise I A) 31 | IndexedProduct = to-displacement-on mk where 32 | mk : make-displacement (Pointwise I A) 33 | mk .make-displacement.ε = 𝒟.ε 34 | mk .make-displacement._⊗_ = pointwise-map₂ 𝒟._⊗_ 35 | mk .make-displacement.idl = funext λ i → 𝒟.idl i 36 | mk .make-displacement.idr = funext λ i → 𝒟.idr i 37 | mk .make-displacement.associative = funext λ i → 𝒟.associative i 38 | mk .make-displacement.left-strict-invariant g≤h .fst i = 𝒟.left-invariant i (g≤h i) 39 | mk .make-displacement.left-strict-invariant g≤h .snd fg=fh = 40 | funext λ i → 𝒟.injectiver-on-related i (g≤h i) (happly fg=fh i) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Additional properties 44 | 45 | module _ (I : Type o) {A : I → Poset o' r'} (𝒟 : (i : I) → Displacement-on (A i)) where 46 | private module A = Reasoning (Pointwise I A) 47 | private module 𝒟 = Displacement-on (IndexedProduct I 𝒟) 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Ordered Monoid 51 | 52 | IndexedProduct-has-ordered-monoid 53 | : (∀ i → has-ordered-monoid (𝒟 i)) → has-ordered-monoid (IndexedProduct I 𝒟) 54 | IndexedProduct-has-ordered-monoid 𝒟-om = 55 | let open module M (i : I) = is-ordered-monoid (𝒟-om i) in 56 | right-invariant→has-ordered-monoid (IndexedProduct I 𝒟) λ f≤g i → right-invariant i (f≤g i) 57 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Int.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Int where 2 | 3 | open import Data.Int 4 | open import Order.Instances.Int 5 | 6 | open import Mugen.Prelude 7 | open import Mugen.Algebra.Displacement 8 | open import Mugen.Order.Instances.Int 9 | 10 | -------------------------------------------------------------------------------- 11 | -- Integers 12 | -- Section 3.3.1 13 | -- 14 | -- This is the evident displacement algebra on the integers. 15 | -- All of the interesting properties are proved in 'Mugen.Data.Int'; 16 | -- this module serves only to bundle them together. 17 | 18 | Int-displacement : Displacement-on Int-poset 19 | Int-displacement = to-displacement-on mk where 20 | mk : make-displacement Int-poset 21 | mk .make-displacement.ε = pos 0 22 | mk .make-displacement._⊗_ = _+ℤ_ 23 | mk .make-displacement.idl = +ℤ-zerol _ 24 | mk .make-displacement.idr = +ℤ-zeror _ 25 | mk .make-displacement.associative {x} {y} {z} = +ℤ-assoc x y z 26 | mk .make-displacement.left-strict-invariant {x} {y} {z} p = 27 | +ℤ-mono-l x y z p , +ℤ-injectiver x y z 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Ordered Monoid 31 | 32 | Int-has-ordered-monoid : has-ordered-monoid Int-displacement 33 | Int-has-ordered-monoid = 34 | right-invariant→has-ordered-monoid Int-displacement $ +ℤ-mono-r _ _ _ 35 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Lexicographic.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Lexicographic where 2 | 3 | open import Algebra.Magma 4 | open import Algebra.Monoid 5 | open import Algebra.Semigroup 6 | 7 | open import Mugen.Prelude 8 | open import Mugen.Algebra.Displacement 9 | open import Mugen.Algebra.Displacement.Instances.Product 10 | open import Mugen.Algebra.OrderedMonoid 11 | open import Mugen.Order.Instances.Lexicographic 12 | 13 | import Mugen.Order.Reasoning as Reasoning 14 | 15 | private variable 16 | o o' r r' : Level 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Lexicographic Products 20 | -- Section 3.3.4 21 | -- 22 | -- The lexicographic product of 2 displacement algebras consists of their product 23 | -- as monoids, as well as their lexicographic product as orders. 24 | -- 25 | -- As noted earlier, algebraic structure is given by the product of monoids, so we don't need 26 | -- to prove that here. 27 | 28 | module _ 29 | {A : Poset o r} {B : Poset o' r'} 30 | (𝒟₁ : Displacement-on A) (𝒟₂ : Displacement-on B) 31 | where 32 | private 33 | module 𝒟₁ = Displacement-on 𝒟₁ 34 | module 𝒟₂ = Displacement-on 𝒟₂ 35 | module P = Displacement-on (Product 𝒟₁ 𝒟₂) 36 | module L = Reasoning (Lexicographic A B) 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Left Invariance 40 | 41 | abstract 42 | left-strict-invariant : ∀ x y z → y L.≤ z → (x P.⊗ y) L.≤[ y ≡ z ] (x P.⊗ z) 43 | left-strict-invariant x y z (y1≤z1 , y2≤z2) = 44 | (𝒟₁.left-invariant y1≤z1 , λ p → 𝒟₂.left-invariant (y2≤z2 (𝒟₁.injectiver-on-related y1≤z1 p))) , 45 | λ p i → 46 | let y1=z1 = 𝒟₁.injectiver-on-related y1≤z1 (ap fst p) in 47 | y1=z1 i , 𝒟₂.injectiver-on-related (y2≤z2 y1=z1) (ap snd p) i 48 | 49 | -- TODO: refactor with Product 50 | LexicographicProduct : Displacement-on (Lexicographic A B) 51 | LexicographicProduct = to-displacement-on mk 52 | where 53 | mk : make-displacement (Lexicographic A B) 54 | mk .make-displacement.ε = P.ε 55 | mk .make-displacement._⊗_ = P._⊗_ 56 | mk .make-displacement.idl = P.idl 57 | mk .make-displacement.idr = P.idr 58 | mk .make-displacement.associative = P.associative 59 | mk .make-displacement.left-strict-invariant = left-strict-invariant _ _ _ 60 | 61 | module _ 62 | {A : Poset o r} {B : Poset o' r'} 63 | {𝒟₁ : Displacement-on A} {𝒟₂ : Displacement-on B} 64 | where 65 | private 66 | module A = Reasoning A 67 | module 𝒟₁ = Displacement-on 𝒟₁ 68 | module 𝒟₂ = Displacement-on 𝒟₂ 69 | module L = Reasoning (Lexicographic A B) 70 | open Displacement-on (LexicographicProduct 𝒟₁ 𝒟₂) 71 | 72 | -------------------------------------------------------------------------------- 73 | -- Ordered Monoids 74 | 75 | -- When 𝒟₁ is /strictly/ right invariant and 𝒟₂ is an ordered monoid, 76 | -- then 'Lex 𝒟₁ 𝒟₂' is also an ordered monoid. 77 | lex-has-ordered-monoid 78 | : has-ordered-monoid 𝒟₁ 79 | → (∀ {x y z} → x A.≤ y → (x 𝒟₁.⊗ z) ≡ (y 𝒟₁.⊗ z) → x ≡ y) 80 | → has-ordered-monoid 𝒟₂ 81 | → has-ordered-monoid (LexicographicProduct 𝒟₁ 𝒟₂) 82 | lex-has-ordered-monoid 𝒟₁-ordered-monoid 𝒟₁-injl-on-related 𝒟₂-ordered-monoid = 83 | right-invariant→has-ordered-monoid (LexicographicProduct 𝒟₁ 𝒟₂) lex-right-invariant 84 | where 85 | module 𝒟₁-ordered-monoid = is-ordered-monoid 𝒟₁-ordered-monoid 86 | module 𝒟₂-ordered-monoid = is-ordered-monoid 𝒟₂-ordered-monoid 87 | 88 | lex-right-invariant : ∀ {x y z} → x L.≤ y → (x ⊗ z) L.≤ (y ⊗ z) 89 | lex-right-invariant (y1≤z1 , y2≤z2) = 90 | 𝒟₁-ordered-monoid.right-invariant y1≤z1 , λ p → 91 | 𝒟₂-ordered-monoid.right-invariant (y2≤z2 (𝒟₁-injl-on-related y1≤z1 p)) 92 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Nat.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Nat where 2 | 3 | open import Data.Nat 4 | open import Data.Int 5 | 6 | open import Mugen.Prelude 7 | open import Mugen.Algebra.Displacement 8 | open import Mugen.Algebra.Displacement.Subalgebra 9 | open import Mugen.Algebra.Displacement.Instances.Int 10 | open import Mugen.Order.StrictOrder 11 | open import Mugen.Order.Instances.Nat 12 | open import Mugen.Order.Instances.Int 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Natural Numbers 16 | -- Section 3.3.1 17 | -- 18 | -- This is the evident displacement algebra on natural numbers. 19 | -- All of the interesting algebraic/order theoretic properties are proven in 20 | -- 'Mugen.Data.Nat'; this module is just bundling together those proofs. 21 | 22 | Nat-displacement : Displacement-on Nat-poset 23 | Nat-displacement = to-displacement-on mk where 24 | mk : make-displacement Nat-poset 25 | mk .make-displacement.ε = 0 26 | mk .make-displacement._⊗_ = _+_ 27 | mk .make-displacement.idl = refl 28 | mk .make-displacement.idr = +-zeror _ 29 | mk .make-displacement.associative {x} {y} {z} = +-associative x y z 30 | mk .make-displacement.left-strict-invariant p = 31 | +-preserves-≤l _ _ _ p , +-inj _ _ _ 32 | 33 | -------------------------------------------------------------------------------- 34 | -- Ordered Monoid 35 | 36 | Nat-has-ordered-monoid : has-ordered-monoid Nat-displacement 37 | Nat-has-ordered-monoid = 38 | right-invariant→has-ordered-monoid Nat-displacement λ {x} {y} {z} → 39 | +-preserves-≤r x y z 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Subdisplacement 43 | 44 | Nat→Int-is-full-subdisplacement 45 | : is-full-subdisplacement Nat-displacement Int-displacement Nat→Int 46 | Nat→Int-is-full-subdisplacement = to-full-subdisplacement mk where 47 | mk : make-full-subdisplacement Nat-displacement Int-displacement Nat→Int 48 | mk .make-full-subdisplacement.injective = pos-injective 49 | mk .make-full-subdisplacement.full (pos≤pos p) = p 50 | mk .make-full-subdisplacement.pres-ε = refl 51 | mk .make-full-subdisplacement.pres-⊗ = refl 52 | mk .make-full-subdisplacement.pres-≤ p = pos≤pos p 53 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/NearlyConstant.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | module Mugen.Algebra.Displacement.Instances.NearlyConstant where 3 | 4 | open import Mugen.Prelude 5 | open import Mugen.Data.List 6 | open import Mugen.Order.StrictOrder 7 | open import Mugen.Order.Instances.Pointwise 8 | open import Mugen.Order.Instances.BasedSupport 9 | open import Mugen.Algebra.Displacement 10 | open import Mugen.Algebra.Displacement.Subalgebra 11 | open import Mugen.Algebra.Displacement.Instances.IndexedProduct 12 | open import Mugen.Algebra.OrderedMonoid 13 | 14 | import Mugen.Order.Reasoning as Reasoning 15 | 16 | private variable 17 | o o' r r' : Level 18 | 19 | -------------------------------------------------------------------------------- 20 | -- Nearly Constant Functions 21 | -- Section 3.3.5 22 | -- 23 | -- A "nearly constant function" is a function 'f : Nat → 𝒟' 24 | -- that differs from some fixed 'base : 𝒟' for only 25 | -- a finite set of 'n : Nat' 26 | -- 27 | -- We represent these via prefix lists. IE: the function 28 | -- 29 | -- > λ n → if n = 1 then 2 else if n = 3 then 1 else 5 30 | -- 31 | -- will be represented as a pair (5, [5,2,5,3]). We will call the 32 | -- first element of this pair "the base" of the function, and the 33 | -- prefix list "the support". 34 | -- 35 | -- However, there is a problem: there can be multiple representations 36 | -- for the same function. The above function can also be represented 37 | -- as (5, [5,2,5,3,5,5,5,5,5,5]), with trailing base elements. 38 | -- To resolve this, we say that a list is compact relative 39 | -- to some 'base : 𝒟' if it does not have any trailing base's. 40 | -- We then only work with compact lists. 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Displacement 44 | 45 | module _ 46 | {A : Poset o r} 47 | ⦃ _ : Discrete ⌞ A ⌟ ⦄ 48 | (𝒟 : Displacement-on A) 49 | where 50 | private 51 | module 𝒟 = Displacement-on 𝒟 52 | 53 | rep : represents-full-subdisplacement (IndexedProduct Nat (λ _ → 𝒟)) (BasedSupport→Pointwise-is-full-subposet A) 54 | rep .represents-full-subdisplacement.ε = based-support-list (raw [] 𝒟.ε) (lift tt) 55 | rep .represents-full-subdisplacement._⊗_ = merge-with 𝒟._⊗_ 56 | rep .represents-full-subdisplacement.pres-ε = refl 57 | rep .represents-full-subdisplacement.pres-⊗ {xs} {ys} = index-merge-with 𝒟._⊗_ xs ys 58 | module rep = represents-full-subdisplacement rep 59 | 60 | NearlyConstant : Displacement-on (BasedSupport A) 61 | NearlyConstant = rep.displacement-on 62 | 63 | NearlyConstant→Pointwise-is-full-subdisplacement : 64 | is-full-subdisplacement NearlyConstant (IndexedProduct Nat (λ _ → 𝒟)) (BasedSupport→Pointwise A) 65 | NearlyConstant→Pointwise-is-full-subdisplacement = rep.has-is-full-subdisplacement 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Ordered Monoid 69 | 70 | module _ 71 | {A : Poset o r} 72 | ⦃ _ : Discrete ⌞ A ⌟ ⦄ 73 | (𝒟 : Displacement-on A) 74 | (𝒟-ordered-monoid : has-ordered-monoid 𝒟) 75 | where 76 | private 77 | module 𝒟 = Displacement-on 𝒟 78 | module B = Reasoning (BasedSupport A) 79 | module N = Displacement-on (NearlyConstant 𝒟) 80 | module P = Reasoning (Pointwise Nat λ _ → A) 81 | module I-is-ordered-monoid = 82 | is-ordered-monoid (IndexedProduct-has-ordered-monoid Nat (λ _ → 𝒟) λ _ → 𝒟-ordered-monoid) 83 | 84 | right-invariant : ∀ {xs ys zs} → xs B.≤ ys → (xs N.⊗ zs) B.≤ (ys N.⊗ zs) 85 | right-invariant {xs} {ys} {zs} xs≤ys = 86 | coe1→0 (λ i → index-merge-with 𝒟._⊗_ xs zs i P.≤ index-merge-with 𝒟._⊗_ ys zs i) $ 87 | I-is-ordered-monoid.right-invariant xs≤ys 88 | 89 | NearlyConstant-has-ordered-monoid : has-ordered-monoid (NearlyConstant 𝒟) 90 | NearlyConstant-has-ordered-monoid = 91 | right-invariant→has-ordered-monoid (NearlyConstant 𝒟) λ {xs} {ys} {zs} → 92 | right-invariant {xs} {ys} {zs} 93 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/NonPositive.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.NonPositive where 2 | 3 | open import Data.Int 4 | 5 | open import Mugen.Prelude 6 | open import Mugen.Algebra.Displacement 7 | open import Mugen.Algebra.Displacement.Subalgebra 8 | open import Mugen.Algebra.Displacement.Instances.Int 9 | open import Mugen.Algebra.Displacement.Instances.Nat 10 | open import Mugen.Algebra.Displacement.Instances.Opposite 11 | 12 | open import Mugen.Order.Instances.NonPositive 13 | renaming (NonPositive to NonPositive-poset) 14 | 15 | -------------------------------------------------------------------------------- 16 | -- The Non-Positive Integers 17 | -- Section 3.3.1 18 | -- 19 | -- These have a terse definition as the opposite order of Nat+, 20 | -- so we just use that. 21 | 22 | NonPositive : Displacement-on NonPositive-poset 23 | NonPositive = Opposite Nat-displacement 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Inclusion into Int 27 | 28 | NonPositive→Int-is-full-subdisplacement 29 | : is-full-subdisplacement NonPositive Int-displacement NonPositive→Int 30 | NonPositive→Int-is-full-subdisplacement = to-full-subdisplacement subalg where 31 | subalg : make-full-subdisplacement NonPositive Int-displacement NonPositive→Int 32 | subalg .make-full-subdisplacement.pres-ε = refl 33 | subalg .make-full-subdisplacement.pres-⊗ {x} {y} = negℤ-distrib (pos x) (pos y) 34 | subalg .make-full-subdisplacement.pres-≤ {x} {y} p = negℤ-anti (pos y) (pos x) (pos≤pos p) 35 | subalg .make-full-subdisplacement.injective p = pos-injective $ negℤ-injective _ _ p 36 | subalg .make-full-subdisplacement.full {x} {y} p 37 | with pos≤pos y≤x ← negℤ-anti-full (pos y) (pos x) p = y≤x 38 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Opposite.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Opposite where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Order.Instances.Opposite renaming (Opposite to Opposite-poset) 5 | open import Mugen.Algebra.Displacement 6 | open import Mugen.Algebra.OrderedMonoid 7 | 8 | private variable 9 | o r : Level 10 | 11 | -------------------------------------------------------------------------------- 12 | -- The Opposite Displacement Algebra 13 | -- Section 3.3.8 14 | -- 15 | -- Given a displacement algebra '𝒟', we can define another displacement 16 | -- algebra with the same monoid structure, but with a reverse order. 17 | 18 | Opposite : ∀ {A : Poset o r} 19 | → Displacement-on A → Displacement-on (Opposite-poset A) 20 | Opposite {A = A} 𝒟 = to-displacement-on displacement where 21 | open Displacement-on 𝒟 22 | 23 | displacement : make-displacement (Opposite-poset A) 24 | displacement .make-displacement.ε = ε 25 | displacement .make-displacement._⊗_ = _⊗_ 26 | displacement .make-displacement.idl = idl 27 | displacement .make-displacement.idr = idr 28 | displacement .make-displacement.associative = associative 29 | displacement .make-displacement.left-strict-invariant p = 30 | left-invariant p , λ q → sym $ injectiver-on-related p (sym q) 31 | 32 | module OpProperties {A : Poset o r} {𝒟 : Displacement-on A} where 33 | open Displacement-on 𝒟 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Ordered Monoid 37 | 38 | Opposite-has-ordered-monoid : has-ordered-monoid 𝒟 → has-ordered-monoid (Opposite 𝒟) 39 | Opposite-has-ordered-monoid 𝒟-ordered-monoid = 40 | right-invariant→has-ordered-monoid (Opposite 𝒟) right-invariant 41 | where 42 | open is-ordered-monoid 𝒟-ordered-monoid 43 | -------------------------------------------------------------------------------- /src/Mugen/Algebra/Displacement/Instances/Prefix.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Algebra.Displacement.Instances.Prefix where 2 | 3 | open import Algebra.Magma 4 | open import Algebra.Monoid 5 | open import Algebra.Semigroup 6 | 7 | open import Mugen.Prelude 8 | open import Mugen.Data.List 9 | open import Mugen.Order.StrictOrder 10 | open import Mugen.Order.Lattice 11 | open import Mugen.Order.Instances.Prefix renaming (Prefix to Prefix-poset) 12 | open import Mugen.Algebra.Displacement 13 | 14 | private variable 15 | o r : Level 16 | 17 | -------------------------------------------------------------------------------- 18 | -- Prefix Displacements 19 | -- Section 3.3.6 20 | -- 21 | -- Given a set 'A', we can define a displacement algebra on 'List A', 22 | -- where 'xs ≤ ys' if 'xs' is a prefix of 'ys'. 23 | 24 | private 25 | -------------------------------------------------------------------------------- 26 | -- Left Invariance 27 | 28 | ++-left-invariant : ∀ {ℓ} {A : Type ℓ} (xs ys zs : List A) → Prefix[ ys ≤ zs ] → Prefix[ (xs ++ ys) ≤ (xs ++ zs) ] 29 | ++-left-invariant [] ys zs ys≤zs = ys≤zs 30 | ++-left-invariant (x ∷ xs) ys zs ys_ 29 | open Strictly-monotone 30 | 31 | open Reasoning A 32 | open Displacement-on 𝒟 33 | 34 | McBride : Hierarchy-theory o (o ⊔ r) 35 | McBride = ht where 36 | M : Functor (Strict-orders o (o ⊔ r)) (Strict-orders o (o ⊔ r)) 37 | M .F₀ L = L ⋉[ ε ] A 38 | M .F₁ f .hom (l , d) = (f .hom l) , d 39 | M .F₁ {L} {N} f .pres-≤[]-equal {l1 , d1} {l2 , d2} = 40 | let module N⋉A = Reasoning (N ⋉[ ε ] A) in 41 | ∥-∥-rec (N⋉A.≤[]-is-hlevel 0 $ Poset.Ob-is-set (L ⋉[ ε ] A) _ _) λ where 42 | (biased l1=l2 d1≤d2) → inc (biased (ap (f .hom) l1=l2) d1≤d2) , λ p → ap₂ _,_ l1=l2 (ap snd p) 43 | (centred l1≤l2 d1≤ε ε≤d2) → inc (centred (pres-≤ f l1≤l2) d1≤ε ε≤d2) , λ p → 44 | ap₂ _,_ (injective-on-related f l1≤l2 (ap fst p)) (ap snd p) 45 | M .F-id = trivial! 46 | M .F-∘ f g = trivial! 47 | 48 | unit : Id => M 49 | unit .η L .hom l = l , ε 50 | unit .η L .pres-≤[]-equal l1≤l2 = inc (centred l1≤l2 ≤-refl ≤-refl) , ap fst 51 | unit .is-natural L L' f = trivial! 52 | 53 | mult : M F∘ M => M 54 | mult .η L .hom ((l , x) , y) = l , (x ⊗ y) 55 | mult .η L .pres-≤[]-equal {(a1 , d1) , e1} {(a2 , d2) , e2} = 56 | let module L⋉A = Reasoning (L ⋉[ ε ] A) in 57 | ∥-∥-rec (L⋉A.≤[]-is-hlevel 0 $ Poset.Ob-is-set (M .F₀ (M .F₀ L)) _ _) lemma where 58 | lemma : (M .F₀ L) ⋉[ ε ] A [ ((a1 , d1) , e1) raw≤ ((a2 , d2) , e2) ] 59 | → (L ⋉[ ε ] A [ (a1 , (d1 ⊗ e1)) ≤ (a2 , (d2 ⊗ e2)) ]) 60 | × ((a1 , (d1 ⊗ e1)) ≡ (a2 , (d2 ⊗ e2)) → ((a1 , d1) , e1) ≡ ((a2 , d2) , e2)) 61 | lemma (biased ad1=ad2 e1≤e2) = 62 | inc (biased (ap fst ad1=ad2) (=+≤→≤ (ap (_⊗ e1) (ap snd ad1=ad2)) (left-invariant e1≤e2))) , 63 | λ p i → ad1=ad2 i , injectiver-on-related e1≤e2 (ap snd p ∙ ap (_⊗ e2) (sym $ ap snd ad1=ad2)) i 64 | lemma (centred ad1≤ad2 e1≤ε ε≤e2) = ∥-∥-map lemma₂ ad1≤ad2 , lemma₃ where 65 | d1⊗e1≤d1 : (d1 ⊗ e1) ≤ d1 66 | d1⊗e1≤d1 = ≤+=→≤ (left-invariant e1≤ε) idr 67 | 68 | d2≤d2⊗e2 : d2 ≤ (d2 ⊗ e2) 69 | d2≤d2⊗e2 = =+≤→≤ (sym idr) (left-invariant ε≤e2) 70 | 71 | lemma₂ : L ⋉[ ε ] A [ (a1 , d1) raw≤ (a2 , d2) ] 72 | → L ⋉[ ε ] A [ (a1 , (d1 ⊗ e1)) raw≤ (a2 , (d2 ⊗ e2)) ] 73 | lemma₂ (biased a1=a2 d1≤d2) = biased a1=a2 (≤-trans d1⊗e1≤d1 (≤-trans d1≤d2 d2≤d2⊗e2)) 74 | lemma₂ (centred a1≤a2 d1≤ε ε≤d2) = centred a1≤a2 (≤-trans d1⊗e1≤d1 d1≤ε) (≤-trans ε≤d2 d2≤d2⊗e2) 75 | 76 | lemma₃ : (a1 , (d1 ⊗ e1)) ≡ (a2 , (d2 ⊗ e2)) → ((a1 , d1) , e1) ≡ ((a2 , d2) , e2) 77 | lemma₃ p i = (a1=a2 i , d1=d2 i) , e1=e2 i where 78 | a1=a2 : a1 ≡ a2 79 | a1=a2 = ap fst p 80 | 81 | d2≤d1 : d2 ≤ d1 82 | d2≤d1 = begin-≤ 83 | d2 ≤⟨ d2≤d2⊗e2 ⟩ 84 | d2 ⊗ e2 ≐⟨ sym $ ap snd p ⟩ 85 | d1 ⊗ e1 ≤⟨ d1⊗e1≤d1 ⟩ 86 | d1 ≤∎ 87 | 88 | d1=d2 : d1 ≡ d2 89 | d1=d2 = ≤-antisym (⋉-snd-invariant ad1≤ad2) d2≤d1 90 | 91 | e1=e2 : e1 ≡ e2 92 | e1=e2 = injectiver-on-related (≤-trans e1≤ε ε≤e2) $ ap snd p ∙ ap (_⊗ e2) (sym d1=d2) 93 | mult .is-natural L L' f = trivial! 94 | 95 | ht : Hierarchy-theory o (o ⊔ r) 96 | ht .Monad.M = M 97 | ht .Monad.unit = unit 98 | ht .Monad.mult = mult 99 | ht .Monad.left-ident = ext λ α d → (refl , idl {d}) 100 | ht .Monad.right-ident = ext λ α d → (refl , idr {d}) 101 | ht .Monad.mult-assoc = ext λ α d1 d2 d3 → (refl , sym (associative {d1} {d2} {d3})) 102 | 103 | -------------------------------------------------------------------------------- 104 | -- The Additional Functoriality of McBride Hierarchy Theory 105 | -- 106 | -- The McBride monad is functorial in the parameter displacement. 107 | 108 | module _ where 109 | open Functor 110 | open _=>_ 111 | open Monad-hom 112 | open Total-hom 113 | open Strictly-monotone 114 | open Displacement-on 115 | open is-displacement-hom 116 | 117 | McBride-functor : Functor (Displacements o r) (Hierarchy-theories o (o ⊔ r)) 118 | McBride-functor .F₀ (_ , 𝒟) = McBride 𝒟 119 | McBride-functor .F₁ σ .nat .η L .hom (l , d) = l , σ # d 120 | McBride-functor .F₁ {A , 𝒟} {B , ℰ} σ .nat .η L .pres-≤[]-equal {l1 , d1} {l2 , d2} = 121 | let module A = Reasoning A 122 | module B = Reasoning B 123 | module σ = Strictly-monotone (σ .hom) 124 | module L⋉A = Reasoning (L ⋉[ 𝒟 .ε ] A) 125 | module L⋉B = Reasoning (L ⋉[ ℰ .ε ] B) 126 | in 127 | ∥-∥-rec (L⋉B.≤[]-is-hlevel 0 $ L⋉A.Ob-is-set _ _) λ where 128 | (biased l1=l2 d1≤d2) → 129 | inc (biased l1=l2 (σ.pres-≤ d1≤d2)) , 130 | λ p → ap₂ _,_ (ap fst p) (σ.injective-on-related d1≤d2 $ ap snd p) 131 | (centred l1≤l2 d1≤ε ε≤d2) → 132 | inc (centred l1≤l2 133 | (B.≤+=→≤ (σ.pres-≤ d1≤ε) (σ .preserves .pres-ε)) 134 | (B.=+≤→≤ (sym $ σ .preserves .pres-ε) (σ.pres-≤ ε≤d2))) , 135 | λ p → ap₂ _,_ (ap fst p) (σ.injective-on-related (A.≤-trans d1≤ε ε≤d2) $ ap snd p) 136 | McBride-functor .F₁ σ .nat .is-natural L N f = trivial! 137 | McBride-functor .F₁ σ .pres-unit = ext λ L l → refl , σ .preserves .pres-ε 138 | McBride-functor .F₁ σ .pres-mult = ext λ L l d1 d2 → refl , σ .preserves .pres-⊗ 139 | McBride-functor .F-id = trivial! 140 | McBride-functor .F-∘ f g = trivial! 141 | -------------------------------------------------------------------------------- /src/Mugen/Cat/HierarchyTheory/Traditional.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Cat.HierarchyTheory.Traditional where 2 | 3 | open import Cat.Diagram.Monad 4 | 5 | open import Order.Instances.Nat 6 | open import Order.Instances.Coproduct 7 | 8 | open import Mugen.Prelude 9 | open import Mugen.Algebra.Displacement 10 | open import Mugen.Order.Instances.LeftInvariantRightCentered 11 | open import Mugen.Order.StrictOrder 12 | open import Mugen.Cat.Instances.StrictOrders 13 | open import Mugen.Cat.HierarchyTheory 14 | 15 | import Mugen.Order.Reasoning 16 | 17 | -------------------------------------------------------------------------------- 18 | -- The Traditional Hierarchy Theory 19 | 20 | module _ {o : Level} where 21 | open Strictly-monotone 22 | open Functor 23 | open _=>_ 24 | 25 | Traditional : Hierarchy-theory o o 26 | Traditional = ht where 27 | M : Functor (Strict-orders o o) (Strict-orders o o) 28 | M .F₀ L = Nat-poset ⊎ᵖ L 29 | M .F₁ f .hom (inl n) = inl n 30 | M .F₁ f .hom (inr l) = inr (f .hom l) 31 | M .F₁ {L} {N} f .pres-≤[]-equal {inl n1} {inl n2} n1≤n2 = n1≤n2 , ap inl ⊙ inl-inj 32 | M .F₁ {L} {N} f .pres-≤[]-equal {inr l1} {inr l2} (lift l1≤l2) = 33 | lift {ℓ = lzero} (Strictly-monotone.pres-≤ f l1≤l2) , 34 | λ eq → ap inr $ Strictly-monotone.injective-on-related f l1≤l2 $ inr-inj eq 35 | M .F-id = ext λ where 36 | (inl n) → refl 37 | (inr l) → refl 38 | M .F-∘ f g = ext λ where 39 | (inl n) → refl 40 | (inr l) → refl 41 | 42 | unit : Id => M 43 | unit .η L .hom l = inr l 44 | unit .η L .pres-≤[]-equal l1≤l2 = lift {ℓ = lzero} l1≤l2 , inr-inj 45 | unit .is-natural L L' f = ext λ _ → refl 46 | 47 | mult-hom : ∀ (L : Poset o o) → Strictly-monotone (Nat-poset ⊎ᵖ (Nat-poset ⊎ᵖ L)) (Nat-poset ⊎ᵖ L) 48 | mult-hom L .hom (inl n) = inl n 49 | mult-hom L .hom (inr l) = l 50 | mult-hom L .pres-≤[]-equal {inl n1} {inl n2} n1≤n2 = n1≤n2 , ap inl ⊙ inl-inj 51 | mult-hom L .pres-≤[]-equal {inr l1} {inr l2} (lift l1≤l2) = l1≤l2 , ap inr 52 | 53 | mult : M F∘ M => M 54 | mult .η = mult-hom 55 | mult .is-natural L L' f = ext λ where 56 | (inl n) → refl 57 | (inr (inl l)) → refl 58 | (inr (inr _)) → refl 59 | 60 | ht : Hierarchy-theory o o 61 | ht .Monad.M = M 62 | ht .Monad.unit = unit 63 | ht .Monad.mult = mult 64 | ht .Monad.left-ident = ext λ { (inl n) → refl ; (inr l) → refl } 65 | ht .Monad.right-ident = ext λ { (inl n) → refl ; (inr l) → refl } 66 | ht .Monad.mult-assoc = ext λ { (inl n) → refl ; (inr l) → refl } 67 | -------------------------------------------------------------------------------- /src/Mugen/Cat/HierarchyTheory/Universality.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | open import Order.Instances.Discrete 3 | open import Order.Instances.Coproduct 4 | 5 | open import Cat.Prelude 6 | open import Cat.Functor.Base 7 | open import Cat.Functor.Compose 8 | open import Cat.Functor.Properties 9 | open import Cat.Diagram.Monad 10 | 11 | import Cat.Reasoning as Cat 12 | import Cat.Functor.Reasoning as FR 13 | 14 | open import Mugen.Prelude 15 | 16 | open import Mugen.Algebra.Displacement 17 | open import Mugen.Algebra.Displacement.Instances.Endomorphism 18 | 19 | open import Mugen.Cat.Instances.Endomorphisms 20 | open import Mugen.Cat.Instances.Indexed 21 | open import Mugen.Cat.Instances.StrictOrders 22 | open import Mugen.Cat.Monad 23 | open import Mugen.Cat.HierarchyTheory 24 | open import Mugen.Cat.HierarchyTheory.McBride 25 | 26 | import Mugen.Order.Reasoning as Reasoning 27 | 28 | -------------------------------------------------------------------------------- 29 | -- The Universal Embedding Theorem 30 | -- Section 3.4, Theorem 3.10 31 | 32 | module Mugen.Cat.HierarchyTheory.Universality {o o' r} 33 | (H : Hierarchy-theory (o ⊔ o') (r ⊔ o')) {I : Type o'} ⦃ Discrete-I : Discrete I ⦄ 34 | (Δ₋ : ⌞ I ⌟ → Poset (o ⊔ o') (r ⊔ o')) (Ψ : Set (lsuc (o ⊔ r ⊔ o'))) where 35 | 36 | private 37 | import Mugen.Cat.HierarchyTheory.Universality.SubcategoryEmbedding as SubcategoryEmbedding 38 | module SE = SubcategoryEmbedding {o = o} {r = r} H Δ₋ 39 | 40 | import Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbedding as EndomorphismEmbedding 41 | module EE = EndomorphismEmbedding H SE.Δ Ψ 42 | 43 | import Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbeddingNaturality as EndomorphismEmbeddingNaturality 44 | module EEN = EndomorphismEmbeddingNaturality H SE.Δ Ψ 45 | 46 | -------------------------------------------------------------------------------- 47 | -- Notation 48 | 49 | private 50 | open Algebra-hom 51 | module H = Monad H 52 | 53 | SOrd : Precategory (lsuc (o ⊔ r ⊔ o')) (o ⊔ r ⊔ o') 54 | SOrd = Strict-orders (o ⊔ o') (r ⊔ o') 55 | open Cat SOrd 56 | 57 | SOrdᴴ : Precategory (lsuc (o ⊔ r ⊔ o')) (lsuc (o ⊔ r ⊔ o')) 58 | SOrdᴴ = Eilenberg-Moore SOrd H 59 | module SOrdᴴ = Cat SOrdᴴ 60 | 61 | -- '↑' for lifting 62 | SOrd↑ : Precategory (lsuc (lsuc (o ⊔ r ⊔ o'))) (lsuc (o ⊔ r ⊔ o')) 63 | SOrd↑ = Strict-orders (lsuc (o ⊔ r ⊔ o')) (lsuc (o ⊔ r ⊔ o')) 64 | module SOrd↑ = Cat SOrd↑ 65 | 66 | SOrdᴹᴰ : Precategory (lsuc (lsuc (o ⊔ r ⊔ o'))) (lsuc (lsuc (o ⊔ r ⊔ o'))) 67 | SOrdᴹᴰ = Eilenberg-Moore SOrd↑ (McBride (Endomorphism H EE.Δ⁺)) 68 | module SOrdᴹᴰ = Cat SOrdᴹᴰ 69 | 70 | Uᴴ : Functor SOrdᴴ SOrd 71 | Uᴴ = Forget SOrd H 72 | 73 | Fᴴ : Functor SOrd SOrdᴴ 74 | Fᴴ = Free SOrd H 75 | 76 | Fᴴ₀ : Poset (o ⊔ o') (r ⊔ o') → Algebra SOrd H 77 | Fᴴ₀ = Fᴴ .Functor.F₀ 78 | 79 | Fᴴ₁ : {X Y : Poset (o ⊔ o') (r ⊔ o')} → Hom X Y → SOrdᴴ.Hom (Fᴴ₀ X) (Fᴴ₀ Y) 80 | Fᴴ₁ = Fᴴ .Functor.F₁ 81 | 82 | Fᴹᴰ : Functor SOrd↑ SOrdᴹᴰ 83 | Fᴹᴰ = Free SOrd↑ (McBride (Endomorphism H EE.Δ⁺)) 84 | 85 | Fᴹᴰ₀ : Poset (lsuc (o ⊔ r ⊔ o')) (lsuc (o ⊔ r ⊔ o')) → Algebra SOrd↑ (McBride (Endomorphism H EE.Δ⁺)) 86 | Fᴹᴰ₀ = Fᴹᴰ .Functor.F₀ 87 | 88 | Uᴹᴰ : Functor SOrdᴹᴰ SOrd↑ 89 | Uᴹᴰ = Forget SOrd↑ (McBride (Endomorphism H EE.Δ⁺)) 90 | 91 | -------------------------------------------------------------------------------- 92 | -- Constructing the natural transformation T 93 | -- Section 3.4, Theorem 3.10 94 | 95 | T : Functor (Indexed SOrdᴴ λ i → Fᴴ₀ (Δ₋ i)) (Endos SOrdᴹᴰ (Fᴹᴰ₀ (Disc Ψ))) 96 | T = EE.T F∘ SE.T 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Constructing the natural transformation ν 100 | -- Section 3.4, Theorem 3.10 101 | 102 | ν : ∣ Ψ ∣ 103 | → liftᶠ-strict-orders F∘ Uᴴ F∘ Indexed-include 104 | => Uᴹᴰ F∘ Endos-include F∘ T 105 | ν pt = lemma-assoc₂ 106 | ∘nt (EEN.ν pt ◂ SE.T) 107 | ∘nt lemma-assoc₁ 108 | ∘nt (liftᶠ-strict-orders ▸ (Uᴴ ▸ SE.ν)) 109 | where 110 | lemma-assoc₁ 111 | : liftᶠ-strict-orders F∘ Uᴴ F∘ Endos-include F∘ SE.T 112 | => (liftᶠ-strict-orders F∘ Uᴴ F∘ Endos-include) F∘ SE.T 113 | lemma-assoc₁ ._=>_.η _ = SOrd↑.id 114 | lemma-assoc₁ ._=>_.is-natural _ _ _ = SOrd↑.id-comm-sym 115 | 116 | lemma-assoc₂ 117 | : (Uᴹᴰ F∘ Endos-include F∘ EE.T) F∘ SE.T 118 | => Uᴹᴰ F∘ Endos-include F∘ EE.T F∘ SE.T 119 | lemma-assoc₂ ._=>_.η _ = SOrd↑.id 120 | lemma-assoc₂ ._=>_.is-natural _ _ _ = SOrd↑.id-comm-sym 121 | 122 | -------------------------------------------------------------------------------- 123 | -- Faithfulness of T 124 | -- Section 3.4, Lemma 3.9 125 | 126 | abstract 127 | T-faithful : ∣ Ψ ∣ → preserves-monos H → is-faithful T 128 | T-faithful pt H-preserves-monos eq = 129 | SE.T-faithful H-preserves-monos $ 130 | EE.T-faithful pt H-preserves-monos eq 131 | -------------------------------------------------------------------------------- /src/Mugen/Cat/HierarchyTheory/Universality/EndomorphismEmbedding.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | open import Order.Instances.Discrete 3 | open import Order.Instances.Coproduct 4 | 5 | open import Cat.Prelude 6 | open import Cat.Functor.Base 7 | open import Cat.Functor.Properties 8 | open import Cat.Diagram.Monad 9 | 10 | import Cat.Reasoning as Cat 11 | 12 | open import Mugen.Prelude 13 | 14 | open import Mugen.Algebra.Displacement 15 | open import Mugen.Algebra.Displacement.Instances.Endomorphism 16 | 17 | open import Mugen.Cat.Instances.Endomorphisms 18 | open import Mugen.Cat.Instances.StrictOrders 19 | open import Mugen.Cat.Monad 20 | open import Mugen.Cat.HierarchyTheory 21 | open import Mugen.Cat.HierarchyTheory.McBride 22 | 23 | open import Mugen.Order.StrictOrder 24 | open import Mugen.Order.Instances.Endomorphism renaming (Endomorphism to Endomorphism-poset) 25 | open import Mugen.Order.Instances.LeftInvariantRightCentered 26 | 27 | import Mugen.Order.Reasoning as Reasoning 28 | 29 | -------------------------------------------------------------------------------- 30 | -- The Universal Embedding Theorem 31 | -- Section 3.4, Lemma 3.8 32 | -- 33 | -- Given a hierarchy theory 'H', a poset Δ, and a set Ψ, we can 34 | -- construct a faithful functor 'T : Endos (Fᴴ Δ) → Endos Fᴹᴰ Ψ', where 35 | -- 'Fᴴ' denotes the free H-algebra on Δ, and 'Fᴹᴰ Ψ' denotes the free McBride 36 | -- Hierarchy theory over the endomorphism displacement algebra on 'H (◆ ⊕ Δ ⊕ Δ)'. 37 | -- 38 | -- Naturality is in a different file 39 | 40 | module Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbedding 41 | {o r} (H : Hierarchy-theory o r) (Δ : Poset o r) (Ψ : Set (lsuc (o ⊔ r))) where 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Notation 45 | -- 46 | -- We begin by defining some useful notation. 47 | 48 | private 49 | open Strictly-monotone 50 | open Algebra-hom 51 | open Cat (Strict-orders o r) 52 | module Δ = Poset Δ 53 | module H = Monad H 54 | 55 | -- made public for the naturality proof in a different file 56 | Δ⁺ : Poset o r 57 | Δ⁺ = 𝟙ᵖ {o = o} {ℓ = r} ⊎ᵖ (Δ ⊎ᵖ Δ) 58 | 59 | private 60 | H⟨Δ⁺⟩ : Poset o r 61 | H⟨Δ⁺⟩ = H.M₀ Δ⁺ 62 | module H⟨Δ⁺⟩ = Reasoning H⟨Δ⁺⟩ 63 | 64 | H⟨Δ⁺⟩→ : Poset (lsuc (o ⊔ r)) (o ⊔ r) 65 | H⟨Δ⁺⟩→ = Endomorphism-poset H Δ⁺ 66 | module H⟨Δ⁺⟩→ = Reasoning H⟨Δ⁺⟩→ 67 | 68 | 𝒟 : Displacement-on H⟨Δ⁺⟩→ 69 | 𝒟 = Endomorphism H Δ⁺ 70 | module 𝒟 = Displacement-on 𝒟 71 | 72 | private 73 | SOrd : Precategory (lsuc (o ⊔ r)) (o ⊔ r) 74 | SOrd = Strict-orders o r 75 | module SOrd = Cat SOrd 76 | 77 | SOrdᴴ : Precategory (lsuc (o ⊔ r)) (lsuc (o ⊔ r)) 78 | SOrdᴴ = Eilenberg-Moore SOrd H 79 | module SOrdᴴ = Cat SOrdᴴ 80 | 81 | -- '↑' for lifting 82 | SOrd↑ : Precategory (lsuc (lsuc (o ⊔ r))) (lsuc (o ⊔ r)) 83 | SOrd↑ = Strict-orders (lsuc (o ⊔ r)) (lsuc (o ⊔ r)) 84 | 85 | SOrdᴹᴰ : Precategory (lsuc (lsuc (o ⊔ r))) (lsuc (lsuc (o ⊔ r))) 86 | SOrdᴹᴰ = Eilenberg-Moore SOrd↑ (McBride 𝒟) 87 | module SOrdᴹᴰ = Cat SOrdᴹᴰ 88 | 89 | Fᴴ : Functor SOrd SOrdᴴ 90 | Fᴴ = Free SOrd H 91 | 92 | Fᴴ₀ : Poset o r → Algebra SOrd H 93 | Fᴴ₀ = Fᴴ .Functor.F₀ 94 | 95 | Fᴴ₁ : {X Y : Poset o r} → Hom X Y → SOrdᴴ.Hom (Fᴴ₀ X) (Fᴴ₀ Y) 96 | Fᴴ₁ = Fᴴ .Functor.F₁ 97 | 98 | Endoᴴ⟨Δ⟩ : Type (o ⊔ r) 99 | Endoᴴ⟨Δ⟩ = Hom (H.M₀ Δ) (H.M₀ Δ) 100 | 101 | Fᴹᴰ₀ : Poset (lsuc o ⊔ lsuc r) (lsuc o ⊔ lsuc r) → Algebra SOrd↑ (McBride 𝒟) 102 | Fᴹᴰ₀ = Functor.F₀ (Free SOrd↑ (McBride 𝒟)) 103 | 104 | -- These patterns and definitions are exported for the naturality proof 105 | -- in another file. 106 | 107 | pattern ⋆ = lift tt 108 | 109 | pattern ι₀ α = inl α 110 | 111 | ι₀-hom : Hom 𝟙ᵖ Δ⁺ 112 | ι₀-hom .hom = ι₀ 113 | ι₀-hom .pres-≤[]-equal α≤β = lift α≤β , λ _ → refl 114 | 115 | pattern ι₁ α = inr (inl α) 116 | 117 | ι₁-inj : ∀ {x y : ⌞ Δ ⌟} → _≡_ {A = ⌞ Δ⁺ ⌟} (ι₁ x) (ι₁ y) → x ≡ y 118 | ι₁-inj = inl-inj ⊙ inr-inj 119 | 120 | ι₁-hom : Hom Δ Δ⁺ 121 | ι₁-hom .hom = ι₁ 122 | ι₁-hom .pres-≤[]-equal α≤β = lift (lift α≤β) , ι₁-inj 123 | 124 | ι₁-monic : SOrd.is-monic ι₁-hom 125 | ι₁-monic g h p = ext λ α → ι₁-inj (p #ₚ α) 126 | 127 | pattern ι₂ α = inr (inr α) 128 | 129 | ι₂-inj : ∀ {x y : ⌞ Δ ⌟} → _≡_ {A = ⌞ Δ⁺ ⌟} (ι₂ x) (ι₂ y) → x ≡ y 130 | ι₂-inj = inr-inj ⊙ inr-inj 131 | 132 | 133 | -------------------------------------------------------------------------------- 134 | -- Construction of the functor T 135 | -- Section 3.4, Lemma 3.8 136 | 137 | σ̅ : SOrdᴴ.Hom (Fᴴ₀ Δ) (Fᴴ₀ Δ) → Hom Δ⁺ H⟨Δ⁺⟩ 138 | σ̅ σ .hom (ι₀ ⋆) = H.η Δ⁺ # ι₀ ⋆ 139 | σ̅ σ .hom (ι₁ α) = H.M₁ ι₁-hom # (σ # (H.η Δ # α)) 140 | σ̅ σ .hom (ι₂ α) = H.η Δ⁺ # ι₂ α 141 | σ̅ σ .pres-≤[]-equal {ι₀ ⋆} {ι₀ ⋆} _ = H⟨Δ⁺⟩.≤-refl , λ _ → refl 142 | σ̅ σ .pres-≤[]-equal {ι₁ α} {ι₁ β} (lift (lift α≤β)) = 143 | H⟨Δ⁺⟩.≤[]-map (ap ι₁) $ (H.M₁ ι₁-hom ∘ σ .morphism ∘ H.η Δ) .pres-≤[]-equal α≤β 144 | σ̅ σ .pres-≤[]-equal {ι₂ α} {ι₂ β} α≤β = H.η Δ⁺ .pres-≤[]-equal α≤β 145 | 146 | abstract 147 | σ̅-id : σ̅ SOrdᴴ.id ≡ H.η Δ⁺ 148 | σ̅-id = ext λ where 149 | (ι₀ α) → refl 150 | (ι₁ α) → sym (H.unit.is-natural Δ Δ⁺ ι₁-hom) #ₚ α 151 | (ι₂ α) → refl 152 | 153 | abstract 154 | σ̅-ι 155 | : ∀ (σ : SOrdᴴ.Hom (Fᴴ₀ Δ) (Fᴴ₀ Δ)) 156 | → (α : ⌞ H.M₀ Δ ⌟) 157 | → H.M₁ (H.M₁ ι₁-hom ∘ σ .morphism ∘ H.η Δ) # α 158 | ≡ H.M₁ (σ̅ σ) # (H.M₁ ι₁-hom # α) 159 | σ̅-ι σ α = 160 | H.M₁ (H.M₁ ι₁-hom ∘ σ .morphism ∘ H.η Δ) # α ≡⟨ ap (λ m → H.M₁ m # α) $ ext (λ _ → refl) ⟩ 161 | H.M₁ (σ̅ σ ∘ ι₁-hom) # α ≡⟨ H.M-∘ _ _ #ₚ α ⟩ 162 | H.M₁ (σ̅ σ) # (H.M₁ ι₁-hom # α) ∎ 163 | 164 | abstract 165 | σ̅-∘ : ∀ (σ δ : SOrdᴴ.Hom (Fᴴ₀ Δ) (Fᴴ₀ Δ)) → σ̅ (σ SOrdᴴ.∘ δ) ≡ H.μ Δ⁺ ∘ H.M₁ (σ̅ σ) ∘ σ̅ δ 166 | σ̅-∘ σ δ = ext λ where 167 | (ι₀ α) → 168 | H.η Δ⁺ # ι₀ α ≡˘⟨ μ-η H (σ̅ σ) #ₚ ι₀ α ⟩ 169 | H.μ Δ⁺ # (H.M₁ (σ̅ σ) # (H.η Δ⁺ # ι₀ α)) ∎ 170 | (ι₁ α) → 171 | H.M₁ ι₁-hom # (σ # (δ # (H.η Δ # α))) ≡˘⟨ ap# (H.M₁ ι₁-hom ∘ σ .morphism) $ H.left-ident #ₚ _ ⟩ 172 | H.M₁ ι₁-hom # (σ # (H.μ Δ # (H.M₁ (H.η Δ) # (δ # (H.η Δ # α))))) ≡˘⟨ ap# (H.M₁ ι₁-hom) $ μ-M-∘-Algebraic H σ (H.η Δ) #ₚ _ ⟩ 173 | H.M₁ ι₁-hom # (H.μ _ # (H.M₁ (σ .morphism ∘ H.η Δ) # (δ # (H.η Δ # α)))) ≡˘⟨ μ-M-∘-M H ι₁-hom (σ .morphism ∘ H.η Δ) #ₚ _ ⟩ 174 | H.μ _ # (H.M₁ (H.M₁ ι₁-hom ∘ σ .morphism ∘ H.η Δ) # (δ # (H.η Δ # α))) ≡⟨ ap# (H.μ _) (σ̅-ι σ (δ # (H.η _ # α))) ⟩ 175 | H.μ _ # (H.M₁ (σ̅ σ) # (H.M₁ ι₁-hom # (δ # (H.η Δ # α)))) ∎ 176 | (ι₂ α) → 177 | H.η Δ⁺ # ι₂ α ≡˘⟨ μ-η H (σ̅ σ) #ₚ ι₂ α ⟩ 178 | H.μ Δ⁺ # (H.M₁ (σ̅ σ) # (H.η Δ⁺ # ι₂ α)) ∎ 179 | 180 | T′ : (σ : SOrdᴴ.Hom (Fᴴ₀ Δ) (Fᴴ₀ Δ)) → SOrdᴴ.Hom (Fᴴ₀ Δ⁺) (Fᴴ₀ Δ⁺) 181 | T′ σ .morphism = H.μ Δ⁺ ∘ H.M₁ (σ̅ σ) 182 | T′ σ .commutes = ext λ α → 183 | H.μ Δ⁺ # (H.M₁ (σ̅ σ) # (H.μ Δ⁺ # α)) ≡˘⟨ ap# (H.μ _) $ H.mult.is-natural _ _ (σ̅ σ) #ₚ α ⟩ 184 | H.μ Δ⁺ # (H.μ (H.M₀ Δ⁺) # (H.M₁ (H.M₁ (σ̅ σ)) # α)) ≡˘⟨ μ-M-∘-μ H (H.M₁ (σ̅ σ)) #ₚ α ⟩ 185 | H.μ Δ⁺ # (H.M₁ (H.μ Δ⁺ ∘ H.M₁ (σ̅ σ)) # α) ∎ 186 | 187 | T : Functor (Endos SOrdᴴ (Fᴴ₀ Δ)) (Endos SOrdᴹᴰ (Fᴹᴰ₀ (Disc Ψ))) 188 | T .Functor.F₀ _ = tt 189 | T .Functor.F₁ σ .morphism .hom (α , d) = α , (T′ σ SOrdᴴ.∘ d) 190 | T .Functor.F₁ σ .morphism .pres-≤[]-equal {α1 , d1} {α2 , d2} p = 191 | let d1≤d2 , injr = 𝒟.left-strict-invariant {T′ σ} {d1} {d2} (⋉-snd-invariant p) in 192 | inc (biased (⋉-fst-invariant p) d1≤d2) , λ q i → q i .fst , injr (ap snd q) i 193 | T .Functor.F₁ σ .commutes = trivial! 194 | T .Functor.F-id = ext λ α d → 195 | refl , λ β → 196 | H.μ _ # (H.M₁ (σ̅ SOrdᴴ.id) # (d # β)) ≡⟨ ap (λ m → H.μ _ # (H.M₁ m # (d # β))) σ̅-id ⟩ 197 | H.μ _ # (H.M₁ (H.η _) # (d # β)) ≡⟨ H.left-ident #ₚ _ ⟩ 198 | d # β ∎ 199 | T .Functor.F-∘ σ δ = ext λ α d → 200 | refl , λ β → 201 | H.μ _ # (H.M₁ (σ̅ (σ SOrdᴴ.∘ δ)) # (d # β)) ≡⟨ ap (λ m → H.μ _ # (H.M₁ m # (d # β))) (σ̅-∘ σ δ) ⟩ 202 | H.μ _ # (H.M₁ (H.μ _ ∘ H.M₁ (σ̅ σ) ∘ σ̅ δ) # (d # β)) ≡⟨ μ-M-∘-μ H (H.M₁ (σ̅ σ) ∘ σ̅ δ) #ₚ (d # β) ⟩ 203 | H.μ _ # (H.μ _ # (H.M₁ (H.M₁ (σ̅ σ) ∘ σ̅ δ) # (d # β))) ≡⟨ ap# (H.μ _) $ μ-M-∘-M H (σ̅ σ) (σ̅ δ) #ₚ (d # β) ⟩ 204 | H.μ _ # (H.M₁ (σ̅ σ) # (H.μ _ # (H.M₁ (σ̅ δ) # (d # β)))) ∎ 205 | 206 | -------------------------------------------------------------------------------- 207 | -- Faithfulness of T 208 | -- Section 3.4, Lemma 3.8 209 | 210 | abstract 211 | T-faithful : ∣ Ψ ∣ → preserves-monos H → is-faithful T 212 | T-faithful pt H-preserves-monos {x} {y} {σ} {δ} eq = 213 | free-algebra-hom-path H $ H-preserves-monos ι₁-hom ι₁-monic _ _ $ ext λ α → 214 | σ̅ σ # ι₁ α ≡˘⟨ μ-η H (σ̅ σ) #ₚ ι₁ α ⟩ 215 | H.μ _ # (H.M₁ (σ̅ σ) # (H.η _ # ι₁ α)) ≡⟨ ap snd (eq #ₚ (pt , SOrdᴴ.id)) #ₚ (H.η _ # ι₁ α) ⟩ 216 | H.μ _ # (H.M₁ (σ̅ δ) # (H.η _ # ι₁ α)) ≡⟨ μ-η H (σ̅ δ) #ₚ ι₁ α ⟩ 217 | σ̅ δ # ι₁ α ∎ 218 | -------------------------------------------------------------------------------- /src/Mugen/Cat/HierarchyTheory/Universality/EndomorphismEmbeddingNaturality.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | open import Order.Instances.Discrete 3 | open import Order.Instances.Coproduct 4 | 5 | open import Cat.Prelude 6 | open import Cat.Functor.Base 7 | open import Cat.Functor.Properties 8 | open import Cat.Diagram.Monad 9 | 10 | import Cat.Reasoning as Cat 11 | import Cat.Functor.Reasoning as FR 12 | 13 | open import Mugen.Prelude 14 | 15 | open import Mugen.Algebra.Displacement 16 | open import Mugen.Algebra.Displacement.Instances.Endomorphism 17 | 18 | open import Mugen.Cat.Instances.Endomorphisms 19 | open import Mugen.Cat.Instances.StrictOrders 20 | open import Mugen.Cat.Monad 21 | open import Mugen.Cat.HierarchyTheory 22 | open import Mugen.Cat.HierarchyTheory.McBride 23 | 24 | open import Mugen.Order.StrictOrder 25 | open import Mugen.Order.Instances.Endomorphism renaming (Endomorphism to Endomorphism-poset) 26 | open import Mugen.Order.Instances.LeftInvariantRightCentered 27 | open import Mugen.Order.Instances.Lift 28 | 29 | import Mugen.Order.Reasoning as Reasoning 30 | 31 | -------------------------------------------------------------------------------- 32 | -- The Universal Embedding Theorem 33 | -- Section 3.4, Lemma 3.8 34 | -- 35 | -- Given a hierarchy theory 'H', a strict order Δ, and a set Ψ, we can 36 | -- construct a faithful functor 'T : Endos (Fᴴ Δ) → Endos Fᴹᴰ Ψ', where 37 | -- 'Fᴴ' denotes the free H-algebra on Δ, and 'Fᴹᴰ Ψ' denotes the free McBride 38 | -- Hierarchy theory over the endomorphism displacement algebra on 'H (◆ ⊕ Δ ⊕ Δ)'. 39 | -- 40 | -- This file covers the naturality 41 | 42 | module Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbeddingNaturality 43 | {o r} (H : Hierarchy-theory o r) (Δ : Poset o r) (Ψ : Set (lsuc (o ⊔ r))) where 44 | 45 | open import Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbedding H Δ Ψ 46 | 47 | -------------------------------------------------------------------------------- 48 | -- Notation 49 | -- 50 | -- We begin by defining some useful notation. 51 | 52 | private 53 | open Strictly-monotone 54 | open Algebra-hom 55 | open Cat (Strict-orders o r) 56 | module Δ = Poset Δ 57 | module H = Monad H 58 | 59 | H⟨Δ⟩ : Poset o r 60 | H⟨Δ⟩ = H.M₀ Δ 61 | module H⟨Δ⟩ = Poset H⟨Δ⟩ 62 | 63 | H⟨Δ⁺⟩ : Poset o r 64 | H⟨Δ⁺⟩ = H.M₀ Δ⁺ 65 | module H⟨Δ⁺⟩ = Reasoning H⟨Δ⁺⟩ 66 | 67 | H⟨Δ⁺⟩→ : Poset (lsuc (o ⊔ r)) (o ⊔ r) 68 | H⟨Δ⁺⟩→ = Endomorphism-poset H Δ⁺ 69 | module H⟨Δ⁺⟩→ = Reasoning H⟨Δ⁺⟩→ 70 | 71 | SOrd : Precategory (lsuc (o ⊔ r)) (o ⊔ r) 72 | SOrd = Strict-orders o r 73 | module SOrd = Cat SOrd 74 | 75 | SOrdᴴ : Precategory (lsuc (o ⊔ r)) (lsuc (o ⊔ r)) 76 | SOrdᴴ = Eilenberg-Moore SOrd H 77 | module SOrdᴴ = Cat SOrdᴴ 78 | 79 | -- '↑' for lifting 80 | SOrd↑ : Precategory (lsuc (lsuc (o ⊔ r))) (lsuc (o ⊔ r)) 81 | SOrd↑ = Strict-orders (lsuc (o ⊔ r)) (lsuc (o ⊔ r)) 82 | 83 | SOrdᴹᴰ : Precategory (lsuc (lsuc (o ⊔ r))) (lsuc (lsuc (o ⊔ r))) 84 | SOrdᴹᴰ = Eilenberg-Moore SOrd↑ (McBride 𝒟) 85 | module SOrdᴹᴰ = Cat SOrdᴹᴰ 86 | 87 | Uᴴ : Functor SOrdᴴ SOrd 88 | Uᴴ = Forget SOrd H 89 | 90 | Fᴴ : Functor SOrd SOrdᴴ 91 | Fᴴ = Free SOrd H 92 | 93 | Fᴴ₀ : Poset o r → Algebra SOrd H 94 | Fᴴ₀ = Fᴴ .Functor.F₀ 95 | 96 | Fᴴ₁ : {X Y : Poset o r} → Hom X Y → SOrdᴴ.Hom (Fᴴ₀ X) (Fᴴ₀ Y) 97 | Fᴴ₁ = Fᴴ .Functor.F₁ 98 | 99 | Uᴹᴰ : Functor SOrdᴹᴰ SOrd↑ 100 | Uᴹᴰ = Forget SOrd↑ (McBride 𝒟) 101 | 102 | -------------------------------------------------------------------------------- 103 | -- Constructing the natural transformation ν 104 | -- Section 3.4, Lemma 3.8 105 | 106 | ν : ∣ Ψ ∣ 107 | → liftᶠ-strict-orders F∘ Uᴴ F∘ Endos-include 108 | => Uᴹᴰ F∘ Endos-include F∘ T 109 | ν pt = nt 110 | where 111 | ℓ̅ : ⌞ H.M₀ Δ ⌟ → Hom Δ⁺ (H.M₀ Δ⁺) 112 | ℓ̅ ℓ .hom (ι₀ _) = H.M₁ ι₁-hom # ℓ 113 | ℓ̅ ℓ .hom (ι₁ α) = H.η _ # ι₂ α 114 | ℓ̅ ℓ .hom (ι₂ α) = H.η _ # ι₂ α 115 | ℓ̅ ℓ .pres-≤[]-equal {ι₀ ⋆} {ι₀ ⋆} _ = H⟨Δ⁺⟩.≤-refl , λ _ → refl 116 | ℓ̅ ℓ .pres-≤[]-equal {ι₁ α} {ι₁ β} α≤β = H⟨Δ⁺⟩.≤[]-map (ap ι₁ ⊙ ι₂-inj) $ H.η _ .pres-≤[]-equal α≤β 117 | ℓ̅ ℓ .pres-≤[]-equal {ι₂ α} {ι₂ β} α≤β = H.η _ .pres-≤[]-equal α≤β 118 | 119 | abstract 120 | ℓ̅-pres-≤ : ∀ {ℓ ℓ′} 121 | → ℓ′ H⟨Δ⟩.≤ ℓ 122 | → ∀ (α : ⌞ Δ⁺ ⌟) → ℓ̅ ℓ′ # α H⟨Δ⁺⟩.≤ ℓ̅ ℓ # α 123 | ℓ̅-pres-≤ ℓ′≤ℓ (ι₀ _) = pres-≤ (H.M₁ ι₁-hom) ℓ′≤ℓ 124 | ℓ̅-pres-≤ ℓ′≤ℓ (ι₁ _) = H⟨Δ⁺⟩.≤-refl 125 | ℓ̅-pres-≤ ℓ′≤ℓ (ι₂ _) = H⟨Δ⁺⟩.≤-refl 126 | 127 | ν′ : ⌞ H.M₀ Δ ⌟ → SOrdᴴ.Hom (Fᴴ₀ Δ⁺) (Fᴴ₀ Δ⁺) 128 | ν′ ℓ .morphism = H.μ Δ⁺ ∘ H.M₁ (ℓ̅ ℓ) 129 | ν′ ℓ .commutes = ext λ α → 130 | H.μ Δ⁺ # (H.M₁ (ℓ̅ ℓ) # (H.μ Δ⁺ # α)) ≡˘⟨ ap# (H.μ _) (H.mult.is-natural _ _ (ℓ̅ ℓ) #ₚ α) ⟩ 131 | H.μ Δ⁺ # (H.μ (H.M₀ Δ⁺) # (H.M₁ (H.M₁ (ℓ̅ ℓ)) # α)) ≡˘⟨ μ-M-∘-μ H (H.M₁ (ℓ̅ ℓ)) #ₚ α ⟩ 132 | H.μ Δ⁺ # (H.M₁ (H.μ Δ⁺ ∘ H.M₁ (ℓ̅ ℓ)) # α) ∎ 133 | 134 | abstract 135 | ν′-mono : ∀ {ℓ′ ℓ : ⌞ H.M₀ Δ ⌟} → ℓ′ H⟨Δ⟩.≤ ℓ → ν′ ℓ′ H⟨Δ⁺⟩→.≤ ν′ ℓ 136 | ν′-mono {ℓ′} {ℓ} ℓ′≤ℓ α = begin-≤ 137 | H.μ Δ⁺ # (H.M₁ (ℓ̅ ℓ′) # (H.η Δ⁺ # α)) ≐⟨ μ-η H (ℓ̅ ℓ′) #ₚ α ⟩ 138 | ℓ̅ ℓ′ # α ≤⟨ ℓ̅-pres-≤ ℓ′≤ℓ α ⟩ 139 | ℓ̅ ℓ # α ≐⟨ sym $ μ-η H (ℓ̅ ℓ) #ₚ α ⟩ 140 | H.μ Δ⁺ # (H.M₁ (ℓ̅ ℓ) # (H.η Δ⁺ # α)) ≤∎ 141 | where 142 | open Reasoning (H.M₀ Δ⁺) 143 | 144 | abstract 145 | ν′-injective-on-related : ∀ {ℓ′ ℓ : ⌞ H.M₀ Δ ⌟} → ℓ′ H⟨Δ⟩.≤ ℓ → ν′ ℓ′ ≡ ν′ ℓ → ℓ′ ≡ ℓ 146 | ν′-injective-on-related {ℓ′} {ℓ} ℓ′≤ℓ p = injective-on-related (H.M₁ ι₁-hom) ℓ′≤ℓ $ 147 | H.M₁ ι₁-hom # ℓ′ ≡˘⟨ μ-η H (ℓ̅ ℓ′) #ₚ _ ⟩ 148 | H.μ Δ⁺ # (H.M₁ (ℓ̅ ℓ′) # (H.η Δ⁺ # ι₀ ⋆)) ≡⟨ p #ₚ (H.η _ # ι₀ ⋆) ⟩ 149 | H.μ Δ⁺ # (H.M₁ (ℓ̅ ℓ) # (H.η Δ⁺ # ι₀ ⋆)) ≡⟨ μ-η H (ℓ̅ ℓ) #ₚ _ ⟩ 150 | H.M₁ ι₁-hom # ℓ ∎ 151 | 152 | abstract 153 | ℓ̅-σ̅ : ∀ {ℓ : ⌞ Fᴴ₀ Δ ⌟} (σ : SOrdᴴ.Hom (Fᴴ₀ Δ) (Fᴴ₀ Δ)) → ℓ̅ (σ # ℓ) ≡ H.μ _ ∘ H.M₁ (σ̅ σ) ∘ ℓ̅ ℓ 154 | ℓ̅-σ̅ {ℓ} σ = ext λ where 155 | (ι₀ ⋆) → 156 | H.M₁ ι₁-hom # (σ # ℓ) ≡˘⟨ ap# (H.M₁ ι₁-hom ∘ σ .morphism) $ H.left-ident #ₚ ℓ ⟩ 157 | H.M₁ ι₁-hom # (σ # (H.μ _ # (H.M₁ (H.η _) # ℓ))) ≡˘⟨ ap# (H.M₁ ι₁-hom) $ μ-M-∘-Algebraic H σ (H.η Δ) #ₚ _ ⟩ 158 | H.M₁ ι₁-hom # (H.μ _ # (H.M₁ (σ .morphism ∘ H.η _) # ℓ)) ≡˘⟨ μ-M-∘-M H ι₁-hom (σ .morphism ∘ H.η Δ) #ₚ _ ⟩ 159 | H.μ _ # (H.M₁ (H.M₁ ι₁-hom ∘ σ .morphism ∘ H.η Δ) # ℓ) ≡⟨ ap# (H.μ _) (σ̅-ι σ ℓ) ⟩ 160 | H.μ _ # (H.M₁ (σ̅ σ) # (H.M₁ ι₁-hom # ℓ)) ∎ 161 | (ι₁ α) → 162 | H.η _ # ι₂ α ≡˘⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 163 | H.μ _ # (H.M₁ (σ̅ σ) # (H.η _ # ι₂ α)) ∎ 164 | (ι₂ α) → 165 | H.η _ # ι₂ α ≡˘⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 166 | H.μ _ # (H.M₁ (σ̅ σ) # (H.η _ # ι₂ α)) ∎ 167 | 168 | nt : liftᶠ-strict-orders F∘ Uᴴ F∘ Endos-include 169 | => Uᴹᴰ F∘ Endos-include F∘ T 170 | nt ._=>_.η _ .hom (lift ℓ) = pt , ν′ ℓ 171 | nt ._=>_.η _ .pres-≤[]-equal (lift ℓ≤ℓ′) = 172 | inc (biased refl (ν′-mono ℓ≤ℓ′)) , λ p → ap lift $ ν′-injective-on-related ℓ≤ℓ′ (ap snd p) 173 | nt ._=>_.is-natural _ _ σ = ext λ ℓ → 174 | refl , λ α → 175 | H.μ _ # (H.M₁ (ℓ̅ (σ # ℓ)) # α) ≡⟨ ap (λ m → (H.μ _ ∘ H.M₁ m) # α) (ℓ̅-σ̅ σ) ⟩ 176 | H.μ _ # (H.M₁ (H.μ _ ∘ H.M₁ (σ̅ σ) ∘ ℓ̅ ℓ) # α) ≡⟨ μ-M-∘-μ H (H.M₁ (σ̅ σ) ∘ ℓ̅ ℓ) #ₚ α ⟩ 177 | H.μ _ # (H.μ _ # (H.M₁ (H.M₁ (σ̅ σ) ∘ (ℓ̅ ℓ)) # α)) ≡⟨ ap# (H.μ _) $ μ-M-∘-M H (σ̅ σ) (ℓ̅ ℓ) #ₚ α ⟩ 178 | H.μ _ # (H.M₁ (σ̅ σ) # (H.μ _ # (H.M₁ (ℓ̅ ℓ) # α))) ∎ 179 | -------------------------------------------------------------------------------- /src/Mugen/Cat/HierarchyTheory/Universality/SubcategoryEmbedding.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | open import Data.Nat 3 | 4 | open import Order.Instances.Discrete 5 | open import Order.Instances.Disjoint 6 | 7 | open import Cat.Prelude 8 | open import Cat.Functor.Base 9 | open import Cat.Functor.Properties 10 | open import Cat.Diagram.Monad 11 | 12 | import Cat.Reasoning as Cat 13 | 14 | open import Mugen.Prelude 15 | 16 | open import Mugen.Cat.Instances.Endomorphisms 17 | open import Mugen.Cat.Instances.Indexed 18 | open import Mugen.Cat.Instances.StrictOrders 19 | open import Mugen.Cat.Monad 20 | open import Mugen.Cat.HierarchyTheory 21 | 22 | open import Mugen.Order.StrictOrder 23 | open import Mugen.Order.Instances.Copower 24 | 25 | import Mugen.Order.Reasoning as Reasoning 26 | 27 | -------------------------------------------------------------------------------- 28 | -- The Universal Embedding Theorem 29 | -- Section 3.4, Lemma 3.9 30 | 31 | module Mugen.Cat.HierarchyTheory.Universality.SubcategoryEmbedding {o o' r} 32 | (H : Hierarchy-theory (o ⊔ o') (r ⊔ o')) {I : Type o'} ⦃ Discrete-I : Discrete I ⦄ 33 | (Δ₋ : ⌞ I ⌟ → Poset (o ⊔ o') (r ⊔ o')) where 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Notation 37 | -- 38 | -- We begin by defining some useful notation. 39 | 40 | private 41 | open Strictly-monotone 42 | open Algebra-hom 43 | open Cat (Strict-orders (o ⊔ o') (r ⊔ o')) 44 | module Δ₋ i = Poset (Δ₋ i) 45 | module H = Monad H 46 | 47 | ⌞Δ₋⌟ : I → Type (o ⊔ o') 48 | ⌞Δ₋⌟ i = ⌞ Δ₋ i ⌟ 49 | 50 | I-is-set : is-set I 51 | I-is-set = Discrete→is-set Discrete-I 52 | 53 | -- Δ is made public for proving the main theorem 54 | Δ : Poset (o ⊔ o') (r ⊔ o') 55 | Δ = Copower (el! Nat) (Disjoint (el I I-is-set) Δ₋) 56 | module Δ = Poset Δ 57 | 58 | private 59 | H⟨Δ⟩ : Poset (o ⊔ o') (r ⊔ o') 60 | H⟨Δ⟩ = H.M₀ Δ 61 | module H⟨Δ⟩ = Reasoning H⟨Δ⟩ 62 | 63 | SOrd : Precategory (lsuc (o ⊔ r ⊔ o')) (o ⊔ r ⊔ o') 64 | SOrd = Strict-orders (o ⊔ o') (r ⊔ o') 65 | module SOrd = Cat SOrd 66 | 67 | SOrdᴴ : Precategory (lsuc (o ⊔ r ⊔ o')) (lsuc (o ⊔ r ⊔ o')) 68 | SOrdᴴ = Eilenberg-Moore SOrd H 69 | module SOrdᴴ = Cat SOrdᴴ 70 | 71 | Uᴴ : Functor SOrdᴴ SOrd 72 | Uᴴ = Forget SOrd H 73 | 74 | Fᴴ : Functor SOrd SOrdᴴ 75 | Fᴴ = Free SOrd H 76 | 77 | Fᴴ₀ : Poset (o ⊔ o') (r ⊔ o') → Algebra SOrd H 78 | Fᴴ₀ = Fᴴ .Functor.F₀ 79 | 80 | Fᴴ₁ : {X Y : Poset (o ⊔ o') (r ⊔ o')} → Hom X Y → SOrdᴴ.Hom (Fᴴ₀ X) (Fᴴ₀ Y) 81 | Fᴴ₁ = Fᴴ .Functor.F₁ 82 | 83 | FᴴΔ₋ : I → Algebra SOrd H 84 | FᴴΔ₋ i = Fᴴ₀ (Δ₋ i) 85 | 86 | pattern ι n i α = (n , i , α) 87 | 88 | ι-inj : ∀ {n : Nat} {i : I} {x y : ⌞ Δ₋ i ⌟} → _≡_ {A = ⌞ Δ ⌟} (ι n i x) (ι n i y) → x ≡ y 89 | ι-inj p = is-set→cast-pathp ⌞Δ₋⌟ I-is-set λ j → p j .snd .snd 90 | 91 | ι-hom : ∀ (n : Nat) (i : I) → Hom (Δ₋ i) Δ 92 | ι-hom n i .hom = ι n i 93 | ι-hom n i .pres-≤[]-equal α≤β = (reflᵢ , (reflᵢ , α≤β)) , ι-inj 94 | 95 | ι-monic : ∀ {n : Nat} {i : I} → SOrd.is-monic (ι-hom n i) 96 | ι-monic g h eq = ext λ α → ι-inj (eq #ₚ α) 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Construction of the functor T 100 | -- Section 3.4, Lemma 3.9 101 | 102 | σ̅ : {i j : I} → SOrdᴴ.Hom (FᴴΔ₋ i) (FᴴΔ₋ j) → Hom Δ H⟨Δ⟩ 103 | σ̅ {i} {j} σ .hom (ι n k α) with k ≡ᵢ? i | n | k ≡ᵢ? j 104 | ... | yes k=ᵢi | 0 | _ = H.M₁ (ι-hom 0 j) # (σ # (H.η (Δ₋ i) # substᵢ ⌞Δ₋⌟ k=ᵢi α)) -- case k0j 105 | ... | yes _ | suc n | yes _ = H.η Δ # ι (suc n) k α -- case k1k 106 | ... | yes _ | suc n | no _ = H.η Δ # ι n k α -- case k1j 107 | ... | no _ | n | yes _ = H.η Δ # ι (suc n) k α -- case ik 108 | ... | no _ | n | no _ = H.η Δ # ι n k α -- case ij 109 | σ̅ {i} {j} σ .pres-≤[]-equal {ι n k α} {ι n k β} (reflᵢ , reflᵢ , α≤β) with k ≡ᵢ? i | n | k ≡ᵢ? j 110 | ... | yes reflᵢ | 0 | _ = H⟨Δ⟩.≤[]-map (ap (ι 0 i)) $ (H.M₁ (ι-hom 0 j) ∘ σ .morphism ∘ H.η (Δ₋ i)) .pres-≤[]-equal α≤β 111 | ... | yes reflᵢ | suc n | yes _ = H.η Δ .pres-≤[]-equal (reflᵢ , reflᵢ , α≤β) 112 | ... | yes reflᵢ | suc n | no _ = H⟨Δ⟩.≤[]-map (ap (ι (suc n) k)) $ (H.η Δ ∘ ι-hom n k) .pres-≤[]-equal α≤β 113 | ... | no _ | n | yes _ = H⟨Δ⟩.≤[]-map (ap (ι n k)) $ (H.η Δ ∘ ι-hom (suc n) k) .pres-≤[]-equal α≤β 114 | ... | no _ | n | no _ = H.η Δ .pres-≤[]-equal (reflᵢ , reflᵢ , α≤β) 115 | 116 | -- Raw β rules of σ̅ σ matching its five cases 117 | module _ where 118 | abstract 119 | σ̅-ι-k0j-ext : ∀ {i j k : I} (σ : SOrdᴴ.Hom (FᴴΔ₋ i) (FᴴΔ₋ j)) 120 | → (p : k ≡ᵢ i) 121 | → (α : ⌞ Δ₋ k ⌟) 122 | → σ̅ σ # ι 0 k α ≡ H.M₁ (ι-hom 0 j) # (σ # (H.η (Δ₋ i) # substᵢ ⌞Δ₋⌟ p α)) 123 | σ̅-ι-k0j-ext {i = i} {j} {k} σ p α with k ≡ᵢ? i 124 | ... | no k≠ᵢi = absurd (k≠ᵢi p) 125 | ... | yes reflᵢ = 126 | H.M₁ (ι-hom 0 j) # (σ # (H.η (Δ₋ i) # α)) 127 | ≡⟨ ap# (H.M₁ (ι-hom 0 j) ∘ σ .morphism ∘ H.η (Δ₋ i)) $ substᵢ-filler-set ⌞Δ₋⌟ I-is-set p α ⟩ 128 | H.M₁ (ι-hom 0 j) # (σ # (H.η (Δ₋ i) # substᵢ ⌞Δ₋⌟ p α)) 129 | ∎ 130 | 131 | σ̅-ι-k1k-ext : ∀ (n : Nat) {i j k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ j))) 132 | → k ≡ᵢ i 133 | → k ≡ᵢ j 134 | → (α : ⌞ Δ₋ k ⌟) 135 | → σ̅ σ # ι (suc n) k α ≡ H.η Δ # ι (suc n) k α 136 | σ̅-ι-k1k-ext n {i = i} {j} {k} σ k=ᵢi k=ᵢj α with k ≡ᵢ? i | k ≡ᵢ? j 137 | ... | no k≠ᵢi | _ = absurd (k≠ᵢi k=ᵢi) 138 | ... | yes _ | no k≠ᵢj = absurd (k≠ᵢj k=ᵢj) 139 | ... | yes _ | yes _ = refl 140 | 141 | σ̅-ι-k1j-ext : ∀ (n : Nat) {i j k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ j))) 142 | → k ≡ᵢ i 143 | → ¬ (k ≡ᵢ j) 144 | → (α : ⌞ Δ₋ k ⌟) 145 | → σ̅ σ # ι (suc n) k α ≡ H.η Δ # ι n k α 146 | σ̅-ι-k1j-ext n {i = i} {j} {k} σ k=ᵢi k≠ᵢj α with k ≡ᵢ? i | k ≡ᵢ? j 147 | ... | no k≠ᵢi | _ = absurd (k≠ᵢi k=ᵢi) 148 | ... | yes _ | yes k=ᵢj = absurd (k≠ᵢj k=ᵢj) 149 | ... | yes _ | no _ = refl 150 | 151 | σ̅-ι-ik-ext : ∀ (n : Nat) {i j k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ j))) 152 | → ¬ (k ≡ᵢ i) 153 | → k ≡ᵢ j 154 | → (α : ⌞ Δ₋ k ⌟) 155 | → σ̅ σ # ι n k α ≡ H.η Δ # ι (suc n) k α 156 | σ̅-ι-ik-ext n {i = i} {j} {k} σ k≠ᵢi k=ᵢj α with k ≡ᵢ? i | k ≡ᵢ? j 157 | ... | yes k=ᵢi | _ = absurd (k≠ᵢi k=ᵢi) 158 | ... | no _ | no k≠ᵢj = absurd (k≠ᵢj k=ᵢj) 159 | ... | no _ | yes _ = refl 160 | 161 | σ̅-ι-ij-ext : ∀ (n : Nat) {i j k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ j))) 162 | → ¬ (k ≡ᵢ i) 163 | → ¬ (k ≡ᵢ j) 164 | → (α : ⌞ Δ₋ k ⌟) 165 | → σ̅ σ # ι n k α ≡ H.η Δ # ι n k α 166 | σ̅-ι-ij-ext n {i = i} {j} {k} σ k≠ᵢi k≠ᵢj α with k ≡ᵢ? i | k ≡ᵢ? j 167 | ... | yes k=ᵢi | _ = absurd (k≠ᵢi k=ᵢi) 168 | ... | no _ | yes k=ᵢj = absurd (k≠ᵢj k=ᵢj) 169 | ... | no _ | no _ = refl 170 | 171 | -- Wrapped β rules of H.M₁ (σ̅ σ) 172 | module _ where 173 | abstract 174 | H-σ̅-ι-k0j : ∀ {k j : I} (σ : SOrdᴴ.Hom (FᴴΔ₋ k) (FᴴΔ₋ j)) (α : ⌞ H.M₀ (Δ₋ k) ⌟) 175 | → H.μ Δ # (H.M₁ (σ̅ σ) # (H.M₁ (ι-hom 0 k) # α)) 176 | ≡ H.M₁ (ι-hom 0 j) # (σ # α) 177 | H-σ̅-ι-k0j {k = k} {j} σ α = 178 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.M₁ (ι-hom 0 k) # α)) 179 | ≡˘⟨ ap# (H.μ Δ) $ H.M-∘ (σ̅ σ) (ι-hom 0 k) #ₚ α ⟩ 180 | H.μ Δ # (H.M₁ (σ̅ σ ∘ ι-hom 0 k) # α) 181 | ≡⟨ ap (λ m → H.μ Δ # (H.M₁ m # α)) $ ext $ σ̅-ι-k0j-ext σ reflᵢ ⟩ 182 | H.μ Δ # (H.M₁ (H.M₁ (ι-hom 0 j) ∘ σ .morphism ∘ H.η (Δ₋ k)) # α) 183 | ≡⟨ μ-M-∘-M H (ι-hom 0 j) (σ .morphism ∘ H.η (Δ₋ k)) #ₚ α ⟩ 184 | H.M₁ (ι-hom 0 j) # (H.μ (Δ₋ j) # (H.M₁ (σ .morphism ∘ H.η (Δ₋ k)) # α)) 185 | ≡⟨ ap# (H.M₁ (ι-hom 0 j)) $ μ-M-∘-Algebraic H σ (H.η (Δ₋ k)) #ₚ α ⟩ 186 | H.M₁ (ι-hom 0 j) # (σ # (H.μ (Δ₋ k) # (H.M₁ (H.η (Δ₋ k)) # α))) 187 | ≡⟨ ap# (H.M₁ (ι-hom 0 j) ∘ σ .morphism) $ H.left-ident #ₚ _ ⟩ 188 | H.M₁ (ι-hom 0 j) # (σ # α) 189 | ∎ 190 | 191 | H-σ̅-η-ι-k1k : ∀ (n : Nat) {i : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ i))) 192 | → (α : ⌞ Δ₋ i ⌟) 193 | → H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι (suc n) i α)) 194 | ≡ H.η Δ # ι (suc n) i α 195 | H-σ̅-η-ι-k1k n {i = i} σ α = 196 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι (suc n) i α)) 197 | ≡⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 198 | σ̅ σ # ι (suc n) i α 199 | ≡⟨ σ̅-ι-k1k-ext n σ reflᵢ reflᵢ α ⟩ 200 | H.η Δ # ι (suc n) i α 201 | ∎ 202 | 203 | H-σ̅-η-ι-k1j : ∀ (n : Nat) {k j : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ k)) (Fᴴ₀ (Δ₋ j))) 204 | → ¬ (k ≡ᵢ j) 205 | → (α : ⌞ Δ₋ k ⌟) 206 | → H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι (suc n) k α)) 207 | ≡ H.η Δ # ι n k α 208 | H-σ̅-η-ι-k1j n {k = k} σ k≠j α = 209 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι (suc n) k α)) 210 | ≡⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 211 | σ̅ σ # ι (suc n) k α 212 | ≡⟨ σ̅-ι-k1j-ext n σ reflᵢ k≠j α ⟩ 213 | H.η Δ # ι n k α 214 | ∎ 215 | 216 | H-σ̅-η-ι-ik : ∀ (n : Nat) {i k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ k))) 217 | → ¬ (k ≡ᵢ i) 218 | → (α : ⌞ Δ₋ k ⌟) 219 | → H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι n k α)) 220 | ≡ H.η Δ # ι (suc n) k α 221 | H-σ̅-η-ι-ik n {i = i} {k} σ k≠i α = 222 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι n k α)) 223 | ≡⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 224 | σ̅ σ # ι n k α 225 | ≡⟨ σ̅-ι-ik-ext n σ k≠i reflᵢ α ⟩ 226 | H.η Δ # ι (suc n) k α 227 | ∎ 228 | 229 | H-σ̅-η-ι-ij : ∀ (n : Nat) {i j k : I} (σ : SOrdᴴ.Hom (Fᴴ₀ (Δ₋ i)) (Fᴴ₀ (Δ₋ j))) 230 | → ¬ (k ≡ᵢ i) 231 | → ¬ (k ≡ᵢ j) 232 | → (α : ⌞ Δ₋ k ⌟) 233 | → H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι n k α)) 234 | ≡ H.η Δ # ι n k α 235 | H-σ̅-η-ι-ij n {i = i} {j} {k} σ k≠i k≠j α = 236 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.η Δ # ι n k α)) 237 | ≡⟨ μ-η H (σ̅ σ) #ₚ _ ⟩ 238 | σ̅ σ # ι n k α 239 | ≡⟨ σ̅-ι-ij-ext n σ k≠i k≠j α ⟩ 240 | H.η Δ # ι n k α 241 | ∎ 242 | 243 | abstract 244 | σ̅-id : ∀ {i : I} (n : Nat) (k : I) (α : ⌞ Δ₋ k ⌟) → 245 | σ̅ {i = i} SOrdᴴ.id # ι n k α ≡ H.η Δ # ι n k α 246 | σ̅-id {i = i} n k α with k ≡ᵢ? i | n 247 | ... | yes reflᵢ | 0 = sym (H.unit.is-natural (Δ₋ i) Δ (ι-hom 0 i)) #ₚ α 248 | ... | yes reflᵢ | suc n = refl 249 | ... | no _ | n = refl 250 | 251 | abstract 252 | σ̅-∘ : ∀ {i j k : I} 253 | (σ : SOrdᴴ.Hom (FᴴΔ₋ j) (FᴴΔ₋ k)) 254 | (δ : SOrdᴴ.Hom (FᴴΔ₋ i) (FᴴΔ₋ j)) 255 | (n : Nat) (l : I) (α : ⌞Δ₋⌟ l) 256 | → σ̅ (σ SOrdᴴ.∘ δ) # ι n l α 257 | ≡ (H.μ Δ ∘ H.M₁ (σ̅ σ) ∘ σ̅ δ) # ι n l α 258 | σ̅-∘ {i = i} {j} {k} σ δ n l α with l ≡ᵢ? i | n | l ≡ᵢ? j | l ≡ᵢ? k 259 | ... | yes reflᵢ | 0 | _ | _ = sym $ H-σ̅-ι-k0j σ (δ # (H.η (Δ₋ i) # α)) 260 | -- Note: the following eight cases correspond to the table in the paper with eight rows. 261 | ... | yes reflᵢ | suc n | yes reflᵢ | yes reflᵢ = sym $ H-σ̅-η-ι-k1k n σ α 262 | ... | yes reflᵢ | suc n | yes reflᵢ | no l≠k = sym $ H-σ̅-η-ι-k1j n σ l≠k α 263 | ... | yes reflᵢ | suc n | no l≠j | yes reflᵢ = sym $ H-σ̅-η-ι-ik n σ l≠j α 264 | ... | yes reflᵢ | suc n | no l≠j | no l≠k = sym $ H-σ̅-η-ι-ij n σ l≠j l≠k α 265 | ... | no l≠i | n | yes reflᵢ | yes reflᵢ = sym $ H-σ̅-η-ι-k1k n σ α 266 | ... | no l≠i | n | yes reflᵢ | no l≠k = sym $ H-σ̅-η-ι-k1j n σ l≠k α 267 | ... | no l≠i | n | no l≠j | yes reflᵢ = sym $ H-σ̅-η-ι-ik n σ l≠j α 268 | ... | no l≠i | n | no l≠j | no l≠k = sym $ H-σ̅-η-ι-ij n σ l≠j l≠k α 269 | 270 | T : Functor (Indexed SOrdᴴ FᴴΔ₋) (Endos SOrdᴴ (Fᴴ₀ Δ)) 271 | T .Functor.F₀ i = tt 272 | T .Functor.F₁ σ .morphism = H.μ Δ ∘ H.M₁ (σ̅ σ) 273 | T .Functor.F₁ σ .commutes = ext λ α → 274 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.μ Δ # α)) ≡˘⟨ ap# (H.μ _) $ H.mult.is-natural _ _ (σ̅ σ) #ₚ α ⟩ 275 | H.μ Δ # (H.μ (H.M₀ Δ) # (H.M₁ (H.M₁ (σ̅ σ)) # α)) ≡˘⟨ μ-M-∘-μ H (H.M₁ (σ̅ σ)) #ₚ α ⟩ 276 | H.μ Δ # (H.M₁ (H.μ Δ ∘ H.M₁ (σ̅ σ)) # α) ∎ 277 | T .Functor.F-id = ext λ α → 278 | H.μ _ # (H.M₁ (σ̅ SOrdᴴ.id) # α) ≡⟨ ap (λ m → H.μ _ # (H.M₁ m # α)) $ ext σ̅-id ⟩ 279 | H.μ _ # (H.M₁ (H.η _) # α) ≡⟨ H.left-ident #ₚ _ ⟩ 280 | α ∎ 281 | T .Functor.F-∘ σ δ = ext λ α → 282 | H.μ Δ # (H.M₁ (σ̅ (σ SOrdᴴ.∘ δ)) # α) ≡⟨ ap# (H.μ Δ) $ ap (H.M₁) (ext $ σ̅-∘ σ δ) #ₚ α ⟩ 283 | H.μ Δ # (H.M₁ (H.μ Δ ∘ H.M₁ (σ̅ σ) ∘ σ̅ δ) # α) ≡⟨ μ-M-∘-μ H (H.M₁ (σ̅ σ) ∘ σ̅ δ) #ₚ α ⟩ 284 | H.μ Δ # (H.μ (H.M₀ Δ) # (H.M₁ (H.M₁ (σ̅ σ) ∘ σ̅ δ) # α)) ≡⟨ ap# (H.μ Δ) $ μ-M-∘-M H (σ̅ σ) (σ̅ δ) #ₚ α ⟩ 285 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.μ Δ # (H.M₁ (σ̅ δ) # α))) ∎ 286 | 287 | -------------------------------------------------------------------------------- 288 | -- Constructing the natural transformation ν 289 | -- Section 3.4, Lemma 3.8 290 | 291 | ν : Indexed-include => Endos-include F∘ T 292 | ν ._=>_.η i = Fᴴ₁ (ι-hom 0 i) 293 | ν ._=>_.is-natural i j σ = sym $ ext $ H-σ̅-ι-k0j σ 294 | 295 | -------------------------------------------------------------------------------- 296 | -- Faithfulness of T 297 | -- Section 3.4, Lemma 3.9 298 | 299 | abstract 300 | T-faithful : preserves-monos H → is-faithful T 301 | T-faithful H-preserves-monos {i} {j} {σ} {δ} eq = 302 | Algebra-hom-path _ $ H-preserves-monos (ι-hom 0 j) ι-monic _ _ $ ext λ α → 303 | H.M₁ (ι-hom 0 j) # (σ # α) ≡˘⟨ H-σ̅-ι-k0j σ α ⟩ 304 | H.μ Δ # (H.M₁ (σ̅ σ) # (H.M₁ (ι-hom 0 i) # α)) ≡⟨ eq #ₚ (H.M₁ (ι-hom 0 i) # α) ⟩ 305 | H.μ Δ # (H.M₁ (σ̅ δ) # (H.M₁ (ι-hom 0 i) # α)) ≡⟨ H-σ̅-ι-k0j δ α ⟩ 306 | H.M₁ (ι-hom 0 j) # (δ # α) ∎ 307 | -------------------------------------------------------------------------------- /src/Mugen/Cat/Instances/Displacements.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Cat.Instances.Displacements where 2 | 3 | open import Cat.Displayed.Base 4 | open import Cat.Displayed.Total 5 | 6 | open import Mugen.Prelude 7 | open import Mugen.Algebra.Displacement 8 | open import Mugen.Cat.Instances.StrictOrders 9 | 10 | -------------------------------------------------------------------------------- 11 | -- The Category of Displacement Algebras 12 | 13 | Displacements-over : ∀ (o r : Level) → Displayed (Strict-orders o r) (o ⊔ lsuc r) o 14 | Displacements-over o r .Displayed.Ob[_] A = Displacement-on A 15 | Displacements-over o r .Displayed.Hom[_] f X Y = is-displacement-hom X Y f 16 | Displacements-over o r .Displayed.Hom[_]-set f X Y = hlevel 2 17 | Displacements-over o r .Displayed.id' = id-is-displacement-hom _ 18 | Displacements-over o r .Displayed._∘'_ = ∘-is-displacement-hom 19 | Displacements-over o r .Displayed.idr' _ = prop! 20 | Displacements-over o r .Displayed.idl' _ = prop! 21 | Displacements-over o r .Displayed.assoc' _ _ _ = prop! 22 | 23 | Displacements : ∀ o r → Precategory (lsuc o ⊔ lsuc r) (o ⊔ r) 24 | Displacements o r = ∫ (Displacements-over o r) 25 | -------------------------------------------------------------------------------- /src/Mugen/Cat/Instances/Endomorphisms.agda: -------------------------------------------------------------------------------- 1 | open import Cat.Prelude 2 | 3 | module Mugen.Cat.Instances.Endomorphisms {o ℓ} where 4 | 5 | -------------------------------------------------------------------------------- 6 | -- The category of endomorphisms on an object. 7 | -- 8 | -- /Technically/ this is a monoid, but it's easier to work with 9 | -- in this form w/o having to introduce a delooping. 10 | 11 | open import Mugen.Cat.Instances.Indexed 12 | 13 | Endos : (𝒞 : Precategory o ℓ) (X : 𝒞 .Precategory.Ob) → Precategory lzero ℓ 14 | Endos 𝒞 X = Indexed {I = ⊤} 𝒞 λ _ → X 15 | 16 | Endos-include : {𝒞 : Precategory o ℓ} {X : 𝒞 .Precategory.Ob} → Functor (Endos 𝒞 X) 𝒞 17 | Endos-include = Indexed-include 18 | -------------------------------------------------------------------------------- /src/Mugen/Cat/Instances/Indexed.agda: -------------------------------------------------------------------------------- 1 | open import Cat.Prelude 2 | 3 | module Mugen.Cat.Instances.Indexed {o o' ℓ} {I : Type o'} where 4 | 5 | import Cat.Reasoning as Cat 6 | 7 | Indexed : (𝒞 : Precategory o ℓ) (F : I → 𝒞 .Precategory.Ob) → Precategory o' ℓ 8 | Indexed 𝒞 F = C where 9 | open Cat 𝒞 10 | C : Precategory o' ℓ 11 | C .Precategory.Ob = I 12 | C .Precategory.Hom i j = Hom (F i) (F j) 13 | C .Precategory.Hom-set _ _ = Hom-set _ _ 14 | C .Precategory.id = id 15 | C .Precategory._∘_ = _∘_ 16 | C .Precategory.idr = idr 17 | C .Precategory.idl = idl 18 | C .Precategory.assoc = assoc 19 | 20 | Indexed-include : ∀ {𝒞} {F : I → 𝒞 .Precategory.Ob} → Functor (Indexed 𝒞 F) 𝒞 21 | Indexed-include {F = F} .Functor.F₀ = F 22 | Indexed-include .Functor.F₁ σ = σ 23 | Indexed-include .Functor.F-id = refl 24 | Indexed-include .Functor.F-∘ _ _ = refl 25 | -------------------------------------------------------------------------------- /src/Mugen/Cat/Instances/StrictOrders.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Cat.Instances.StrictOrders where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Order.StrictOrder 5 | open import Mugen.Order.Instances.Lift 6 | 7 | -------------------------------------------------------------------------------- 8 | -- The Category of Strict Orders 9 | 10 | open Precategory 11 | 12 | Strict-orders : ∀ (o r : Level) → Precategory (lsuc o ⊔ lsuc r) (o ⊔ r) 13 | Strict-orders o r .Ob = Poset o r 14 | Strict-orders o r .Hom = Strictly-monotone 15 | Strict-orders o r .Hom-set X Y = hlevel 2 16 | Strict-orders o r .id = strictly-monotone-id 17 | Strict-orders o r ._∘_ = strictly-monotone-∘ 18 | Strict-orders o r .idr f = ext λ _ → refl 19 | Strict-orders o r .idl f = ext λ _ → refl 20 | Strict-orders o r .assoc f g h = ext λ _ → refl 21 | 22 | liftᶠ-strict-orders : ∀ {o r o' r' : Level} → Functor (Strict-orders o r) (Strict-orders (o ⊔ o') (r ⊔ r')) 23 | liftᶠ-strict-orders {o' = o'} {r'} .Functor.F₀ X = Liftᵖ o' r' X 24 | liftᶠ-strict-orders .Functor.F₁ f = strictly-monotone-∘ (strictly-monotone-∘ lift-strictly-monotone f) lower-strictly-monotone 25 | liftᶠ-strict-orders .Functor.F-id = ext λ _ → refl 26 | liftᶠ-strict-orders .Functor.F-∘ _ _ = ext λ _ → refl 27 | -------------------------------------------------------------------------------- /src/Mugen/Cat/Monad.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Cat.Monad where 2 | 3 | open import Cat.Diagram.Monad 4 | import Cat.Reasoning as Cat 5 | 6 | open import Mugen.Prelude 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Misc. Lemmas for Monads 10 | 11 | module _ {o r} {C : Precategory o r} (M : Monad C) where 12 | private 13 | module M = Monad M 14 | 15 | open Cat C 16 | open Algebra-hom 17 | 18 | Free₀ : Ob → Algebra C M 19 | Free₀ = Functor.F₀ (Free C M) 20 | 21 | Free₁ : ∀ {X Y} → Hom X Y → Algebra-hom C M (Free₀ X) (Free₀ Y) 22 | Free₁ = Functor.F₁ (Free C M) 23 | 24 | abstract 25 | μ-M-∘-Algebraic : ∀ {X Y Z} (σ : Algebra-hom C M (Free₀ Y) (Free₀ Z)) (δ : Hom X (M.M₀ Y)) 26 | → M.μ Z ∘ M.M₁ (σ .morphism ∘ δ) ≡ σ .morphism ∘ M.μ Y ∘ M.M₁ δ 27 | μ-M-∘-Algebraic {X = X} {Y} {Z} σ δ = 28 | M.μ Z ∘ M.M₁ (σ .morphism ∘ δ) 29 | ≡⟨ ap (M.μ Z ∘_) $ M.M-∘ (σ .morphism) δ ⟩ 30 | M.μ Z ∘ M.M₁ (σ .morphism) ∘ (M.M₁ δ) 31 | ≡⟨ assoc (M.μ Z) (M.M₁ (σ .morphism)) (M.M₁ δ) ⟩ 32 | (M.μ Z ∘ M.M₁ (σ .morphism)) ∘ (M.M₁ δ) 33 | ≡˘⟨ ap (_∘ M.M₁ δ) $ σ .commutes ⟩ 34 | (σ .morphism ∘ M.μ Y) ∘ M.M₁ δ 35 | ≡˘⟨ assoc (σ .morphism) (M.μ Y) (M.M₁ δ) ⟩ 36 | σ .morphism ∘ M.μ Y ∘ M.M₁ δ 37 | ∎ 38 | 39 | μ-M-∘-M : ∀ {X Y Z} (σ : Hom Y Z) (δ : Hom X (M.M₀ Y)) 40 | → M.μ Z ∘ M.M₁ (M.M₁ σ ∘ δ) ≡ M.M₁ σ ∘ M.μ Y ∘ M.M₁ δ 41 | μ-M-∘-M σ δ = μ-M-∘-Algebraic (Free₁ σ) δ 42 | 43 | μ-M-∘-μ : ∀ {X Y} (σ : Hom X (M.M₀ (M.M₀ Y))) 44 | → M.μ Y ∘ M.M₁ (M.μ Y ∘ σ) ≡ M.μ Y ∘ M.μ (M.M₀ Y) ∘ M.M₁ σ 45 | μ-M-∘-μ {Y = Y} σ = 46 | M.μ Y ∘ M.M₁ (M.μ Y ∘ σ) 47 | ≡⟨ ap (M.μ Y ∘_) $ M.M-∘ (M.μ Y) σ ⟩ 48 | M.μ Y ∘ M.M₁ (M.μ Y) ∘ M.M₁ σ 49 | ≡⟨ assoc (M.μ Y) (M.M₁ (M.μ Y)) (M.M₁ σ) ⟩ 50 | (M.μ Y ∘ M.M₁ (M.μ Y)) ∘ M.M₁ σ 51 | ≡⟨ ap (_∘ M.M₁ σ) $ M.mult-assoc ⟩ 52 | (M.μ Y ∘ M.μ (M.M₀ Y)) ∘ M.M₁ σ 53 | ≡˘⟨ assoc (M.μ Y) (M.μ (M.M₀ Y)) (M.M₁ σ) ⟩ 54 | M.μ Y ∘ M.μ (M.M₀ Y) ∘ M.M₁ σ 55 | ∎ 56 | 57 | -- Favonia: what would be a better name? 58 | μ-η : ∀ {X Y} (σ : Hom X (M.M₀ Y)) 59 | → M.μ Y ∘ M.M₁ σ ∘ M.η X ≡ σ 60 | μ-η {X = X} {Y} σ = 61 | M.μ Y ∘ M.M₁ σ ∘ M.η X 62 | ≡˘⟨ ap (M.μ Y ∘_) $ M.unit.is-natural X (M.M₀ Y) σ ⟩ 63 | M.μ Y ∘ M.η (M.M₀ Y) ∘ σ 64 | ≡⟨ assoc (M.μ Y) (M.η (M.M₀ Y)) σ ⟩ 65 | (M.μ Y ∘ M.η (M.M₀ Y)) ∘ σ 66 | ≡⟨ eliml M.right-ident ⟩ 67 | σ 68 | ∎ 69 | 70 | -- Favonia: does this lemma belong to 1lab? 71 | free-algebra-hom-path : ∀ {X Y} {f g : Algebra-hom C M (Free₀ X) (Free₀ Y)} 72 | → f .morphism ∘ M.η _ ≡ (g .morphism ∘ M.η _) → f ≡ g 73 | free-algebra-hom-path {f = f} {g = g} p = Algebra-hom-path _ $ 74 | f .morphism ≡⟨ intror M.left-ident ⟩ 75 | f .morphism ∘ M.μ _ ∘ M.M₁ (M.η _) ≡˘⟨ μ-M-∘-Algebraic f (M.η _) ⟩ 76 | M.μ _ ∘ M.M₁ (f .morphism ∘ M.η _) ≡⟨ ap (λ ϕ → M.μ _ ∘ M.M₁ ϕ) p ⟩ 77 | M.μ _ ∘ M.M₁ (g .morphism ∘ M.η _) ≡⟨ μ-M-∘-Algebraic g (M.η _) ⟩ 78 | g .morphism ∘ M.μ _ ∘ M.M₁ (M.η _) ≡⟨ elimr M.left-ident ⟩ 79 | g .morphism ∎ 80 | -------------------------------------------------------------------------------- /src/Mugen/Cat/README.md: -------------------------------------------------------------------------------- 1 | # Categorical Properties 2 | 3 | This directory formalizes various categorical results, focusing on the definition of [hierarchy theories](HierarchyTheory.agda), 4 | as well as the first steps towards proving that the [McBride Hierarchy Theory is universal](HierarchyTheory/Universality/). 5 | -------------------------------------------------------------------------------- /src/Mugen/Data/List.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Data.List where 2 | 3 | open import Algebra.Magma 4 | open import Algebra.Monoid 5 | open import Algebra.Semigroup 6 | 7 | -- The version of reverse in the 1Lab is difficult to reason about, 8 | -- due to a where-bound recursive helper. Instead, we define our own. 9 | open import Data.List hiding (reverse) public 10 | 11 | open import Mugen.Prelude 12 | 13 | private variable 14 | ℓ : Level 15 | A : Type ℓ 16 | 17 | ++-injr : (xs ys zs : List A) → xs ++ ys ≡ xs ++ zs → ys ≡ zs 18 | ++-injr [] _ _ p = p 19 | ++-injr (x ∷ xs) _ _ p = ++-injr xs _ _ $ ∷-tail-inj p 20 | 21 | module _ (aset : is-set A) where 22 | 23 | ++-is-magma : is-magma {A = List A} _++_ 24 | ++-is-magma .has-is-set = ListPath.List-is-hlevel 0 aset 25 | 26 | ++-is-semigroup : is-semigroup {A = List A} _++_ 27 | ++-is-semigroup .has-is-magma = ++-is-magma 28 | ++-is-semigroup .associative {x} {y} {z} = sym (++-assoc x y z) 29 | 30 | ++-is-monoid : is-monoid {A = List A} [] _++_ 31 | ++-is-monoid .has-is-semigroup = ++-is-semigroup 32 | ++-is-monoid .idl {x} = ++-idl x 33 | ++-is-monoid .idr {x} = ++-idr x 34 | -------------------------------------------------------------------------------- /src/Mugen/Data/NonEmpty.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Data.NonEmpty where 2 | 3 | open import Mugen.Prelude 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Non-Empty Lists 7 | 8 | data List⁺ {ℓ} (A : Type ℓ) : Type ℓ where 9 | [_] : A → List⁺ A 10 | _∷_ : A → List⁺ A → List⁺ A 11 | 12 | private variable 13 | ℓ : Level 14 | A : Type ℓ 15 | 16 | head : List⁺ A → A 17 | head [ x ] = x 18 | head (x ∷ xs) = x 19 | 20 | private 21 | tail : List⁺ A → List⁺ A 22 | tail [ x ] = [ x ] 23 | tail (x ∷ xs) = xs 24 | 25 | []-inj : ∀ {x y : A} → [ x ] ≡ [ y ] → x ≡ y 26 | []-inj p = ap head p 27 | 28 | ∷-head-inj : ∀ {x y : A} {xs ys : List⁺ A} → (x ∷ xs) ≡ (y ∷ ys) → x ≡ y 29 | ∷-head-inj p = ap head p 30 | 31 | ∷-tail-inj : ∀ {x y : A} {xs ys : List⁺ A} → (x ∷ xs) ≡ (y ∷ ys) → xs ≡ ys 32 | ∷-tail-inj p = ap tail p 33 | 34 | []≢∷ : ∀ {x y : A} {ys : List⁺ A} → [ x ] ≡ y ∷ ys → ⊥ 35 | []≢∷ p = subst distinguish p tt 36 | where 37 | distinguish : List⁺ A → Type 38 | distinguish [ x ] = ⊤ 39 | distinguish (x ∷ xs) = ⊥ 40 | 41 | module List⁺-Path {ℓ} {A : Type ℓ} where 42 | Code : List⁺ A → List⁺ A → Type ℓ 43 | Code [ x ] [ y ] = x ≡ y 44 | Code [ x ] (y ∷ ys) = Lift _ ⊥ 45 | Code (x ∷ xs) [ _ ] = Lift _ ⊥ 46 | Code (x ∷ xs) (y ∷ ys) = (x ≡ y) × Code xs ys 47 | 48 | encode : ∀ {xs ys : List⁺ A} → xs ≡ ys → Code xs ys 49 | encode {xs = [ x ]} {ys = [ y ]} xs≡ys = []-inj xs≡ys 50 | encode {xs = [ x ]} {ys = y ∷ ys} xs≡ys = lift ([]≢∷ xs≡ys) 51 | encode {xs = x ∷ xs} {ys = [ y ]} xs≡ys = lift ([]≢∷ (sym xs≡ys)) 52 | encode {xs = x ∷ xs} {ys = y ∷ ys} xs≡ys = ∷-head-inj xs≡ys , encode {xs = xs} {ys = ys} (∷-tail-inj xs≡ys) 53 | 54 | decode : ∀ {xs ys : List⁺ A} → Code xs ys → xs ≡ ys 55 | decode {xs = [ x ]} {ys = [ y ]} p = ap [_] p 56 | decode {xs = x ∷ xs} {ys = y ∷ ys} (p , q) = ap₂ _∷_ p (decode q) 57 | 58 | encode-decode : ∀ {xs ys : List⁺ A} → (p : Code xs ys) → encode (decode p) ≡ p 59 | encode-decode {xs = [ x ]} {ys = [ y ]} p = refl 60 | encode-decode {xs = x ∷ xs} {ys = y ∷ ys} (p , q) = ap (p ,_) (encode-decode q) 61 | 62 | decode-encode : ∀ {xs ys : List⁺ A} → (p : xs ≡ ys) → decode (encode p) ≡ p 63 | decode-encode {xs = xs} {ys = ys} = J (λ y p → decode (encode p) ≡ p) de-refl where 64 | de-refl : ∀ {xs : List⁺ A} → decode (encode (λ i → xs)) ≡ (λ i → xs) 65 | de-refl {xs = [ x ]} = refl 66 | de-refl {xs = x ∷ xs} i j = x ∷ (de-refl {xs = xs} i j) 67 | 68 | Path≃Code : ∀ {xs ys : List⁺ A} → (xs ≡ ys) ≃ Code xs ys 69 | Path≃Code = Iso→Equiv (encode , iso decode encode-decode decode-encode) 70 | 71 | open List⁺-Path 72 | 73 | List⁺-is-hlevel : (n : Nat) → is-hlevel A (2 + n) → is-hlevel (List⁺ A) (2 + n) 74 | List⁺-is-hlevel {A = A} n ahl x y = Equiv→is-hlevel (suc n) Path≃Code List⁺-Code-is-hlevel where 75 | List⁺-Code-is-hlevel : ∀ {xs ys : List⁺ A} → is-hlevel (Code xs ys) (suc n) 76 | List⁺-Code-is-hlevel {xs = [ x ]} {ys = [ y ]} = ahl x y 77 | List⁺-Code-is-hlevel {xs = [ x ]} {ys = y ∷ ys} = is-prop→is-hlevel-suc (λ x → absurd (Lift.lower x)) 78 | List⁺-Code-is-hlevel {xs = x ∷ xs} {ys = [ y ]} = is-prop→is-hlevel-suc (λ x → absurd (Lift.lower x)) 79 | List⁺-Code-is-hlevel {xs = x ∷ xs} {ys = y ∷ ys} = ×-is-hlevel (suc n) (ahl x y) List⁺-Code-is-hlevel 80 | -------------------------------------------------------------------------------- /src/Mugen/Data/README.md: -------------------------------------------------------------------------------- 1 | # Data structures 2 | 3 | This directory contains various results about simple data structures (nats, lists, etc), as 4 | well as the definition of the coimage of a function. 5 | -------------------------------------------------------------------------------- /src/Mugen/Everything.agda: -------------------------------------------------------------------------------- 1 | 2 | -- DO NOT EDIT THIS FILE! 3 | -- THIS FILE IS AUTOMATICALLY GENERATED BY 'make Everything.agda' 4 | 5 | module Mugen.Everything where 6 | import Mugen.Algebra.Displacement 7 | import Mugen.Algebra.Displacement.Action 8 | import Mugen.Algebra.Displacement.Instances.Constant 9 | import Mugen.Algebra.Displacement.Instances.Endomorphism 10 | import Mugen.Algebra.Displacement.Instances.Fractal 11 | import Mugen.Algebra.Displacement.Instances.IndexedProduct 12 | import Mugen.Algebra.Displacement.Instances.Int 13 | import Mugen.Algebra.Displacement.Instances.Lexicographic 14 | import Mugen.Algebra.Displacement.Instances.Nat 15 | import Mugen.Algebra.Displacement.Instances.NearlyConstant 16 | import Mugen.Algebra.Displacement.Instances.NonPositive 17 | import Mugen.Algebra.Displacement.Instances.Opposite 18 | import Mugen.Algebra.Displacement.Instances.Prefix 19 | import Mugen.Algebra.Displacement.Instances.Product 20 | import Mugen.Algebra.Displacement.Instances.Support 21 | import Mugen.Algebra.Displacement.Instances.WeirdFractal 22 | import Mugen.Algebra.Displacement.Subalgebra 23 | import Mugen.Algebra.OrderedMonoid 24 | import Mugen.Cat.HierarchyTheory 25 | import Mugen.Cat.HierarchyTheory.McBride 26 | import Mugen.Cat.HierarchyTheory.Traditional 27 | import Mugen.Cat.HierarchyTheory.Universality 28 | import Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbedding 29 | import Mugen.Cat.HierarchyTheory.Universality.EndomorphismEmbeddingNaturality 30 | import Mugen.Cat.HierarchyTheory.Universality.SubcategoryEmbedding 31 | import Mugen.Cat.Instances.Displacements 32 | import Mugen.Cat.Instances.Endomorphisms 33 | import Mugen.Cat.Instances.Indexed 34 | import Mugen.Cat.Instances.StrictOrders 35 | import Mugen.Cat.Monad 36 | import Mugen.Data.List 37 | import Mugen.Data.NonEmpty 38 | import Mugen.Order.Instances.BasedSupport 39 | import Mugen.Order.Instances.Copower 40 | import Mugen.Order.Instances.Endomorphism 41 | import Mugen.Order.Instances.Fractal 42 | import Mugen.Order.Instances.Int 43 | import Mugen.Order.Instances.LeftInvariantRightCentered 44 | import Mugen.Order.Instances.Lexicographic 45 | import Mugen.Order.Instances.Lift 46 | import Mugen.Order.Instances.Nat 47 | import Mugen.Order.Instances.NonPositive 48 | import Mugen.Order.Instances.Opposite 49 | import Mugen.Order.Instances.Pointwise 50 | import Mugen.Order.Instances.Prefix 51 | import Mugen.Order.Instances.Product 52 | import Mugen.Order.Instances.Support 53 | import Mugen.Order.Lattice 54 | import Mugen.Order.Reasoning 55 | import Mugen.Order.StrictOrder 56 | import Mugen.Prelude 57 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/BasedSupport.agda: -------------------------------------------------------------------------------- 1 | -- vim: nowrap 2 | module Mugen.Order.Instances.BasedSupport where 3 | 4 | open import Mugen.Prelude 5 | open import Mugen.Data.List 6 | open import Mugen.Order.Lattice 7 | open import Mugen.Order.StrictOrder 8 | open import Mugen.Order.Instances.Pointwise 9 | 10 | import Mugen.Order.Reasoning as Reasoning 11 | 12 | private variable 13 | o o' r r' : Level 14 | 15 | -------------------------------------------------------------------------------- 16 | -- Nearly Constant Functions 17 | -- Section 3.3.5 18 | -- 19 | -- A "nearly constant function" is a function 'f : Nat → 𝒟' 20 | -- that differs from some fixed 'base : 𝒟' for only 21 | -- a finite set of 'n : Nat' 22 | -- 23 | -- We represent these via prefix lists. IE: the function 24 | -- 25 | -- > λ n → if n = 1 then 2 else if n = 3 then 1 else 5 26 | -- 27 | -- will be represented as a pair (5, [5,2,5,3]). We will call the 28 | -- first element of this pair "the base" of the function, and the 29 | -- prefix list "the support". 30 | -- 31 | -- However, there is a slight problem here when we go to show that 32 | -- this is a subalgebra of 'IdxProd': it's not injective! The problem 33 | -- occurs when you have trailing base elements, meaning 2 lists can 34 | -- denote the same function! 35 | -- 36 | -- To resolve this, we say that a list is compact relative 37 | -- to some 'base : 𝒟' if it does not have any trailing base's. 38 | -- We then only work with compact lists in our displacement algebra. 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Raw Support Lists 42 | -- 43 | 44 | record RawList (A : Type o) : Type o where 45 | constructor raw 46 | field 47 | elts : List A 48 | base : A 49 | open RawList 50 | 51 | raw-path : ∀ {A : Type o} {xs ys : RawList A} 52 | → xs .elts ≡ ys .elts 53 | → xs .base ≡ ys .base 54 | → xs ≡ ys 55 | raw-path p q i .elts = p i 56 | raw-path p q i .base = q i 57 | 58 | -- Lemmas about hlevel 59 | module _ {A : Type o} where 60 | abstract instance 61 | H-Level-RawList : {n : Nat} ⦃ _ : H-Level A (2 + n) ⦄ → H-Level (RawList A) (2 + n) 62 | H-Level-RawList {n} = hlevel-instance $ 63 | Equiv→is-hlevel (2 + n) (Iso→Equiv raw-eqv) $ hlevel (2 + n) 64 | where 65 | unquoteDecl raw-eqv = declare-record-iso raw-eqv (quote RawList) 66 | 67 | -- Operations and properties for raw support lists 68 | module Raw {A : Type o} where 69 | private 70 | _raw∷_ : A → RawList A → RawList A 71 | x raw∷ (raw xs b) = raw (x ∷ xs) b 72 | 73 | -- Indexing function that turns a list into a map 'Nat → A' 74 | index : RawList A → (Nat → A) 75 | index (raw [] b) n = b 76 | index (raw (x ∷ xs) b) zero = x 77 | index (raw (x ∷ xs) b) (suc n) = index (raw xs b) n 78 | 79 | -------------------------------------------------------------------------------- 80 | -- Compactness of Raw Lists 81 | 82 | is-compact : RawList A → Type o 83 | is-compact (raw [] b) = Lift o ⊤ 84 | is-compact (raw (x ∷ []) b) = ¬ (x ≡ b) 85 | is-compact (raw (_ ∷ y ∷ ys) b) = is-compact (raw (y ∷ ys) b) 86 | 87 | abstract 88 | is-compact-is-prop : ∀ xs → is-prop (is-compact xs) 89 | is-compact-is-prop (raw [] _) = hlevel 1 90 | is-compact-is-prop (raw (_ ∷ []) _) = hlevel 1 91 | is-compact-is-prop (raw (_ ∷ y ∷ ys) _) = is-compact-is-prop (raw (y ∷ ys) _) 92 | 93 | abstract 94 | tail-is-compact : ∀ x xs → is-compact (x raw∷ xs) → is-compact xs 95 | tail-is-compact x (raw [] _) _ = lift tt 96 | tail-is-compact x (raw (y ∷ ys) _) compact = compact 97 | 98 | abstract 99 | private 100 | base-singleton-isnt-compact : ∀ {x xs b} → x ≡ b → xs ≡ raw [] b → is-compact (x raw∷ xs) → ⊥ 101 | base-singleton-isnt-compact {xs = raw [] _} x=b xs=[] is-compact = is-compact $ x=b ∙ sym (ap base xs=[]) 102 | base-singleton-isnt-compact {xs = raw (_ ∷ _) _} x=b xs=[] is-compact = ∷≠[] $ ap elts xs=[] 103 | 104 | -------------------------------------------------------------------------------- 105 | -- Compacting of Raw Lists 106 | 107 | module _ ⦃ _ : Discrete A ⦄ where 108 | module _ (b : A) where 109 | compact-list-step : A → List A → List A 110 | compact-list-step x [] with x ≡? b 111 | ... | yes _ = [] 112 | ... | no _ = x ∷ [] 113 | compact-list-step x (y ∷ ys) = x ∷ y ∷ ys 114 | 115 | compact-list : List A → List A 116 | compact-list [] = [] 117 | compact-list (x ∷ xs) = compact-list-step x (compact-list xs) 118 | 119 | compact-step : A → RawList A → RawList A 120 | compact-step x (raw xs b) = raw (compact-list-step b x xs) b 121 | 122 | compact : RawList A → RawList A 123 | compact (raw xs b) = raw (compact-list b xs) b 124 | 125 | abstract 126 | compact-compacted : ∀ {xs} → is-compact xs → compact xs ≡ xs 127 | compact-compacted {xs = raw [] _} _ = refl 128 | compact-compacted {xs = raw (x ∷ []) b} x≠b with x ≡? b 129 | ... | yes x=b = absurd (x≠b x=b) 130 | ... | no _ = refl 131 | compact-compacted {xs = raw (x ∷ y ∷ ys) b} is-compact = 132 | ap (compact-step x) $ compact-compacted {xs = raw (y ∷ ys) b} is-compact 133 | 134 | -- the result of 'compact' is a compact list 135 | abstract 136 | private 137 | compact-step-is-compact : ∀ x xs 138 | → is-compact xs 139 | → is-compact (compact-step x xs) 140 | compact-step-is-compact x (raw [] b) _ with x ≡? b 141 | ... | yes _ = lift tt 142 | ... | no x≠b = x≠b 143 | compact-step-is-compact x (raw (y ∷ ys) b) is-compact = is-compact 144 | 145 | compact-is-compact : ∀ xs → is-compact (compact xs) 146 | compact-is-compact (raw [] _) = lift tt 147 | compact-is-compact (raw (x ∷ xs) b) = 148 | compact-step-is-compact x (compact (raw xs b)) (compact-is-compact (raw xs b)) 149 | 150 | -------------------------------------------------------------------------------- 151 | -- Lemmas about Indexing and Compacting 152 | -- 153 | -- Compacting a raw list does not change its indexed values. 154 | 155 | module _ ⦃ _ : Discrete A ⦄ where 156 | abstract 157 | private 158 | index-compact-step-zero : ∀ x xs 159 | → index (compact-step x xs) zero ≡ x 160 | index-compact-step-zero x (raw [] b) with x ≡? b 161 | ... | yes x=b = sym x=b 162 | ... | no _ = refl 163 | index-compact-step-zero x (raw (_ ∷ _) _) = refl 164 | 165 | index-compact-step-suc : ∀ x xs n 166 | → index (compact-step x xs) (suc n) ≡ index xs n 167 | index-compact-step-suc x (raw [] b) n with x ≡? b 168 | ... | yes _ = refl 169 | ... | no _ = refl 170 | index-compact-step-suc x (raw (_ ∷ _) _) n = refl 171 | 172 | index-compact : ∀ xs n → index (compact xs) n ≡ index xs n 173 | index-compact (raw [] _) n = refl 174 | index-compact (raw (x ∷ xs) b) zero = 175 | index-compact-step-zero x (compact (raw xs b)) 176 | index-compact (raw (x ∷ xs) b) (suc n) = 177 | index (compact-step x (compact (raw xs b))) (suc n) 178 | ≡⟨ index-compact-step-suc x (compact (raw xs b)) n ⟩ 179 | index (compact (raw xs b)) n 180 | ≡⟨ index-compact (raw xs b) n ⟩ 181 | index (raw xs b) n 182 | ∎ 183 | 184 | -------------------------------------------------------------------------------- 185 | -- Merging Lists 186 | 187 | merge-list-with : (A → A → A) → RawList A → RawList A → List A 188 | merge-list-with _⊚_ (raw [] b1) (raw [] b2) = [] 189 | merge-list-with _⊚_ (raw [] b1) (raw (y ∷ ys) b2) = (b1 ⊚ y) ∷ merge-list-with _⊚_ (raw [] b1) (raw ys b2) 190 | merge-list-with _⊚_ (raw (x ∷ xs) b1) (raw [] b2) = (x ⊚ b2) ∷ merge-list-with _⊚_ (raw xs b1) (raw [] b2) 191 | merge-list-with _⊚_ (raw (x ∷ xs) b1) (raw (y ∷ ys) b2) = (x ⊚ y) ∷ merge-list-with _⊚_ (raw xs b1) (raw ys b2) 192 | 193 | merge-with : (A → A → A) → RawList A → RawList A → RawList A 194 | merge-with _⊚_ xs ys = raw (merge-list-with _⊚_ xs ys) (xs .base ⊚ ys .base) 195 | 196 | abstract 197 | index-merge-with : ∀ f xs ys n → index (merge-with f xs ys) n ≡ f (index xs n) (index ys n) 198 | index-merge-with f (raw [] b1) (raw [] b2) n = refl 199 | index-merge-with f (raw [] b1) (raw (y ∷ ys) b2) zero = refl 200 | index-merge-with f (raw [] b1) (raw (y ∷ ys) b2) (suc n) = index-merge-with f (raw [] b1) (raw ys b2) n 201 | index-merge-with f (raw (x ∷ xs) b1) (raw [] b2) zero = refl 202 | index-merge-with f (raw (x ∷ xs) b1) (raw [] b2) (suc n) = index-merge-with f (raw xs b1) (raw [] b2) n 203 | index-merge-with f (raw (x ∷ xs) b1) (raw (y ∷ ys) b2) zero = refl 204 | index-merge-with f (raw (x ∷ xs) b1) (raw (y ∷ ys) b2) (suc n) = index-merge-with f (raw xs b1) (raw ys b2) n 205 | 206 | -------------------------------------------------------------------------------- 207 | -- Order 208 | 209 | -- 'index' is injective for compacted lists 210 | abstract 211 | index-compacted-injective : ∀ xs ys 212 | → is-compact xs 213 | → is-compact ys 214 | → ((n : Nat) → index xs n ≡ index ys n) 215 | → xs ≡ ys 216 | index-compacted-injective (raw [] b1) (raw [] b2) _ _ p = raw-path refl (p 0) 217 | index-compacted-injective (raw (x ∷ xs) b1) (raw [] b2) x∷xs-compact []-compact p = 218 | let xs-compact = tail-is-compact x (raw xs b1) x∷xs-compact in 219 | let xs=[] = index-compacted-injective (raw xs b1) (raw [] b2) xs-compact []-compact (p ⊙ suc) in 220 | absurd (base-singleton-isnt-compact (p 0) xs=[] x∷xs-compact) 221 | index-compacted-injective (raw [] b1) (raw (y ∷ ys) b2) []-compact y∷ys-compact p = 222 | let ys-compact = tail-is-compact y (raw ys b2) y∷ys-compact in 223 | let []=ys = index-compacted-injective (raw [] b1) (raw ys b2) []-compact ys-compact (p ⊙ suc) in 224 | absurd $ᵢ base-singleton-isnt-compact (sym (p 0)) (sym []=ys) y∷ys-compact 225 | index-compacted-injective (raw (x ∷ xs) b1) (raw (y ∷ ys) b2) x∷xs-compact y∷ys-compact p = 226 | let xs-compact = tail-is-compact x (raw xs b1) x∷xs-compact in 227 | let ys-compact = tail-is-compact y (raw ys b2) y∷ys-compact in 228 | let xs=ys = index-compacted-injective (raw xs b1) (raw ys b2) xs-compact ys-compact (p ⊙ suc) in 229 | ap₂ _raw∷_ (p 0) xs=ys 230 | 231 | -------------------------------------------------------------------------------- 232 | -- These will be the actual elements of our displacement algebra. 233 | -- A support list is a compact raw list. 234 | 235 | record BasedSupportList (A : Type o) : Type o where 236 | constructor based-support-list 237 | no-eta-equality 238 | field 239 | list : RawList A 240 | has-is-compact : Raw.is-compact list 241 | open RawList list public 242 | 243 | module _ {A : Type o} where 244 | open BasedSupportList 245 | 246 | -- Paths in support lists are determined by paths between the bases + paths between the elements. 247 | abstract 248 | based-support-list-path : ∀ {xs ys : BasedSupportList A} → xs .list ≡ ys .list → xs ≡ ys 249 | based-support-list-path p i .list = p i 250 | based-support-list-path {xs = xs} {ys = ys} p i .has-is-compact = 251 | is-prop→pathp (λ i → Raw.is-compact-is-prop (p i)) (xs .has-is-compact) (ys .has-is-compact) i 252 | 253 | abstract instance 254 | H-Level-BasedSupportList : ∀ {n : Nat} ⦃ _ : H-Level A (2 + n) ⦄ → H-Level (BasedSupportList A) (2 + n) 255 | H-Level-BasedSupportList {n} = hlevel-instance $ 256 | Equiv→is-hlevel (2 + n) (Iso→Equiv eqv) $ 257 | Σ-is-hlevel (2 + n) (hlevel (2 + n)) λ xs → 258 | is-prop→is-hlevel-suc {n = 1 + n} (Raw.is-compact-is-prop xs) 259 | where 260 | unquoteDecl eqv = declare-record-iso eqv (quote BasedSupportList) 261 | 262 | index : BasedSupportList A → (Nat → A) 263 | index xs = Raw.index (xs .list) 264 | 265 | module _ ⦃ _ : Discrete A ⦄ where 266 | merge-with : (A → A → A) → BasedSupportList A → BasedSupportList A → BasedSupportList A 267 | merge-with f xs ys .list = Raw.compact $ Raw.merge-with f (xs .list) (ys .list) 268 | merge-with f xs ys .has-is-compact = Raw.compact-is-compact $ Raw.merge-with f (xs .list) (ys .list) 269 | 270 | -- 'index' commutes with 'merge' 271 | abstract 272 | index-merge-with : ∀ f xs ys 273 | → index (merge-with f xs ys) ≡ pointwise-map₂ (λ _ x y → f x y) (index xs) (index ys) 274 | index-merge-with f xs ys = funext λ n → 275 | Raw.index-compact (Raw.merge-with f (xs .list) (ys .list)) n 276 | ∙ Raw.index-merge-with f (xs .list) (ys .list) n 277 | 278 | abstract 279 | index-injective : ∀ {xs ys} → index xs ≡ index ys → xs ≡ ys 280 | index-injective {xs} {ys} p = based-support-list-path $ 281 | Raw.index-compacted-injective _ _ (xs .has-is-compact) (ys .has-is-compact) $ 282 | happly p 283 | 284 | module _ (A : Poset o r) where 285 | private 286 | rep : represents-full-subposet (Pointwise Nat (λ _ → A)) index 287 | rep .represents-full-subposet.injective = index-injective 288 | module rep = represents-full-subposet rep 289 | 290 | BasedSupport : Poset o r 291 | BasedSupport = rep.poset 292 | 293 | BasedSupport→Pointwise : Strictly-monotone BasedSupport (Pointwise Nat (λ _ → A)) 294 | BasedSupport→Pointwise = rep.strictly-monotone 295 | 296 | BasedSupport→Pointwise-is-full-subposet : is-full-subposet BasedSupport→Pointwise 297 | BasedSupport→Pointwise-is-full-subposet = rep.has-is-full-subposet 298 | 299 | -------------------------------------------------------------------------------- 300 | -- Joins 301 | 302 | module _ 303 | {A : Poset o r} 304 | ⦃ _ : Discrete ⌞ A ⌟ ⦄ 305 | (A-has-joins : has-joins A) 306 | where 307 | private 308 | module A = Reasoning A 309 | module P = Reasoning (Pointwise Nat λ _ → A) 310 | module A-has-joins = has-joins A-has-joins 311 | P-has-joins = Pointwise-has-joins Nat λ _ → A-has-joins 312 | module P-has-joins = has-joins P-has-joins 313 | 314 | rep : represents-full-subsemilattice P-has-joins (BasedSupport→Pointwise-is-full-subposet A) 315 | rep .represents-full-subsemilattice.join = merge-with A-has-joins.join 316 | rep .represents-full-subsemilattice.pres-join {x} {y} = index-merge-with A-has-joins.join x y 317 | module rep = represents-full-subsemilattice rep 318 | 319 | BasedSupport-has-joins : has-joins (BasedSupport A) 320 | BasedSupport-has-joins = rep.joins 321 | 322 | BasedSupport→Pointwise-is-full-subsemilattice 323 | : is-full-subsemilattice BasedSupport-has-joins P-has-joins (BasedSupport→Pointwise A) 324 | BasedSupport→Pointwise-is-full-subsemilattice = rep.has-is-full-subsemilattice 325 | 326 | -------------------------------------------------------------------------------- 327 | -- Bottoms 328 | 329 | module _ 330 | (A : Poset o r) 331 | ⦃ _ : Discrete ⌞ A ⌟ ⦄ 332 | (A-has-bottom : has-bottom A) 333 | where 334 | private 335 | module A = Reasoning A 336 | module P = Reasoning (Pointwise Nat λ _ → A) 337 | module A-has-bottom = has-bottom A-has-bottom 338 | P-has-bottom = Pointwise-has-bottom Nat λ _ → A-has-bottom 339 | module P-has-bottom = has-bottom P-has-bottom 340 | 341 | rep : represents-full-bounded-subposet P-has-bottom (BasedSupport→Pointwise-is-full-subposet A) 342 | rep .represents-full-bounded-subposet.bot = based-support-list (raw [] A-has-bottom.bot) (lift tt) 343 | rep .represents-full-bounded-subposet.pres-bot = refl 344 | module rep = represents-full-bounded-subposet rep 345 | 346 | BasedSupport-has-bottom : has-bottom (BasedSupport A) 347 | BasedSupport-has-bottom = rep.bottom 348 | 349 | BasedSupport→Pointwise-is-full-bounded-subposet 350 | : is-full-bounded-subposet BasedSupport-has-bottom P-has-bottom (BasedSupport→Pointwise A) 351 | BasedSupport→Pointwise-is-full-bounded-subposet = rep.has-is-full-bounded-subposet 352 | 353 | -------------------------------------------------------------------------------- 354 | -- Extensionality 355 | 356 | module _ {A : Type o} {ℓr} ⦃ s : Extensional (Nat → A) ℓr ⦄ where 357 | 358 | instance 359 | Extensional-BasedSupportList 360 | : ⦃ A-is-set : H-Level A 2 ⦄ 361 | → Extensional (BasedSupportList A) ℓr 362 | Extensional-BasedSupportList ⦃ A-is-set ⦄ = 363 | injection→extensional! index-injective s 364 | 365 | private 366 | open import Data.Nat 367 | _ : (f : BasedSupportList Nat) → f ≡ f 368 | _ = λ f → ext λ _ → refl 369 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Copower.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Copower where 2 | 3 | open import Order.Instances.Discrete 4 | 5 | open import Mugen.Prelude 6 | open import Mugen.Order.Instances.Product 7 | 8 | Copower : ∀ {o o' r'} → Set o → Poset o' r' → Poset (o ⊔ o') (o ⊔ r') 9 | Copower I A = Product (Discᵢ I) A 10 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Endomorphism.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Endomorphism where 2 | 3 | open import Cat.Diagram.Monad 4 | import Cat.Reasoning as Cat 5 | 6 | open import Mugen.Prelude 7 | 8 | open import Mugen.Order.StrictOrder 9 | open import Mugen.Cat.Monad 10 | open import Mugen.Cat.Instances.StrictOrders 11 | 12 | import Mugen.Order.Reasoning as Reasoning 13 | 14 | private variable 15 | o o' r r' : Level 16 | 17 | -------------------------------------------------------------------------------- 18 | -- Endomorphism Posets 19 | -- Section 3.4 20 | -- 21 | -- Given a Monad 'H' on the category of strict orders, we can construct a poset 22 | -- whose carrier set is the set of endomorphisms 'Free H Δ → Free H Δ' between 23 | -- free H-algebras in the Eilenberg-Moore category. 24 | open Algebra-hom 25 | 26 | module _ (H : Monad (Strict-orders o r)) (Δ : Poset o r) where 27 | 28 | open Monad H renaming (M₀ to H₀; M₁ to H₁) 29 | open Cat (Eilenberg-Moore (Strict-orders o r) H) 30 | 31 | private 32 | module H⟨Δ⟩ = Reasoning (H₀ Δ) 33 | Fᴴ⟨Δ⟩ : Algebra (Strict-orders o r) H 34 | Fᴴ⟨Δ⟩ = Functor.F₀ (Free (Strict-orders o r) H) Δ 35 | 36 | Endomorphism-type : Type (lsuc o ⊔ lsuc r) 37 | Endomorphism-type = Hom Fᴴ⟨Δ⟩ Fᴴ⟨Δ⟩ 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Order 41 | 42 | endo[_≤_] : ∀ (σ δ : Endomorphism-type) → Type (o ⊔ r) 43 | endo[_≤_] σ δ = (α : ⌞ Δ ⌟) → σ # (unit.η Δ # α) H⟨Δ⟩.≤ δ # (unit.η Δ # α) 44 | 45 | abstract 46 | endo≤-thin : ∀ σ δ → is-prop endo[ σ ≤ δ ] 47 | endo≤-thin σ δ = hlevel 1 48 | 49 | endo≤-refl : ∀ σ → endo[ σ ≤ σ ] 50 | endo≤-refl σ _ = H⟨Δ⟩.≤-refl 51 | 52 | endo≤-trans : ∀ σ δ τ → endo[ σ ≤ δ ] → endo[ δ ≤ τ ] → endo[ σ ≤ τ ] 53 | endo≤-trans σ δ τ σ≤δ δ≤τ α = H⟨Δ⟩.≤-trans (σ≤δ α) (δ≤τ α) 54 | 55 | endo≤-antisym : ∀ σ δ → endo[ σ ≤ δ ] → endo[ δ ≤ σ ] → σ ≡ δ 56 | endo≤-antisym σ δ σ≤δ δ≤σ = free-algebra-hom-path H $ ext λ α → 57 | H⟨Δ⟩.≤-antisym (σ≤δ α) (δ≤σ α) 58 | 59 | Endomorphism : Poset (lsuc o ⊔ lsuc r) (o ⊔ r) 60 | Endomorphism .Poset.Ob = Endomorphism-type 61 | Endomorphism .Poset._≤_ = endo[_≤_] 62 | Endomorphism .Poset.≤-thin {σ} {δ} = endo≤-thin σ δ 63 | Endomorphism .Poset.≤-refl {σ} = endo≤-refl σ 64 | Endomorphism .Poset.≤-trans {σ} {δ} {τ} = endo≤-trans σ δ τ 65 | Endomorphism .Poset.≤-antisym {σ} {δ} = endo≤-antisym σ δ 66 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Fractal.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Fractal where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Data.NonEmpty 5 | 6 | import Mugen.Order.Reasoning as Reasoning 7 | 8 | private variable 9 | o r : Level 10 | 11 | -------------------------------------------------------------------------------- 12 | -- Fractal Posets 13 | -- Section 3.3.7 14 | 15 | module _ (A : Poset o r) where 16 | private 17 | module A = Reasoning A 18 | 19 | -- The first argument of 'fractal[_][_≤_]' (after being re-exported to the top level) 20 | -- is the poset A. 21 | data fractal[_][_≤_] : List⁺ ⌞ A ⌟ → List⁺ ⌞ A ⌟ → Type (o ⊔ r) where 22 | single≤ : ∀ {x y} → x A.≤ y → fractal[_][_≤_] [ x ] [ y ] 23 | tail≤' : ∀ {x xs y ys} → x A.≤[ fractal[_][_≤_] xs ys ] y → fractal[_][_≤_] (x ∷ xs) (y ∷ ys) 24 | pattern tail≤ α β = tail≤' (α , β) 25 | 26 | private 27 | _≤_ : List⁺ ⌞ A ⌟ → List⁺ ⌞ A ⌟ → Type (o ⊔ r) 28 | x ≤ y = fractal[_][_≤_] x y 29 | 30 | abstract 31 | ≤-refl : ∀ (xs : List⁺ ⌞ A ⌟) → xs ≤ xs 32 | ≤-refl [ x ] = single≤ A.≤-refl 33 | ≤-refl (x ∷ xs) = tail≤ A.≤-refl λ _ → ≤-refl xs 34 | 35 | ≤-trans : ∀ (xs ys zs : List⁺ ⌞ A ⌟) → xs ≤ ys → ys ≤ zs → xs ≤ zs 36 | ≤-trans [ x ] [ y ] [ z ] (single≤ x≤y) (single≤ y≤z) = single≤ (A.≤-trans x≤y y≤z) 37 | ≤-trans (x ∷ xs) (y ∷ ys) (z ∷ zs) (tail≤ x≤y xs≤ys) (tail≤ y≤z ys≤zs) = 38 | tail≤ (A.≤-trans x≤y y≤z) λ x=z → 39 | ≤-trans xs ys zs (xs≤ys (A.≤-antisym'-l x≤y y≤z x=z)) (ys≤zs (A.≤-antisym'-r x≤y y≤z x=z)) 40 | 41 | ≤-antisym : ∀ (xs ys : List⁺ ⌞ A ⌟) → xs ≤ ys → ys ≤ xs → xs ≡ ys 42 | ≤-antisym [ x ] [ y ] (single≤ x≤y) (single≤ y≤x) = ap [_] $ A.≤-antisym x≤y y≤x 43 | ≤-antisym (x ∷ xs) (y ∷ ys) (tail≤ x≤y xs≤ys) (tail≤ y≤x ys≤xs) = 44 | let x=y = A.≤-antisym x≤y y≤x in ap₂ _∷_ x=y $ ≤-antisym xs ys (xs≤ys x=y) (ys≤xs (sym x=y)) 45 | 46 | ≤-thin : ∀ (xs ys : List⁺ ⌞ A ⌟) → is-prop (xs ≤ ys) 47 | ≤-thin [ x ] [ y ] (single≤ x≤y) (single≤ x≤y') = ap single≤ (A.≤-thin x≤y x≤y') 48 | ≤-thin (x ∷ xs) (y ∷ ys) (tail≤ x≤y xs≤ys) (tail≤ x≤y' xs≤ys') = ap₂ tail≤ (A.≤-thin x≤y x≤y') $ 49 | funext λ p → ≤-thin xs ys (xs≤ys p) (xs≤ys' p) 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Poset Bundle 53 | 54 | Fractal : Poset o (o ⊔ r) 55 | Fractal = poset where 56 | poset : Poset o (o ⊔ r) 57 | poset .Poset.Ob = List⁺ ⌞ A ⌟ 58 | poset .Poset._≤_ = _≤_ 59 | poset .Poset.≤-thin = ≤-thin _ _ 60 | poset .Poset.≤-refl = ≤-refl _ 61 | poset .Poset.≤-trans = ≤-trans _ _ _ 62 | poset .Poset.≤-antisym = ≤-antisym _ _ 63 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Int.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Int where 2 | 3 | open import Data.Int 4 | open import Order.Instances.Int 5 | 6 | open import Mugen.Prelude 7 | open import Mugen.Order.Lattice 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Joins 11 | 12 | Int-has-joins : has-joins Int-poset 13 | Int-has-joins .has-joins.join = maxℤ 14 | Int-has-joins .has-joins.joinl {x} {y} = maxℤ-≤l x y 15 | Int-has-joins .has-joins.joinr {x} {y} = maxℤ-≤r x y 16 | Int-has-joins .has-joins.universal {x} {y} {z} = maxℤ-univ x y z 17 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/LeftInvariantRightCentered.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.LeftInvariantRightCentered where 2 | 3 | open import Mugen.Prelude 4 | 5 | import Mugen.Order.Reasoning as Reasoning 6 | 7 | module _ {o o' r r'} (A : Poset o r) (B : Poset o' r') (b : ⌞ B ⌟) where 8 | private 9 | module A = Reasoning A 10 | module B = Reasoning B 11 | 12 | data RawLeftInvariantRightCentered≤ (x y : ⌞ A ⌟ × ⌞ B ⌟) : Type (o ⊔ r ⊔ r') where 13 | biased : fst x ≡ fst y → snd x B.≤ snd y → RawLeftInvariantRightCentered≤ x y 14 | centred : fst x A.≤ fst y → snd x B.≤ b → b B.≤ snd y → RawLeftInvariantRightCentered≤ x y 15 | 16 | LeftInvariantRightCentered≤ : (x y : ⌞ A ⌟ × ⌞ B ⌟) → Type (o ⊔ r ⊔ r') 17 | LeftInvariantRightCentered≤ x y = ∥ RawLeftInvariantRightCentered≤ x y ∥ 18 | 19 | private 20 | ⋉-thin : ∀ (x y : ⌞ A ⌟ × ⌞ B ⌟) → is-prop (LeftInvariantRightCentered≤ x y) 21 | ⋉-thin x y = squash 22 | 23 | ⋉-refl : ∀ (x : ⌞ A ⌟ × ⌞ B ⌟) → LeftInvariantRightCentered≤ x x 24 | ⋉-refl (a , b1) = pure $ biased refl B.≤-refl 25 | 26 | ⋉-trans : ∀ (x y z : ⌞ A ⌟ × ⌞ B ⌟) 27 | → LeftInvariantRightCentered≤ x y 28 | → LeftInvariantRightCentered≤ y z 29 | → LeftInvariantRightCentered≤ x z 30 | ⋉-trans x y z = ∥-∥-map₂ λ where 31 | (biased a1=a2 b1≤b2) (biased a2=a3 b2≤b3) → biased (a1=a2 ∙ a2=a3) (B.≤-trans b1≤b2 b2≤b3) 32 | (biased a1=a2 b1≤b2) (centred a2≤a3 b2≤b b≤b3) → centred (A.=+≤→≤ a1=a2 a2≤a3) (B.≤-trans b1≤b2 b2≤b) b≤b3 33 | (centred a1≤a2 b1≤b b≤b2) (biased a2=a3 b2≤b3) → centred (A.≤+=→≤ a1≤a2 a2=a3) b1≤b (B.≤-trans b≤b2 b2≤b3) 34 | (centred a1≤a2 b1≤b b≤b2) (centred a2≤a3 b2≤b b≤b3) → centred (A.≤-trans a1≤a2 a2≤a3) b1≤b b≤b3 35 | 36 | ⋉-antisym : ∀ (x y : ⌞ A ⌟ × ⌞ B ⌟) 37 | → LeftInvariantRightCentered≤ x y 38 | → LeftInvariantRightCentered≤ y x 39 | → x ≡ y 40 | ⋉-antisym x y = ∥-∥-rec₂ (×-is-hlevel 2 A.Ob-is-set B.Ob-is-set _ _) λ where 41 | (biased a1=a2 b1≤b2) (biased a2=a1 b2≤b1) → 42 | ap₂ _,_ a1=a2 (B.≤-antisym b1≤b2 b2≤b1) 43 | (biased a1=a2 b1≤b2) (centred a2≤a1 b2≤b b≤b1) → 44 | ap₂ _,_ a1=a2 (B.≤-antisym b1≤b2 $ B.≤-trans b2≤b b≤b1) 45 | (centred a1≤a2 b1≤b b≤b2) (biased a2=a1 b2≤b1) → 46 | ap₂ _,_ (sym a2=a1) (B.≤-antisym (B.≤-trans b1≤b b≤b2) b2≤b1) 47 | (centred a1≤a2 b1≤b b≤b2) (centred a2≤a1 b2≤b b≤b1) → 48 | ap₂ _,_ (A.≤-antisym a1≤a2 a2≤a1) (B.≤-antisym (B.≤-trans b1≤b b≤b2) (B.≤-trans b2≤b b≤b1)) 49 | 50 | LeftInvariantRightCentered : Poset (o ⊔ o') (o ⊔ r ⊔ r') 51 | LeftInvariantRightCentered .Poset.Ob = ⌞ A ⌟ × ⌞ B ⌟ 52 | LeftInvariantRightCentered .Poset._≤_ x y = LeftInvariantRightCentered≤ x y 53 | LeftInvariantRightCentered .Poset.≤-thin = ⋉-thin _ _ 54 | LeftInvariantRightCentered .Poset.≤-refl {x} = ⋉-refl x 55 | LeftInvariantRightCentered .Poset.≤-trans {x} {y} {z} = ⋉-trans x y z 56 | LeftInvariantRightCentered .Poset.≤-antisym {x} {y} = ⋉-antisym x y 57 | 58 | syntax RawLeftInvariantRightCentered≤ A B b x y = A ⋉[ b ] B [ x raw≤ y ] 59 | syntax LeftInvariantRightCentered≤ A B b x y = A ⋉[ b ] B [ x ≤ y ] 60 | syntax LeftInvariantRightCentered A B b = A ⋉[ b ] B 61 | 62 | module _ {o o' r r'} {A : Poset o' r'} {B : Poset o r} {b : ⌞ B ⌟} where 63 | private 64 | module A = Reasoning A 65 | module B = Reasoning B 66 | module A⋉B = Reasoning (A ⋉[ b ] B) 67 | 68 | ⋉-fst-invariant : ∀ {x y : A⋉B.Ob} → A ⋉[ b ] B [ x ≤ y ] → fst x A.≤ fst y 69 | ⋉-fst-invariant = ∥-∥-rec A.≤-thin λ where 70 | (biased a1=a2 b1≤b2) → A.=→≤ a1=a2 71 | (centred a1≤a2 b1≤b b≤b2) → a1≤a2 72 | 73 | ⋉-snd-invariant : ∀ {x y : ⌞ A ⌟ × ⌞ B ⌟} → A ⋉[ b ] B [ x ≤ y ] → snd x B.≤ snd y 74 | ⋉-snd-invariant = ∥-∥-rec B.≤-thin λ where 75 | (biased a1=a2 b1≤b2) → b1≤b2 76 | (centred a1≤a2 b1≤b b≤b2) → B.≤-trans b1≤b b≤b2 77 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Lexicographic.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Lexicographic where 2 | 3 | open import Mugen.Prelude 4 | open import Mugen.Order.Lattice 5 | 6 | import Mugen.Order.Reasoning as Reasoning 7 | 8 | private variable 9 | o o' r r' : Level 10 | 11 | -------------------------------------------------------------------------------- 12 | -- Lexicographic Products 13 | -- Section 3.3.4 14 | -- 15 | -- The lexicographic product of 2 posets consists of their product 16 | -- as monoids, as well as their lexicographic product as orders. 17 | 18 | module _ (A : Poset o r) (B : Poset o' r') where 19 | private 20 | module A = Reasoning A 21 | module B = Reasoning B 22 | 23 | Lexicographic : Poset (o ⊔ o') (o ⊔ r ⊔ r') 24 | Lexicographic = poset where 25 | 26 | _≤_ : ∀ (x y : ⌞ A ⌟ × ⌞ B ⌟) → Type (o ⊔ r ⊔ r') 27 | _≤_ x y = x .fst A.≤[ x .snd B.≤ y .snd ] y .fst 28 | 29 | abstract 30 | ≤-thin : ∀ x y → is-prop (x ≤ y) 31 | ≤-thin x y = hlevel 1 32 | 33 | ≤-refl : ∀ x → x ≤ x 34 | ≤-refl x = A.≤-refl , λ _ → B.≤-refl 35 | 36 | ≤-trans : ∀ x y z → x ≤ y → y ≤ z → x ≤ z 37 | ≤-trans x y z (x1≤y1 , x2≤y2) (y1≤z1 , y2≤z2) = 38 | A.≤-trans x1≤y1 y1≤z1 , λ x1=z1 → 39 | B.≤-trans 40 | (x2≤y2 (A.≤-antisym'-l x1≤y1 y1≤z1 x1=z1)) 41 | (y2≤z2 (A.≤-antisym'-r x1≤y1 y1≤z1 x1=z1)) 42 | 43 | ≤-antisym : ∀ x y → x ≤ y → y ≤ x → x ≡ y 44 | ≤-antisym x y (x1≤y1 , x2≤y2) (y1≤x1 , y2≤x2) i = 45 | let x1=y1 = A.≤-antisym x1≤y1 y1≤x1 in 46 | x1=y1 i , B.≤-antisym (x2≤y2 x1=y1) (y2≤x2 (sym x1=y1)) i 47 | 48 | poset : Poset (o ⊔ o') (o ⊔ r ⊔ r') 49 | poset .Poset.Ob = ⌞ A ⌟ × ⌞ B ⌟ 50 | poset .Poset._≤_ = _≤_ 51 | poset .Poset.≤-thin = ≤-thin _ _ 52 | poset .Poset.≤-refl = ≤-refl _ 53 | poset .Poset.≤-trans = ≤-trans _ _ _ 54 | poset .Poset.≤-antisym = ≤-antisym _ _ 55 | 56 | module _ {A : Poset o r} {B : Poset o' r'} where 57 | private 58 | module A = Reasoning A 59 | module B = Reasoning B 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Joins 63 | 64 | -- If the following conditions are true, then 'Lex 𝒟₁ 𝒟₂' has joins: 65 | -- (1) Both 𝒟₁ and 𝒟₂ have joins. 66 | -- (2) 𝒟₂ has a bottom. 67 | -- (3) It's decidable in 𝒟₁ whether an element is equal to its join with another element. 68 | lex-has-joins 69 | : (A-joins : has-joins A) (let module A-joins = has-joins A-joins) 70 | → (∀ x y → Dec (x ≡ A-joins.join x y) × Dec (y ≡ A-joins.join x y)) 71 | → (B-joins : has-joins B) → has-bottom B 72 | → has-joins (Lexicographic A B) 73 | 74 | lex-has-joins A-joins _≡∨₁?_ B-joins B-bottom = joins 75 | where 76 | module A-joins = has-joins A-joins 77 | module B-joins = has-joins B-joins 78 | module B-bottom = has-bottom B-bottom 79 | 80 | joins : has-joins (Lexicographic A B) 81 | joins .has-joins.join (x1 , x2) (y1 , y2) with x1 ≡∨₁? y1 82 | ... | yes _ , yes _ = A-joins.join x1 y1 , B-joins.join x2 y2 83 | ... | yes _ , no _ = A-joins.join x1 y1 , x2 84 | ... | no _ , yes _ = A-joins.join x1 y1 , y2 85 | ... | no _ , no _ = A-joins.join x1 y1 , B-bottom.bot 86 | joins .has-joins.joinl {x1 , _} {y1 , _} with x1 ≡∨₁? y1 87 | ... | yes x1=x1∨y1 , yes _ = A-joins.joinl , λ _ → B-joins.joinl 88 | ... | yes x1=x1∨y1 , no _ = A-joins.joinl , λ _ → B.≤-refl 89 | ... | no x1≠x1∨y1 , yes _ = A-joins.joinl , λ x1≡x1∨y1 → absurd (x1≠x1∨y1 x1≡x1∨y1) 90 | ... | no x1≠x1∨y1 , no _ = A-joins.joinl , λ x1≡x1∨y1 → absurd (x1≠x1∨y1 x1≡x1∨y1) 91 | joins .has-joins.joinr {x1 , _} {y1 , _} with x1 ≡∨₁? y1 92 | ... | yes _ , yes y1=x1∨y1 = A-joins.joinr , λ _ → B-joins.joinr 93 | ... | yes _ , no y1≠x1∨y1 = A-joins.joinr , λ y1≡x1∨y1 → absurd (y1≠x1∨y1 y1≡x1∨y1) 94 | ... | no _ , yes y1=x1∨y1 = A-joins.joinr , λ _ → B.≤-refl 95 | ... | no _ , no y1≠x1∨y1 = A-joins.joinr , λ y1≡x1∨y1 → absurd (y1≠x1∨y1 y1≡x1∨y1) 96 | joins .has-joins.universal {x1 , _} {y1 , _} {_ , z2} x≤z y≤z with x1 ≡∨₁? y1 97 | ... | yes x1=x1∨y1 , yes y1=x1∨y1 = 98 | A-joins.universal (x≤z .fst) (y≤z .fst) , λ x1vy1=z1 → 99 | B-joins.universal (x≤z .snd (x1=x1∨y1 ∙ x1vy1=z1)) (y≤z .snd (y1=x1∨y1 ∙ x1vy1=z1)) 100 | ... | yes x1=x1∨y1 , no y1≠x1∨y1 = 101 | A-joins.universal (x≤z .fst) (y≤z .fst) , λ x1vy1=z1 → x≤z .snd (x1=x1∨y1 ∙ x1vy1=z1) 102 | ... | no x1≠x1∨y1 , yes y1=x1∨y1 = 103 | A-joins.universal (x≤z .fst) (y≤z .fst) , λ x1vy1=z1 → y≤z .snd (y1=x1∨y1 ∙ x1vy1=z1) 104 | ... | no x1≠x1∨y1 , no y1≠x1∨y1 = 105 | A-joins.universal (x≤z .fst) (y≤z .fst) , λ x1vy1=z1 → B-bottom.is-bottom 106 | 107 | -------------------------------------------------------------------------------- 108 | -- Bottoms 109 | 110 | lex-has-bottom : has-bottom A → has-bottom B → has-bottom (Lexicographic A B) 111 | lex-has-bottom A-bottom B-bottom = bottom 112 | where 113 | module A-bottom = has-bottom (A-bottom) 114 | module B-bottom = has-bottom (B-bottom) 115 | 116 | bottom : has-bottom (Lexicographic A B) 117 | bottom .has-bottom.bot = A-bottom.bot , B-bottom.bot 118 | bottom .has-bottom.is-bottom = A-bottom.is-bottom , λ _ → B-bottom.is-bottom 119 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Lift.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Lift where 2 | 3 | open import Order.Instances.Lift using (Liftᵖ) public 4 | 5 | open import Mugen.Prelude 6 | open import Mugen.Order.StrictOrder 7 | 8 | lift-strictly-monotone 9 | : ∀ {bo br o r} {X : Poset o r} 10 | → Strictly-monotone X (Liftᵖ bo br X) 11 | lift-strictly-monotone = F where 12 | open Strictly-monotone 13 | F : Strictly-monotone _ _ 14 | F .hom = lift 15 | F .pres-≤[]-equal α = lift α , ap Lift.lower 16 | 17 | lower-strictly-monotone 18 | : ∀ {bo br o r} {X : Poset o r} 19 | → Strictly-monotone (Liftᵖ bo br X) X 20 | lower-strictly-monotone = F where 21 | open Strictly-monotone 22 | F : Strictly-monotone _ _ 23 | F .hom = Lift.lower 24 | F .pres-≤[]-equal (lift α) = α , ap lift 25 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Nat.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Nat where 2 | 3 | open import Data.Nat 4 | import Data.Int as Int 5 | open import Order.Instances.Int 6 | 7 | open import Mugen.Prelude 8 | open import Mugen.Order.StrictOrder 9 | open import Mugen.Order.Lattice 10 | open import Mugen.Order.Instances.Int 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Bundles 14 | 15 | Nat-poset : Poset lzero lzero 16 | Nat-poset .Poset.Ob = Nat 17 | Nat-poset .Poset._≤_ = _≤_ 18 | Nat-poset .Poset.≤-thin = ≤-is-prop 19 | Nat-poset .Poset.≤-refl = ≤-refl 20 | Nat-poset .Poset.≤-trans = ≤-trans 21 | Nat-poset .Poset.≤-antisym = ≤-antisym 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Inclusion to Int-poset 25 | 26 | Nat→Int : Strictly-monotone Nat-poset Int-poset 27 | Nat→Int .Strictly-monotone.hom = Int.Int.pos 28 | Nat→Int .Strictly-monotone.pres-≤[]-equal p .fst = Int.pos≤pos p 29 | Nat→Int .Strictly-monotone.pres-≤[]-equal p .snd = Int.pos-injective 30 | 31 | abstract 32 | Nat→Int-is-full-subposet : is-full-subposet Nat→Int 33 | Nat→Int-is-full-subposet .is-full-subposet.injective = Int.pos-injective 34 | Nat→Int-is-full-subposet .is-full-subposet.full (Int.pos≤pos p) = p 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Joins 38 | 39 | Nat-has-joins : has-joins Nat-poset 40 | Nat-has-joins .has-joins.join = max 41 | Nat-has-joins .has-joins.joinl = max-≤l _ _ 42 | Nat-has-joins .has-joins.joinr = max-≤r _ _ 43 | Nat-has-joins .has-joins.universal = max-univ _ _ _ 44 | 45 | abstract 46 | Nat→Int-is-subsemilattice : is-full-subsemilattice Nat-has-joins Int-has-joins Nat→Int 47 | Nat→Int-is-subsemilattice .is-full-subsemilattice.has-is-full-subposet = Nat→Int-is-full-subposet 48 | Nat→Int-is-subsemilattice .is-full-subsemilattice.pres-join = refl 49 | 50 | -------------------------------------------------------------------------------- 51 | -- Bottoms 52 | 53 | Nat-has-bottom : has-bottom Nat-poset 54 | Nat-has-bottom .has-bottom.bot = zero 55 | Nat-has-bottom .has-bottom.is-bottom = 0≤x 56 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/NonPositive.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.NonPositive where 2 | 3 | open import Data.Nat 4 | open import Data.Int 5 | open import Order.Instances.Int 6 | 7 | open import Mugen.Prelude 8 | 9 | open import Mugen.Order.StrictOrder 10 | open import Mugen.Order.Lattice 11 | open import Mugen.Order.Instances.Nat 12 | open import Mugen.Order.Instances.Int 13 | open import Mugen.Order.Instances.Opposite 14 | 15 | -------------------------------------------------------------------------------- 16 | -- The Non-Positive Integers 17 | -- Section 3.3.1 18 | -- 19 | -- These have a terse definition as the opposite order of Nat+, 20 | -- so we just use that. 21 | 22 | NonPositive : Poset lzero lzero 23 | NonPositive = Opposite Nat-poset 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Inclusion to Int-poset 27 | 28 | NonPositive→Int : Strictly-monotone NonPositive Int-poset 29 | NonPositive→Int .Strictly-monotone.hom x = negℤ (pos x) 30 | NonPositive→Int .Strictly-monotone.pres-≤[]-equal p .fst = negℤ-anti _ _ (pos≤pos p) 31 | NonPositive→Int .Strictly-monotone.pres-≤[]-equal p .snd q = pos-injective $ negℤ-injective _ _ q 32 | 33 | abstract 34 | NonPositive→Int-is-full-subposet : is-full-subposet NonPositive→Int 35 | NonPositive→Int-is-full-subposet .is-full-subposet.injective p = pos-injective $ negℤ-injective _ _ p 36 | NonPositive→Int-is-full-subposet .is-full-subposet.full {_} {zero} _ = 0≤x 37 | NonPositive→Int-is-full-subposet .is-full-subposet.full {zero} {suc _} () 38 | NonPositive→Int-is-full-subposet .is-full-subposet.full {suc _} {suc _} (neg≤neg p) = s≤s p 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Joins 42 | 43 | NonPositive-has-joins : has-joins NonPositive 44 | NonPositive-has-joins .has-joins.join = min 45 | NonPositive-has-joins .has-joins.joinl {x} {y} = min-≤l x y 46 | NonPositive-has-joins .has-joins.joinr {x} {y} = min-≤r x y 47 | NonPositive-has-joins .has-joins.universal {x} {y} {z} = min-univ x y z 48 | 49 | abstract 50 | NonPositive→Int-is-full-subsemilattice : is-full-subsemilattice NonPositive-has-joins Int-has-joins NonPositive→Int 51 | NonPositive→Int-is-full-subsemilattice .is-full-subsemilattice.has-is-full-subposet = NonPositive→Int-is-full-subposet 52 | NonPositive→Int-is-full-subsemilattice .is-full-subsemilattice.pres-join = negℤ-distrib-min _ _ 53 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Opposite.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Opposite where 2 | 3 | open import Mugen.Prelude 4 | 5 | module _ {o r} (A : Poset o r) where 6 | open Poset A 7 | 8 | Opposite : Poset o r 9 | Opposite .Poset.Ob = Ob 10 | Opposite .Poset._≤_ x y = y ≤ x 11 | Opposite .Poset.≤-refl = ≤-refl 12 | Opposite .Poset.≤-trans p q = ≤-trans q p 13 | Opposite .Poset.≤-thin = ≤-thin 14 | Opposite .Poset.≤-antisym p q = ≤-antisym q p 15 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Pointwise.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Pointwise where 2 | 3 | open import Order.Instances.Pointwise using (Pointwise) public 4 | 5 | open import Mugen.Prelude 6 | open import Mugen.Order.Lattice 7 | 8 | import Mugen.Order.Reasoning as Reasoning 9 | 10 | private variable 11 | o o' o'' o''' r r' r'' r''' : Level 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Product of Indexed Posets 15 | -- POPL 2023 Section 3.3.5 discussed the special case where I = Nat and A is a constant family 16 | 17 | pointwise-map₂ 18 | : {A : Type o} {B : A → Type o'} {C : A → Type o''} {D : A → Type o'''} 19 | → (∀ (x : A) → B x → C x → D x) → (∀ x → B x) → (∀ x → C x) → (∀ x → D x) 20 | pointwise-map₂ m f g i = m i (f i) (g i) 21 | 22 | module _ (I : Type o) {A : I → Poset o' r'} where 23 | private 24 | module A (i : I) = Poset (A i) 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Joins 28 | 29 | Pointwise-has-joins : (∀ i → has-joins (A i)) → has-joins (Pointwise I A) 30 | Pointwise-has-joins 𝒟-joins = joins 31 | where 32 | open module J (i : I) = has-joins (𝒟-joins i) 33 | 34 | joins : has-joins (Pointwise I A) 35 | joins .has-joins.join = pointwise-map₂ join 36 | joins .has-joins.joinl i = joinl i 37 | joins .has-joins.joinr i = joinr i 38 | joins .has-joins.universal f≤h g≤h = λ i → universal i (f≤h i) (g≤h i) 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Bottom 42 | 43 | Pointwise-has-bottom : (∀ i → has-bottom (A i)) → has-bottom (Pointwise I A) 44 | Pointwise-has-bottom A-bottom = bottom 45 | where 46 | open module B (i : I) = has-bottom (A-bottom i) 47 | 48 | bottom : has-bottom (Pointwise I A) 49 | bottom .has-bottom.bot i = bot i 50 | bottom .has-bottom.is-bottom i = is-bottom i 51 | -------------------------------------------------------------------------------- /src/Mugen/Order/Instances/Prefix.agda: -------------------------------------------------------------------------------- 1 | module Mugen.Order.Instances.Prefix where 2 | 3 | open import Data.List 4 | open import Mugen.Order.Lattice 5 | 6 | open import Mugen.Prelude 7 | 8 | private variable 9 | o : Level 10 | A : Type o 11 | 12 | module _ where 13 | 14 | data Prefix[_≤_] {A : Type o} : List A → List A → Type o where 15 | pre[] : ∀ {xs} → Prefix[ [] ≤ xs ] 16 | -- '_pre∷_' is taking the extra argument of type 'x ≡ y' to work around --without-K 17 | _pre∷_ : ∀ {x y xs ys} → x ≡ y → Prefix[ xs ≤ ys ] → Prefix[ (x ∷ xs) ≤ (y ∷ ys) ] 18 | 19 | private abstract 20 | prefix-refl : (xs : List A) → Prefix[ xs ≤ xs ] 21 | prefix-refl [] = pre[] 22 | prefix-refl (x ∷ xs) = refl pre∷ prefix-refl xs 23 | 24 | prefix-trans : (xs ys zs : List A) → Prefix[ xs ≤ ys ] → Prefix[ ys ≤ zs ] → Prefix[ xs ≤ zs ] 25 | prefix-trans _ _ _ pre[] _ = pre[] 26 | prefix-trans (x ∷ xs) (y ∷ ys) (z ∷ zs) (x≡y pre∷ xs≤ys) (y≡z pre∷ ys≤zs) = 27 | (x≡y ∙ y≡z) pre∷ (prefix-trans xs ys zs xs≤ys ys≤zs) 28 | 29 | prefix-antisym : ∀ (xs ys : List A) → Prefix[ xs ≤ ys ] → Prefix[ ys ≤ xs ] → xs ≡ ys 30 | prefix-antisym _ _ pre[] pre[] = refl 31 | prefix-antisym (x ∷ xs) (y ∷ ys) (x≡y pre∷ xs≤ys) (y≡x pre∷ ys≤xs) = 32 | ap₂ _∷_ x≡y (prefix-antisym xs ys xs≤ys ys≤xs) 33 | 34 | prefix-is-prop : ∀ {xs ys : List A} → is-set A → is-prop (Prefix[ xs ≤ ys ]) 35 | prefix-is-prop {xs = []} aset pre[] pre[] = refl 36 | prefix-is-prop {xs = x ∷ xs} {ys = y ∷ ys} aset (x≡y pre∷ xs_ 47 | 48 | _|>_ : ∀ {ℓ₁ ℓ₂} {A : Type ℓ₁} {B : A → Type ℓ₂} → (x : A) → ((x : A) → B x) → B x 49 | x |> f = f x 50 | {-# INLINE _|>_ #-} 51 | 52 | over : ∀ {ℓ} {A : Type ℓ} {x y : A} {f : A → A} → (∀ x → f x ≡ x) → f x ≡ f y → x ≡ y 53 | over {x = x} {y = y} p q = sym (p x) ·· q ·· p y 54 | 55 | -------------------------------------------------------------------------------- 56 | -- This lemma should probably be put into 1lab 57 | identity-system-hlevel 58 | : ∀ {ℓ ℓ'} {A : Type ℓ} n {R : A → A → Type ℓ'} {r : ∀ x → R x x} 59 | → is-identity-system R r 60 | → is-hlevel A (suc n) 61 | → ∀ {x y : A} → is-hlevel (R x y) n 62 | identity-system-hlevel n ids hl {x} {y} = 63 | Equiv→is-hlevel n (identity-system-gives-path ids) (Path-is-hlevel' n hl x y) 64 | --------------------------------------------------------------------------------