├── .gitignore ├── CartesianMorphism.agda ├── FreeMonad.agda ├── PolyMisc.agda ├── Polynomial.agda ├── PolynomialMonad.agda ├── PullbackMonad.agda ├── README.md ├── SliceMonad.agda ├── WTypes.agda └── simple └── Simple.agda /.gitignore: -------------------------------------------------------------------------------- 1 | *.agdai 2 | -------------------------------------------------------------------------------- /CartesianMorphism.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import Polynomial 6 | 7 | module CartesianMorphism where 8 | 9 | record CartesianMorphism {ℓ} {I J K L : Type ℓ} (f : I → K) (g : J → L) (P : Poly I J) (Q : Poly K L) : Type ℓ where 10 | field 11 | 12 | γ-map : {j : J} → γ P j → γ Q (g j) 13 | ρ-eqv : {j : J} {c : γ P j} → ρ P c ≃ ρ Q (γ-map c) 14 | τ-coh : {j : J} {c : γ P j} (p : ρ P c) → f (τ P p) == τ Q (–> ρ-eqv p) 15 | 16 | open CartesianMorphism public 17 | 18 | ⟦_∣_⟧⟦_⇒_⟧ : ∀ {ℓ} {I J K L : Type ℓ} (f : I → K) (g : J → L) (P : Poly I J) (Q : Poly K L) → Type ℓ 19 | ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧ = CartesianMorphism f g P Q 20 | 21 | infixl 30 _⇝_ 22 | 23 | _⇝_ : ∀ {ℓ} {I J : Type ℓ} (P Q : Poly I J) → Type ℓ 24 | P ⇝ Q = ⟦ (λ i → i) ∣ (λ j → j) ⟧⟦ P ⇒ Q ⟧ 25 | 26 | poly-id : ∀ {ℓ} {I J : Type ℓ} (P : Poly I J) → P ⇝ P 27 | γ-map (poly-id P) = idf _ 28 | ρ-eqv (poly-id P) = ide _ 29 | τ-coh (poly-id P) p = idp 30 | 31 | module _ {ℓ} {I J K L : Type ℓ} 32 | {f : I → K} {g : J → L} 33 | {P : Poly I J} {Q : Poly K L} 34 | (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) {j : J} 35 | where 36 | 37 | ⟪_⟫ : γ P j → γ Q (g j) 38 | ⟪_⟫ = γ-map α 39 | 40 | ⟪_ⓐ_⟫≃ : (c : γ P j) → ρ P c ≃ ρ Q (⟪_⟫ c) 41 | ⟪_ⓐ_⟫≃ c = ρ-eqv α {c = c} 42 | 43 | ⟪_ⓐ_⟫↓ : (c : γ P j) → ρ P c → ρ Q (⟪_⟫ c) 44 | ⟪_ⓐ_⟫↓ c = –> (⟪_ⓐ_⟫≃ c) 45 | 46 | ⟪_ⓐ_⟫↑ : (c : γ P j) → ρ Q (⟪_⟫ c) → ρ P c 47 | ⟪_ⓐ_⟫↑ c = <– (⟪_ⓐ_⟫≃ c) 48 | 49 | ⟪_ⓐ_⟫⇵ : (c : γ P j) (p : ρ P c) → ⟪_ⓐ_⟫↑ c (⟪_ⓐ_⟫↓ c p) == p 50 | ⟪_ⓐ_⟫⇵ c = <–-inv-l (⟪_ⓐ_⟫≃ c) 51 | 52 | ⟪_ⓐ_⟫⇅ : (c : γ P j) (q : ρ Q (⟪_⟫ c)) → ⟪_ⓐ_⟫↓ c (⟪_ⓐ_⟫↑ c q) == q 53 | ⟪_ⓐ_⟫⇅ c = <–-inv-r (⟪_ⓐ_⟫≃ c) 54 | 55 | ⟪_ⓐ_⟫↓= : (c : γ P j) (p : ρ P c) → f (τ P p) == τ Q (⟪_ⓐ_⟫↓ c p) 56 | ⟪_ⓐ_⟫↓= c = τ-coh α {c = c} 57 | 58 | ⟪_ⓐ_⟫↑= : (c : γ P j) (q : ρ Q (⟪_⟫ c)) → f (τ P (⟪_ⓐ_⟫↑ c q)) == τ Q q 59 | ⟪_ⓐ_⟫↑= c q = ⟪_ⓐ_⟫↓= c (⟪_ⓐ_⟫↑ c q) ∙ ap (τ Q) (⟪_ⓐ_⟫⇅ c q) 60 | 61 | module _ {c : γ P j} where 62 | 63 | ⟪_⟫≃ : ρ P c ≃ ρ Q (⟪_⟫ c) 64 | ⟪_⟫≃ = ⟪_ⓐ_⟫≃ c 65 | 66 | ⟪_⟫↓ : ρ P c → ρ Q (⟪_⟫ c) 67 | ⟪_⟫↓ = –> ⟪_⟫≃ 68 | 69 | ⟪_⟫↑ : ρ Q (⟪_⟫ c) → ρ P c 70 | ⟪_⟫↑ = <– ⟪_⟫≃ 71 | 72 | ⟪_⟫⇵ : (p : ρ P c) → ⟪_⟫↑ (⟪_⟫↓ p) == p 73 | ⟪_⟫⇵ = <–-inv-l ⟪_⟫≃ 74 | 75 | ⟪_⟫⇅ : (q : ρ Q (⟪_⟫ c)) → ⟪_⟫↓ (⟪_⟫↑ q) == q 76 | ⟪_⟫⇅ = <–-inv-r ⟪_⟫≃ 77 | 78 | ⟪_⟫-adj : (p : ρ P c) → ap (⟪_⟫↓) (⟪_⟫⇵ p) == ⟪_⟫⇅ (⟪_⟫↓ p) 79 | ⟪_⟫-adj = <–-inv-adj ⟪_⟫≃ 80 | 81 | ⟪_⟫↓= : (p : ρ P c) → f (τ P p) == τ Q (⟪_⟫↓ p) 82 | ⟪_⟫↓= = τ-coh α {c = c} 83 | 84 | ⟪_⟫↑= : (q : ρ Q ⟪ c ⟫) → f (τ P (⟪_⟫↑ q)) == τ Q q 85 | ⟪ q ⟫↑= = (⟪_⟫↓= (⟪_⟫↑ q)) ∙ ap (τ Q) (⟪_⟫⇅ q) 86 | 87 | -- 88 | -- The following says that for any q : p₀ == p₁, 89 | -- we have a commutative square : 90 | -- 91 | -- f (τ P p₀) == τ Q (⟪ α ⟫↓ p₁) 92 | -- || || 93 | -- || || 94 | -- f (τ P p₁) == τ Q (⟪ α ⟫↓ p₁) 95 | -- 96 | 97 | ⟪_⟫■ : {p₀ p₁ : ρ P c} (q : p₀ == p₁) → 98 | ! (ap (f ∘ τ P) q) ∙ ⟪_⟫↓= p₀ ∙ ap (τ Q) (ap (⟪_⟫↓) q) == ⟪_⟫↓= p₁ 99 | ⟪_⟫■ idp = ∙-unit-r ( ⟪_⟫↓= _) 100 | 101 | module _ {ℓ} {I J K L : Type ℓ} 102 | {f : I → K} {g : J → L} 103 | {P : Poly I J} {Q : Poly K L} where 104 | 105 | -- A very general method for transferring decorations ... 106 | push : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) 107 | (X : I → Type ℓ) (Y : K → Type ℓ) 108 | (T : {i : I} → X i → Y (f i)) 109 | {j : J} {c : γ P j} 110 | → ⟦ P ⟧⟦ c ≺ X ⟧ → ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ Y ⟧ 111 | push α X Y T φ q = transport Y (⟪ α ⟫↑= q) (T (φ (⟪ α ⟫↑ q))) 112 | 113 | push-coh : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) 114 | (X : I → Type ℓ) (Y : K → Type ℓ) 115 | (T : {i : I} → X i → Y (f i)) 116 | {j : J} {c : γ P j} (φ : ⟦ P ⟧⟦ c ≺ X ⟧) (p : ρ P c) → 117 | T (φ p) == push α X Y T φ (⟪ α ⟫↓ p) [ Y ↓ ⟪ α ⟫↓= p ] 118 | push-coh α X Y T φ p = from-transp Y (⟪ α ⟫↓= p) lemma 119 | 120 | where φ-expand : transport Y (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) (T (φ p)) == T (φ (⟪ α ⟫↑ (⟪ α ⟫↓ p))) 121 | φ-expand = to-transp (!ᵈ (↓-ap-in Y (f ∘ τ P) (apd (T ∘ φ) (⟪ α ⟫⇵ p)))) 122 | 123 | lemma = transport Y (⟪ α ⟫↓= p) (T (φ p)) 124 | =⟨ ! (⟪ α ⟫■ (⟪ α ⟫⇵ p))|in-ctx (λ x → transport Y x (T (φ p))) ⟩ 125 | transport Y (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (ap ⟪ α ⟫↓ (⟪ α ⟫⇵ p))) (T (φ p)) 126 | =⟨ ⟪ α ⟫-adj p |in-ctx (λ x → transport Y (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) x) (T (φ p))) ⟩ 127 | transport Y (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p)))) (T (φ p)) 128 | =⟨ trans-∙ (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) (⟪ α ⟫↑= (⟪ α ⟫↓ p)) (T (φ p)) ⟩ 129 | transport Y (⟪ α ⟫↑= (⟪ α ⟫↓ p)) (transport Y (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) (T (φ p))) 130 | =⟨ φ-expand |in-ctx (λ x → transport Y (⟪ α ⟫↑= (⟪ α ⟫↓ p)) x) ⟩ 131 | transport Y (⟪ α ⟫↑= (⟪ α ⟫↓ p)) (T (φ (⟪ α ⟫↑ (⟪ α ⟫↓ p)))) ∎ 132 | 133 | 134 | -- Specialized to the case where T is the identity, the above 135 | -- induces an equivalence on decorations 136 | ⟪_∣_⟫⇓ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} → 137 | ⟦ P ⟧⟦ c ≺ X ∘ f ⟧ → ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧ 138 | ⟪ α ∣ X ⟫⇓ φ q = push α (X ∘ f) X (λ x → x) φ q 139 | 140 | ⟪_∣_⟫⇑ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} → 141 | ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧ → ⟦ P ⟧⟦ c ≺ X ∘ f ⟧ 142 | ⟪ α ∣ X ⟫⇑ ψ p = transport X (! (⟪ α ⟫↓= p)) (ψ (⟪ α ⟫↓ p)) 143 | 144 | -- ⟪_∣_⟫⇓-po : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 145 | -- (φ : ⟦ P ⟧⟦ c ≺ X ∘ f ⟧) (q : ρ Q (⟪ α ⟫ c)) → 146 | -- φ (⟪ α ⟫↑ q) == ⟪ α ∣ X ⟫⇓ φ q [ X ↓ (⟪ α ⟫↑= q) ] 147 | -- ⟪ α ∣ X ⟫⇓-po φ q = from-transp X (⟪ α ⟫↑= q) idp 148 | 149 | -- ⟪_∣_⟫⇑-po : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 150 | -- (ψ : ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧) (p : ρ P c) → 151 | -- ⟪ α ∣ X ⟫⇑ ψ p == ψ (⟪ α ⟫↓ p) [ X ↓ ⟪ α ⟫↓= p ] 152 | -- ⟪ α ∣ X ⟫⇑-po ψ p = from-transp X (⟪ α ⟫↓= p) {!idp!} -- (trans-move-left (⟪ α ⟫↓= p) idp) 153 | 154 | -- A version of the previous, parameterized over a path 155 | -- ⟪_∣_↓_⟫⇑ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) 156 | -- {j : J} {c : γ P j} {d : γ Q (g j)} 157 | -- (r : ⟪ α ⟫ c == d) → 158 | -- ⟦ Q ⟧⟦ d ≺ X ⟧ → ⟦ P ⟧⟦ c ≺ X ∘ f ⟧ 159 | -- ⟪ α ∣ X ↓ idp ⟫⇑ ψ = ⟪ α ∣ X ⟫⇑ ψ 160 | 161 | -- -- Another path parameterized version, though this is getting a bit messy ... 162 | -- ⟪_∣_↓_⟫⇑-po : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) 163 | -- {j : J} {c : γ P j} {d : γ Q (g j)} → 164 | -- (r : ⟪ α ⟫ c == d) (ψ : ⟦ Q ⟧⟦ d ≺ X ⟧) (p : ρ P c) → 165 | -- ⟪ α ∣ X ↓ r ⟫⇑ ψ p == ψ (⟦ Q ↓ r ⟧↓ ( ⟪ α ⟫↓ p)) [ X ↓ ⟪ α ⟫↓= p ∙ ⟦ Q ↓ r ⟧↓= (⟪ α ⟫↓ p) ] 166 | -- ⟪ α ∣ X ↓ idp ⟫⇑-po ψ p = transport (λ x → PathOver X x (⟪ α ∣ X ⟫⇑ ψ p) (ψ (⟪ α ⟫↓ p))) (! (∙-unit-r (⟪ α ⟫↓= p))) 167 | -- (⟪ α ∣ X ⟫⇑-po ψ p) 168 | 169 | ⟪_∣_⟫⇓-coh : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 170 | (φ : ⟦ P ⟧⟦ c ≺ X ∘ f ⟧) (p : ρ P c) → 171 | φ p == ⟪ α ∣ X ⟫⇓ φ (⟪ α ⟫↓ p) [ X ↓ ⟪ α ⟫↓= p ] 172 | ⟪ α ∣ X ⟫⇓-coh φ = push-coh α (X ∘ f) X (λ x → x) φ 173 | 174 | ⟪_∣_⟫⇑-coh : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 175 | (ψ : ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧) (q : ρ Q (⟪ α ⟫ c)) → 176 | ψ q == ⟪ α ∣ X ⟫⇑ ψ (⟪ α ⟫↑ q) [ X ↓ ! (⟪ α ⟫↑= q) ] 177 | ⟪ α ∣ X ⟫⇑-coh ψ q = from-transp X (! (⟪ α ⟫↑= q)) lemma 178 | 179 | where ψ-expand : transport X (! (ap (τ Q) (⟪ α ⟫⇅ q))) (ψ q) == (ψ (⟪ α ⟫↓ (⟪ α ⟫↑ q))) 180 | ψ-expand = to-transp (!ᵈ (↓-ap-in X (τ Q) (apd ψ (⟪ α ⟫⇅ q)))) 181 | 182 | lemma = transport X (! (⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q))) (ψ q) 183 | =⟨ !-∙ (⟪ α ⟫↓= (⟪ α ⟫↑ q)) (ap (τ Q) (⟪ α ⟫⇅ q)) |in-ctx (λ x → transport X x (ψ q)) ⟩ 184 | transport X ((! (ap (τ Q) (⟪ α ⟫⇅ q))) ∙ (! (⟪ α ⟫↓= (⟪ α ⟫↑ q)))) (ψ q) 185 | =⟨ trans-∙ ((! (ap (τ Q) (⟪ α ⟫⇅ q)))) ((! (⟪ α ⟫↓= (⟪ α ⟫↑ q)))) (ψ q) ⟩ 186 | transport X (! (⟪ α ⟫↓= (⟪ α ⟫↑ q))) (transport X (! (ap (τ Q) (⟪ α ⟫⇅ q))) (ψ q)) 187 | =⟨ ψ-expand |in-ctx (λ x → transport X (! (⟪ α ⟫↓= (⟪ α ⟫↑ q))) x) ⟩ -- expand ψ 188 | ⟪ α ∣ X ⟫⇑ ψ (⟪ α ⟫↑ q) ∎ 189 | 190 | ⟪_∣_⟫⇕-l : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 191 | (φ : ⟦ P ⟧⟦ c ≺ X ∘ f ⟧) (p : ρ P c) → 192 | ⟪ α ∣ X ⟫⇑ (⟪ α ∣ X ⟫⇓ φ) p == φ p 193 | ⟪ α ∣ X ⟫⇕-l φ p = ! (transport (λ x → φ p == ⟪ α ∣ X ⟫⇑ (⟪ α ∣ X ⟫⇓ φ) p [ X ↓ x ]) po-path-is-id po-lemma) 194 | 195 | where po-path : f (τ P p) == f (τ P p) 196 | po-path = ⟪ α ⟫↓= p ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) ∙ ap (f ∘ τ P) (⟪ α ⟫⇵ p) 197 | 198 | po-lemma : φ p == ⟪ α ∣ X ⟫⇑ (⟪ α ∣ X ⟫⇓ φ) p [ X ↓ po-path ] 199 | po-lemma = ⟪ α ∣ X ⟫⇓-coh φ p ∙ᵈ 200 | ⟪ α ∣ X ⟫⇑-coh (⟪ α ∣ X ⟫⇓ φ) (⟪ α ⟫↓ p) ∙ᵈ 201 | ↓-ap-in X (f ∘ τ P) (apd (⟪ α ∣ X ⟫⇑ (⟪ α ∣ X ⟫⇓ φ)) (⟪ α ⟫⇵ p)) 202 | 203 | po-path-is-id : po-path == idp 204 | po-path-is-id = ⟪ α ⟫↓= p ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) ∙ ap (f ∘ τ P) (⟪ α ⟫⇵ p) 205 | =⟨ ! (!-! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) |in-ctx (λ x → ⟪ α ⟫↓= p ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) ∙ x) ⟩ 206 | ⟪ α ⟫↓= p ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) ∙ ! (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) 207 | =⟨ ∙-! (⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p))) |in-ctx (λ x → ⟪ α ⟫↓= p ∙ x) ⟩ 208 | ⟪ α ⟫↓= p ∙ ! (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (⟪ α ⟫⇅ (⟪ α ⟫↓ p))) 209 | =⟨ ! (⟪ α ⟫-adj p) |in-ctx (λ x → ⟪ α ⟫↓= p ∙ ! (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) x)) ⟩ 210 | ⟪ α ⟫↓= p ∙ ! (! (ap (f ∘ τ P) (⟪ α ⟫⇵ p)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ (⟪ α ⟫↓ p)) ∙ ap (τ Q) (ap (⟪ α ⟫↓) (⟪ α ⟫⇵ p))) 211 | =⟨ ⟪ α ⟫■ (⟪ α ⟫⇵ p) |in-ctx (λ x → ⟪ α ⟫↓= p ∙ ! x) ⟩ 212 | ⟪ α ⟫↓= p ∙ ! (⟪ α ⟫↓= p) 213 | =⟨ !-inv-r (⟪ α ⟫↓= p) ⟩ 214 | idp ∎ 215 | 216 | ⟪_∣_⟫⇕-r : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} 217 | (ψ : ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧) (q : ρ Q ( ⟪ α ⟫ c)) → 218 | ⟪ α ∣ X ⟫⇓ (⟪ α ∣ X ⟫⇑ ψ) q == ψ q 219 | ⟪ α ∣ X ⟫⇕-r ψ q = ! (transport (λ x → ψ q == ⟪ α ∣ X ⟫⇓ (⟪ α ∣ X ⟫⇑ ψ) q [ X ↓ x ]) po-path-is-id po-lemma) 220 | 221 | where po-path : τ Q q == τ Q q 222 | po-path = ! (⟪ α ⟫↑= q) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 223 | 224 | po-lemma : ψ q == ⟪ α ∣ X ⟫⇓ (⟪ α ∣ X ⟫⇑ ψ) q [ X ↓ po-path ] 225 | po-lemma = ⟪ α ∣ X ⟫⇑-coh ψ q ∙ᵈ 226 | ⟪ α ∣ X ⟫⇓-coh (⟪ α ∣ X ⟫⇑ ψ) (⟪ α ⟫↑ q) ∙ᵈ 227 | ↓-ap-in X (τ Q) (apd (⟪ α ∣ X ⟫⇓ (⟪ α ∣ X ⟫⇑ ψ)) (⟪ α ⟫⇅ q)) 228 | 229 | po-path-is-id : po-path == idp 230 | po-path-is-id = ! (⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 231 | =⟨ !-∙ (⟪ α ⟫↓= (⟪ α ⟫↑ q)) (ap (τ Q) (⟪ α ⟫⇅ q)) |in-ctx (λ x → x ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q)) ⟩ 232 | (! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ q))) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 233 | =⟨ ∙-assoc (! (ap (τ Q) (⟪ α ⟫⇅ q))) (! (⟪ α ⟫↓= (⟪ α ⟫↑ q))) (⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q)) ⟩ 234 | ! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ ! (⟪ α ⟫↓= (⟪ α ⟫↑ q)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 235 | =⟨ ! (∙-assoc (! (⟪ α ⟫↓= (⟪ α ⟫↑ q))) (⟪ α ⟫↓= (⟪ α ⟫↑ q)) (ap (τ Q) (⟪ α ⟫⇅ q))) |in-ctx (λ x → ! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ x) ⟩ 236 | ! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ (! (⟪ α ⟫↓= (⟪ α ⟫↑ q)) ∙ ⟪ α ⟫↓= (⟪ α ⟫↑ q)) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 237 | =⟨ !-inv-l (⟪ α ⟫↓= (⟪ α ⟫↑ q)) |in-ctx (λ x → ! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ x ∙ ap (τ Q) (⟪ α ⟫⇅ q)) ⟩ 238 | ! (ap (τ Q) (⟪ α ⟫⇅ q)) ∙ ap (τ Q) (⟪ α ⟫⇅ q) 239 | =⟨ !-inv-l (ap (τ Q) (⟪ α ⟫⇅ q)) ⟩ 240 | idp ∎ 241 | 242 | ⟪_∣_⟫⇕-eqv : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (X : K → Type ℓ) {j : J} {c : γ P j} → 243 | ⟦ P ⟧⟦ c ≺ X ∘ f ⟧ ≃ ⟦ Q ⟧⟦ ⟪ α ⟫ c ≺ X ⟧ 244 | ⟪ α ∣ X ⟫⇕-eqv = equiv ⟪ α ∣ X ⟫⇓ ⟪ α ∣ X ⟫⇑ (λ ψ → λ= (⟪ α ∣ X ⟫⇕-r ψ)) (λ φ → λ= (⟪ α ∣ X ⟫⇕-l φ)) 245 | 246 | -- Vertical composition 247 | module _ {ℓ} {I J K L M N : Type ℓ} 248 | {f : I → K} {g : J → L} 249 | {h : K → M} {k : L → N} 250 | {P : Poly I J} {Q : Poly K L} {R : Poly M N} where 251 | 252 | infixr 50 _▶_ 253 | 254 | _▶_ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ h ∣ k ⟧⟦ Q ⇒ R ⟧) → ⟦ h ∘ f ∣ k ∘ g ⟧⟦ P ⇒ R ⟧ 255 | γ-map (α ▶ β) = ⟪ β ⟫ ∘ ⟪ α ⟫ 256 | ρ-eqv (α ▶ β) = ⟪ β ⟫≃ ∘e ⟪ α ⟫≃ 257 | τ-coh (α ▶ β) p = (ap h (⟪ α ⟫↓= p)) ∙ ⟪ β ⟫↓= (⟪ α ⟫↓ p) 258 | 259 | -- Horizontal composition 260 | module _ {ℓ} {I J K L M N : Type ℓ} 261 | {f : I → L} {g : J → M} {h : K → N} 262 | {P : Poly I J} {R : Poly J K} 263 | {Q : Poly L M} {S : Poly M N} where 264 | 265 | -- With the very general "push" method above, these versions for 266 | -- horizontal composition become special cases. 267 | 268 | ⟪_∣_⟫⇕ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ g ∣ h ⟧⟦ R ⇒ S ⟧) {k : K} {c : γ R k} → 269 | ⟦ R ⟧⟦ c ≺ γ P ⟧ → ⟦ S ⟧⟦ ⟪ β ⟫ c ≺ γ Q ⟧ 270 | ⟪ α ∣ β ⟫⇕ φ = push β (γ P) (γ Q) ⟪ α ⟫ φ 271 | 272 | ⟪_∣_⟫⇕-coh : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ g ∣ h ⟧⟦ R ⇒ S ⟧) {k : K} {c : γ R k} → 273 | (φ : ⟦ R ⟧⟦ c ≺ γ P ⟧) (p : ρ R c) → 274 | ⟪ α ⟫ (φ p) == ⟪ α ∣ β ⟫⇕ φ (⟪ β ⟫↓ p) [ γ Q ↓ ⟪ β ⟫↓= p ] 275 | ⟪ α ∣ β ⟫⇕-coh φ = push-coh β (γ P) (γ Q) ⟪ α ⟫ φ 276 | 277 | infixr 40 _∥_ 278 | 279 | _∥_ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ g ∣ h ⟧⟦ R ⇒ S ⟧) → ⟦ f ∣ h ⟧⟦ P ⊚ R ⇒ Q ⊚ S ⟧ 280 | γ-map (α ∥ β) (c , φ) = ⟪ β ⟫ c , ⟪ α ∣ β ⟫⇕ φ 281 | ρ-eqv (α ∥ β) {_} {c , φ} = equiv-Σ' ⟪ β ⟫≃ (λ p → ⟦ Q ↓ ⟪ α ∣ β ⟫⇕-coh φ p ⟧≃ ∘e ⟪ α ⟫≃) 282 | τ-coh (α ∥ β) {_} {c , φ} (p₀ , p₁) = ⟪ α ⟫↓= p₁ ∙ ⟦ Q ↓ ⟪ α ∣ β ⟫⇕-coh φ p₀ ⟧↓= (⟪ α ⟫↓ p₁) 283 | 284 | module _ {ℓ} {I J K L : Type ℓ} 285 | {f : I → K} {g : J → L} 286 | {P : Poly I J} {Q : Poly K L} where 287 | 288 | record LocalEqv (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) {j : J} (c : γ P j) : Type ℓ where 289 | constructor lcl-eqv 290 | field 291 | γ≈ : ⟪ α ⟫ c == ⟪ β ⟫ c 292 | ρ≈ : (p : ρ P c) → ⟪ α ⟫↓ p == ⟪ β ⟫↓ p [ ρ Q ↓ γ≈ ] 293 | τ≈ : (p : ρ P c) → ⟪ α ⟫↓= p == ⟪ β ⟫↓= p [ (λ cp → f (τ P p) == τ Q (snd cp)) ↓ pair= γ≈ (ρ≈ p) ] 294 | 295 | open LocalEqv public 296 | 297 | _≈_ⓐ_ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) {j : J} (c : γ P j) → Type ℓ 298 | α ≈ β ⓐ c = LocalEqv α β c 299 | 300 | _≈_ : (α : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) (β : ⟦ f ∣ g ⟧⟦ P ⇒ Q ⟧) → Type ℓ 301 | α ≈ β = {j : J} → (c : γ P j) → α ≈ β ⓐ c 302 | -------------------------------------------------------------------------------- /FreeMonad.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import Polynomial 6 | open import PolyMisc 7 | open import PolynomialMonad 8 | open import CartesianMorphism 9 | open import WTypes 10 | 11 | module FreeMonad where 12 | 13 | module _ {ℓ} {I : Set ℓ} (P : Poly I I) where 14 | 15 | open PolyMonad renaming (P to MP) 16 | 17 | FrP : Poly I I 18 | γ FrP = W P 19 | ρ FrP = leafOf 20 | τ FrP = leafType 21 | 22 | fr-η : IdP I ⇝ FrP 23 | γ-map fr-η {i} lt = leaf i 24 | ρ-eqv fr-η = ide _ 25 | τ-coh fr-η p = idp 26 | 27 | fr-Η : P ⇝ FrP 28 | γ-map fr-Η = corolla 29 | ρ-eqv fr-Η = (Σ₂-LUnit)⁻¹ 30 | τ-coh fr-Η p = idp 31 | 32 | fr-P : FrP ⊚ P ⇝ FrP 33 | γ-map fr-P (c , φ) = node (c , φ) 34 | ρ-eqv fr-P {j} {c , φ} = ide _ 35 | τ-coh fr-P p = idp 36 | 37 | {-# TERMINATING #-} 38 | fr-fix : {Q : Poly I I} (α : Q ⊚ P ⇝ Q) → Q ⊚ FrP ⇝ Q 39 | γ-map (fr-fix α) (leaf i , ψ) = ψ lt 40 | γ-map (fr-fix α) (node (c , φ) , ψ) = ⟪ α ⟫ (c , (λ p₀ → γ-map (fr-fix α) (φ p₀ , (λ p₁ → ψ (p₀ , p₁))))) 41 | ρ-eqv (fr-fix α) {c = leaf ._ , ψ} = Σ₁-LUnit 42 | ρ-eqv (fr-fix α) {c = node (c , φ) , ψ} = ⟪ α ⟫≃ ∘e equiv-Σ-snd (λ p → ρ-eqv (fr-fix α)) ∘e Σ-assoc 43 | τ-coh (fr-fix α) {c = leaf ._ , ψ} p = idp 44 | τ-coh (fr-fix α) {c = node (c , φ) , ψ} ((p , l) , q) = τ-coh (fr-fix α) (l , q) ∙ ⟪ α ⟫↓= (p , –> (ρ-eqv (fr-fix α)) (l , q)) 45 | 46 | fr-μ : FrP ⊚ FrP ⇝ FrP 47 | fr-μ = fr-fix fr-P 48 | 49 | -- Any polynomial with a "unit" and "multiplication" admits a map from FrP 50 | -- fr-univ : {Q : Poly I I} (η₀ : IdP I ⇝ Q) (μ₀ : Q ⊚ P ⇝ Q) → FrP ⇝ Q 51 | -- fr-univ {Q} η₀ μ₀ = ⊚-unit-l FrP ▶ (η₀ ∥ poly-id FrP) ▶ fr-fix μ₀ 52 | 53 | open ADMIT 54 | 55 | fr-η-left-law : ⊚-unit-l FrP ▶ (fr-η ∥ poly-id FrP) ▶ fr-μ ≈ poly-id FrP 56 | fr-η-left-law (leaf i) = lcl-eqv idp (λ _ → idp) (λ _ → idp) 57 | fr-η-left-law (node (c , φ)) = lcl-eqv γ-eq {!ρ-eq!} {!!} 58 | where IH : (p : ρ P c) → (⊚-unit-l FrP ▶ (fr-η ∥ poly-id FrP) ▶ fr-μ) ≈ (poly-id FrP) ⓐ φ p 59 | IH p = fr-η-left-law (φ p) 60 | 61 | γ-eq : ⟪ ⊚-unit-l FrP ▶ (fr-η ∥ poly-id FrP) ▶ fr-μ ⟫ (node (c , φ)) 62 | == ⟪ poly-id FrP ⟫ (node (c , φ)) 63 | γ-eq = ↓-W-node-lcl-in (γ≈ ∘ IH) 64 | 65 | ρ-eq : (p : ρ FrP (node (c , φ))) → 66 | (⟪ ⊚-unit-l FrP ▶ (fr-η ∥ poly-id FrP) ▶ fr-μ ⟫↓ p) == 67 | (⟪ poly-id FrP ⟫↓ p) [ ρ FrP ↓ γ-eq ] 68 | ρ-eq (p , l) = ↓-leaf-lcl-in (γ≈ ∘ IH) (ρ≈ (IH p) l) 69 | 70 | -- τ-eq : (p : ρ FrP (node (c , φ))) → 71 | -- (⟪ ⊚-unit-l FrP ▶ (fr-η ∥ poly-id FrP) ▶ fr-μ ⟫↓= p) == 72 | -- (⟪ poly-id FrP ⟫↓= p) [ (λ cp → (τ FrP p) == τ FrP (snd cp)) ↓ (pair= γ-eq (ρ-eq p)) ] 73 | -- τ-eq (p , l) = {!!} 74 | 75 | -- -- The right law is definitional 76 | fr-η-right-law : ⊚-unit-r FrP ▶ (poly-id FrP ∥ fr-η) ▶ fr-μ ≈ poly-id FrP 77 | γ≈ (fr-η-right-law c) = idp 78 | ρ≈ (fr-η-right-law c) p = idp 79 | τ≈ (fr-η-right-law c) p = idp 80 | 81 | -- fr-μ-assoc-law : ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ≈ (fr-μ ∥ poly-id FrP) ▶ fr-μ 82 | -- fr-μ-assoc-law = ADMIT 83 | 84 | FrM : PolyMonad I 85 | MP FrM = FrP 86 | η FrM = fr-η 87 | μ FrM = fr-μ 88 | 89 | -- don't do τ≈ 90 | η-left-law FrM = fr-η-left-law 91 | η-right-law FrM = fr-η-right-law 92 | μ-assoc-law FrM = ADMIT 93 | 94 | -- fr-fix-unit : {Q : Poly I I} (α : Q ⊚ P ⇝ Q) → (poly-id Q ∥ fr-η) ▶ fr-fix α ≈ ⊚-unit-inv-r Q 95 | -- fr-fix-unit {Q} α c = leq idp (λ p → idp) (λ p → idp) 96 | 97 | -- fr-fix-mult : {Q : Poly I I} (α : Q ⊚ P ⇝ Q) → (poly-id Q ∥ fr-P) ▶ fr-fix α ≈ ⊚-assoc-l Q FrP P ▶ (fr-fix α ∥ poly-id P) ▶ α 98 | -- fr-fix-mult {Q} α c = leq idp (λ p → idp ) lemma 99 | 100 | -- where lemma : (p : ρ (Q ⊚ FrP ⊚ P) c) → 101 | -- ⟪ (poly-id Q ∥ fr-P) ▶ fr-fix α ⟫↓= p == 102 | -- ⟪ ⊚-assoc-l Q FrP P ▶ (fr-fix α ∥ poly-id P) ▶ α ⟫↓= p 103 | -- lemma ((p , l) , q) = 104 | -- ⟪ fr-fix α ⟫↓= (l , q) ∙ ⟪ α ⟫↓= (p , (⟪ fr-fix α ⟫↓ ((l , q)))) 105 | -- =⟨ ! (∙-unit-r (⟪ fr-fix α ⟫↓= (l , q))) |in-ctx (λ x → x ∙ ⟪ α ⟫↓= (p , (⟪ fr-fix α ⟫↓ ((l , q))))) ⟩ 106 | -- (⟪ fr-fix α ⟫↓= (l , q) ∙ idp) ∙ ⟪ α ⟫↓= (p , (⟪ fr-fix α ⟫↓ ((l , q)))) 107 | -- =⟨ ! (ap-idf (⟪ fr-fix α ⟫↓= (l , q) ∙ idp)) |in-ctx (λ x → x ∙ ⟪ α ⟫↓= (p , (⟪ fr-fix α ⟫↓ ((l , q))))) ⟩ 108 | -- ap (λ i → i) (⟪ fr-fix α ⟫↓= (l , q) ∙ idp) ∙ ⟪ α ⟫↓= (p , (⟪ fr-fix α ⟫↓ ((l , q)))) ∎ 109 | 110 | -- fr-unique : {Q : Poly I I} {α β : FrP ⇝ Q} → 111 | -- fr-η ▶ α ≈ fr-η ▶ β → 112 | -- fr-P ▶ α ≈ fr-P ▶ β → 113 | -- α ≈ β 114 | -- fr-unique η-eq μ-eq (leaf i) = leq (γ≈ (η-eq lt)) (ρ≈ (η-eq lt)) (τ≈ (η-eq lt)) 115 | -- fr-unique η-eq μ-eq (node (c , φ)) = leq (γ≈ (μ-eq (c , φ))) (ρ≈ (μ-eq (c , φ))) (τ≈ (μ-eq (c , φ))) 116 | 117 | -- Here is the identity which you seem to need to 118 | -- complete the proof. It is the exact analog of the 119 | -- decoration lemma you had before. I would still like 120 | -- to see this fit nicer into a general scheme ... 121 | 122 | -- fr-fix-mult : {Q : Poly I I} (α : Q ⊚ P ⇝ Q) → (poly-id Q ∥ fr-P) ▶ fr-fix α ≈ ⊚-assoc-l Q FrP P ▶ (fr-fix α ∥ poly-id P) ▶ α 123 | -- fr-fix-mult {Q} α c = leq idp (λ p → idp ) lemma 124 | 125 | 126 | -- COMPARE: 127 | -- (poly-id Q ∥ fr-P) ▶ fr-fix α ≈ 128 | -- ⊚-assoc-l Q FrP P ▶ (fr-fix α ∥ poly-id P) ▶ α 129 | 130 | -- unroll : (poly-id (FrP ⊚ FrP) ∥ fr-P) ▶ ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ≈ 131 | -- ⊚-assoc-l (FrP ⊚ FrP) FrP P ▶ ((⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ) ∥ poly-id P) ▶ fr-P 132 | -- unroll = ADMIT 133 | 134 | -- {-# TERMINATING #-} 135 | -- fr-μ-assoc-law : ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ≈ (fr-μ ∥ poly-id FrP) ▶ fr-μ 136 | -- fr-μ-assoc-law (leaf i , ψ) = leq idp (λ p → idp) ADMIT 137 | -- fr-μ-assoc-law (node (c , φ) , ψ) = leq γ-eq ρ-eq ADMIT 138 | 139 | -- where γ-eq : ⟪ ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ⟫ (node (c , φ) , ψ) == 140 | -- ⟪ (fr-μ ∥ poly-id FrP) ▶ fr-μ ⟫ (node (c , φ) , ψ) 141 | -- γ-eq = γ≈ (unroll ((c , φ) , ψ)) ∙ ↓-W-node-lcl-in (λ p → γ≈ (fr-μ-assoc-law (φ p , λ p₁ → ψ (p , p₁)))) 142 | 143 | -- ρ-eq : (p : ρ ((FrP ⊚ FrP) ⊚ FrP) (node (c , φ) , ψ)) → 144 | -- ⟪ ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ⟫↓ p == 145 | -- ⟪ (fr-μ ∥ poly-id FrP) ▶ fr-μ ⟫↓ p [ ρ FrP ↓ γ-eq ] 146 | -- ρ-eq p = ? 147 | 148 | -- -- where dec₀ : ⟦ P ⟧⟦ c ≺ γ FrP ⟧ 149 | -- -- dec₀ p = ⟪ ⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ ⟫ (φ p , λ p₁ → ψ (p , p₁)) 150 | 151 | -- -- dec₁ : ⟦ P ⟧⟦ c ≺ γ FrP ⟧ 152 | -- -- dec₁ p = ⟪ (fr-μ ∥ poly-id FrP) ▶ fr-μ ⟫ (φ p , λ p₁ → ψ (p , p₁)) 153 | 154 | -- -- IH : dec₀ == dec₁ 155 | -- -- IH = λ= (λ p → γ≈ (fr-μ-assoc-law (φ p , λ p₁ → ψ (p , p₁)))) 156 | 157 | -- -- bleep : γ (FrP ⊚ P) _ 158 | -- -- bleep = ⟪ ⊚-assoc-l (FrP ⊚ FrP) FrP P ▶ ((⊚-assoc-r FrP FrP FrP ▶ (poly-id FrP ∥ fr-μ) ▶ fr-μ) ∥ poly-id P) ⟫ ((c , φ) , ψ) 159 | -- -- -- (FrP ⊚ FrP) ⊚ (FrP ⊚ P) ⇝ ((FrP ⊚ FrP) ⊚ FrP) ⊚ P ⇝ (FrP ⊚ (FrP ⊚ FrP)) ⊚ P ⇝ (FrP ⊚ FrP) ⊚ P ⇝ FrP ⊚ P 160 | 161 | -- -- blorp : γ (FrP ⊚ P) _ 162 | -- -- blorp = ⟪ ⊚-assoc-l (FrP ⊚ FrP) FrP P ▶ (((fr-μ ∥ poly-id FrP) ▶ fr-μ) ∥ poly-id P) ⟫ ((c , φ) , ψ) 163 | 164 | -- -- fullIH : bleep == blorp 165 | -- -- fullIH = pair= idp IH 166 | 167 | -- -- res₀ : ⟦ P ⟧⟦ c ≺ γ FrP ⟧ 168 | -- -- res₀ p = ⟪ fr-μ ⟫ (⟪ fr-μ ⟫ (φ p , λ p₁ → fst (ψ (p , p₁))) , 169 | -- -- (λ p₁ → ⟪ poly-id FrP ∣ fr-μ ⟫⇕ (λ pp → snd (ψ (fst pp)) (snd pp)) (p , p₁))) 170 | -- -- --(λ p₁ → ⟪ poly-id FrP ∣ fr-μ ⟫⇕ (snd (⟪ ⊚-assoc-r FrP FrP FrP ⟫ (node (c , φ) , ψ))) (p , p₁))) 171 | 172 | -- -- -- ⊚-assoc-r (c , φ) = (c , (λ p → fst (φ p))) , (λ pp → snd (φ (fst pp)) (snd pp)) 173 | -- -- -- ⊚-assoc-l ((c , φ) , ψ) = (c , (λ p → (φ p , (λ q → ψ (p , q))))) 174 | -- -- -- (α ∥ β) (c , φ) = (⟪ β ⟫ c , ⟪ α ∣ β ⟫⇕ φ) 175 | -- -- -- (poly-id Q ∥ fr-P) ▶ fr-fix α ≈ ⊚-assoc-l Q FrP P ▶ (fr-fix α ∥ poly-id P) ▶ α 176 | 177 | -- -- res₁ : ⟦ P ⟧⟦ c ≺ γ FrP ⟧ 178 | -- -- res₁ p = ⟪ fr-μ ⟫ (φ p , (λ p₁ → ⟪ fr-μ ∣ poly-id FrP ⟫⇕ ψ (p , p₁))) 179 | -- -- --dec₁ p = ⟪ (fr-μ ∥ poly-id FrP) ▶ fr-μ ⟫ (φ p , λ p₁ → ψ (p , p₁)) 180 | 181 | -- -- finale : res₀ == res₁ 182 | -- -- finale = {!γ≈ (unroll ((c , φ) , ψ))!} 183 | 184 | -- -- maybe : (p : ρ P c) → res₁ p == dec₁ p 185 | -- -- maybe p = idp 186 | -------------------------------------------------------------------------------- /PolyMisc.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import Polynomial 6 | open import CartesianMorphism 7 | 8 | module PolyMisc where 9 | 10 | -- 11 | -- These lemmas come from Equivalences.agda, but we need them 12 | -- for the unit type lifted to a higher universe level 13 | -- 14 | 15 | LUnit : ∀ {k} → Type k 16 | LUnit {k} = Lift {lzero} {k} Unit 17 | 18 | lt : ∀ {k} → LUnit {k} 19 | lt = lift unit 20 | 21 | module _ {j k} {B : LUnit {k} → Type j} where 22 | Σ₁-LUnit : Σ LUnit B ≃ B (lt) 23 | Σ₁-LUnit = equiv (λ {(lift unit , b) → b}) (λ b → (lt , b)) (λ _ → idp) (λ _ → idp) 24 | 25 | Π₁-LUnit : Π LUnit B ≃ B (lt) 26 | Π₁-LUnit = equiv (λ f → f lt) (λ b _ → b) (λ _ → idp) (λ _ → idp) 27 | 28 | module _ {i k} {A : Type i} where 29 | Σ₂-LUnit : Σ A (λ _ → LUnit {k}) ≃ A 30 | Σ₂-LUnit = equiv fst (λ a → (a , lt)) (λ _ → idp) (λ _ → idp) 31 | 32 | Π₂-LUnit : Π A (λ _ → LUnit {k}) ≃ LUnit {k} 33 | Π₂-LUnit = equiv (λ _ → lt) (λ _ _ → lt) (λ _ → idp) (λ _ → idp) 34 | 35 | -- 36 | -- Now we can define some useful cartesian morphisms 37 | -- 38 | 39 | -- Unicity maps 40 | ⊚-unit-l : ∀ {ℓ} {I : Type ℓ} (P : Poly I I) → P ⇝ IdP I ⊚ P 41 | γ-map (⊚-unit-l P) c = c , (λ x → lift tt) 42 | ρ-eqv (⊚-unit-l P) = (Σ₂-LUnit)⁻¹ 43 | τ-coh (⊚-unit-l P) p = idp 44 | 45 | ⊚-unit-inv-l : ∀ {ℓ} {I : Type ℓ} (P : Poly I I) → IdP I ⊚ P ⇝ P 46 | γ-map (⊚-unit-inv-l P) (c , φ) = c 47 | ρ-eqv (⊚-unit-inv-l P) = Σ₂-LUnit 48 | τ-coh (⊚-unit-inv-l P) p = idp 49 | 50 | ⊚-unit-r : ∀ {ℓ} {I : Type ℓ} (P : Poly I I) → P ⇝ P ⊚ IdP I 51 | γ-map (⊚-unit-r P) c = lt , cst c 52 | ρ-eqv (⊚-unit-r P) = (Σ₁-LUnit)⁻¹ 53 | τ-coh (⊚-unit-r P) p = idp 54 | 55 | ⊚-unit-inv-r : ∀ {ℓ} {I : Type ℓ} (P : Poly I I) → P ⊚ IdP I ⇝ P 56 | γ-map (⊚-unit-inv-r P) (lt , φ) = φ lt 57 | ρ-eqv (⊚-unit-inv-r P) = Σ₁-LUnit 58 | τ-coh (⊚-unit-inv-r P) p = idp 59 | 60 | -- Associativity of polynomial composition 61 | module _ {ℓ} {I J K L : Type ℓ} (P : Poly I J) (Q : Poly J K) (R : Poly K L) where 62 | 63 | ⊚-assoc-r : (P ⊚ Q) ⊚ R ⇝ P ⊚ (Q ⊚ R) 64 | γ-map ⊚-assoc-r (c , φ) = (c , fst ∘ φ) , (λ { (p₀ , p₁) → snd (φ p₀) p₁ }) 65 | ρ-eqv ⊚-assoc-r {c = c , φ} = (Σ-assoc)⁻¹ 66 | τ-coh ⊚-assoc-r {c = c , φ} (p , (l₀ , l₁)) = idp 67 | 68 | ⊚-assoc-l : P ⊚ (Q ⊚ R) ⇝ (P ⊚ Q) ⊚ R 69 | γ-map ⊚-assoc-l ((c , φ) , ψ) = (c , λ p → (φ p , λ q → ψ (p , q))) 70 | ρ-eqv ⊚-assoc-l {c = (c , φ) , ψ} = Σ-assoc 71 | τ-coh ⊚-assoc-l {c = (c , φ) , ψ} p = idp 72 | 73 | module _ {ℓ} {I J K : Type ℓ} (P : Poly I J) (Q R : Poly J K) where 74 | 75 | ⊚-dist-⊕ : P ⊚ (Q ⊕ R) ⇝ (P ⊚ Q) ⊕ (P ⊚ R) 76 | γ-map ⊚-dist-⊕ (inl cq , φ) = inl (cq , φ) 77 | γ-map ⊚-dist-⊕ (inr cr , φ) = inr (cr , φ) 78 | ρ-eqv ⊚-dist-⊕ {c = inl cq , φ} = ide _ 79 | ρ-eqv ⊚-dist-⊕ {c = inr cr , φ} = ide _ 80 | τ-coh ⊚-dist-⊕ {c = inl cq , φ} p = idp 81 | τ-coh ⊚-dist-⊕ {c = inr cr , φ} p = idp 82 | 83 | -------------------------------------------------------------------------------- /Polynomial.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | module Polynomial where 4 | 5 | open import HoTT 6 | 7 | record Poly {ℓ} (I : Type ℓ) (J : Type ℓ) : Type (lsucc ℓ) where 8 | constructor _≺_/_ 9 | field 10 | γ : (j : J) → Type ℓ 11 | ρ : {j : J} → (c : γ j) → Type ℓ 12 | τ : {j : J} → {c : γ j} → (p : ρ c) → I 13 | 14 | ρ-Σ : Σ J γ → Type ℓ 15 | ρ-Σ = uncurryi ρ 16 | 17 | τ-Σ : Σ (Σ J γ) ρ-Σ → I 18 | τ-Σ (_ , p) = τ p 19 | 20 | open Poly public 21 | 22 | ⟦_⟧⟦_≺_⟧ : ∀ {ℓ κ} {I J : Type ℓ} (P : Poly I J) → {j : J} → γ P j → (I → Type κ) → Type (lmax ℓ κ) 23 | ⟦ P ⟧⟦ c ≺ X ⟧ = Π (ρ P c) (X ∘ τ P) 24 | 25 | ⟦_⟧≺ : ∀ {ℓ κ} {I J : Type ℓ} (P : Poly I J) (X : I → Type κ) → Σ J (γ P) → Type (lmax ℓ κ) 26 | ⟦ P ⟧≺ X (j , c) = ⟦ P ⟧⟦ c ≺ X ⟧ 27 | 28 | ⟦_⟧ : ∀ {ℓ κ} {I J : Type ℓ} → Poly I J → (I → Type κ) → (J → Type (lmax ℓ κ)) 29 | ⟦ P ⟧ X j = Σ (γ P j) (λ c → ⟦ P ⟧⟦ c ≺ X ⟧) 30 | 31 | ⟦_↓_⟧≃ : ∀ {ℓ} {I J : Type ℓ} (P : Poly I J) 32 | {j₀ j₁ : J} {q : j₀ == j₁} {c₀ : γ P j₀} {c₁ : γ P j₁} 33 | (r : c₀ == c₁ [ γ P ↓ q ]) → ρ P c₀ ≃ ρ P c₁ 34 | ⟦_↓_⟧≃ P {q = idp} idp = ide _ 35 | 36 | ⟦_↓_⟧↓ : ∀ {ℓ} {I J : Type ℓ} (P : Poly I J) 37 | {j₀ j₁ : J} {q : j₀ == j₁} {c₀ : γ P j₀} {c₁ : γ P j₁} 38 | (r : c₀ == c₁ [ γ P ↓ q ]) → ρ P c₀ → ρ P c₁ 39 | ⟦ P ↓ r ⟧↓ p = –> ⟦ P ↓ r ⟧≃ p 40 | 41 | ⟦_↓_⟧↓= : ∀ {ℓ} {I J : Type ℓ} (P : Poly I J) 42 | {j₀ j₁ : J} {q : j₀ == j₁} {c₀ : γ P j₀} {c₁ : γ P j₁} 43 | (r : c₀ == c₁ [ γ P ↓ q ]) (p : ρ P c₀) → 44 | τ P p == τ P (⟦ P ↓ r ⟧↓ p) 45 | ⟦_↓_⟧↓= P {q = idp} idp p = idp 46 | 47 | infixr 60 _⊗_ 48 | infixr 50 _⊕_ 49 | infixr 40 _⊚_ 50 | 51 | _⊕_ : ∀ {ℓ} {I J : Type ℓ} → Poly I J → Poly I J → Poly I J 52 | γ (P ⊕ Q) j = γ P j ⊔ γ Q j 53 | ρ (P ⊕ Q) (inl c) = ρ P c 54 | ρ (P ⊕ Q) (inr c) = ρ Q c 55 | τ (P ⊕ Q) {c = inl c} p = τ P p 56 | τ (P ⊕ Q) {c = inr c} p = τ Q p 57 | 58 | _⊗_ : ∀ {ℓ} {I J : Type ℓ} → Poly I J → Poly I J → Poly I J 59 | γ (P ⊗ Q) j = γ P j × γ Q j 60 | ρ (P ⊗ Q) (cp , cq) = ρ P cp ⊔ ρ Q cq 61 | τ (P ⊗ Q) (inl p) = τ P p 62 | τ (P ⊗ Q) (inr p) = τ Q p 63 | 64 | _⊚_ : ∀ {ℓ} {I J K : Type ℓ} → Poly I J → Poly J K → Poly I K 65 | γ (P ⊚ Q) = ⟦ Q ⟧ (γ P) 66 | ρ (P ⊚ Q) (c , φ) = Σ (ρ Q c) (ρ P ∘ φ) 67 | τ (P ⊚ Q) (q , p) = τ P p 68 | 69 | _–_ : ∀ {ℓ} (I : Type ℓ) (i : I) → Type ℓ 70 | I – i = Σ I (λ i' → i ≠ i') 71 | 72 | ∂ : ∀ {ℓ} {I J : Type ℓ} → Poly I J → Poly I J 73 | γ (∂ P) j = Σ (γ P j) (ρ P) 74 | ρ (∂ P) (c , p) = ρ P c – p 75 | τ (∂ P) (p , _) = τ P p 76 | 77 | IdP : ∀ {ℓ} (I : Type ℓ) → Poly I I 78 | γ (IdP I) _ = Lift ⊤ 79 | ρ (IdP I) _ = Lift ⊤ 80 | τ (IdP I) {j} _ = j 81 | 82 | module _ {ℓ} {I : Type ℓ} (P : Poly I I) where 83 | τ-inv : {i i′ : I} {i=i′ : i == i′} 84 | {c : γ P i} {c′ : γ P i′} (c=c′ : c == c′ [ γ P ↓ i=i′ ]) 85 | {p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 86 | → τ P p == τ P p′ 87 | τ-inv {i=i′ = idp} idp idp = idp 88 | 89 | ↓-≺-in : ∀ {κ} {X : I → Type κ} {i i′ : I} {i=i′ : i == i′} 90 | {c : γ P i} {c′ : γ P i′} {c=c′ : c == c′ [ γ P ↓ i=i′ ]} 91 | {φ : ⟦ P ⟧⟦ c ≺ X ⟧}{φ′ : ⟦ P ⟧⟦ c′ ≺ X ⟧} 92 | → ({p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 93 | → φ p == φ′ p′ [ X ↓ τ-inv c=c′ p=p′ ]) 94 | → φ == φ′ [ ⟦ P ⟧≺ X ↓ pair= i=i′ c=c′ ] 95 | ↓-≺-in {i=i′ = idp} {c=c′ = idp} f = λ= (λ p → f idp) 96 | 97 | ↓-≺-out : ∀ {κ} {X : I → Type κ} {i i′ : I} {i=i′ : i == i′} 98 | {c : γ P i} {c′ : γ P i′} {c=c′ : c == c′ [ γ P ↓ i=i′ ]} 99 | {φ : ⟦ P ⟧⟦ c ≺ X ⟧} {φ′ : ⟦ P ⟧⟦ c′ ≺ X ⟧} (φ=φ′ : φ == φ′ [ ⟦ P ⟧≺ X ↓ pair= i=i′ c=c′ ]) 100 | → ({p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 101 | → φ p == φ′ p′ [ X ↓ τ-inv c=c′ p=p′ ]) 102 | ↓-≺-out {i=i′ = idp} {c=c′ = idp} q idp = app= q _ 103 | 104 | ↓-≺-β : ∀ {κ} {X : I → Type κ} {i i′ : I} {i=i′ : i == i′} 105 | {c : γ P i} {c′ : γ P i′} {c=c′ : c == c′ [ γ P ↓ i=i′ ]} 106 | {φ : ⟦ P ⟧⟦ c ≺ X ⟧}{φ′ : ⟦ P ⟧⟦ c′ ≺ X ⟧} 107 | → (f : {p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 108 | → φ p == φ′ p′ [ X ↓ τ-inv c=c′ p=p′ ]) 109 | → {p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 110 | → ↓-≺-out (↓-≺-in f) p=p′ == f p=p′ 111 | ↓-≺-β {i=i′ = idp} {c=c′ = idp} f idp = app=-β (λ p → f idp) _ 112 | 113 | ↓-≺-η : ∀ {κ} {X : I → Type κ} {i i′ : I} {i=i′ : i == i′} 114 | {c : γ P i} {c′ : γ P i′} {c=c′ : c == c′ [ γ P ↓ i=i′ ]} 115 | {φ : ⟦ P ⟧⟦ c ≺ X ⟧} {φ′ : ⟦ P ⟧⟦ c′ ≺ X ⟧} (φ=φ′ : φ == φ′ [ ⟦ P ⟧≺ X ↓ pair= i=i′ c=c′ ]) 116 | → ↓-≺-in (↓-≺-out {X = X} {i=i′ = i=i′} φ=φ′) == φ=φ′ 117 | ↓-≺-η {i=i′ = idp} {c=c′ = idp} q = ! (λ=-η q) 118 | 119 | module _ {ℓ κ} {I J : Type ℓ} (P : Poly I J) {X : I → Type κ} where 120 | □ : ∀ {ℓ′} → (Σ I X → Type ℓ′) → (Σ J (⟦ P ⟧ X) → Type _) 121 | □ f (_ , _ , φ) = ∀ p → f (_ , φ p) 122 | 123 | ⋄ : ∀ {ℓ′} → (Σ I X → Type ℓ′) → (Σ J (⟦ P ⟧ X) → Type _) 124 | ⋄ f (_ , _ , φ) = Σ _ λ p → f (_ , φ p) 125 | -------------------------------------------------------------------------------- /PolynomialMonad.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import Polynomial 6 | open import CartesianMorphism 7 | open import PolyMisc 8 | 9 | module PolynomialMonad where 10 | 11 | record PolyMonad {ℓ} (I : Type ℓ) : Type (lsucc ℓ) where 12 | field 13 | 14 | P : Poly I I 15 | 16 | η : IdP I ⇝ P 17 | μ : P ⊚ P ⇝ P 18 | 19 | -- P ⇝ IdP I ⊚ P ⇝ P ⊚ P ⇝ P 20 | η-left-law : ⊚-unit-l P ▶ (η ∥ poly-id P) ▶ μ ≈ poly-id P 21 | 22 | -- P ⇝ P ⊚ IdP I ⇝ P ⊚ P ⇝ P 23 | η-right-law : ⊚-unit-r P ▶ (poly-id P ∥ η) ▶ μ ≈ poly-id P 24 | 25 | -- (P ⊚ P) ⊚ P ⇝ P ⊚ (P ⊚ P) ⇝ P ⊚ P ⇝ P 26 | μ-assoc-law : ⊚-assoc-r P P P ▶ (poly-id P ∥ μ) ▶ μ ≈ (μ ∥ poly-id P) ▶ μ 27 | 28 | -- The other associative law (which should be provable ...) 29 | -- μ-assoc-law' : ⊚-assoc-l P P P ▶ (μ ∥ poly-id P) ▶ μ ≈ (poly-id P ∥ μ) ▶ μ 30 | 31 | module _ {ℓ} {I : Type ℓ} (M : PolyMonad I) where 32 | 33 | open PolyMonad M 34 | 35 | η-cns : (i : I) → γ P i 36 | η-cns i = ⟪ η ⟫ lt 37 | 38 | η-plc : (i : I) → ρ P (η-cns i) 39 | η-plc i = ⟪ η ⟫↓ lt 40 | 41 | η-plc-contr : (i : I) → is-contr (ρ P (η-cns i)) 42 | η-plc-contr i = equiv-preserves-level (⟪ η ⟫≃ ∘e (lower-equiv)⁻¹ ) Unit-is-contr 43 | 44 | η-dec-eqv : (i : I) (X : I → Type ℓ) → X i ≃ ⟦ P ⟧⟦ ⟪ η ⟫ lt ≺ X ⟧ 45 | η-dec-eqv i X = ⟪ η ∣ X ⟫⇕-eqv ∘e lemma 46 | 47 | where lemma : {i : I} → X i ≃ ((p : ρ (IdP I) {i} lt) → X (τ (IdP I) {i} {lt} p)) 48 | lemma {i} = equiv (λ x → cst x) (λ f → f lt) (λ f → λ= (λ x → idp)) (λ x → idp) 49 | 50 | η-dec-unique : {i₀ i₁ : I} → (p : i₀ == i₁) → 51 | (δ₀ : ⟦ P ⟧⟦ ⟪ η ⟫ {i₀} lt ≺ γ P ⟧) → 52 | (δ₁ : ⟦ P ⟧⟦ ⟪ η ⟫ {i₁} lt ≺ γ P ⟧) → 53 | δ₀ (η-plc i₀) == δ₁ (η-plc i₁) [ _ ↓ p ] → 54 | δ₀ == δ₁ [ (λ j → ⟦ P ⟧⟦ ⟪ η ⟫ {j} lt ≺ γ P ⟧) ↓ p ] 55 | η-dec-unique idp δ₀ δ₁ r = {!!} 56 | 57 | 58 | η-unfold : (i : I) → (δ : ⟦ P ⟧⟦ η-cns i ≺ γ P ⟧) → 59 | ⟪ μ ⟫ (η-cns i , δ) == δ (η-plc i) [ γ P ↓ ⟪ η ⟫↓= lt ] 60 | η-unfold i δ = lemma₁ ∙'ᵈ (γ≈ (η-right-law (δ (η-plc i)))) 61 | 62 | where α : ⟪ ⊚-unit-r P ▶ (poly-id P ∥ η) ▶ μ ⟫ (δ (η-plc i)) == (δ (η-plc i)) 63 | α = γ≈ (η-right-law (δ (η-plc i))) 64 | 65 | β : ⟪ ⊚-unit-r P ▶ (poly-id P ∥ η) ▶ μ ⟫ (δ (η-plc i)) == (δ (η-plc i))  66 | β = ⟪ ⊚-unit-r P ▶ (poly-id P ∥ η) ▶ μ ⟫ (δ (η-plc i)) =⟨ idp ⟩ 67 | ⟪ μ ⟫ (⟪ ⊚-unit-r P ▶ (poly-id P ∥ η) ⟫ (δ (η-plc i))) =⟨ idp ⟩ 68 | ⟪ μ ⟫ (⟪ poly-id P ∥ η ⟫ (⟪ ⊚-unit-r P ⟫ (δ (η-plc i)))) =⟨ idp ⟩ 69 | ⟪ μ ⟫ (⟪ poly-id P ∥ η ⟫ (lt , λ _ → δ (η-plc i))) =⟨ idp ⟩ 70 | ⟪ μ ⟫ (⟪ η ⟫ lt , ⟪ poly-id P ∣ η ⟫⇕ (cst (δ (η-plc i)))) =⟨ α ⟩ 71 | (δ (η-plc i))  ∎ 72 | 73 | blorp : ⟦ P ⟧⟦ ⟪ η ⟫ {τ P (η-plc i)} lt ≺ γ P ⟧ 74 | blorp = ⟪ poly-id P ∣ η ⟫⇕ (cst (δ (η-plc i))) 75 | 76 | bleep : ⟦ P ⟧⟦ ⟪ η ⟫ {i} lt ≺ γ P ⟧ 77 | bleep = δ 78 | 79 | lemma : δ == ⟪ poly-id P ∣ η ⟫⇕ (cst (δ (η-plc i))) [ (λ j → ⟦ P ⟧⟦ ⟪ η ⟫ {j} lt ≺ γ P ⟧) ↓ ⟪ η ⟫↓= lt ] 80 | lemma = {!!} 81 | 82 | lemma₁ : ⟪ μ ⟫ (⟪ η ⟫ lt , δ) == ⟪ μ ⟫ (⟪ η ⟫ lt , ⟪ poly-id P ∣ η ⟫⇕ (cst (δ (η-plc i)))) [ γ P ↓ ⟪ η ⟫↓= lt ] 83 | lemma₁ = ap↓ (λ δ' → ⟪ μ ⟫ (⟪ η ⟫ lt , δ')) lemma 84 | 85 | fred : δ (η-plc i) == ⟪ poly-id P ∣ η ⟫⇕ (cst (δ (η-plc i))) (⟪ η ⟫↓ lt) [ γ P ↓ ⟪ η ⟫↓= lt ] 86 | fred = ⟪ poly-id P ∣ η ⟫⇕-coh (cst (δ (η-plc i))) lt 87 | 88 | wilma : δ (η-plc i) == transport (γ P) (⟪ η ⟫↑= (⟪ η ⟫↓ lt)) (δ (η-plc i)) [ γ P ↓ ⟪ η ⟫↓= lt ] 89 | wilma = ⟪ poly-id P ∣ η ⟫⇕-coh (cst (δ (η-plc i))) lt 90 | -------------------------------------------------------------------------------- /PullbackMonad.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import opetopes.Polynomial 6 | open import opetopes.CartesianMorphism 7 | open import opetopes.PolynomialMonad 8 | open import opetopes.PolyMisc 9 | 10 | module opetopes.PullbackMonad where 11 | 12 | module _ {ℓ} {I : Set ℓ} (X : I → Set ℓ) (M : PolyMonad I) where 13 | 14 | open PolyMonad 15 | 16 | T : Set ℓ 17 | T = Σ I X 18 | 19 | PbP : Poly T T 20 | γ PbP (i , x) = ⟦ P M ⟧ X i 21 | ρ PbP (c , φ) = ρ (P M) c 22 | τ PbP {c = c , φ} p = τ (P M) p , φ p 23 | 24 | π-pb : ⟦ fst ∣ fst ⟧⟦ PbP ⇒ (P M) ⟧ 25 | γ-map π-pb (c , φ) = c 26 | ρ-eqv π-pb = ide _ 27 | τ-coh π-pb p = idp 28 | 29 | -- pb-η : IdP T ⇝ PbP 30 | -- γ-map pb-η {j = i , x} _ = (⟪ η M ⟫ lt , ⟪ η M ∣ X ⟫⇓ (cst x)) 31 | -- ρ-eqv pb-η = ⟪ η M ⟫≃ 32 | -- τ-coh pb-η {j = i , x} p = pair= (⟪ η M ⟫↓= lt) (⟪ η M ∣ X ⟫⇓-coh (cst x) lt) 33 | 34 | -- pb-μ : PbP ⊚ PbP ⇝ PbP 35 | -- γ-map pb-μ ((c , φ) , ψ) = (⟪ μ M ⟫ (c , fst ∘ ψ) , ⟪ μ M ∣ X ⟫⇓ (λ { (p₀ , p₁) → snd (ψ p₀) p₁ })) 36 | -- ρ-eqv pb-μ {c = (c , φ) , ψ} = ⟪ μ M ⟫≃ 37 | -- τ-coh pb-μ {c = (c , φ) , ψ} (p₀ , p₁) = pair= (⟪ μ M ⟫↓= (p₀ , p₁)) (⟪ μ M ∣ X ⟫⇓-coh (λ { (p₀ , p₁) → snd (ψ p₀) p₁ }) (p₀ , p₁)) 38 | 39 | -- open ADMIT 40 | 41 | -- pb-η-left-law : ⊚-unit-l PbP ▶ (pb-η ∥ poly-id PbP) ▶ pb-μ ≈ poly-id PbP 42 | -- pb-η-left-law = ADMIT 43 | 44 | -- pb-η-right-law : ⊚-unit-r PbP ▶ (poly-id PbP ∥ pb-η) ▶ pb-μ ≈ poly-id PbP 45 | -- pb-η-right-law = ADMIT 46 | 47 | -- pb-μ-assoc-law : ⊚-assoc-r PbP PbP PbP ▶ (poly-id PbP ∥ pb-μ) ▶ pb-μ ≈ (pb-μ ∥ poly-id PbP) ▶ pb-μ 48 | -- pb-μ-assoc-law = ADMIT 49 | 50 | -- PbM : PolyMonad T 51 | -- P PbM = PbP 52 | -- η PbM = pb-η 53 | -- μ PbM = pb-μ 54 | -- η-left-law PbM = pb-η-left-law 55 | -- η-right-law PbM = pb-η-right-law 56 | -- μ-assoc-law PbM = pb-μ-assoc-law 57 | 58 | -- -- Using the pullback, we can define maps of monads over a given fibration 59 | -- PolyMapOver : ∀ {ℓ} {I : Type ℓ} (X : I → Type ℓ) (M : PolyMonad (Σ I X)) (N : PolyMonad I) → Type ℓ 60 | -- PolyMapOver X M N = PolyMonadMap M (PbM X N) 61 | 62 | 63 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # opetopes-in-agda 2 | Formalization of Opetopes and Opetopic Sets in Agda 3 | -------------------------------------------------------------------------------- /SliceMonad.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | open import Polynomial 6 | open import CartesianMorphism 7 | open import PolynomialMonad 8 | open import PolyMisc 9 | 10 | module SliceMonad where 11 | 12 | module _ {ℓ} {I : Type ℓ} (M : PolyMonad I) where 13 | 14 | open PolyMonad 15 | open ADMIT 16 | 17 | data SlCn : {i : I} → γ (P M) i → Type ℓ where 18 | dot : (i : I) → SlCn {i = i} (⟪ η M ⟫ lt) 19 | box : {i : I} → (c : γ (P M) i) → 20 | (δ : (p : ρ (P M) c) → γ (P M) (τ (P M) p)) → 21 | (ε : (p : ρ (P M) c) → SlCn (δ p)) → 22 | SlCn (⟪ μ M ⟫ (c , δ)) 23 | 24 | SlPl : {i : I} → {c : γ (P M) i} → (w : SlCn c) → Type ℓ 25 | SlPl (dot i) = Lift ⊥ 26 | SlPl (box c δ ε) = Lift {j = ℓ} ⊤ ⊔ Σ (ρ (P M) c) (λ p → SlPl (ε p)) 27 | 28 | B : Type ℓ 29 | B = Σ I (γ (P M)) 30 | 31 | SlCn' : B → Type ℓ 32 | SlCn' (i , c) = SlCn c 33 | 34 | {-# TERMINATING #-} 35 | SlP : Poly B B 36 | γ SlP (i , c) = SlCn c 37 | ρ SlP {i , c} n = SlPl n 38 | τ SlP {i , _} {dot .i} (lift ()) 39 | τ SlP {i , _} {box c δ ε} (inl (lift unit)) = i , c 40 | τ SlP {i , _} {box c δ ε} (inr (p , n)) = τ SlP n 41 | 42 | sl-η : IdP B ⇝ SlP 43 | γ-map sl-η {i , c} _ = transport SlCn (γ≈ (η-left-law M c)) (box c (λ p → ⟪ η M ⟫ lt) (λ p → dot (τ (P M) p))) 44 | ρ-eqv sl-η {i , c} {lift unit} = {!!} ∘e lemma 45 | 46 | where lemma : Lift {j = ℓ} ⊤ ≃ SlPl (box c (λ p → ⟪ η M ⟫ lt) (λ p → dot (τ (P M) p))) 47 | lemma = (λ { (lift unit) → inl lt }) , is-eq _ (λ { p → lt }) 48 | (λ { (inl (lift unit)) → idp ; (inr (_ , lift ())) }) 49 | (λ { (lift unit) → idp }) 50 | 51 | τ-coh sl-η p = {!!} 52 | 53 | sl-graft : {i : I} → {c : γ (P M) i} → (w : SlCn c) → 54 | (δ : (p : ρ (P M) c) → γ (P M) (τ (P M) p)) → 55 | (ε : (p : ρ (P M) c) → SlCn (δ p)) → SlCn (⟪ μ M ⟫ (c , δ)) 56 | sl-graft (dot i) δ₁ ε₁ = {!!} -- transport! SlCn' (pair= (τ-coh (η M) lt) {!γ≈ (η-left-law M (γ-map (η M) lt))!}) (ε₁ (⟪ η M ⟫↓ lt)) 57 | 58 | where ηi : γ (P M) i 59 | ηi = ⟪ η M ⟫ lt 60 | 61 | ηp : ρ (P M) ηi 62 | ηp = ⟪ η M ⟫↓ lt 63 | 64 | ε' : SlCn (δ₁ ηp) 65 | ε' = ε₁ ηp 66 | 67 | test : {!!} == ηi 68 | test = γ≈ (η-left-law M ηi) 69 | 70 | sl-graft (box c δ ε) δ₁ ε₁ = transport! SlCn {!!} (box c (λ p → ⟪ μ M ⟫ (δ p , α p)) IH) 71 | 72 | where α : (p : ρ (P M) c) → (q : ρ (P M) (δ p)) → γ (P M) (τ (P M) q) 73 | α p q = {!!} 74 | 75 | β : (p : ρ (P M) c) → (q : ρ (P M) (δ p)) → SlCn (α p q) 76 | β p q = {!!} 77 | 78 | IH : (p : ρ (P M) c) → SlCn (⟪ μ M ⟫ (δ p , α p)) 79 | IH p = sl-graft (ε p) (α p) (β p) 80 | 81 | sl-graft-ρ-here : {i : I} → {c : γ (P M) i} → (w : SlCn c) → 82 | (δ : (p : ρ (P M) c) → γ (P M) (τ (P M) p)) → 83 | (ε : (p : ρ (P M) c) → SlCn (δ p)) → (n : SlPl w) → SlPl (sl-graft w δ ε) 84 | sl-graft-ρ-here (dot i) δ ε (lift ()) 85 | sl-graft-ρ-here (box c δ ε) δ₁ ε₁ (inl (lift unit)) = {!!} -- ⟦ SlP ↓ from-transp! SlCn idp {!!} ⟧↓ {!!} 86 | sl-graft-ρ-here (box c δ ε) δ₁ ε₁ (inr (p , n)) = {!!} 87 | 88 | sl-μ-γ : {i : I} {c : γ (P M) i} (w : SlCn c) (κ : (p : ρ SlP w) → SlCn' (τ SlP p)) → SlCn c 89 | sl-μ-γ (dot i) κ = dot i 90 | sl-μ-γ (box c δ ε) κ = sl-graft (κ (inl lt)) δ (λ p → sl-μ-γ (ε p) (λ n → κ (inr (p , n)))) 91 | 92 | sl-μ-ρ : {i : I} {c : γ (P M) i} (w : SlCn c) (κ : (p : ρ SlP w) → SlCn (snd (τ SlP p))) → 93 | Σ (SlPl w) (SlPl ∘ κ) → SlPl (sl-μ-γ w κ) 94 | sl-μ-ρ (dot i) k (lift () , n₁) 95 | sl-μ-ρ (box c δ ε) k (n₀ , n₁) = {!!} 96 | 97 | {-# TERMINATING #-} 98 | sl-μ : SlP ⊚ SlP ⇝ SlP 99 | γ-map sl-μ (w , κ) = sl-μ-γ w κ 100 | ρ-eqv sl-μ {c = w , k} = sl-μ-ρ w k , {!!} 101 | τ-coh sl-μ p = {!!} 102 | 103 | -------------------------------------------------------------------------------- /WTypes.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | module WTypes where 3 | 4 | open import HoTT 5 | 6 | open import Polynomial 7 | open import PolyMisc 8 | 9 | data W {ℓ} {I : Type ℓ} (P : Poly I I) : I → Type ℓ where 10 | leaf : (i : I) → W P i 11 | node : {i : I} → ⟦ P ⟧ (W P) i → W P i 12 | 13 | module _ {ℓ} {I : Type ℓ} {P : Poly I I} where 14 | equiv-W : {i : I} → W P i ≃ (⊤ ⊔ ⟦ P ⟧ (W P) i) 15 | equiv-W {i} = unroll-W , is-eq unroll-W roll-W unroll-roll roll-unroll 16 | where 17 | unroll-W : {i : I} → W P i → ⊤ ⊔ ⟦ P ⟧ (W P) i 18 | unroll-W (leaf i) = inl unit 19 | unroll-W (node (c , φ)) = inr (c , φ) 20 | 21 | roll-W : {i : I} → ⊤ ⊔ ⟦ P ⟧ (W P) i → W P i 22 | roll-W {i} (inl _) = leaf i 23 | roll-W (inr (c , φ)) = node (c , φ) 24 | 25 | unroll-roll : ∀ {i} → (uw : ⊤ ⊔ ⟦ P ⟧ (W P) i) → unroll-W (roll-W uw) == uw 26 | unroll-roll (inl x) = idp 27 | unroll-roll (inr x) = idp 28 | 29 | roll-unroll : ∀ {i} → (w : W P i) → roll-W (unroll-W w) == w 30 | roll-unroll (leaf i) = idp 31 | roll-unroll (node x) = idp 32 | 33 | <<<<<<< HEAD 34 | W-adj : ∀ {i} → (w : W P i) → ap W-unroll (roll-unroll w) == unroll-roll (W-unroll w) 35 | W-adj (leaf i) = idp 36 | W-adj (node x) = idp 37 | 38 | {-# TERMINATING #-} 39 | W-preserves-level : (γ-set : (i : I) → is-set (γ P i)) → 40 | (i : I) → is-set (W P i) 41 | W-preserves-level γ-set i = equiv-preserves-level ((W-equiv {i}) ⁻¹) 42 | (⊔-level Unit-has-level (Σ-level (γ-set i) (λ c → Π-level (λ p → W-preserves-level γ-set (τ P p))))) 43 | 44 | ======= 45 | >>>>>>> origin-dev 46 | ↓-W-leaf-in : {i₀ i₁ : I} {q : i₀ == i₁} 47 | → leaf i₀ == leaf i₁ [ W P ↓ q ] 48 | ↓-W-leaf-in {q = idp} = idp 49 | 50 | -- ? 51 | ↓-W-leaf-out : {i i′ : I} {q : i == i′} 52 | → leaf i == leaf i′ [ W P ↓ q ] 53 | → i == i′ 54 | ↓-W-leaf-out {q = q} _ = q 55 | 56 | ↓-W-leaf-β : {i i′ : I} {q : i == i′} → (l : leaf i == leaf i′ [ W P ↓ q ]) 57 | → (↓-W-leaf-out (↓-W-leaf-in {q = q})) == q 58 | ↓-W-leaf-β {q = idp} _ = idp 59 | 60 | ↓-W-leaf-η : {i i′ : I} {q : i == i′} → (l : leaf i == leaf i′ [ W P ↓ q ]) 61 | → ↓-W-leaf-in {q = ↓-W-leaf-out l} == l 62 | ↓-W-leaf-η {i} {.i} {q = idp} l = ! (ap (<– lf=lf-equiv) contr-in-⊤) ∙ (<–-inv-l lf=lf-equiv l) 63 | where lf=lf-equiv : (leaf i == leaf i) ≃ (unit == unit) 64 | lf=lf-equiv = inl=inl-equiv unit unit ∘e equiv-ap equiv-W (leaf i) (leaf i) 65 | 66 | contr-in-⊤ : –> lf=lf-equiv l == idp 67 | contr-in-⊤ = fst $ ⊤-is-set unit unit (–> lf=lf-equiv l) idp 68 | 69 | ↓-W-node-in : {i i′ : I} {q : i == i′} {c : γ P i} {c′ : γ P i′} 70 | {φ : ⟦ P ⟧⟦ c ≺ W P ⟧ } {φ′ : ⟦ P ⟧⟦ c′ ≺ W P ⟧ } 71 | (r : c == c′ [ γ P ↓ q ]) 72 | (s : φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= q r ]) 73 | → node (c , φ) == node (c′ , φ′) [ W P ↓ q ] 74 | ↓-W-node-in {q = idp} idp s = ap (λ φ' → node (_ , φ')) s 75 | 76 | ↓-W-node-out : {i i′ : I} {q : i == i′} {c : γ P i} {c′ : γ P i′} 77 | {φ : ⟦ P ⟧⟦ c ≺ W P ⟧ } {φ′ : ⟦ P ⟧⟦ c′ ≺ W P ⟧ } 78 | → (node (c , φ) == node (c′ , φ′) [ W P ↓ q ]) 79 | → Σ (c == c′ [ γ P ↓ q ]) (λ r → φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= q r ]) 80 | ↓-W-node-out {q = idp} {c} {c′} {φ} {φ′} n=n = (fst= cφ=cφ′ , {!snd= cφ=cφ′!}) 81 | 82 | where nd=nd-eqv : (node (c , φ) == node (c′ , φ′)) ≃ ((c , φ) == (c′ , φ′)) 83 | nd=nd-eqv = inr=inr-equiv (c , φ) (c′ , φ′) ∘e equiv-ap equiv-W (node (c , φ)) (node (c′ , φ′)) 84 | 85 | cφ=cφ′ : (c , φ) == (c′ , φ′) 86 | cφ=cφ′ = –> nd=nd-eqv n=n 87 | 88 | ↓-W-node-lcl-in : {i : I} {c : γ P i} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 89 | (s : (p : ρ P c) → φ p == φ′ p) 90 | → node (c , φ) == node (c , φ′) 91 | ↓-W-node-lcl-in s = ↓-W-node-in idp (λ= s) 92 | 93 | ↓-W-node-lcl-out : {i : I} {c : γ P i} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 94 | → (q : node (c , φ) == node (c , φ′)) 95 | → =Σ {A = γ P i} {B = λ c → ⟦ P ⟧⟦ c ≺ W P ⟧} (c , φ) (c , φ′) 96 | ↓-W-node-lcl-out {i} {c} {φ} {φ′} q = fst= cφ=cφ′ , snd= cφ=cφ′ 97 | where nd=nd-eqv : (node (c , φ) == node (c , φ′)) ≃ ((c , φ) == (c , φ′)) 98 | nd=nd-eqv = inr=inr-equiv (c , φ) (c , φ′) ∘e equiv-ap equiv-W (node (c , φ)) (node (c , φ′)) 99 | 100 | cφ=cφ′ : (c , φ) == (c , φ′) 101 | cφ=cφ′ = –> nd=nd-eqv q 102 | 103 | ↓-W-node-lcl-in′ : {i : I} {c : γ P i} {q : c == c} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 104 | (s : φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= idp q ]) 105 | → node (c , φ) == node (c , φ′) 106 | ↓-W-node-lcl-in′ {q = q} s = ↓-W-node-in q s 107 | 108 | -- ↓-W-node-lcl-out′ : {i : I} {c : γ P i} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 109 | -- → (q : node (c , φ) == node (c , φ′)) 110 | -- → φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= idp {!!} ] 111 | -- ↓-W-node-lcl-out′ {i} {c} {φ} {φ′} q = {!!} 112 | -- 113 | -- ↓-W-node-lcl-β : {i : I} {c : γ P i} {q : c == c} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 114 | -- (s : φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= idp q ]) 115 | -- → ↓-W-node-lcl-out (↓-W-node-lcl-in′ s) == q , {!!} 116 | -- ↓-W-node-lcl-β {i} {c} {φ} {φ′} s = {!!} 117 | -- ↓-W-node-lcl-out (↓-W-node-lcl-in s) =⟨ idp |in-ctx (λ x → ↓-W-node-lcl-out x) ⟩ 118 | -- ↓-W-node-lcl-out (↓-W-node-in idp (λ= s)) =⟨ idp |in-ctx (λ x → ↓-W-node-lcl-out x) ⟩ 119 | -- ↓-W-node-lcl-out (ap (λ x → node (c , x)) (λ= s)) =⟨ {!!} ⟩ 120 | -- idp , {!!} =⟨ {!!} ⟩ 121 | -- {!!} , λ= s ∎ 122 | 123 | module _ {ℓ} {I : Type ℓ} {P : Poly I I} where 124 | 125 | leafOf : {i : I} → W P i → Type ℓ 126 | leafOf (leaf i) = Lift Unit 127 | leafOf (node (c , φ)) = Σ (ρ P c) (λ p → leafOf (φ p)) 128 | 129 | leafOf′ : Σ I (W P) → Type ℓ 130 | leafOf′ (i , w) = leafOf w 131 | 132 | -- leafDec : {i : I} → (w : W P i) → has-dec-eq (leafOf w) 133 | -- leafDec (leaf i) = Lift-Unit-has-dec-eq 134 | -- leafDec (node (c , φ)) = Σ-has-dec-eq (ρ-dec P c) (λ p → leafDec (φ p)) 135 | 136 | leafType : {i : I} → {w : W P i} → leafOf w → I 137 | leafType {w = leaf i} (lift unit) = i 138 | leafType {w = node _} (_ , l) = leafType l 139 | 140 | ↓-leaf-in : {i i′ : I} {i=i′ : i == i′} 141 | {c : γ P i} {c′ : γ P i′} (c=c′ : c == c′ [ γ P ↓ i=i′ ]) 142 | {p : ρ P c} {p′ : ρ P c′} (p=p′ : p == p′ [ ρ-Σ P ↓ pair= i=i′ c=c′ ]) 143 | {φ : ⟦ P ⟧⟦ c ≺ W P ⟧} {φ′ : ⟦ P ⟧⟦ c′ ≺ W P ⟧} 144 | → (φ=φ′ : φ == φ′ [ ⟦ P ⟧≺ (W P) ↓ pair= i=i′ c=c′ ]) 145 | {lf : leafOf (φ p)} {lf′ : leafOf (φ′ p′)} 146 | → (lf=lf′ : lf == lf′ [ leafOf′ ↓ pair= (τ-inv P c=c′ p=p′) (↓-≺-out P φ=φ′ p=p′) ]) 147 | → (p , lf) == (p′ , lf′) [ leafOf′ ↓ pair= i=i′ (↓-W-node-in c=c′ φ=φ′) ] 148 | ↓-leaf-in {i=i′ = idp} idp idp idp idp = idp 149 | 150 | ↓-leaf-lcl-in : {i : I} {c : γ P i} {p : ρ P c} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 151 | (s : (p : ρ P c) → φ p == φ′ p) 152 | {l : leafOf (φ p)} {l′ : leafOf (φ′ p)} (t : l == l′ [ leafOf ↓ s p ]) 153 | → (p , l) == (p , l′) [ leafOf ↓ ↓-W-node-lcl-in s ] 154 | ↓-leaf-lcl-in {i} {c} {p} s {l} {l′} t = ↓-ap-out leafOf′ (_,_ i) (↓-W-node-lcl-in s) po₂ 155 | where po₀ : l == l′ [ leafOf′ ↓ ap (_,_ (τ P p)) (s p) ] 156 | po₀ = ↓-ap-in leafOf′ (λ w → (τ P p) , w) t 157 | 158 | po₁ : l == l′ [ leafOf′ ↓ ap (_,_ (τ P p)) (↓-≺-out P {X = W P} (λ= s) idp) ] 159 | po₁ = transport (λ x → l == l′ [ leafOf′ ↓ ap (_,_ (τ P p)) x ]) (! (app=-β s p)) po₀ 160 | 161 | po₂ : (p , l) == (p , l′) [ leafOf′ ↓ (ap (_,_ i) (↓-W-node-lcl-in s)) ] 162 | po₂ = ↓-leaf-in idp idp (λ= s) po₁ 163 | 164 | -- ↓-leaf-lcl-in′ : {i : I} {c : γ P i} {p : ρ P c} {φ φ′ : ⟦ P ⟧⟦ c ≺ W P ⟧} 165 | -- (s : (p : ρ P c) → φ p == φ′ p) 166 | -- {l : leafOf (φ p)} {l′ : leafOf (φ′ p)} (t : l == l′ [ leafOf ↓ s p ]) 167 | -- → (p , l) == (p , l′) [ leafOf ↓ ↓-W-node-lcl-in s ] 168 | -- ↓-leaf-lcl-in′ {i} {c} {p} s {l} {l′} t = ↓-Σ-in {A = ρ P c} {C = λ q w → } {!!} {!!} {!!} 169 | 170 | -- quek : ∀ {i j} {A : Type i} {B : A → Type j} {x y : A} 171 | 172 | 173 | -- We need one more for the type coherence, but I don't quite see what we're doing here .... 174 | -- -- ↓-leaf-type-lcl-in : {i : I} {c : γ P i} {p : ρ P c} {φ₀ φ₁ : ⟦ P ⟧⟦ c ≺ W P ⟧} 175 | -- -- (s : (p' : ρ P c) → φ₀ p' == φ₁ p') 176 | -- -- {l₀ : leafOf (φ₀ p)} {l₁ : leafOf (φ₁ p)} 177 | -- -- (t : l₀ == l₁ [ leafOf ↓ s p ]) → 178 | -- -- {!!} == {!!} [ (λ wl → {!leafType!} == leafType (snd wl)) ↓ pair= (↓-W-node-lcl-in s) (↓-leaf-lcl-in s t) ] 179 | -- -- ↓-leaf-type-lcl-in s t = {!!} 180 | 181 | nodeOf : {i : I} → W P i → Type ℓ 182 | nodeOf (leaf i) = Lift Empty 183 | nodeOf (node (c , φ)) = Lift {j = ℓ} Unit ⊔ (Σ (ρ P c) (λ p → nodeOf (φ p))) 184 | 185 | -- nodeDec : {i : I} → (w : W P i) → has-dec-eq (nodeOf w) 186 | -- nodeDec (leaf i) (lift ()) 187 | -- nodeDec (node (c , φ)) = ⊔-has-dec-eq Lift-Unit-has-dec-eq (Σ-has-dec-eq (ρ-dec P c) (λ p → nodeDec (φ p))) 188 | 189 | nodeType : {i : I} → {w : W P i} → nodeOf w → Σ I (γ P) 190 | nodeType {w = leaf ._} (lift ()) 191 | nodeType {w = node (c , _)} (inl _) = (_ , c) 192 | nodeType {w = node _} (inr (_ , n)) = nodeType n 193 | 194 | -- nodeOutType : {i : I} → {w : W P i} → nodeOf w → I 195 | -- nodeOutType {w = leaf ._} (lift e) = ⊥-rec e 196 | -- nodeOutType {i} {w = node (c , φ)} (inl _) = i 197 | -- nodeOutType {i} {w = node (c , φ)} (inr (p , n)) = nodeOutType n 198 | 199 | nodeTrans : {i₀ i₁ : I} {q : i₀ == i₁ } {w₀ : W P i₀} {w₁ : W P i₁} → 200 | w₀ == w₁ [ W P ↓ q ] → nodeOf w₀ → nodeOf w₁ 201 | nodeTrans {q = idp} idp n = n 202 | 203 | nodeTypeCoh : {i₀ i₁ : I} {q : i₀ == i₁ } {w₀ : W P i₀} {w₁ : W P i₁} → 204 | (e : w₀ == w₁ [ W P ↓ q ]) → (n : nodeOf w₀) → 205 | nodeType n == nodeType (nodeTrans e n) 206 | nodeTypeCoh {q = idp} idp n = idp 207 | 208 | corolla : {i : I} → (c : γ P i) → W P i 209 | corolla c = node (c , λ p → leaf _) 210 | 211 | corolla-node-unique : {i : I} {c : γ P i} → Lift {j = ℓ} Unit ≃ nodeOf (corolla c) 212 | corolla-node-unique = 213 | equiv (cst (inl lt)) (cst lt) 214 | (λ { (inl _) → idp ; 215 | (inr (_ , lift e)) → ⊥-rec e }) 216 | (cst idp) 217 | -------------------------------------------------------------------------------- /simple/Simple.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --without-K #-} 2 | 3 | open import HoTT 4 | 5 | module Simple where 6 | 7 | open ADMIT 8 | 9 | trans-eqv : {A : Type₀} (B : A → Type₀) (C : {a : A} → B a → Type₀) 10 | {a₀ a₁ : A} (e : a₀ == a₁) (b : B a₀) → C b ≃ C (transport B e b) 11 | trans-eqv B C idp b = ide _ 12 | 13 | trans-lemma : {A : Type₀} (B : A → Type₀) (C : {a : A} → B a → Type₀) 14 | {a₀ a₁ : A} (e : a₀ == a₁) (b : B a₀) → C b → C (transport B e b) 15 | trans-lemma B C e b = –> (trans-eqv B C e b) 16 | 17 | record Monad : Type₁ where 18 | field 19 | 20 | Idx : Type₀ 21 | 22 | γ : Idx → Type₀ 23 | ρ : {i : Idx} → (c : γ i) → Type₀ 24 | τ : {i : Idx} → {c : γ i} → (p : ρ c) → Idx 25 | 26 | η : (i : Idx) → γ i 27 | μ : {i : Idx} → (c : γ i) → (δ : (p : ρ c) → γ (τ p)) → γ i 28 | 29 | ηp-eqv : {i : Idx} → ⊤ ≃ ρ (η i) 30 | μp-eqv : {i : Idx} {c : γ i} (δ : (p : ρ c) → γ (τ p)) → 31 | Σ (ρ c) (ρ ∘ δ) ≃ ρ (μ c δ) 32 | 33 | ηp : (i : Idx) → ρ (η i) 34 | ηp i = –> ηp-eqv unit 35 | 36 | ηp-unique : (i : Idx) (p : ρ (η i)) → p == ηp i 37 | ηp-unique i p = contr-has-all-paths (equiv-preserves-level ηp-eqv Unit-is-contr) p (ηp i) 38 | 39 | μp : {i : Idx} {c : γ i} (δ : (p : ρ c) → γ (τ p)) → 40 | (p : ρ c) → (q : ρ (δ p)) → ρ (μ c δ) 41 | μp δ p q = –> (μp-eqv δ) (p , q) 42 | 43 | ρ-fst : {i : Idx} {c : γ i} (δ : (p : ρ c) → γ (τ p)) → ρ (μ c δ) → ρ c 44 | ρ-fst δ pp = fst (<– (μp-eqv δ) pp) 45 | 46 | ρ-snd : {i : Idx} {c : γ i} (δ : (p : ρ c) → γ (τ p)) → (pp : ρ (μ c δ)) → ρ (δ (ρ-fst δ pp)) 47 | ρ-snd δ pp = snd (<– (μp-eqv δ) pp) 48 | 49 | field 50 | 51 | ηp-compat : {i : Idx} → τ (ηp i) == i 52 | μp-compat : {i : Idx} → {c : γ i} → {δ : (p : ρ c) → γ (τ p)} → 53 | (p : ρ c) → (q : ρ (δ p)) → τ (μp δ p q) == τ q 54 | 55 | unit-l : {i : Idx} → (c : γ i) → μ c (λ p → η (τ p)) == c 56 | unit-r : {i : Idx} → (δ : (p : ρ (η i)) → γ (τ p)) → 57 | δ (ηp i) == μ (η i) δ [ γ ↓ ηp-compat {i} ] 58 | 59 | assoc : {i : Idx} → (c : γ i) → 60 | (δ : (p : ρ c) → γ (τ p)) → 61 | (ε : (q : ρ (μ c δ)) → γ (τ q)) → 62 | μ c (λ p → μ (δ p) (λ q → transport γ (μp-compat {δ = δ} p q) (ε (μp δ p q)))) == μ (μ c δ) ε 63 | 64 | -- 65 | -- The Slice Monad 66 | -- 67 | 68 | module _ (M : Monad) where 69 | 70 | open Monad M 71 | 72 | SlIdx : Type₀ 73 | SlIdx = Σ Idx γ 74 | 75 | data SlCn : {i : Idx} → (c : γ i) → Type₀ where 76 | dot : (i : Idx) → SlCn (η i) 77 | box : {i : Idx} → (c : γ i) → 78 | (δ : (p : ρ c) → γ (τ p)) → 79 | (ε : (p : ρ c) → SlCn (δ p)) → 80 | SlCn (μ c δ) 81 | 82 | SlCn' : SlIdx → Type₀ 83 | SlCn' (i , c) = SlCn c 84 | 85 | SlPl : {i : Idx} {c : γ i} (w : SlCn c) → Type₀ 86 | SlPl (dot i) = ⊥ 87 | SlPl (box c δ ε) = ⊤ ⊔ Σ (ρ c) (λ p → SlPl (ε p)) 88 | 89 | SlTy : {i : Idx} {c : γ i} (w : SlCn c) (n : SlPl w) → SlIdx 90 | SlTy (dot i) () 91 | SlTy (box c δ ε) (inl unit) = _ , c 92 | SlTy (box c δ ε) (inr (p , n)) = SlTy (ε p) n 93 | 94 | module Local {i : Idx} (c : γ i) 95 | (δ : (p : ρ c) → γ (τ p)) 96 | (ε : (p : ρ c) → SlCn (δ p)) 97 | (δ₁ : (p : ρ (μ c δ)) → γ (τ p)) 98 | (ε₁ : (p : ρ (μ c δ)) → SlCn (δ₁ p)) where 99 | 100 | δ₁' : (p : ρ c) → (q : ρ (δ p)) → γ (τ q) 101 | δ₁' p q = transport γ (μp-compat p q) (δ₁ (μp δ p q)) 102 | 103 | ε₁' : (p : ρ c) → (q : ρ (δ p)) → SlCn (δ₁' p q) 104 | ε₁' p q = transport SlCn' (pair= (μp-compat p q) (from-transp γ _ idp)) (ε₁ (μp δ p q)) 105 | 106 | δ' : (p : ρ c) → γ (τ p) 107 | δ' p = μ (δ p) (δ₁' p) 108 | 109 | SlGrft : {i : Idx} {c : γ i} (w : SlCn c) 110 | (δ : (p : ρ c) → γ (τ p)) 111 | (ε : (p : ρ c) → SlCn (δ p)) → 112 | SlCn (μ c δ) 113 | SlGrft (dot i) δ ε = transport SlCn' (pair= ηp-compat (unit-r δ)) (ε (ηp i)) 114 | SlGrft (box c δ ε) δ₁ ε₁ = transport SlCn (assoc c δ δ₁) (box c δ' (λ p → SlGrft (ε p) (δ₁' p) (ε₁' p))) 115 | where open Local c δ ε δ₁ ε₁ 116 | 117 | SlGrftPl₀ : {i : Idx} {c : γ i} (w : SlCn c) 118 | (δ : (p : ρ c) → γ (τ p)) 119 | (ε : (p : ρ c) → SlCn (δ p)) → 120 | (n : SlPl w) → SlPl (SlGrft w δ ε) 121 | SlGrftPl₀ (dot i) δ ε () 122 | SlGrftPl₀ (box c δ ε) δ₁ ε₁ (inl unit) = trans-lemma SlCn SlPl (assoc c δ δ₁) _ (inl unit) 123 | SlGrftPl₀ (box c δ ε) δ₁ ε₁ (inr (p , n)) = trans-lemma SlCn SlPl (assoc c δ δ₁) _ (inr (p , SlGrftPl₀ (ε p) (δ₁' p) (ε₁' p) n)) 124 | where open Local c δ ε δ₁ ε₁ 125 | 126 | SlGrftPl₁ : {i : Idx} {c : γ i} (w : SlCn c) 127 | (δ : (p : ρ c) → γ (τ p)) 128 | (ε : (p : ρ c) → SlCn (δ p)) → 129 | (p : ρ c) → (n : SlPl (ε p)) → SlPl (SlGrft w δ ε) 130 | SlGrftPl₁ (dot i) δ ε p n = –> (trans-eqv SlCn' SlPl (pair= ηp-compat (unit-r δ)) (ε (ηp i))) (transport (SlPl ∘ ε) (ηp-unique i p) n) 131 | SlGrftPl₁ (box c δ ε) δ₁ ε₁ p n = trans-lemma SlCn SlPl (assoc c δ δ₁) _ (inr (p₀ , IH)) 132 | 133 | where open Local c δ ε δ₁ ε₁ 134 | 135 | p₀ = ρ-fst δ p 136 | p₁ = ρ-snd δ p 137 | 138 | lemma : ε₁ p == ε₁' p₀ p₁ [ SlCn' ↓ pair= ADMIT ADMIT ] 139 | lemma = ADMIT 140 | 141 | IH : SlPl (SlGrft (ε p₀) (δ₁' p₀) (ε₁' p₀)) 142 | IH = SlGrftPl₁ (ε p₀) (δ₁' p₀) (ε₁' p₀) p₁ ADMIT 143 | -- right, well, the last guy is just "n" but the 144 | -- type has to be fixed up... 145 | 146 | SlSplitPl : {i : Idx} {c : γ i} (w : SlCn c) 147 | (δ : (p : ρ c) → (γ (τ p))) 148 | (ε : (p : ρ c) → SlCn (δ p)) → 149 | (n : SlPl (SlGrft w δ ε)) → SlPl w ⊔ Σ (ρ c) (λ p → SlPl (ε p)) 150 | SlSplitPl (dot i) δ₁ ε₁ n = inr (ηp i , <– (trans-eqv SlCn' SlPl (pair= ηp-compat (unit-r δ₁)) (ε₁ (ηp i))) n) 151 | SlSplitPl (box c δ ε) δ₁ ε₁ n with <– (trans-eqv SlCn SlPl (assoc c δ δ₁) _) n 152 | SlSplitPl (box c δ ε) δ₁ ε₁ n | inl unit = inl (inl unit) 153 | SlSplitPl (box c δ ε) δ₁ ε₁ n | inr (p , n') with let open Local c δ ε δ₁ ε₁ in SlSplitPl (ε p) (δ₁' p) (ε₁' p) n' 154 | SlSplitPl (box c δ ε) δ₁ ε₁ n | inr (p , n') | (inl n₀) = inl (inr (p , n₀)) 155 | SlSplitPl (box c δ ε) δ₁ ε₁ n | inr (p , n') | (inr (q , n₀)) = inr (μp δ p q , <– (trans-eqv SlCn' SlPl (pair= (μp-compat p q) (from-transp γ (μp-compat p q) idp)) (ε₁ (μp δ p q))) n₀) 156 | where open Local c δ ε δ₁ ε₁ 157 | 158 | open Monad 159 | 160 | η-sl : (M : Monad) (b : SlIdx M) → SlCn' M b 161 | η-sl M (i , c) = transport (SlCn M) (unit-l M c) (box c (λ p → η M (τ M p)) (λ p → dot (τ M p))) 162 | 163 | μ-sl : (M : Monad) {b : SlIdx M} (w : SlCn' M b) (κ : (p : SlPl M w) → SlCn' M (SlTy M w p)) → SlCn' M b 164 | μ-sl M (dot i) κ = dot i 165 | μ-sl M (box c δ ε) κ = SlGrft M (κ (inl unit)) δ (λ p → μ-sl M (ε p) (λ q → κ (inr (p , q)))) 166 | 167 | μ-pl : (M : Monad) {b : SlIdx M} (w : SlCn' M b) (κ : (p : SlPl M w) → SlCn' M (SlTy M w p)) → 168 | Σ (SlPl M w) (SlPl M ∘ κ) → SlPl M (μ-sl M w κ) 169 | μ-pl M (dot i) κ (() , n₁) 170 | μ-pl M (box c δ ε) κ (inl unit , n₁) = SlGrftPl₀ M (κ (inl unit)) δ (λ p → μ-sl M (ε p) (λ q → κ (inr (p , q)))) n₁ 171 | μ-pl M (box c δ ε) κ (inr (p , n₀) , n₁) = SlGrftPl₁ M (κ (inl unit)) δ (λ p → μ-sl M (ε p) (λ q → κ (inr (p , q)))) p IH 172 | 173 | where κ' : (n : SlPl M (ε p)) → SlCn' M (SlTy M (ε p) n) 174 | κ' n = κ (inr (p , n)) 175 | 176 | IH : SlPl M (μ-sl M (ε p) κ') 177 | IH = μ-pl M (ε p) κ' (n₀ , n₁) 178 | 179 | μ-pl-inv : (M : Monad) {b : SlIdx M} (w : SlCn' M b) (κ : (p : SlPl M w) → SlCn' M (SlTy M w p)) → 180 | SlPl M (μ-sl M w κ) → Σ (SlPl M w) (SlPl M ∘ κ) 181 | μ-pl-inv M (dot i) κ () 182 | μ-pl-inv M (box c δ ε) κ n with SlSplitPl M (κ (inl unit)) δ (λ p → μ-sl M (ε p) (λ q → κ (inr (p , q)))) n 183 | μ-pl-inv M (box c δ ε) κ n | inl n₁ = inl unit , n₁ 184 | μ-pl-inv M (box c δ ε) κ n | inr (p , n₁) = inr (p , fst IH) , snd IH 185 | 186 | where IH : Σ (SlPl M (ε p)) (λ n' → SlPl M (κ (inr (p , n')))) 187 | IH = μ-pl-inv M (ε p) (λ n' → κ (inr (p , n'))) n₁ 188 | 189 | Sl : Monad → Monad 190 | Idx (Sl M) = SlIdx M 191 | γ (Sl M) = SlCn' M 192 | ρ (Sl M) w = SlPl M w 193 | τ (Sl M) n = SlTy M _ n 194 | η (Sl M) = η-sl M 195 | μ (Sl M) = μ-sl M 196 | ηp-eqv (Sl M) = ADMIT 197 | μp-eqv (Sl M) κ = μ-pl M _ κ , ADMIT 198 | ηp-compat (Sl M) = ADMIT 199 | μp-compat (Sl M) = ADMIT 200 | unit-l (Sl M) = ADMIT 201 | unit-r (Sl M) = ADMIT 202 | assoc (Sl M) = ADMIT 203 | --------------------------------------------------------------------------------