diff --git a/docs/Cubical.Categories.Adjoint.html b/docs/Cubical.Categories.Adjoint.html index 2c878d2..6007114 100644 --- a/docs/Cubical.Categories.Adjoint.html +++ b/docs/Cubical.Categories.Adjoint.html @@ -1,25 +1,25 @@ -Cubical.Categories.Adjoint
{-# OPTIONS --allow-unsolved-metas #-}
+Cubical.Categories.Adjoint
{-# OPTIONS --safe #-}
 
-module Cubical.Categories.Adjoint where
+module Cubical.Categories.Adjoint where
 
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
 
-open import Cubical.Data.Sigma
-open import Cubical.Categories.Category
-open import Cubical.Categories.Functor
-open import Cubical.Categories.Instances.Functors
-open import Cubical.Categories.NaturalTransformation
-open import Cubical.Foundations.Isomorphism
-open import Cubical.Foundations.Univalence
+open import Cubical.Data.Sigma
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Instances.Functors
+open import Cubical.Categories.NaturalTransformation
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
 
-open Functor
+open Functor
 
-open Iso
-open Category
+open Iso
+open Category
 
-{-
+{-
 ==============================================
                   Overview
 ==============================================
@@ -30,11 +30,11 @@
 equivalence.
 -}
 
-private
-  variable
-    ℓC ℓC' ℓD ℓD' : Level
+private
+  variable
+    ℓC ℓC' ℓD ℓD' : Level
 
-{-
+{-
 ==============================================
              Adjoint definitions
 ==============================================
@@ -45,195 +45,195 @@
 definition.
 -}
 
-module UnitCounit {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) (G : Functor D C) where
-  record TriangleIdentities
-    (η : 𝟙⟨ C ⟩ ⇒ (funcComp G F))
-    (ε : (funcComp F G) ⇒ 𝟙⟨ D ⟩)
-    : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
-    where
-    field
-      Δ₁ : ∀ c → F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε ⟦ F ⟅ c ⟆ ⟧ ≡ D .id
-      Δ₂ : ∀ d → η ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫ ≡ C .id
-
-  -- Adjoint def 1: unit-counit
-  record _⊣_ : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
-    field
-      -- unit
-      η : 𝟙⟨ C ⟩ ⇒ (funcComp G F)
-      -- counit
-      ε : (funcComp F G) ⇒ 𝟙⟨ D ⟩
-      triangleIdentities : TriangleIdentities η ε
-    open TriangleIdentities triangleIdentities public
-
-
-private
-  variable
-    C : Category ℓC ℓC'
-    D : Category ℓC ℓC'
-
-
-module _ {F : Functor C D} {G : Functor D C} where
-  open UnitCounit
-  open _⊣_
-  open NatTrans
-  open TriangleIdentities
-  opositeAdjunction : (F ⊣ G) → ((G ^opF) ⊣ (F ^opF))
-  N-ob (η (opositeAdjunction x)) = N-ob (ε x)
-  N-hom (η (opositeAdjunction x)) f = sym (N-hom (ε x) f)
-  N-ob (ε (opositeAdjunction x)) = N-ob (η x)
-  N-hom (ε (opositeAdjunction x)) f = sym (N-hom (η x) f)
-  Δ₁ (triangleIdentities (opositeAdjunction x)) =
-    Δ₂ (triangleIdentities x)
-  Δ₂ (triangleIdentities (opositeAdjunction x)) =
-   Δ₁ (triangleIdentities x)
-
-  Iso⊣^opF : Iso (F ⊣ G) ((G ^opF) ⊣ (F ^opF))
-  fun Iso⊣^opF = opositeAdjunction
-  inv Iso⊣^opF = _
-  rightInv Iso⊣^opF _ = refl
-  leftInv Iso⊣^opF _ = refl
-
-private
-  variable
-    F F' : Functor C D
-    G G' : Functor D C
-
-
-module AdjointUniqeUpToNatIso where
- open UnitCounit
- module Left
-          (F⊣G  : _⊣_ {D = D} F G)
-          (F'⊣G : F' ⊣ G) where
-  open NatTrans
-
-  private
-    variable
-      H H' : Functor C D
-
-  _D⋆_ = seq' D
-
-  m : (H⊣G : H ⊣ G) (H'⊣G : H' ⊣ G) →
-        ∀ {x} → D [ H ⟅ x ⟆ , H' ⟅ x ⟆ ]
-  m {H = H} H⊣G H'⊣G =
-    H ⟪ (H'⊣G .η) ⟦ _ ⟧ ⟫ ⋆⟨ D ⟩ (H⊣G .ε) ⟦ _ ⟧ where open _⊣_
-
-  private
-   s : (H⊣G : H ⊣ G) (H'⊣G : H' ⊣ G) → ∀ {x} →
-           seq' D (m H'⊣G H⊣G {x}) (m H⊣G H'⊣G {x})
-              ≡ D .id
-   s {H = H} {H' = H'} H⊣G H'⊣G = by-N-homs ∙ by-Δs
-     where
-      open _⊣_ H⊣G  using (η ; Δ₂)
-      open _⊣_ H'⊣G using (ε ; Δ₁)
-      by-N-homs =
-        AssocCong₂⋆R {C = D} _
-        (AssocCong₂⋆L {C = D} (sym (N-hom ε _)) _)
-          ∙ cong₂ _D⋆_
-               (sym (F-seq H' _ _)
-                ∙∙ cong (H' ⟪_⟫) ((sym (N-hom η  _)))
-                ∙∙ F-seq H' _ _)
-               (sym (N-hom ε _))
-
-      by-Δs =
-        ⋆Assoc D _ _ _
-        ∙∙ cong (H' ⟪ _ ⟫ D⋆_)
-             (sym (⋆Assoc D _ _ _)
-             ∙ cong (_D⋆ ε ⟦ _ ⟧)
-                 (  sym (F-seq H' _ _)
-                 ∙∙ cong (H' ⟪_⟫) (Δ₂ (H' ⟅ _ ⟆))
-                 ∙∙ F-id H')
-             ∙ ⋆IdL D _)
-        ∙∙ Δ₁ _
-
-  open NatIso
-  open isIso
-
-  F≅ᶜF' : F ≅ᶜ F'
-  N-ob (trans F≅ᶜF') _ = _
-  N-hom (trans F≅ᶜF') _ =
-       sym (⋆Assoc D _ _ _)
-    ∙∙ cong (_D⋆ (F⊣G .ε) ⟦ _ ⟧)
-         (sym (F-seq F _ _)
-         ∙∙ cong (F ⟪_⟫) (N-hom (F'⊣G .η) _)
-         ∙∙ (F-seq F _ _))
-    ∙∙ AssocCong₂⋆R {C = D} _ (N-hom (F⊣G .ε) _)
-   where open _⊣_
-  inv (nIso F≅ᶜF' _) = _
-  sec (nIso F≅ᶜF' _) = s F⊣G F'⊣G
-  ret (nIso F≅ᶜF' _) = s F'⊣G F⊣G
-
-  F≡F' : isUnivalent D → F ≡ F'
-  F≡F' univD =
-   isUnivalent.CatIsoToPath
-    (isUnivalentFUNCTOR _ _ univD)
-     (NatIso→FUNCTORIso _ _ F≅ᶜF')
-
- module Right (F⊣G  : F UnitCounit.⊣ G)
-              (F⊣G' : F UnitCounit.⊣ G') where
-
-  G≅ᶜG' : G ≅ᶜ G'
-  G≅ᶜG' = Iso.inv congNatIso^opFiso
-    (Left.F≅ᶜF' (opositeAdjunction F⊣G')
-                (opositeAdjunction F⊣G))
-
-  open NatIso
-
-  G≡G' : isUnivalent _ → G ≡ G'
-  G≡G' univC =
-   isUnivalent.CatIsoToPath
-    (isUnivalentFUNCTOR _ _ univC)
-     (NatIso→FUNCTORIso _ _ G≅ᶜG')
-
-module NaturalBijection where
-  -- Adjoint def 2: natural bijection
-  record _⊣_ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) (G : Functor D C) : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
-    field
-      adjIso : ∀ {c d} → Iso (D [ F ⟅ c ⟆ , d ]) (C [ c , G ⟅ d ⟆ ])
-
-    infix 40 _♭
-    infix 40 _♯
-    _♭ : ∀ {c d} → (D [ F ⟅ c ⟆ , d ]) → (C [ c , G ⟅ d ⟆ ])
-    (_♭) {_} {_} = adjIso .fun
-
-    _♯ : ∀ {c d} → (C [ c , G ⟅ d ⟆ ]) → (D [ F ⟅ c ⟆ , d ])
-    (_♯) {_} {_} = adjIso .inv
-
-    field
-      adjNatInD : ∀ {c : C .ob} {d d'} (f : D [ F ⟅ c ⟆ , d ]) (k : D [ d , d' ])
-                → (f ⋆⟨ D ⟩ k) ♭ ≡ f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫
-
-      adjNatInC : ∀ {c' c d} (g : C [ c , G ⟅ d ⟆ ]) (h : C [ c' , c ])
-                → (h ⋆⟨ C ⟩ g) ♯ ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯
-
-    adjNatInD' : ∀ {c : C .ob} {d d'} (g : C [ c , G ⟅ d ⟆ ]) (k : D [ d , d' ])
-                → g ♯ ⋆⟨ D ⟩ k ≡ (g ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
-    adjNatInD' {c} {d} {d'} g k =
-      g ♯ ⋆⟨ D ⟩ k
-        ≡⟨ sym (adjIso .leftInv (g ♯ ⋆⟨ D ⟩ k)) ⟩
-      ((g ♯ ⋆⟨ D ⟩ k) ♭) ♯
-        ≡⟨ cong _♯ (adjNatInD (g ♯) k) ⟩
-      ((g ♯) ♭ ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
-        ≡⟨ cong _♯ (cong (λ g' → seq' C g' (G ⟪ k ⟫)) (adjIso .rightInv g)) ⟩
-      (g ⋆⟨ C ⟩ G ⟪ k ⟫) ♯ ∎
-
-    adjNatInC' : ∀ {c' c d} (f : D [ F ⟅ c ⟆ , d ]) (h : C [ c' , c ])
-                → h ⋆⟨ C ⟩ (f ♭) ≡ (F ⟪ h ⟫ ⋆⟨ D ⟩ f) ♭
-    adjNatInC' {c'} {c} {d} f h =
-      h ⋆⟨ C ⟩ (f ♭)
-        ≡⟨ sym (adjIso .rightInv (h ⋆⟨ C ⟩ (f ♭))) ⟩
-      ((h ⋆⟨ C ⟩ (f ♭)) ♯) ♭
-        ≡⟨ cong _♭ (adjNatInC (f ♭) h) ⟩
-      ((F ⟪ h ⟫ ⋆⟨ D ⟩ (f ♭) ♯) ♭)
-        ≡⟨ cong _♭ (cong (λ f' → seq' D (F ⟪ h ⟫) f') (adjIso .leftInv f)) ⟩
-      (F ⟪ h ⟫ ⋆⟨ D ⟩ f) ♭ ∎
-
-  isLeftAdjoint : {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) → Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
-  isLeftAdjoint {C = C}{D} F = Σ[ G ∈ Functor D C ] F ⊣ G
-
-  isRightAdjoint : {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (G : Functor D C) → Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
-  isRightAdjoint {C = C}{D} G = Σ[ F ∈ Functor C D ] F ⊣ G
-
-{-
+module UnitCounit {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) (G : Functor D C) where
+  record TriangleIdentities
+    (η : 𝟙⟨ C ⟩ ⇒ (funcComp G F))
+    (ε : (funcComp F G) ⇒ 𝟙⟨ D ⟩)
+    : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
+    where
+    field
+      Δ₁ : ∀ c → F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε ⟦ F ⟅ c ⟆ ⟧ ≡ D .id
+      Δ₂ : ∀ d → η ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫ ≡ C .id
+
+  -- Adjoint def 1: unit-counit
+  record _⊣_ : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
+    field
+      -- unit
+      η : 𝟙⟨ C ⟩ ⇒ (funcComp G F)
+      -- counit
+      ε : (funcComp F G) ⇒ 𝟙⟨ D ⟩
+      triangleIdentities : TriangleIdentities η ε
+    open TriangleIdentities triangleIdentities public
+
+
+private
+  variable
+    C : Category ℓC ℓC'
+    D : Category ℓC ℓC'
+
+
+module _ {F : Functor C D} {G : Functor D C} where
+  open UnitCounit
+  open _⊣_
+  open NatTrans
+  open TriangleIdentities
+  opositeAdjunction : (F ⊣ G) → ((G ^opF) ⊣ (F ^opF))
+  N-ob (η (opositeAdjunction x)) = N-ob (ε x)
+  N-hom (η (opositeAdjunction x)) f = sym (N-hom (ε x) f)
+  N-ob (ε (opositeAdjunction x)) = N-ob (η x)
+  N-hom (ε (opositeAdjunction x)) f = sym (N-hom (η x) f)
+  Δ₁ (triangleIdentities (opositeAdjunction x)) =
+    Δ₂ (triangleIdentities x)
+  Δ₂ (triangleIdentities (opositeAdjunction x)) =
+   Δ₁ (triangleIdentities x)
+
+  Iso⊣^opF : Iso (F ⊣ G) ((G ^opF) ⊣ (F ^opF))
+  fun Iso⊣^opF = opositeAdjunction
+  inv Iso⊣^opF = _
+  rightInv Iso⊣^opF _ = refl
+  leftInv Iso⊣^opF _ = refl
+
+private
+  variable
+    F F' : Functor C D
+    G G' : Functor D C
+
+
+module AdjointUniqeUpToNatIso where
+ open UnitCounit
+ module Left
+          (F⊣G  : _⊣_ {D = D} F G)
+          (F'⊣G : F' ⊣ G) where
+  open NatTrans
+
+  private
+    variable
+      H H' : Functor C D
+
+  _D⋆_ = seq' D
+
+  m : (H⊣G : H ⊣ G) (H'⊣G : H' ⊣ G) →
+        ∀ {x} → D [ H ⟅ x ⟆ , H' ⟅ x ⟆ ]
+  m {H = H} H⊣G H'⊣G =
+    H ⟪ (H'⊣G .η) ⟦ _ ⟧ ⟫ ⋆⟨ D ⟩ (H⊣G .ε) ⟦ _ ⟧ where open _⊣_
+
+  private
+   s : (H⊣G : H ⊣ G) (H'⊣G : H' ⊣ G) → ∀ {x} →
+           seq' D (m H'⊣G H⊣G {x}) (m H⊣G H'⊣G {x})
+              ≡ D .id
+   s {H = H} {H' = H'} H⊣G H'⊣G = by-N-homs ∙ by-Δs
+     where
+      open _⊣_ H⊣G  using (η ; Δ₂)
+      open _⊣_ H'⊣G using (ε ; Δ₁)
+      by-N-homs =
+        AssocCong₂⋆R {C = D} _
+        (AssocCong₂⋆L {C = D} (sym (N-hom ε _)) _)
+          ∙ cong₂ _D⋆_
+               (sym (F-seq H' _ _)
+                ∙∙ cong (H' ⟪_⟫) ((sym (N-hom η  _)))
+                ∙∙ F-seq H' _ _)
+               (sym (N-hom ε _))
+
+      by-Δs =
+        ⋆Assoc D _ _ _
+        ∙∙ cong (H' ⟪ _ ⟫ D⋆_)
+             (sym (⋆Assoc D _ _ _)
+             ∙ cong (_D⋆ ε ⟦ _ ⟧)
+                 (  sym (F-seq H' _ _)
+                 ∙∙ cong (H' ⟪_⟫) (Δ₂ (H' ⟅ _ ⟆))
+                 ∙∙ F-id H')
+             ∙ ⋆IdL D _)
+        ∙∙ Δ₁ _
+
+  open NatIso
+  open isIso
+
+  F≅ᶜF' : F ≅ᶜ F'
+  N-ob (trans F≅ᶜF') _ = _
+  N-hom (trans F≅ᶜF') _ =
+       sym (⋆Assoc D _ _ _)
+    ∙∙ cong (_D⋆ (F⊣G .ε) ⟦ _ ⟧)
+         (sym (F-seq F _ _)
+         ∙∙ cong (F ⟪_⟫) (N-hom (F'⊣G .η) _)
+         ∙∙ (F-seq F _ _))
+    ∙∙ AssocCong₂⋆R {C = D} _ (N-hom (F⊣G .ε) _)
+   where open _⊣_
+  inv (nIso F≅ᶜF' _) = _
+  sec (nIso F≅ᶜF' _) = s F⊣G F'⊣G
+  ret (nIso F≅ᶜF' _) = s F'⊣G F⊣G
+
+  F≡F' : isUnivalent D → F ≡ F'
+  F≡F' univD =
+   isUnivalent.CatIsoToPath
+    (isUnivalentFUNCTOR _ _ univD)
+     (NatIso→FUNCTORIso _ _ F≅ᶜF')
+
+ module Right (F⊣G  : F UnitCounit.⊣ G)
+              (F⊣G' : F UnitCounit.⊣ G') where
+
+  G≅ᶜG' : G ≅ᶜ G'
+  G≅ᶜG' = Iso.inv congNatIso^opFiso
+    (Left.F≅ᶜF' (opositeAdjunction F⊣G')
+                (opositeAdjunction F⊣G))
+
+  open NatIso
+
+  G≡G' : isUnivalent _ → G ≡ G'
+  G≡G' univC =
+   isUnivalent.CatIsoToPath
+    (isUnivalentFUNCTOR _ _ univC)
+     (NatIso→FUNCTORIso _ _ G≅ᶜG')
+
+module NaturalBijection where
+  -- Adjoint def 2: natural bijection
+  record _⊣_ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) (G : Functor D C) : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
+    field
+      adjIso : ∀ {c d} → Iso (D [ F ⟅ c ⟆ , d ]) (C [ c , G ⟅ d ⟆ ])
+
+    infix 40 _♭
+    infix 40 _♯
+    _♭ : ∀ {c d} → (D [ F ⟅ c ⟆ , d ]) → (C [ c , G ⟅ d ⟆ ])
+    (_♭) {_} {_} = adjIso .fun
+
+    _♯ : ∀ {c d} → (C [ c , G ⟅ d ⟆ ]) → (D [ F ⟅ c ⟆ , d ])
+    (_♯) {_} {_} = adjIso .inv
+
+    field
+      adjNatInD : ∀ {c : C .ob} {d d'} (f : D [ F ⟅ c ⟆ , d ]) (k : D [ d , d' ])
+                → (f ⋆⟨ D ⟩ k) ♭ ≡ f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫
+
+      adjNatInC : ∀ {c' c d} (g : C [ c , G ⟅ d ⟆ ]) (h : C [ c' , c ])
+                → (h ⋆⟨ C ⟩ g) ♯ ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯
+
+    adjNatInD' : ∀ {c : C .ob} {d d'} (g : C [ c , G ⟅ d ⟆ ]) (k : D [ d , d' ])
+                → g ♯ ⋆⟨ D ⟩ k ≡ (g ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
+    adjNatInD' {c} {d} {d'} g k =
+      g ♯ ⋆⟨ D ⟩ k
+        ≡⟨ sym (adjIso .leftInv (g ♯ ⋆⟨ D ⟩ k)) ⟩
+      ((g ♯ ⋆⟨ D ⟩ k) ♭) ♯
+        ≡⟨ cong _♯ (adjNatInD (g ♯) k) ⟩
+      ((g ♯) ♭ ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
+        ≡⟨ cong _♯ (cong (λ g' → seq' C g' (G ⟪ k ⟫)) (adjIso .rightInv g)) ⟩
+      (g ⋆⟨ C ⟩ G ⟪ k ⟫) ♯ ∎
+
+    adjNatInC' : ∀ {c' c d} (f : D [ F ⟅ c ⟆ , d ]) (h : C [ c' , c ])
+                → h ⋆⟨ C ⟩ (f ♭) ≡ (F ⟪ h ⟫ ⋆⟨ D ⟩ f) ♭
+    adjNatInC' {c'} {c} {d} f h =
+      h ⋆⟨ C ⟩ (f ♭)
+        ≡⟨ sym (adjIso .rightInv (h ⋆⟨ C ⟩ (f ♭))) ⟩
+      ((h ⋆⟨ C ⟩ (f ♭)) ♯) ♭
+        ≡⟨ cong _♭ (adjNatInC (f ♭) h) ⟩
+      ((F ⟪ h ⟫ ⋆⟨ D ⟩ (f ♭) ♯) ♭)
+        ≡⟨ cong _♭ (cong (λ f' → seq' D (F ⟪ h ⟫) f') (adjIso .leftInv f)) ⟩
+      (F ⟪ h ⟫ ⋆⟨ D ⟩ f) ♭ ∎
+
+  isLeftAdjoint : {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) → Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
+  isLeftAdjoint {C = C}{D} F = Σ[ G ∈ Functor D C ] F ⊣ G
+
+  isRightAdjoint : {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (G : Functor D C) → Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
+  isRightAdjoint {C = C}{D} G = Σ[ F ∈ Functor C D ] F ⊣ G
+
+{-
 ==============================================
             Proofs of equivalence
 ==============================================
@@ -245,160 +245,160 @@
 The second unnamed module does the reverse.
 -}
 
-module _ (F : Functor C D) (G : Functor D C) where
-  open UnitCounit
-  open NaturalBijection renaming (_⊣_ to _⊣²_)
-  module _ (adj : F ⊣² G) where
-    open _⊣²_ adj
-    open _⊣_
-
-    -- Naturality condition implies that a commutative square in C
-    -- appears iff the transpose in D is commutative as well
-    -- Used in adj'→adj
-    adjNat' : ∀ {c c' d d'} {f : D [ F ⟅ c ⟆ , d ]} {k : D [ d , d' ]}
-            → {h : C [ c , c' ]} {g : C [ c' , G ⟅ d' ⟆ ]}
-            -- commutativity of squares is iff
-            → ((f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) → (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g))
-            × ((f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g) → (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯))
-    adjNat' {c} {c'} {d} {d'} {f} {k} {h} {g} = D→C , C→D
-      where
-        D→C : (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) → (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g)
-        D→C eq = f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫
-              ≡⟨ sym (adjNatInD _ _) ⟩
-                ((f ⋆⟨ D ⟩ k) ♭)
-              ≡⟨ cong _♭ eq ⟩
-                (F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) ♭
-              ≡⟨ sym (cong _♭ (adjNatInC _ _)) ⟩
-                (h ⋆⟨ C ⟩ g) ♯ ♭
-              ≡⟨ adjIso .rightInv _ ⟩
-                h ⋆⟨ C ⟩ g
-              ∎
-        C→D : (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g) → (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯)
-        C→D eq = f ⋆⟨ D ⟩ k
-              ≡⟨ sym (adjIso .leftInv _) ⟩
-                (f ⋆⟨ D ⟩ k) ♭ ♯
-              ≡⟨ cong _♯ (adjNatInD _ _) ⟩
-                (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
-              ≡⟨ cong _♯ eq ⟩
-                (h ⋆⟨ C ⟩ g) ♯
-              ≡⟨ adjNatInC _ _ ⟩
-                F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯
-              ∎
-
-    open NatTrans
-
-    -- note : had to make this record syntax because termination checker was complaining
-    -- due to referencing η and ε from the definitions of Δs
-    adj'→adj : F ⊣ G
-    adj'→adj = record
-      { η = η'
-      ; ε = ε'
-      ; triangleIdentities = record
-        {Δ₁ = Δ₁'
-        ; Δ₂ = Δ₂' }}
-
-      where
-        -- ETA
-
-        -- trivial commutative diagram between identities in D
-        commInD : ∀ {x y} (f : C [ x , y ]) → D .id ⋆⟨ D ⟩ F ⟪ f ⟫ ≡ F ⟪ f ⟫ ⋆⟨ D ⟩ D .id
-        commInD f = (D .⋆IdL _) ∙ sym (D .⋆IdR _)
-
-        sharpen1 : ∀ {x y} (f : C [ x , y ]) → F ⟪ f ⟫ ⋆⟨ D ⟩ D .id ≡ F ⟪ f ⟫ ⋆⟨ D ⟩ D .id ♭ ♯
-        sharpen1 f = cong (λ v → F ⟪ f ⟫ ⋆⟨ D ⟩ v) (sym (adjIso .leftInv _))
-
-        η' : 𝟙⟨ C ⟩ ⇒ G ∘F F
-        η' .N-ob x = D .id ♭
-        η' .N-hom f = sym (fst (adjNat') (commInD f ∙ sharpen1 f))
-
-        -- EPSILON
-
-        -- trivial commutative diagram between identities in C
-        commInC : ∀ {x y} (g : D [ x , y ]) → C .id ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ G ⟪ g ⟫ ⋆⟨ C ⟩ C .id
-        commInC g = (C .⋆IdL _) ∙ sym (C .⋆IdR _)
-
-        sharpen2 : ∀ {x y} (g : D [ x , y ]) → C .id ♯ ♭ ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ C .id ⋆⟨ C ⟩ G ⟪ g ⟫
-        sharpen2 g = cong (λ v → v ⋆⟨ C ⟩ G ⟪ g ⟫) (adjIso .rightInv _)
-
-        ε' : F ∘F G ⇒ 𝟙⟨ D ⟩
-        ε' .N-ob x  = C .id ♯
-        ε' .N-hom g = sym (snd adjNat' (sharpen2 g ∙ commInC g))
-
-        -- DELTA 1
-
-        Δ₁' : ∀ c → F ⟪ η' ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε' ⟦ F ⟅ c ⟆ ⟧ ≡ D .id
-        Δ₁' c =
-            F ⟪ η' ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε' ⟦ F ⟅ c ⟆ ⟧
-          ≡⟨ sym (snd adjNat' (cong (λ v → (η' ⟦ c ⟧) ⋆⟨ C ⟩ v) (G .F-id))) ⟩
-            D .id ⋆⟨ D ⟩ D .id
-          ≡⟨ D .⋆IdL _ ⟩
-            D .id
-          ∎
-
-        -- DELTA 2
-
-        Δ₂' : ∀ d → η' ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε' ⟦ d ⟧ ⟫ ≡ C .id
-        Δ₂' d =
-            (η' ⟦ G ⟅ d ⟆ ⟧) ⋆⟨ C ⟩ (G ⟪ ε' ⟦ d ⟧ ⟫)
-          ≡⟨ fst adjNat' (cong (λ v → v ⋆⟨ D ⟩ (ε' ⟦ d ⟧)) (sym (F .F-id))) ⟩
-            C .id ⋆⟨ C ⟩ C .id
-          ≡⟨ C .⋆IdL _ ⟩
-            C .id
-          ∎
-
-
-  module _ (adj : F ⊣ G) where
-    open _⊣_ adj
-    open _⊣²_
-    open NatTrans
-
-    adj→adj' : F ⊣² G
-    -- ∀ {c d} → Iso (D [ F ⟅ c ⟆ , d ]) (C [ c , G ⟅ d ⟆ ])
-    -- takes f to Gf precomposed with the unit
-    adj→adj' .adjIso {c = c} .fun f = η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ f ⟫
-    -- takes g to Fg postcomposed with the counit
-    adj→adj' .adjIso {d = d} .inv g = F ⟪ g ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
-    -- invertibility follows from the triangle identities
-    adj→adj' .adjIso {c = c} {d} .rightInv g
-      = η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧ ⟫
-      ≡⟨ cong (λ v → η ⟦ c ⟧ ⋆⟨ C ⟩ v) (G .F-seq _ _) ⟩
-        η ⟦ c ⟧ ⋆⟨ C ⟩ (G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫)
-      ≡⟨ sym (C .⋆Assoc _ _ _) ⟩
-        η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫
-      -- apply naturality
-      ≡⟨ rCatWhisker {C = C} _ _ _ natu ⟩
-        (g ⋆⟨ C ⟩ η ⟦ G ⟅ d ⟆ ⟧) ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫
-      ≡⟨ C .⋆Assoc _ _ _ ⟩
-        g ⋆⟨ C ⟩ (η ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫)
-      ≡⟨ lCatWhisker {C = C} _ _ _ (Δ₂ d) ⟩
-        g ⋆⟨ C ⟩ C .id
-      ≡⟨ C .⋆IdR _ ⟩
-        g
-      ∎
-      where
-        natu : η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ≡ g ⋆⟨ C ⟩ η ⟦ G ⟅ d ⟆ ⟧
-        natu = sym (η .N-hom _)
-    adj→adj' .adjIso {c = c} {d} .leftInv f
-      = F ⟪ η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
-      ≡⟨ cong (λ v → v ⋆⟨ D ⟩ ε ⟦ d ⟧) (F .F-seq _ _) ⟩
-        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
-      ≡⟨ D .⋆Assoc _ _ _ ⟩
-        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ (F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧)
-      -- apply naturality
-      ≡⟨ lCatWhisker {C = D} _ _ _ natu ⟩
-        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ (ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f)
-      ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
-        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f
-      -- apply triangle identity
-      ≡⟨ rCatWhisker {C = D} _ _ _ (Δ₁ c) ⟩
-        D .id ⋆⟨ D ⟩ f
-      ≡⟨ D .⋆IdL _ ⟩
-        f
-      ∎
-      where
-        natu : F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧ ≡ ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f
-        natu = ε .N-hom _
-    -- follows directly from functoriality
-    adj→adj' .adjNatInD {c = c} f k = cong (λ v → η ⟦ c ⟧ ⋆⟨ C ⟩ v) (G .F-seq _ _) ∙ (sym (C .⋆Assoc _ _ _))
-    adj→adj' .adjNatInC {d = d} g h = cong (λ v → v ⋆⟨ D ⟩ ε ⟦ d ⟧) (F .F-seq _ _) ∙ D .⋆Assoc _ _ _
+module _ (F : Functor C D) (G : Functor D C) where
+  open UnitCounit
+  open NaturalBijection renaming (_⊣_ to _⊣²_)
+  module _ (adj : F ⊣² G) where
+    open _⊣²_ adj
+    open _⊣_
+
+    -- Naturality condition implies that a commutative square in C
+    -- appears iff the transpose in D is commutative as well
+    -- Used in adj'→adj
+    adjNat' : ∀ {c c' d d'} {f : D [ F ⟅ c ⟆ , d ]} {k : D [ d , d' ]}
+            → {h : C [ c , c' ]} {g : C [ c' , G ⟅ d' ⟆ ]}
+            -- commutativity of squares is iff
+            → ((f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) → (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g))
+            × ((f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g) → (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯))
+    adjNat' {c} {c'} {d} {d'} {f} {k} {h} {g} = D→C , C→D
+      where
+        D→C : (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) → (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g)
+        D→C eq = f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫
+              ≡⟨ sym (adjNatInD _ _) ⟩
+                ((f ⋆⟨ D ⟩ k) ♭)
+              ≡⟨ cong _♭ eq ⟩
+                (F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯) ♭
+              ≡⟨ sym (cong _♭ (adjNatInC _ _)) ⟩
+                (h ⋆⟨ C ⟩ g) ♯ ♭
+              ≡⟨ adjIso .rightInv _ ⟩
+                h ⋆⟨ C ⟩ g
+              ∎
+        C→D : (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫ ≡ h ⋆⟨ C ⟩ g) → (f ⋆⟨ D ⟩ k ≡ F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯)
+        C→D eq = f ⋆⟨ D ⟩ k
+              ≡⟨ sym (adjIso .leftInv _) ⟩
+                (f ⋆⟨ D ⟩ k) ♭ ♯
+              ≡⟨ cong _♯ (adjNatInD _ _) ⟩
+                (f ♭ ⋆⟨ C ⟩ G ⟪ k ⟫) ♯
+              ≡⟨ cong _♯ eq ⟩
+                (h ⋆⟨ C ⟩ g) ♯
+              ≡⟨ adjNatInC _ _ ⟩
+                F ⟪ h ⟫ ⋆⟨ D ⟩ g ♯
+              ∎
+
+    open NatTrans
+
+    -- note : had to make this record syntax because termination checker was complaining
+    -- due to referencing η and ε from the definitions of Δs
+    adj'→adj : F ⊣ G
+    adj'→adj = record
+      { η = η'
+      ; ε = ε'
+      ; triangleIdentities = record
+        {Δ₁ = Δ₁'
+        ; Δ₂ = Δ₂' }}
+
+      where
+        -- ETA
+
+        -- trivial commutative diagram between identities in D
+        commInD : ∀ {x y} (f : C [ x , y ]) → D .id ⋆⟨ D ⟩ F ⟪ f ⟫ ≡ F ⟪ f ⟫ ⋆⟨ D ⟩ D .id
+        commInD f = (D .⋆IdL _) ∙ sym (D .⋆IdR _)
+
+        sharpen1 : ∀ {x y} (f : C [ x , y ]) → F ⟪ f ⟫ ⋆⟨ D ⟩ D .id ≡ F ⟪ f ⟫ ⋆⟨ D ⟩ D .id ♭ ♯
+        sharpen1 f = cong (λ v → F ⟪ f ⟫ ⋆⟨ D ⟩ v) (sym (adjIso .leftInv _))
+
+        η' : 𝟙⟨ C ⟩ ⇒ G ∘F F
+        η' .N-ob x = D .id ♭
+        η' .N-hom f = sym (fst (adjNat') (commInD f ∙ sharpen1 f))
+
+        -- EPSILON
+
+        -- trivial commutative diagram between identities in C
+        commInC : ∀ {x y} (g : D [ x , y ]) → C .id ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ G ⟪ g ⟫ ⋆⟨ C ⟩ C .id
+        commInC g = (C .⋆IdL _) ∙ sym (C .⋆IdR _)
+
+        sharpen2 : ∀ {x y} (g : D [ x , y ]) → C .id ♯ ♭ ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ C .id ⋆⟨ C ⟩ G ⟪ g ⟫
+        sharpen2 g = cong (λ v → v ⋆⟨ C ⟩ G ⟪ g ⟫) (adjIso .rightInv _)
+
+        ε' : F ∘F G ⇒ 𝟙⟨ D ⟩
+        ε' .N-ob x  = C .id ♯
+        ε' .N-hom g = sym (snd adjNat' (sharpen2 g ∙ commInC g))
+
+        -- DELTA 1
+
+        Δ₁' : ∀ c → F ⟪ η' ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε' ⟦ F ⟅ c ⟆ ⟧ ≡ D .id
+        Δ₁' c =
+            F ⟪ η' ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε' ⟦ F ⟅ c ⟆ ⟧
+          ≡⟨ sym (snd adjNat' (cong (λ v → (η' ⟦ c ⟧) ⋆⟨ C ⟩ v) (G .F-id))) ⟩
+            D .id ⋆⟨ D ⟩ D .id
+          ≡⟨ D .⋆IdL _ ⟩
+            D .id
+          ∎
+
+        -- DELTA 2
+
+        Δ₂' : ∀ d → η' ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε' ⟦ d ⟧ ⟫ ≡ C .id
+        Δ₂' d =
+            (η' ⟦ G ⟅ d ⟆ ⟧) ⋆⟨ C ⟩ (G ⟪ ε' ⟦ d ⟧ ⟫)
+          ≡⟨ fst adjNat' (cong (λ v → v ⋆⟨ D ⟩ (ε' ⟦ d ⟧)) (sym (F .F-id))) ⟩
+            C .id ⋆⟨ C ⟩ C .id
+          ≡⟨ C .⋆IdL _ ⟩
+            C .id
+          ∎
+
+
+  module _ (adj : F ⊣ G) where
+    open _⊣_ adj
+    open _⊣²_
+    open NatTrans
+
+    adj→adj' : F ⊣² G
+    -- ∀ {c d} → Iso (D [ F ⟅ c ⟆ , d ]) (C [ c , G ⟅ d ⟆ ])
+    -- takes f to Gf precomposed with the unit
+    adj→adj' .adjIso {c = c} .fun f = η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ f ⟫
+    -- takes g to Fg postcomposed with the counit
+    adj→adj' .adjIso {d = d} .inv g = F ⟪ g ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
+    -- invertibility follows from the triangle identities
+    adj→adj' .adjIso {c = c} {d} .rightInv g
+      = η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧ ⟫
+      ≡⟨ cong (λ v → η ⟦ c ⟧ ⋆⟨ C ⟩ v) (G .F-seq _ _) ⟩
+        η ⟦ c ⟧ ⋆⟨ C ⟩ (G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫)
+      ≡⟨ sym (C .⋆Assoc _ _ _) ⟩
+        η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫
+      -- apply naturality
+      ≡⟨ rCatWhisker {C = C} _ _ _ natu ⟩
+        (g ⋆⟨ C ⟩ η ⟦ G ⟅ d ⟆ ⟧) ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫
+      ≡⟨ C .⋆Assoc _ _ _ ⟩
+        g ⋆⟨ C ⟩ (η ⟦ G ⟅ d ⟆ ⟧ ⋆⟨ C ⟩ G ⟪ ε ⟦ d ⟧ ⟫)
+      ≡⟨ lCatWhisker {C = C} _ _ _ (Δ₂ d) ⟩
+        g ⋆⟨ C ⟩ C .id
+      ≡⟨ C .⋆IdR _ ⟩
+        g
+      ∎
+      where
+        natu : η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ≡ g ⋆⟨ C ⟩ η ⟦ G ⟅ d ⟆ ⟧
+        natu = sym (η .N-hom _)
+    adj→adj' .adjIso {c = c} {d} .leftInv f
+      = F ⟪ η ⟦ c ⟧ ⋆⟨ C ⟩ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
+      ≡⟨ cong (λ v → v ⋆⟨ D ⟩ ε ⟦ d ⟧) (F .F-seq _ _) ⟩
+        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧
+      ≡⟨ D .⋆Assoc _ _ _ ⟩
+        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ (F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧)
+      -- apply naturality
+      ≡⟨ lCatWhisker {C = D} _ _ _ natu ⟩
+        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ (ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f)
+      ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
+        F ⟪ η ⟦ c ⟧ ⟫ ⋆⟨ D ⟩ ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f
+      -- apply triangle identity
+      ≡⟨ rCatWhisker {C = D} _ _ _ (Δ₁ c) ⟩
+        D .id ⋆⟨ D ⟩ f
+      ≡⟨ D .⋆IdL _ ⟩
+        f
+      ∎
+      where
+        natu : F ⟪ G ⟪ f ⟫ ⟫ ⋆⟨ D ⟩ ε ⟦ d ⟧ ≡ ε ⟦ F ⟅ c ⟆ ⟧ ⋆⟨ D ⟩ f
+        natu = ε .N-hom _
+    -- follows directly from functoriality
+    adj→adj' .adjNatInD {c = c} f k = cong (λ v → η ⟦ c ⟧ ⋆⟨ C ⟩ v) (G .F-seq _ _) ∙ (sym (C .⋆Assoc _ _ _))
+    adj→adj' .adjNatInC {d = d} g h = cong (λ v → v ⋆⟨ D ⟩ ε ⟦ d ⟧) (F .F-seq _ _) ∙ D .⋆Assoc _ _ _
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Category.Base.html b/docs/Cubical.Categories.Category.Base.html
index 1163e41..bd0d8b8 100644
--- a/docs/Cubical.Categories.Category.Base.html
+++ b/docs/Cubical.Categories.Category.Base.html
@@ -24,7 +24,7 @@
     ⋆IdR : ∀ {x y} (f : Hom[ x , y ]) → f ⋆ id ≡ f
     ⋆Assoc : ∀ {x y z w} (f : Hom[ x , y ]) (g : Hom[ y , z ]) (h : Hom[ z , w ])
            → (f ⋆ g) ⋆ h ≡ f ⋆ (g ⋆ h)
-    isSetHom : ∀ {x y} → isSet Hom[ x , y ]
+    isSetHom : ∀ {x y} → isSet Hom[ x , y ]
 
   -- composition: alternative to diagramatic order
   _∘_ : ∀ {x y z} (g : Hom[ y , z ]) (f : Hom[ x , y ]) → Hom[ x , z ]
@@ -39,119 +39,127 @@
 _[_,_] : (C : Category ℓ ℓ') → (x y : C .ob) → Type ℓ'
 _[_,_] = Hom[_,_]
 
--- Needed to define this in order to be able to make the subsequence syntax declaration
-seq' : ∀ (C : Category ℓ ℓ') {x y z} (f : C [ x , y ]) (g : C [ y , z ]) → C [ x , z ]
-seq' = _⋆_
+_End[_] : (C : Category ℓ ℓ') → (x : C .ob) → Type ℓ'
+C End[ x ] = C [ x , x ]
 
-infixl 15 seq'
-syntax seq' C f g = f ⋆⟨ C ⟩ g
-
--- composition
-comp' : ∀ (C : Category ℓ ℓ') {x y z} (g : C [ y , z ]) (f : C [ x , y ]) → C [ x , z ]
-comp' = _∘_
-
-infixr 16 comp'
-syntax comp' C g f = g ∘⟨ C ⟩ f
-
-
--- Isomorphisms and paths in categories
-
-record isIso (C : Category ℓ ℓ'){x y : C .ob}(f : C [ x , y ]) : Type ℓ' where
-  constructor isiso
-  field
-    inv : C [ y , x ]
-    sec : inv ⋆⟨ C ⟩ f ≡ C .id
-    ret : f ⋆⟨ C ⟩ inv ≡ C .id
-
-open isIso
-
-isPropIsIso : {C : Category ℓ ℓ'}{x y : C .ob}(f : C [ x , y ]) → isProp (isIso C f)
-isPropIsIso {C = C} f p q i .inv =
-    (sym (C .⋆IdL _)
-  ∙ (λ i → q .sec (~ i) ⋆⟨ C ⟩ p .inv)
-  ∙ C .⋆Assoc _ _ _
-  ∙ (λ i → q .inv ⋆⟨ C ⟩ p .ret i)
-  ∙ C .⋆IdR _) i
-isPropIsIso {C = C} f p q i .sec j =
-  isSet→SquareP (λ i j → C .isSetHom)
-    (p .sec) (q .sec) (λ i → isPropIsIso {C = C} f p q i .inv ⋆⟨ C ⟩ f) refl i j
-isPropIsIso {C = C} f p q i .ret j =
-  isSet→SquareP (λ i j → C .isSetHom)
-    (p .ret) (q .ret) (λ i → f ⋆⟨ C ⟩ isPropIsIso {C = C} f p q i .inv) refl i j
-
-CatIso : (C : Category ℓ ℓ') (x y : C .ob) → Type ℓ'
-CatIso C x y = Σ[ f ∈ C [ x , y ] ] isIso C f
-
-CatIso≡ : {C : Category ℓ ℓ'}{x y : C .ob}(f g : CatIso C x y) → f .fst ≡ g .fst → f ≡ g
-CatIso≡ f g = Σ≡Prop isPropIsIso
-
--- `constructor` of CatIso
-catiso : {C : Category ℓ ℓ'}{x y : C .ob}
-  → (mor : C [ x , y ])
-  → (inv : C [ y , x ])
-  → (sec : inv ⋆⟨ C ⟩ mor ≡ C .id)
-  → (ret : mor ⋆⟨ C ⟩ inv ≡ C .id)
-  → CatIso C x y
-catiso mor inv sec ret = mor , isiso inv sec ret
-
-
-idCatIso : {C : Category ℓ ℓ'} {x : C .ob} → CatIso C x x
-idCatIso {C = C} = C .id , isiso (C .id) (C .⋆IdL (C .id)) (C .⋆IdL (C .id))
-
-isSet-CatIso : {C : Category ℓ ℓ'} → ∀ x y → isSet (CatIso C x y)
-isSet-CatIso {C = C} x y = isOfHLevelΣ 2 (C .isSetHom) (λ f → isProp→isSet (isPropIsIso f))
-
-
-pathToIso : {C : Category ℓ ℓ'} {x y : C .ob} (p : x ≡ y) → CatIso C x y
-pathToIso {C = C} p = J (λ z _ → CatIso C _ z) idCatIso p
-
-pathToIso-refl : {C : Category ℓ ℓ'} {x : C .ob} → pathToIso {C = C} {x} refl ≡ idCatIso
-pathToIso-refl {C = C} {x} = JRefl (λ z _ → CatIso C x z) (idCatIso)
-
-
--- Univalent Categories
-record isUnivalent (C : Category ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
-  field
-    univ : (x y : C .ob) → isEquiv (pathToIso {C = C} {x = x} {y = y})
-
-  -- package up the univalence equivalence
-  univEquiv : ∀ (x y : C .ob) → (x ≡ y) ≃ (CatIso _ x y)
-  univEquiv x y = pathToIso , univ x y
-
-  -- The function extracting paths from category-theoretic isomorphisms.
-  CatIsoToPath : {x y : C .ob} (p : CatIso _ x y) → x ≡ y
-  CatIsoToPath = invEq (univEquiv _ _)
-
-  isGroupoid-ob : isGroupoid (C .ob)
-  isGroupoid-ob = isOfHLevelPath'⁻ 2 (λ _ _ → isOfHLevelRespectEquiv 2 (invEquiv (univEquiv _ _)) (isSet-CatIso _ _))
-
-
--- Opposite category
-_^op : Category ℓ ℓ' → Category ℓ ℓ'
-ob (C ^op)           = ob C
-Hom[_,_] (C ^op) x y = C [ y , x ]
-id (C ^op)           = id C
-_⋆_ (C ^op) f g      = g ⋆⟨ C ⟩ f
-⋆IdL (C ^op)         = C .⋆IdR
-⋆IdR (C ^op)         = C .⋆IdL
-⋆Assoc (C ^op) f g h = sym (C .⋆Assoc _ _ _)
-isSetHom (C ^op)     = C .isSetHom
-
-ΣPropCat : (C : Category ℓ ℓ') (P : ℙ (ob C)) → Category ℓ ℓ'
-ob (ΣPropCat C P) = Σ[ x ∈ ob C ] x ∈ P
-Hom[_,_] (ΣPropCat C P) x y = C [ fst x , fst y ]
-id (ΣPropCat C P) = id C
-_⋆_ (ΣPropCat C P) = _⋆_ C
-⋆IdL (ΣPropCat C P) = ⋆IdL C
-⋆IdR (ΣPropCat C P) = ⋆IdR C
-⋆Assoc (ΣPropCat C P) = ⋆Assoc C
-isSetHom (ΣPropCat C P) = isSetHom C
-
-isIsoΣPropCat : {C : Category ℓ ℓ'} {P : ℙ (ob C)}
-                {x y : ob C} (p : x ∈ P) (q : y ∈ P)
-                (f : C [ x , y ])
-              → isIso C f → isIso (ΣPropCat C P) {x , p} {y , q} f
-inv (isIsoΣPropCat p q f isIsoF) = isIsoF .inv
-sec (isIsoΣPropCat p q f isIsoF) = isIsoF .sec
-ret (isIsoΣPropCat p q f isIsoF) = isIsoF .ret
+
+-- Needed to define this in order to be able to make the subsequence syntax declaration
+seq' : ∀ (C : Category ℓ ℓ') {x y z} (f : C [ x , y ]) (g : C [ y , z ]) → C [ x , z ]
+seq' = _⋆_
+
+infixl 15 seq'
+syntax seq' C f g = f ⋆⟨ C ⟩ g
+
+-- composition
+comp' : ∀ (C : Category ℓ ℓ') {x y z} (g : C [ y , z ]) (f : C [ x , y ]) → C [ x , z ]
+comp' = _∘_
+
+infixr 16 comp'
+syntax comp' C g f = g ∘⟨ C ⟩ f
+
+
+-- Isomorphisms and paths in categories
+
+record isIso (C : Category ℓ ℓ'){x y : C .ob}(f : C [ x , y ]) : Type ℓ' where
+  constructor isiso
+  field
+    inv : C [ y , x ]
+    sec : inv ⋆⟨ C ⟩ f ≡ C .id
+    ret : f ⋆⟨ C ⟩ inv ≡ C .id
+
+open isIso
+
+isPropIsIso : {C : Category ℓ ℓ'}{x y : C .ob}(f : C [ x , y ]) → isProp (isIso C f)
+isPropIsIso {C = C} f p q i .inv =
+    (sym (C .⋆IdL _)
+  ∙ (λ i → q .sec (~ i) ⋆⟨ C ⟩ p .inv)
+  ∙ C .⋆Assoc _ _ _
+  ∙ (λ i → q .inv ⋆⟨ C ⟩ p .ret i)
+  ∙ C .⋆IdR _) i
+isPropIsIso {C = C} f p q i .sec j =
+  isSet→SquareP (λ i j → C .isSetHom)
+    (p .sec) (q .sec) (λ i → isPropIsIso {C = C} f p q i .inv ⋆⟨ C ⟩ f) refl i j
+isPropIsIso {C = C} f p q i .ret j =
+  isSet→SquareP (λ i j → C .isSetHom)
+    (p .ret) (q .ret) (λ i → f ⋆⟨ C ⟩ isPropIsIso {C = C} f p q i .inv) refl i j
+
+CatIso : (C : Category ℓ ℓ') (x y : C .ob) → Type ℓ'
+CatIso C x y = Σ[ f ∈ C [ x , y ] ] isIso C f
+
+CatIso≡ : {C : Category ℓ ℓ'}{x y : C .ob}(f g : CatIso C x y) → f .fst ≡ g .fst → f ≡ g
+CatIso≡ f g = Σ≡Prop isPropIsIso
+
+-- `constructor` of CatIso
+catiso : {C : Category ℓ ℓ'}{x y : C .ob}
+  → (mor : C [ x , y ])
+  → (inv : C [ y , x ])
+  → (sec : inv ⋆⟨ C ⟩ mor ≡ C .id)
+  → (ret : mor ⋆⟨ C ⟩ inv ≡ C .id)
+  → CatIso C x y
+catiso mor inv sec ret = mor , isiso inv sec ret
+
+
+idCatIso : {C : Category ℓ ℓ'} {x : C .ob} → CatIso C x x
+idCatIso {C = C} = C .id , isiso (C .id) (C .⋆IdL (C .id)) (C .⋆IdL (C .id))
+
+isSet-CatIso : {C : Category ℓ ℓ'} → ∀ x y → isSet (CatIso C x y)
+isSet-CatIso {C = C} x y = isOfHLevelΣ 2 (C .isSetHom) (λ f → isProp→isSet (isPropIsIso f))
+
+
+pathToIso : {C : Category ℓ ℓ'} {x y : C .ob} (p : x ≡ y) → CatIso C x y
+pathToIso {C = C} p = J (λ z _ → CatIso C _ z) idCatIso p
+
+pathToIso-refl : {C : Category ℓ ℓ'} {x : C .ob} → pathToIso {C = C} {x} refl ≡ idCatIso
+pathToIso-refl {C = C} {x} = JRefl (λ z _ → CatIso C x z) (idCatIso)
+
+
+-- Univalent Categories
+record isUnivalent (C : Category ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
+  field
+    univ : (x y : C .ob) → isEquiv (pathToIso {C = C} {x = x} {y = y})
+
+  -- package up the univalence equivalence
+  univEquiv : ∀ (x y : C .ob) → (x ≡ y) ≃ (CatIso _ x y)
+  univEquiv x y = pathToIso , univ x y
+
+  -- The function extracting paths from category-theoretic isomorphisms.
+  CatIsoToPath : {x y : C .ob} (p : CatIso _ x y) → x ≡ y
+  CatIsoToPath = invEq (univEquiv _ _)
+
+  isGroupoid-ob : isGroupoid (C .ob)
+  isGroupoid-ob = isOfHLevelPath'⁻ 2 (λ _ _ → isOfHLevelRespectEquiv 2 (invEquiv (univEquiv _ _)) (isSet-CatIso _ _))
+
+isPropIsUnivalent : {C : Category ℓ ℓ'} → isProp (isUnivalent C)
+isPropIsUnivalent =
+ isPropRetract isUnivalent.univ _ (λ _ → refl)
+  (isPropΠ2 λ _ _ → isPropIsEquiv _ )
+
+-- Opposite category
+_^op : Category ℓ ℓ' → Category ℓ ℓ'
+ob (C ^op)           = ob C
+Hom[_,_] (C ^op) x y = C [ y , x ]
+id (C ^op)           = id C
+_⋆_ (C ^op) f g      = g ⋆⟨ C ⟩ f
+⋆IdL (C ^op)         = C .⋆IdR
+⋆IdR (C ^op)         = C .⋆IdL
+⋆Assoc (C ^op) f g h = sym (C .⋆Assoc _ _ _)
+isSetHom (C ^op)     = C .isSetHom
+
+ΣPropCat : (C : Category ℓ ℓ') (P : ℙ (ob C)) → Category ℓ ℓ'
+ob (ΣPropCat C P) = Σ[ x ∈ ob C ] x ∈ P
+Hom[_,_] (ΣPropCat C P) x y = C [ fst x , fst y ]
+id (ΣPropCat C P) = id C
+_⋆_ (ΣPropCat C P) = _⋆_ C
+⋆IdL (ΣPropCat C P) = ⋆IdL C
+⋆IdR (ΣPropCat C P) = ⋆IdR C
+⋆Assoc (ΣPropCat C P) = ⋆Assoc C
+isSetHom (ΣPropCat C P) = isSetHom C
+
+isIsoΣPropCat : {C : Category ℓ ℓ'} {P : ℙ (ob C)}
+                {x y : ob C} (p : x ∈ P) (q : y ∈ P)
+                (f : C [ x , y ])
+              → isIso C f → isIso (ΣPropCat C P) {x , p} {y , q} f
+inv (isIsoΣPropCat p q f isIsoF) = isIsoF .inv
+sec (isIsoΣPropCat p q f isIsoF) = isIsoF .sec
+ret (isIsoΣPropCat p q f isIsoF) = isIsoF .ret
\ No newline at end of file diff --git a/docs/Cubical.Categories.Category.Properties.html b/docs/Cubical.Categories.Category.Properties.html index 71ac7f0..92726db 100644 --- a/docs/Cubical.Categories.Category.Properties.html +++ b/docs/Cubical.Categories.Category.Properties.html @@ -18,21 +18,21 @@ -- isSet where your allowed to compare paths where one side is only -- equal up to path. Is there a generalization of this? isSetHomP1 : ∀ {x y : C .ob} {n : C [ x , y ]} - → isOfHLevelDep 1 (λ m → m ≡ n) - isSetHomP1 {x = x} {y} {n} = isOfHLevel→isOfHLevelDep 1 (λ m → isSetHom C m n) + → isOfHLevelDep 1 (λ m → m ≡ n) + isSetHomP1 {x = x} {y} {n} = isOfHLevel→isOfHLevelDep 1 (λ m → isSetHom C m n) -- isSet where the arrows can be between non-definitionally equal obs isSetHomP2l : ∀ {y : C .ob} - → isOfHLevelDep 2 (λ x → C [ x , y ]) - isSetHomP2l = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom C {x = a}) + → isOfHLevelDep 2 (λ x → C [ x , y ]) + isSetHomP2l = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom C {x = a}) isSetHomP2r : ∀ {x : C .ob} - → isOfHLevelDep 2 (λ y → C [ x , y ]) - isSetHomP2r = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom C {y = a}) + → isOfHLevelDep 2 (λ y → C [ x , y ]) + isSetHomP2r = isOfHLevel→isOfHLevelDep 2 (λ a → isSetHom C {y = a}) -- opposite of opposite is definitionally equal to itself -involutiveOp : ∀ {C : Category ℓ ℓ'} → C ^op ^op ≡ C +involutiveOp : ∀ {C : Category ℓ ℓ'} → C ^op ^op ≡ C involutiveOp = refl module _ {C : Category ℓ ℓ'} where @@ -40,12 +40,12 @@ -- whisker the parallel morphisms g and g' with f lCatWhisker : {x y z : C .ob} (f : C [ x , y ]) (g g' : C [ y , z ]) (p : g ≡ g') - → f ⋆⟨ C ⟩ g ≡ f ⋆⟨ C ⟩ g' + → f ⋆⟨ C ⟩ g ≡ f ⋆⟨ C ⟩ g' lCatWhisker f _ _ p = cong (_⋆_ C f) p rCatWhisker : {x y z : C .ob} (f f' : C [ x , y ]) (g : C [ y , z ]) (p : f ≡ f') - → f ⋆⟨ C ⟩ g ≡ f' ⋆⟨ C ⟩ g - rCatWhisker _ _ g p = cong (λ v → v ⋆⟨ C ⟩ g) p + → f ⋆⟨ C ⟩ g ≡ f' ⋆⟨ C ⟩ g + rCatWhisker _ _ g p = cong (λ v → v ⋆⟨ C ⟩ g) p -- working with equal objects idP : ∀ {x x'} {p : x ≡ x'} → C [ x , x' ] @@ -55,65 +55,65 @@ seqP : ∀ {x y y' z} {p : y ≡ y'} → (f : C [ x , y ]) (g : C [ y' , z ]) → C [ x , z ] - seqP {x} {_} {_} {z} {p} f g = f ⋆⟨ C ⟩ (subst (λ a → C [ a , z ]) (sym p) g) + seqP {x} {_} {_} {z} {p} f g = f ⋆⟨ C ⟩ (subst (λ a → C [ a , z ]) (sym p) g) -- also heterogeneous seq, but substituting on the left seqP' : ∀ {x y y' z} {p : y ≡ y'} → (f : C [ x , y ]) (g : C [ y' , z ]) → C [ x , z ] - seqP' {x} {_} {_} {z} {p} f g = subst (λ a → C [ x , a ]) p f ⋆⟨ C ⟩ g + seqP' {x} {_} {_} {z} {p} f g = subst (λ a → C [ x , a ]) p f ⋆⟨ C ⟩ g -- show that they're equal seqP≡seqP' : ∀ {x y y' z} {p : y ≡ y'} → (f : C [ x , y ]) (g : C [ y' , z ]) → seqP {p = p} f g ≡ seqP' {p = p} f g seqP≡seqP' {x = x} {z = z} {p = p} f g i = - (toPathP {A = λ i' → C [ x , p i' ]} {f} refl i) - ⋆⟨ C ⟩ - (toPathP {A = λ i' → C [ p (~ i') , z ]} {x = g} (sym refl) (~ i)) + (toPathP {A = λ i' → C [ x , p i' ]} {f} refl i) + ⋆⟨ C ⟩ + (toPathP {A = λ i' → C [ p (~ i') , z ]} {x = g} (sym refl) (~ i)) -- seqP is equal to normal seq when y ≡ y' seqP≡seq : ∀ {x y z} → (f : C [ x , y ]) (g : C [ y , z ]) - → seqP {p = refl} f g ≡ f ⋆⟨ C ⟩ g - seqP≡seq {y = y} {z} f g i = f ⋆⟨ C ⟩ toPathP {A = λ _ → C [ y , z ]} {x = g} refl (~ i) + → seqP {p = refl} f g ≡ f ⋆⟨ C ⟩ g + seqP≡seq {y = y} {z} f g i = f ⋆⟨ C ⟩ toPathP {A = λ _ → C [ y , z ]} {x = g} refl (~ i) -- whiskering with heterogenous seq -- (maybe should let z be heterogeneous too) lCatWhiskerP : {x y z y' : C .ob} {p : y ≡ y'} → (f : C [ x , y ]) (g : C [ y , z ]) (g' : C [ y' , z ]) → (r : PathP (λ i → C [ p i , z ]) g g') - → f ⋆⟨ C ⟩ g ≡ seqP {p = p} f g' + → f ⋆⟨ C ⟩ g ≡ seqP {p = p} f g' lCatWhiskerP {z = z} {p = p} f g g' r = - cong (λ v → f ⋆⟨ C ⟩ v) (sym (fromPathP (symP {A = λ i → C [ p (~ i) , z ]} r))) + cong (λ v → f ⋆⟨ C ⟩ v) (sym (fromPathP (symP {A = λ i → C [ p (~ i) , z ]} r))) rCatWhiskerP : {x y' y z : C .ob} {p : y' ≡ y} → (f' : C [ x , y' ]) (f : C [ x , y ]) (g : C [ y , z ]) → (r : PathP (λ i → C [ x , p i ]) f' f) - → f ⋆⟨ C ⟩ g ≡ seqP' {p = p} f' g - rCatWhiskerP f' f g r = cong (λ v → v ⋆⟨ C ⟩ g) (sym (fromPathP r)) + → f ⋆⟨ C ⟩ g ≡ seqP' {p = p} f' g + rCatWhiskerP f' f g r = cong (λ v → v ⋆⟨ C ⟩ g) (sym (fromPathP r)) AssocCong₂⋆L : {x y' y z w : C .ob} → {f' : C [ x , y' ]} {f : C [ x , y ]} {g' : C [ y' , z ]} {g : C [ y , z ]} - → f ⋆⟨ C ⟩ g ≡ f' ⋆⟨ C ⟩ g' → (h : C [ z , w ]) - → f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ h) ≡ - f' ⋆⟨ C ⟩ (g' ⋆⟨ C ⟩ h) + → f ⋆⟨ C ⟩ g ≡ f' ⋆⟨ C ⟩ g' → (h : C [ z , w ]) + → f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ h) ≡ + f' ⋆⟨ C ⟩ (g' ⋆⟨ C ⟩ h) AssocCong₂⋆L p h = sym (⋆Assoc C _ _ h) - ∙∙ (λ i → p i ⋆⟨ C ⟩ h) ∙∙ + ∙∙ (λ i → p i ⋆⟨ C ⟩ h) ∙∙ ⋆Assoc C _ _ h AssocCong₂⋆R : {x y z z' w : C .ob} → (f : C [ x , y ]) {g' : C [ y , z' ]} {g : C [ y , z ]} {h' : C [ z' , w ]} {h : C [ z , w ]} - → g ⋆⟨ C ⟩ h ≡ g' ⋆⟨ C ⟩ h' - → (f ⋆⟨ C ⟩ g) ⋆⟨ C ⟩ h ≡ - (f ⋆⟨ C ⟩ g') ⋆⟨ C ⟩ h' + → g ⋆⟨ C ⟩ h ≡ g' ⋆⟨ C ⟩ h' + → (f ⋆⟨ C ⟩ g) ⋆⟨ C ⟩ h ≡ + (f ⋆⟨ C ⟩ g') ⋆⟨ C ⟩ h' AssocCong₂⋆R f p = ⋆Assoc C f _ _ - ∙∙ (λ i → f ⋆⟨ C ⟩ p i) ∙∙ + ∙∙ (λ i → f ⋆⟨ C ⟩ p i) ∙∙ sym (⋆Assoc C _ _ _) \ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.BinProduct.html b/docs/Cubical.Categories.Constructions.BinProduct.html index 1106138..b1cae3e 100644 --- a/docs/Cubical.Categories.Constructions.BinProduct.html +++ b/docs/Cubical.Categories.Constructions.BinProduct.html @@ -24,7 +24,7 @@ (C ×C D) .ob = (ob C) × (ob D) (C ×C D) .Hom[_,_] (c , d) (c' , d') = (C [ c , c' ]) × (D [ d , d' ]) (C ×C D) .id = (id C , id D) -(C ×C D) ._⋆_ _ _ = (_ ⋆⟨ C ⟩ _ , _ ⋆⟨ D ⟩ _) +(C ×C D) ._⋆_ _ _ = (_ ⋆⟨ C ⟩ _ , _ ⋆⟨ D ⟩ _) (C ×C D) .⋆IdL _ = ≡-× (⋆IdL C _) (⋆IdL D _) (C ×C D) .⋆IdR _ = ≡-× (⋆IdR C _) (⋆IdR D _) (C ×C D) .⋆Assoc _ _ _ = ≡-× (⋆Assoc C _ _ _) (⋆Assoc D _ _ _) @@ -95,11 +95,11 @@ -- The isomorphisms in product category - open isIso + open isIso - CatIso× : {x y : C .ob}{z w : D .ob} → CatIso C x y → CatIso D z w → CatIso (C ×C D) (x , z) (y , w) + CatIso× : {x y : C .ob}{z w : D .ob} → CatIso C x y → CatIso D z w → CatIso (C ×C D) (x , z) (y , w) CatIso× f g .fst = f .fst , g .fst - CatIso× f g .snd .inv = f .snd .inv , g .snd .inv - CatIso× f g .snd .sec i = f .snd .sec i , g .snd .sec i - CatIso× f g .snd .ret i = f .snd .ret i , g .snd .ret i + CatIso× f g .snd .inv = f .snd .inv , g .snd .inv + CatIso× f g .snd .sec i = f .snd .sec i , g .snd .sec i + CatIso× f g .snd .ret i = f .snd .ret i , g .snd .ret i \ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.Elements.html b/docs/Cubical.Categories.Constructions.Elements.html new file mode 100644 index 0000000..50f610e --- /dev/null +++ b/docs/Cubical.Categories.Constructions.Elements.html @@ -0,0 +1,114 @@ + +Cubical.Categories.Constructions.Elements
{-# OPTIONS --safe #-}
+
+-- The Category of Elements
+
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Categories.Category
+import      Cubical.Categories.Constructions.Slice.Base as Slice
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Instances.Sets
+open import Cubical.Categories.Isomorphism
+import      Cubical.Categories.Morphism as Morphism
+
+
+
+module Cubical.Categories.Constructions.Elements where
+
+-- some issues
+-- * always need to specify objects during composition because can't infer isSet
+open Category
+open Functor
+
+module Covariant {ℓ ℓ'} {C : Category ℓ ℓ'} where
+    getIsSet : ∀ {ℓS} (F : Functor C (SET ℓS)) → (c : C .ob) → isSet (fst (F ⟅ c ⟆))
+    getIsSet F c = snd (F ⟅ c ⟆)
+
+    Element : ∀ {ℓS} (F : Functor C (SET ℓS)) → Type (ℓ-max ℓ ℓS)
+    Element F = Σ[ c ∈ C .ob ] fst (F ⟅ c ⟆)
+
+    infix 50 ∫_
+    ∫_ : ∀ {ℓS} → Functor C (SET ℓS) → Category (ℓ-max ℓ ℓS) (ℓ-max ℓ' ℓS)
+    -- objects are (c , x) pairs where c ∈ C and x ∈ F c
+    (∫ F) .ob = Element F
+    -- morphisms are f : c → c' which take x to x'
+    (∫ F) .Hom[_,_] (c , x) (c' , x')  = fiber (λ (f : C [ c , c' ]) → (F ⟪ f ⟫) x) x'
+    (∫ F) .id {x = (c , x)} = C .id , funExt⁻ (F .F-id) x
+    (∫ F) ._⋆_ {c , x} {c₁ , x₁} {c₂ , x₂} (f , p) (g , q)
+      = (f ⋆⟨ C ⟩ g) , ((F ⟪ f ⋆⟨ C ⟩ g ⟫) x
+                ≡⟨ funExt⁻ (F .F-seq _ _) _ ⟩
+                  (F ⟪ g ⟫) ((F ⟪ f ⟫) x)
+                ≡⟨ cong (F ⟪ g ⟫) p ⟩
+                  (F ⟪ g ⟫) x₁
+                ≡⟨ q ⟩
+                  x₂
+                ∎)
+    (∫ F) .⋆IdL o@{c , x} o1@{c' , x'} f'@(f , p) i
+      = (cIdL i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS' ((F ⟪ a ⟫) x) x') p' p cIdL i
+        where
+          isS = getIsSet F c
+          isS' = getIsSet F c'
+          cIdL = C .⋆IdL f
+
+          -- proof from composition with id
+          p' : (F ⟪ C .id ⋆⟨ C ⟩ f ⟫) x ≡ x'
+          p' = snd ((∫ F) ._⋆_ ((∫ F) .id) f')
+    (∫ F) .⋆IdR o@{c , x} o1@{c' , x'} f'@(f , p) i
+        = (cIdR i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS' ((F ⟪ a ⟫) x) x') p' p cIdR i
+          where
+            cIdR = C .⋆IdR f
+            isS' = getIsSet F c'
+
+            p' : (F ⟪ f ⋆⟨ C ⟩ C .id ⟫) x ≡ x'
+            p' = snd ((∫ F) ._⋆_ f' ((∫ F) .id))
+    (∫ F) .⋆Assoc o@{c , x} o1@{c₁ , x₁} o2@{c₂ , x₂} o3@{c₃ , x₃} f'@(f , p) g'@(g , q) h'@(h , r) i
+      = (cAssoc i) , isOfHLevel→isOfHLevelDep 1 (λ a → isS₃ ((F ⟪ a ⟫) x) x₃) p1 p2 cAssoc i
+        where
+          cAssoc = C .⋆Assoc f g h
+          isS₃ = getIsSet F c₃
+
+          p1 : (F ⟪ (f ⋆⟨ C ⟩ g) ⋆⟨ C ⟩ h ⟫) x ≡ x₃
+          p1 = snd ((∫ F) ._⋆_ ((∫ F) ._⋆_ {o} {o1} {o2} f' g') h')
+
+          p2 : (F ⟪ f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ h) ⟫) x ≡ x₃
+          p2 = snd ((∫ F) ._⋆_ f' ((∫ F) ._⋆_ {o1} {o2} {o3} g' h'))
+    (∫ F) .isSetHom {x} {y} = isSetΣSndProp (C .isSetHom) λ _ → (F ⟅ fst y ⟆) .snd _ _
+
+    ForgetElements : ∀ {ℓS} → (F : Functor C (SET ℓS)) → Functor (∫ F) C
+    F-ob (ForgetElements F) = fst
+    F-hom (ForgetElements F) = fst
+    F-id (ForgetElements F) = refl
+    F-seq (ForgetElements F) _ _ = refl
+
+module Contravariant {ℓ ℓ'} {C : Category ℓ ℓ'} where
+    open Covariant {C = C ^op}
+
+    -- same thing but for presheaves
+    ∫ᴾ_ : ∀ {ℓS} → Functor (C ^op) (SET ℓS) → Category (ℓ-max ℓ ℓS) (ℓ-max ℓ' ℓS)
+    ∫ᴾ F = (∫ F) ^op
+
+    Elementᴾ : ∀ {ℓS} → Functor (C ^op) (SET ℓS) → Type (ℓ-max ℓ ℓS)
+    Elementᴾ F = (∫ᴾ F) .ob
+
+    -- helpful results
+
+    module _ {ℓS} {F : Functor (C ^op) (SET ℓS)} where
+
+      -- morphisms are equal as long as the morphisms in C are equal
+      ∫ᴾhomEq : ∀ {o1 o1' o2 o2'} (f : (∫ᴾ F) [ o1 , o2 ]) (g : (∫ᴾ F) [ o1' , o2' ])
+              → (p : o1 ≡ o1') (q : o2 ≡ o2')
+              → (eqInC : PathP (λ i → C [ fst (p i) , fst (q i) ]) (fst f) (fst g))
+              → PathP (λ i → (∫ᴾ F) [ p i , q i ]) f g
+      ∫ᴾhomEq _ _ _ _ = ΣPathPProp (λ f → snd (F ⟅ _ ⟆) _ _)
+
+      ∫ᴾhomEqSimpl : ∀ {o1 o2} (f g : (∫ᴾ F) [ o1 , o2 ])
+                   → fst f ≡ fst g → f ≡ g
+      ∫ᴾhomEqSimpl f g p = ∫ᴾhomEq f g refl refl p
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.Slice.Base.html b/docs/Cubical.Categories.Constructions.Slice.Base.html new file mode 100644 index 0000000..1c65f6c --- /dev/null +++ b/docs/Cubical.Categories.Constructions.Slice.Base.html @@ -0,0 +1,395 @@ + +Cubical.Categories.Constructions.Slice.Base
{-# OPTIONS --safe #-}
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Transport using (transpFill)
+
+open import Cubical.Categories.Category renaming (isIso to isIsoC)
+open import Cubical.Categories.Morphism
+
+open import Cubical.Data.Sigma
+
+open Category
+open isUnivalent
+open Iso
+
+module Cubical.Categories.Constructions.Slice.Base {ℓ ℓ' : Level} (C : Category ℓ ℓ') (c : C .ob) where
+
+-- just a helper to prevent redundency
+TypeC : Type (ℓ-suc (ℓ-max ℓ ℓ'))
+TypeC = Type (ℓ-max ℓ ℓ')
+
+-- Components of a slice category
+
+record SliceOb : TypeC where
+  constructor sliceob
+  field
+    {S-ob} : C .ob
+    S-arr : C [ S-ob , c ]
+
+open SliceOb public
+
+record SliceHom (a b : SliceOb) : Type ℓ' where
+  constructor slicehom
+  field
+    S-hom : C [ S-ob a , S-ob b ]
+    -- commutative diagram
+    S-comm : S-hom ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a
+
+open SliceHom public
+
+-- Helpers for working with equality
+-- can probably replace these by showing that SliceOb is isomorphic to Sigma and
+-- that paths are isomorphic to Sigma? But sounds like that would need a lot of transp
+
+SliceOb-≡-intro : ∀ {a b} {f g}
+                 → (p : a ≡ b)
+                 → PathP (λ i → C [ p i , c ]) f g
+                 → sliceob {a} f ≡ sliceob {b} g
+SliceOb-≡-intro p q = λ i → sliceob {p i} (q i)
+
+module _ {xf yg : SliceOb} where
+  private
+    x = xf .S-ob
+    f = xf .S-arr
+    y = yg .S-ob
+    g = yg .S-arr
+
+  -- a path between slice objects is the "same" as a pair of paths between C obs and C arrows
+  SOPathIsoPathΣ : Iso (xf ≡ yg) (Σ[ p ∈ x ≡ y ] PathP (λ i → C [ p i , c ]) f g)
+  SOPathIsoPathΣ .fun p = (λ i → (p i) .S-ob) , (λ i → (p i) .S-arr)
+  SOPathIsoPathΣ .inv (p , q) i = sliceob {p i} (q i)
+  SOPathIsoPathΣ .rightInv _ = refl
+  SOPathIsoPathΣ .leftInv _ = refl
+
+  SOPath≃PathΣ = isoToEquiv SOPathIsoPathΣ
+
+  SOPath≡PathΣ = ua (isoToEquiv SOPathIsoPathΣ)
+
+-- If the type of objects of C forms a set then so does the type of objects of the slice cat
+module _ (isSetCOb : isSet (C .ob)) where
+  isSetSliceOb : isSet SliceOb
+  isSetSliceOb x y =
+    subst
+      (λ t → isProp t)
+      (sym (SOPath≡PathΣ {xf = x} {yg = y}))
+      (isPropΣ
+        (isSetCOb (x .S-ob) (y .S-ob))
+        λ x≡y →
+          subst
+            (λ t → isProp t)
+            (sym (ua (PathP≃Path (λ i → C [ x≡y i , c ]) (x .S-arr) (y .S-arr))))
+            (C .isSetHom (transport (λ i → C [ x≡y i , c ]) (x .S-arr)) (y .S-arr)))
+
+-- intro and elim for working with SliceHom equalities (is there a better way to do this?)
+SliceHom-≡-intro : ∀ {a b} {f g} {c₁} {c₂}
+                → (p : f ≡ g)
+                → PathP (λ i → (p i) ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a) c₁ c₂
+                → slicehom f c₁ ≡ slicehom g c₂
+SliceHom-≡-intro p q = λ i → slicehom (p i) (q i)
+
+SliceHom-≡-elim : ∀ {a b} {f g} {c₁} {c₂}
+                → slicehom f c₁ ≡ slicehom g c₂
+                → Σ[ p ∈ f ≡ g ] PathP (λ i → (p i) ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a) c₁ c₂
+SliceHom-≡-elim r = (λ i → S-hom (r i)) , λ i → S-comm (r i)
+
+
+SliceHom-≡-intro' : ∀ {a b} {f g : C [ a .S-ob , b .S-ob ]} {c₁} {c₂}
+                  → (p : f ≡ g)
+                  → slicehom f c₁ ≡ slicehom g c₂
+SliceHom-≡-intro' {a} {b} {f} {g} {c₁} {c₂} p i = slicehom (p i) (c₁≡c₂ i)
+  where
+    c₁≡c₂ : PathP (λ i → (p i) ⋆⟨ C ⟩ (b .S-arr) ≡ a .S-arr) c₁ c₂
+    c₁≡c₂ = isOfHLevel→isOfHLevelDep 1 (λ _ → C .isSetHom _ _) c₁ c₂ p
+
+-- SliceHom is isomorphic to the Sigma type with the same components
+SliceHom-Σ-Iso : ∀ {a b}
+            → Iso (SliceHom a b) (Σ[ h ∈ C [ S-ob a , S-ob b ] ] h ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a)
+SliceHom-Σ-Iso .fun (slicehom h c) = h , c
+SliceHom-Σ-Iso .inv (h , c) = slicehom h c
+SliceHom-Σ-Iso .rightInv = λ x → refl
+SliceHom-Σ-Iso .leftInv = λ x → refl
+
+
+-- Category definition
+
+SliceCat : Category (ℓ-max ℓ ℓ') ℓ'
+ob SliceCat = SliceOb
+Hom[_,_] SliceCat = SliceHom
+id SliceCat = slicehom (C .id) (C .⋆IdL _)
+_⋆_ SliceCat {sliceob j} {sliceob k} {sliceob l} (slicehom f p) (slicehom g p') =
+  slicehom
+    (f ⋆⟨ C ⟩ g)
+    ( f ⋆⟨ C ⟩ g ⋆⟨ C ⟩ l
+    ≡⟨ C .⋆Assoc _ _ _ ⟩
+      f ⋆⟨ C ⟩ (g ⋆⟨ C ⟩ l)
+    ≡⟨ cong (λ v → f ⋆⟨ C ⟩ v) p' ⟩
+      f ⋆⟨ C ⟩ k
+    ≡⟨ p ⟩
+      j
+    ∎)
+⋆IdL SliceCat (slicehom S-hom S-comm) =
+  SliceHom-≡-intro (⋆IdL C _) (toPathP (C .isSetHom _ _ _ _))
+⋆IdR SliceCat (slicehom S-hom S-comm) =
+  SliceHom-≡-intro (⋆IdR C _) (toPathP (C .isSetHom _ _ _ _))
+⋆Assoc SliceCat f g h =
+  SliceHom-≡-intro (⋆Assoc C _ _ _) (toPathP (C .isSetHom _ _ _ _))
+isSetHom SliceCat {a} {b} (slicehom f c₁) (slicehom g c₂) p q = cong isoP p'≡q'
+    where
+      -- paths between SliceHoms are equivalent to the projection paths
+      p' : Σ[ p ∈ f ≡ g ] PathP (λ i → (p i) ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a) c₁ c₂
+      p' = SliceHom-≡-elim p
+      q' : Σ[ p ∈ f ≡ g ] PathP (λ i → (p i) ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a) c₁ c₂
+      q' = SliceHom-≡-elim q
+
+      -- we want all paths between (dependent) paths of this type to be equal
+      B = λ v → v ⋆⟨ C ⟩ (S-arr b) ≡ S-arr a
+
+      -- need the groupoidness for dependent paths
+      isGroupoidDepHom : isOfHLevelDep 2 B
+      isGroupoidDepHom = isOfHLevel→isOfHLevelDep 2 (λ v x y → isSet→isGroupoid (C .isSetHom) _ _ x y)
+
+      -- we first prove that the projected paths are equal
+      p'≡q' : p' ≡ q'
+      p'≡q' = ΣPathP (C .isSetHom _ _ _ _ , toPathP (isGroupoidDepHom _ _ _ _ _))
+
+      -- and then we can use equivalence to lift these paths up
+      -- to actual SliceHom paths
+      isoP = λ g → cong (inv SliceHom-Σ-Iso) (fun (ΣPathIsoPathΣ) g)
+
+-- SliceCat is univalent if C is univalent
+
+module _ ⦃ isU : isUnivalent C ⦄ where
+  open isIsoC
+  open Iso
+
+  module _ { xf yg : SliceOb } where
+    private
+      x = xf .S-ob
+      y = yg .S-ob
+
+    -- names for the equivalences/isos
+
+    pathIsoEquiv : (x ≡ y) ≃ (CatIso _ x y)
+    pathIsoEquiv = univEquiv isU x y
+
+    isoPathEquiv : (CatIso _ x y) ≃ (x ≡ y)
+    isoPathEquiv = invEquiv pathIsoEquiv
+
+    pToIIso' : Iso (x ≡ y) (CatIso _ x y)
+    pToIIso' = equivToIso pathIsoEquiv
+
+    -- the iso in SliceCat we're given induces an iso in C between x and y
+    module _ ( cIso@(kc , isiso lc s r) : CatIso SliceCat xf yg ) where
+      extractIso' : CatIso C x y
+      extractIso' .fst = kc .S-hom
+      extractIso' .snd .inv = lc .S-hom
+      extractIso' .snd .sec i = (s i) .S-hom
+      extractIso' .snd .ret i = (r i) .S-hom
+
+  instance
+    preservesUnivalenceSlice : isUnivalent SliceCat
+    -- we prove the equivalence by going through Iso
+    preservesUnivalenceSlice .univ xf@(sliceob {x} f) yg@(sliceob {y} g) = isoToIsEquiv sIso
+      where
+        -- this is just here because the type checker can't seem to infer xf and yg
+        pToIIso : Iso (x ≡ y) (CatIso _ x y)
+        pToIIso = pToIIso' {xf = xf} {yg}
+
+        -- the meat of the proof
+        sIso : Iso (xf ≡ yg) (CatIso _ xf yg)
+        sIso .fun p = pathToIso p -- we use the normal pathToIso via path induction to get an isomorphism
+        sIso .inv is@(kc , isiso lc s r) = SliceOb-≡-intro x≡y (symP (sym (lc .S-comm) ◁ lf≡f))
+          where
+            -- we get a path between xf and yg by combining paths between
+            -- x and y, and f and g
+            -- 1. x≡y follows from univalence of C
+            -- 2. f≡g is more tricky; by commutativity, we know that g ≡ l ⋆ f
+              -- so we want l to be id; we get this by showing: id ≡ pathToIso x y x≡y ≡ l
+              -- where the first step follows from path induction, and the second from univalence of C
+
+            -- morphisms in C from kc and lc
+            k = kc .S-hom
+            l = lc .S-hom
+
+            -- extract out the iso between x and y
+            extractIso : CatIso C x y
+            extractIso = extractIso' is
+
+            -- and we can use univalence of C to get x ≡ y
+            x≡y : x ≡ y
+            x≡y = pToIIso .inv extractIso
+
+            -- to show that f ≡ g, we show that l ≡ id
+            -- by using C's isomorphism
+            pToI≡id : PathP (λ i → C [ x≡y (~ i) , x ]) (pathToIso {C = C} x≡y .snd .inv) (C .id)
+            pToI≡id = J (λ y p → PathP (λ i → C [ p (~ i) , x ]) (pathToIso {C = C} p .snd .inv) (C .id))
+                        (λ j → JRefl pToIFam pToIBase j .snd .inv)
+                        x≡y
+              where
+                idx = C .id
+                pToIFam = (λ z _ → CatIso C x z)
+                pToIBase = catiso (C .id) idx (C .⋆IdL idx) (C .⋆IdL idx)
+
+            l≡pToI : l ≡ pathToIso {C = C} x≡y .snd .inv
+            l≡pToI i = pToIIso .rightInv extractIso (~ i) .snd .inv
+
+            l≡id : PathP (λ i → C [ x≡y (~ i) , x ]) l (C .id)
+            l≡id = l≡pToI ◁ pToI≡id
+
+            lf≡f : PathP (λ i → C [ x≡y (~ i) , c ]) (l ⋆⟨ C ⟩ f) f
+            lf≡f = (λ i → (l≡id i) ⋆⟨ C ⟩ f) ▷ C .⋆IdL _
+
+        sIso .rightInv is@(kc , isiso lc s r) i = catiso (kc'≡kc i) (lc'≡lc i) (s'≡s i) (r'≡r i)
+          -- we prove rightInv using a combination of univalence and the fact that homs are an h-set
+          where
+            kc' = (sIso .fun) (sIso .inv is) .fst
+            lc' = (sIso .fun) (sIso .inv is) .snd .inv
+            k' = kc' .S-hom
+            l' = lc' .S-hom
+            k = kc .S-hom
+            l = lc .S-hom
+
+            extractIso : CatIso C x y
+            extractIso = extractIso' is
+
+            -- we do the equality component wise
+
+            -- mor
+
+            k'≡k : k' ≡ k
+            k'≡k i = (pToIIso .rightInv extractIso) i .fst
+
+            kcom'≡kcom : PathP (λ j → (k'≡k j) ⋆⟨ C ⟩ g ≡ f) (kc' .S-comm) (kc .S-comm)
+            kcom'≡kcom = isSetHomP1 {C = C} _ _ λ i → (k'≡k i) ⋆⟨ C ⟩ g
+            kc'≡kc : kc' ≡ kc
+            kc'≡kc i = slicehom (k'≡k i) (kcom'≡kcom i)
+
+            -- inv
+
+            l'≡l : l' ≡ l
+            l'≡l i = (pToIIso .rightInv extractIso) i .snd .inv
+
+            lcom'≡lcom : PathP (λ j → (l'≡l j) ⋆⟨ C ⟩ f ≡ g) (lc' .S-comm) (lc .S-comm)
+            lcom'≡lcom = isSetHomP1 {C = C} _ _ λ i → (l'≡l i) ⋆⟨ C ⟩ f
+
+            lc'≡lc : lc' ≡ lc
+            lc'≡lc i = slicehom (l'≡l i) (lcom'≡lcom i)
+
+            -- sec
+
+            s' = (sIso .fun) (sIso .inv is) .snd .sec
+            s'≡s : PathP (λ i → lc'≡lc i ⋆⟨ SliceCat ⟩ kc'≡kc i ≡ SliceCat .id) s' s
+            s'≡s = isSetHomP1 {C = SliceCat} _ _ λ i → lc'≡lc i ⋆⟨ SliceCat ⟩ kc'≡kc i
+
+            -- ret
+
+            r' = (sIso .fun) (sIso .inv is) .snd .ret
+            r'≡r : PathP (λ i → kc'≡kc i ⋆⟨ SliceCat ⟩ lc'≡lc i ≡ SliceCat .id) r' r
+            r'≡r = isSetHomP1 {C = SliceCat} _ _ λ i → kc'≡kc i ⋆⟨ SliceCat ⟩ lc'≡lc i
+
+        sIso .leftInv p = p'≡p
+          -- to show that the round trip is equivalent to the identity
+          -- we show that this is true for each component (S-ob, S-arr)
+          -- and then combine
+          -- specifically, we show that p'Ob≡pOb and p'Mor≡pMor
+          -- and it follows that p'≡p
+          where
+            p' = (sIso .inv) (sIso .fun p)
+
+            pOb : x ≡ y
+            pOb i = (p i) .S-ob
+
+            p'Ob : x ≡ y
+            p'Ob i = (p' i) .S-ob
+
+
+            pMor : PathP (λ i → C [ pOb i , c ]) f g
+            pMor i = (p i) .S-arr
+
+            p'Mor : PathP (λ i → C [ p'Ob i , c ]) f g
+            p'Mor i = (p' i) .S-arr
+
+            -- we first show that it's equivalent to use sIso first then extract, or to extract first than use pToIIso
+            extractCom : extractIso' (sIso .fun p) ≡ pToIIso .fun pOb
+            extractCom = J (λ yg' p̃ → extractIso' (pathToIso p̃) ≡ pToIIso' {xf = xf} {yg'} .fun (λ i → (p̃ i) .S-ob))
+                           (cong extractIso' (JRefl pToIFam' pToIBase') ∙ sym (JRefl pToIFam pToIBase))
+                           p
+               where
+                 idx = C .id
+                 pToIFam = (λ z _ → CatIso C x z)
+                 pToIBase = catiso (C .id) idx (C .⋆IdL idx) (C .⋆IdL idx)
+
+                 idxf = SliceCat .id
+                 pToIFam' = (λ z _ → CatIso SliceCat xf z)
+                 pToIBase' = catiso (SliceCat .id) idxf (SliceCat .⋆IdL idxf) (SliceCat .⋆IdL idxf)
+
+            -- why does this not follow definitionally?
+            -- from extractCom, we get that performing the roundtrip on pOb gives us back p'Ob
+            ppp : p'Ob ≡ (pToIIso .inv) (pToIIso .fun pOb)
+            ppp = cong (pToIIso .inv) extractCom
+
+            -- apply univalence of C
+            -- this gives us the first component that we want
+            p'Ob≡pOb : p'Ob ≡ pOb
+            p'Ob≡pOb = ppp ∙ pToIIso .leftInv pOb
+
+            -- isSetHom gives us the second component, path between morphisms
+            p'Mor≡pMor : PathP (λ j → PathP (λ i → C [ (p'Ob≡pOb j) i , c ]) f g) p'Mor pMor
+            p'Mor≡pMor = isSetHomP2l {C = C} _ _ p'Mor pMor p'Ob≡pOb
+
+            -- we can use the above paths to show that p' ≡ p
+            p'≡p : p' ≡ p
+            p'≡p i = comp (λ i' → SOPath≡PathΣ {xf = xf} {yg} (~ i'))
+                            (λ j → λ { (i = i0) → left (~ j) ; (i = i1) → right (~ j) })
+                            (p'Σ≡pΣ i)
+              where
+                -- we break up p' and p into their constituent paths
+                -- first via transport and then via our component definitions from before
+                -- we show that p'ΣT ≡ p'Σ (and same for p) via univalence
+                -- and p'Σ≡pΣ follows from our work from above
+                p'ΣT : Σ[ p ∈ x ≡ y ] PathP (λ i → C [ p i , c ]) f g
+                p'ΣT = transport SOPath≡PathΣ p'
+                p'Σ : Σ[ p ∈ x ≡ y ] PathP (λ i → C [ p i , c ]) f g
+                p'Σ = (p'Ob , p'Mor)
+
+                pΣT : Σ[ p ∈ x ≡ y ] PathP (λ i → C [ p i , c ]) f g
+                pΣT = transport SOPath≡PathΣ p
+                pΣ : Σ[ p ∈ x ≡ y ] PathP (λ i → C [ p i , c ]) f g
+                pΣ = (pOb , pMor)-- transport SOPathP≡PathPSO p
+
+                -- using the computation rule to ua
+                p'ΣT≡p'Σ : p'ΣT ≡ p'Σ
+                p'ΣT≡p'Σ = uaβ SOPath≃PathΣ p'
+
+                pΣT≡pΣ : pΣT ≡ pΣ
+                pΣT≡pΣ = uaβ SOPath≃PathΣ p
+
+                p'Σ≡pΣ : p'Σ ≡ pΣ
+                p'Σ≡pΣ = ΣPathP (p'Ob≡pOb , p'Mor≡pMor)
+
+                -- two sides of the square we're connecting
+                left : PathP (λ i → SOPath≡PathΣ {xf = xf} {yg} i) p' p'Σ
+                left = transport-filler SOPath≡PathΣ p' ▷ p'ΣT≡p'Σ
+
+                right : PathP (λ i → SOPath≡PathΣ {xf = xf} {yg} i) p pΣ
+                right = transport-filler SOPath≡PathΣ p ▷ pΣT≡pΣ
+
+-- properties
+-- TODO: move to own file
+
+open isIsoC renaming (inv to invC)
+
+-- make a slice isomorphism from just the hom
+sliceIso : ∀ {a b} (f : C [ a .S-ob , b .S-ob ]) (c : (f ⋆⟨ C ⟩ b .S-arr) ≡ a .S-arr)
+         → isIsoC C f
+         → isIsoC SliceCat (slicehom f c)
+sliceIso f c isof .invC = slicehom (isof .invC) (sym (invMoveL (isIso→areInv isof) c))
+sliceIso f c isof .sec = SliceHom-≡-intro' (isof .sec)
+sliceIso f c isof .ret = SliceHom-≡-intro' (isof .ret)
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.Slice.Properties.html b/docs/Cubical.Categories.Constructions.Slice.Properties.html new file mode 100644 index 0000000..994ee10 --- /dev/null +++ b/docs/Cubical.Categories.Constructions.Slice.Properties.html @@ -0,0 +1,66 @@ + +Cubical.Categories.Constructions.Slice.Properties
{-# OPTIONS --safe #-}
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Data.Sigma
+
+open import Cubical.HITs.PropositionalTruncation using (∣_∣₁)
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Constructions.Slice.Base
+import Cubical.Categories.Constructions.Elements as Elements
+open import Cubical.Categories.Equivalence
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Instances.Sets
+open import Cubical.Categories.NaturalTransformation
+
+open Category
+
+module Cubical.Categories.Constructions.Slice.Properties
+  {ℓC ℓ'C : Level}
+  (C : Category ℓC ℓ'C)
+  (c : C .ob)
+  where
+
+open Elements.Contravariant {C = C}
+
+open _≃ᶜ_
+open Functor
+open WeakInverse
+
+slice→el : Functor (SliceCat C c) (∫ᴾ (C [-, c ]))
+slice→el .F-ob s = s .S-ob , s .S-arr
+slice→el .F-hom f = f .S-hom , f .S-comm
+slice→el .F-id = ΣPathP (refl , (isOfHLevelPath' 1 (C .isSetHom) _ _ _ _))
+slice→el .F-seq _ _ = ΣPathP (refl , (isOfHLevelPath' 1 (C .isSetHom) _ _ _ _))
+
+el→slice : Functor (∫ᴾ (C [-, c ])) (SliceCat C c)
+el→slice .F-ob (_ , s) = sliceob s
+el→slice .F-hom (f , comm) = slicehom f comm
+el→slice .F-id = SliceHom-≡-intro C c refl (isOfHLevelPath' 1 (C .isSetHom) _ _ _ _)
+el→slice .F-seq _ _ = SliceHom-≡-intro C c refl (isOfHLevelPath' 1 (C .isSetHom) _ _ _ _)
+
+open NatTrans
+open NatIso
+
+sliceIsElementsOfRep : SliceCat C c ≃ᶜ (∫ᴾ (C [-, c ]))
+sliceIsElementsOfRep .func = slice→el
+sliceIsElementsOfRep .isEquiv  = ∣ w-inv ∣₁
+  where
+    w-inv : WeakInverse slice→el
+    w-inv .invFunc = el→slice
+    w-inv .η .trans .N-ob s = SliceCat C c .id
+    w-inv .η .trans .N-hom f = (SliceCat C c .⋆IdR f)
+                             ∙ sym (SliceCat C c .⋆IdL f)
+    w-inv .η .nIso x = isiso (SliceCat C c .id)
+                             (SliceCat C c .⋆IdR _)
+                             (SliceCat C c .⋆IdR _)
+    w-inv .ε .trans .N-ob s = (∫ᴾ (C [-, c ])) .id
+    w-inv .ε .trans .N-hom f = ((∫ᴾ (C [-, c ])) .⋆IdR f)
+                             ∙ sym ((∫ᴾ (C [-, c ])) .⋆IdL f)
+    w-inv .ε .nIso x = isiso ((∫ᴾ (C [-, c ])) .id)
+                             ((∫ᴾ (C [-, c ])) .⋆IdR _)
+                             ((∫ᴾ (C [-, c ])) .⋆IdR _)
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.Slice.html b/docs/Cubical.Categories.Constructions.Slice.html new file mode 100644 index 0000000..d1aed79 --- /dev/null +++ b/docs/Cubical.Categories.Constructions.Slice.html @@ -0,0 +1,18 @@ + +Cubical.Categories.Constructions.Slice
{-# OPTIONS --safe #-}
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Categories.Category
+
+open Category
+
+module Cubical.Categories.Constructions.Slice
+  {ℓ ℓ' : Level}
+  (C : Category ℓ ℓ')
+  (c : C .ob)
+  where
+
+open import Cubical.Categories.Constructions.Slice.Base C c public
+open import Cubical.Categories.Constructions.Slice.Properties C c public
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Constructions.SubObject.html b/docs/Cubical.Categories.Constructions.SubObject.html new file mode 100644 index 0000000..6cec691 --- /dev/null +++ b/docs/Cubical.Categories.Constructions.SubObject.html @@ -0,0 +1,93 @@ + +Cubical.Categories.Constructions.SubObject
{-# OPTIONS --safe #-}
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Powerset
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Univalence
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Morphism
+
+open import Cubical.Relation.Binary.Order.Preorder
+
+open Category
+
+module Cubical.Categories.Constructions.SubObject
+  {ℓ ℓ' : Level}
+  (C : Category ℓ ℓ')
+  (c : C .ob)
+  where
+
+open import Cubical.Categories.Constructions.Slice C c
+
+isSubObj : ℙ (SliceCat .ob)
+isSubObj (sliceob arr) = isMonic C arr , isPropIsMonic C arr
+
+SubObjCat : Category (ℓ-max ℓ ℓ') ℓ'
+SubObjCat = ΣPropCat SliceCat isSubObj
+
+SubObjCat→SliceCat : Functor SubObjCat SliceCat
+SubObjCat→SliceCat = forgetΣPropCat SliceCat isSubObj
+
+subObjMorIsMonic : {s t : SubObjCat .ob} (f : SubObjCat [ s , t ])
+  → isMonic C (S-hom f)
+subObjMorIsMonic {s = s} {t = t} f = postcompCreatesMonic C
+  (S-hom f) (S-arr (t .fst)) comp-is-monic
+  where comp-is-monic = subst (isMonic C) (sym (S-comm f)) (s .snd)
+
+isPropSubObjMor : (s t : SubObjCat .ob) → isProp (SubObjCat [ s , t ])
+SliceHom.S-hom
+  (isPropSubObjMor
+    (sliceob incS , isMonicIncS)
+    (sliceob incT , isMonicIncT)
+    (slicehom x xComm)
+    (slicehom y yComm) i) =
+    isMonicIncT {a = x} {a' = y} (xComm ∙ sym  yComm) i
+SliceHom.S-comm
+  (isPropSubObjMor
+    (sliceob incS , isMonicIncS)
+    (sliceob incT , isMonicIncT)
+    (slicehom x xComm)
+    (slicehom y yComm) i) =
+    isProp→PathP (λ i → C .isSetHom (seq' C (isMonicIncT (xComm ∙ sym yComm) i) incT) incS) xComm yComm i
+
+isReflSubObjMor : (x : SubObjCat .ob) → SubObjCat [ x , x ]
+SliceHom.S-hom (isReflSubObjMor (sliceob inc , isMonicInc)) = C .id
+SliceHom.S-comm (isReflSubObjMor (sliceob inc , isMonicInc)) = C .⋆IdL inc
+
+isTransSubObjMor : (x y z : SubObjCat .ob) → SubObjCat [ x , y ] → SubObjCat [ y , z ] → SubObjCat [ x , z ]
+SliceHom.S-hom
+  (isTransSubObjMor
+    (sliceob incX , isMonicIncX)
+    (sliceob incY , isMonicIncY)
+    (sliceob incZ , isMonicIncZ)
+    (slicehom f fComm)
+    (slicehom g gComm)) = seq' C f g
+SliceHom.S-comm
+  (isTransSubObjMor
+    (sliceob incX , isMonicIncX)
+    (sliceob incY , isMonicIncY)
+    (sliceob incZ , isMonicIncZ)
+    (slicehom f fComm)
+    (slicehom g gComm)) =
+  seq' C (seq' C f g) incZ
+    ≡⟨ C .⋆Assoc f g incZ ⟩
+  seq' C f (seq' C g incZ)
+    ≡⟨ cong (λ x → seq' C f x) gComm ⟩
+  seq' C f incY
+    ≡⟨ fComm ⟩
+  incX
+    ∎
+
+module _ (isSetCOb : isSet (C .ob)) where
+  subObjCatPreorderStr : PreorderStr _ (SubObjCat .ob)
+  PreorderStr._≲_ subObjCatPreorderStr x y = SubObjCat [ x , y ]
+  IsPreorder.is-set (PreorderStr.isPreorder subObjCatPreorderStr) = isSetΣ (isSetSliceOb isSetCOb) λ x → isProp→isSet (∈-isProp isSubObj x)
+  IsPreorder.is-prop-valued (PreorderStr.isPreorder subObjCatPreorderStr) = isPropSubObjMor
+  IsPreorder.is-refl (PreorderStr.isPreorder subObjCatPreorderStr) = isReflSubObjMor
+  IsPreorder.is-trans (PreorderStr.isPreorder subObjCatPreorderStr) = isTransSubObjMor
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Equivalence.Base.html b/docs/Cubical.Categories.Equivalence.Base.html new file mode 100644 index 0000000..c8e799e --- /dev/null +++ b/docs/Cubical.Categories.Equivalence.Base.html @@ -0,0 +1,41 @@ + +Cubical.Categories.Equivalence.Base
{-# OPTIONS --safe #-}
+module Cubical.Categories.Equivalence.Base where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.HITs.PropositionalTruncation
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.NaturalTransformation
+
+open Category
+open Functor
+
+private
+  variable
+    ℓC ℓC' ℓD ℓD' : Level
+
+record WeakInverse {C : Category ℓC ℓC'} {D : Category ℓD ℓD'}
+                     (func : Functor C D) : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
+  field
+    invFunc : Functor D C
+
+    η : 𝟙⟨ C ⟩ ≅ᶜ invFunc ∘F func
+    ε : func ∘F invFunc ≅ᶜ 𝟙⟨ D ⟩
+
+-- I don't know of a good alternative representation of isEquivalence that
+-- avoids truncation in the general case.  If the categories are univalent, then
+-- an adjoint equivalence might be enough.
+isEquivalence : {C : Category ℓC ℓC'} {D : Category ℓD ℓD'}
+              → (func : Functor C D) → Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
+isEquivalence func = ∥ WeakInverse func ∥₁
+
+record _≃ᶜ_ (C : Category ℓC ℓC') (D : Category ℓD ℓD') :
+               Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
+  constructor equivᶜ
+  field
+    func : Functor C D
+    isEquiv : isEquivalence func
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Equivalence.Properties.html b/docs/Cubical.Categories.Equivalence.Properties.html new file mode 100644 index 0000000..66f319a --- /dev/null +++ b/docs/Cubical.Categories.Equivalence.Properties.html @@ -0,0 +1,203 @@ + +Cubical.Categories.Equivalence.Properties
{-# OPTIONS --safe #-}
+
+module Cubical.Categories.Equivalence.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+  renaming (isEquiv to isEquivMap)
+open import Cubical.Foundations.Equiv.Dependent
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Powerset
+open import Cubical.Data.Sigma
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.NaturalTransformation
+open import Cubical.Categories.Morphism
+open import Cubical.Categories.Equivalence.Base
+open import Cubical.HITs.PropositionalTruncation
+
+open Category
+open Functor
+open NatIso
+open isIso
+open WeakInverse
+
+private
+  variable
+    ℓC ℓC' ℓD ℓD' : Level
+
+-- Equivalence implies Full, Faithul, and Essentially Surjective
+
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
+  symWeakInverse : ∀ {F : Functor C D} → (e : WeakInverse F) → WeakInverse (e .invFunc)
+  symWeakInverse {F} record { invFunc = G ; η = η ; ε = ε } = record { invFunc = F ; η = symNatIso ε ; ε = symNatIso η }
+
+  isEquiv→Faithful : ∀ {F : Functor C D} → isEquivalence F → isFaithful F
+  isEquiv→Faithful {F} = rec (isPropΠ5 (λ _ _ _ _ _ → C .isSetHom _ _)) lifted
+    where
+      lifted : WeakInverse F → isFaithful F
+      lifted record { invFunc = G
+                              ; η = η
+                              ; ε = _ }
+                   c c' f g p = f
+                              ≡⟨ sqRL η ⟩
+                                cIso .fst ⋆⟨ C ⟩ G ⟪ F ⟪ f ⟫ ⟫ ⋆⟨ C ⟩ c'Iso .snd .inv
+                              ≡⟨ cong (λ v → cIso .fst ⋆⟨ C ⟩ (G ⟪ v ⟫) ⋆⟨ C ⟩ c'Iso .snd .inv) p ⟩
+                                cIso .fst ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ c'Iso .snd .inv
+                              ≡⟨ sym (sqRL η) ⟩
+                                g
+                              ∎
+         where
+           -- isomorphism between c and GFc
+          cIso = isIso→CatIso (η .nIso c)
+          -- isomorphism between c' and GFc'
+          c'Iso = isIso→CatIso (η .nIso c')
+
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
+  isEquiv→Full : ∀ {F : Functor C D} → isEquivalence F → isFull F
+  isEquiv→Full {F} = rec (isPropΠ3 (λ _ _ _ → isPropPropTrunc)) lifted
+    where
+      lifted : WeakInverse F → isFull F
+      lifted eq@record { invFunc = G
+                             ; η = η
+                             ; ε = _ }
+        c c' g = ∣ h , isEquiv→Faithful ∣ symWeakInverse eq ∣₁ _ _ _ _ GFh≡Gg ∣₁ -- apply faithfulness of G
+        where
+          -- isomorphism between c and GFc
+          cIso = isIso→CatIso (η .nIso c)
+          -- isomorphism between c' and GFc'
+          c'Iso = isIso→CatIso (η .nIso c')
+
+          -- reverses
+          cIso⁻ = symCatIso cIso
+          c'Iso⁻ = symCatIso c'Iso
+
+          h = cIso .fst ⋆⟨ C ⟩ G ⟪ g ⟫ ⋆⟨ C ⟩ c'Iso .snd .inv
+
+          -- we show that both `G ⟪ g ⟫` and `G ⟪ F ⟪ h ⟫ ⟫`
+          -- are equal to the same thing
+          -- namely : cIso .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .mor
+          Gg≡ηhη : G ⟪ g ⟫ ≡ cIso .snd .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .fst
+          Gg≡ηhη = invMoveL cAreInv move-c' ∙ sym (C .⋆Assoc _ _ _)
+            where
+              cAreInv : areInv _ (cIso .fst) (cIso .snd .inv)
+              cAreInv = CatIso→areInv cIso
+
+              c'AreInv : areInv _ (c'Iso .fst) (c'Iso .snd .inv)
+              c'AreInv = CatIso→areInv c'Iso
+
+              move-c' : cIso .fst ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ h ⋆⟨ C ⟩ c'Iso .fst
+              move-c' = invMoveR (symAreInv c'AreInv) refl
+
+          GFh≡Gg : G ⟪ F ⟪ h ⟫ ⟫ ≡ G ⟪ g ⟫
+          GFh≡Gg = G ⟪ F ⟪ h ⟫ ⟫
+                 ≡⟨ sqLR η ⟩
+                   cIso .snd .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .fst
+                 ≡⟨ sym Gg≡ηhη ⟩
+                   G ⟪ g ⟫
+                 ∎
+
+  isEquiv→FullyFaithful :  ∀ {F : Functor C D} → isEquivalence F → isFullyFaithful F
+  isEquiv→FullyFaithful {F = F} h = isFull+Faithful→isFullyFaithful {F = F} (isEquiv→Full h) (isEquiv→Faithful h)
+
+  isEquiv→Surj : ∀ {F : Functor C D} → isEquivalence F → isEssentiallySurj F
+  isEquiv→Surj = rec (isPropΠ (λ _ → isPropPropTrunc))
+    (λ wkInv d → ∣ (wkInv .invFunc ⟅ d ⟆) , isIso→CatIso ((wkInv .ε .nIso) d) ∣₁)
+
+
+-- A fully-faithful functor that induces equivalence on objects is an equivalence
+
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'}
+  {F : Functor C D} where
+
+  isFullyFaithful+isEquivF-ob→isEquiv : isFullyFaithful F → isEquivMap (F .F-ob) → isEquivalence F
+  isFullyFaithful+isEquivF-ob→isEquiv fullfaith isequiv = ∣ w ∣₁
+    where
+    open Iso
+    open IsoOver
+
+    MorC : C .ob × C .ob → Type _
+    MorC (x , y) = C [ x , y ]
+
+    MorD : D .ob × D .ob → Type _
+    MorD (x , y) = D [ x , y ]
+
+    F-Mor : ((x , y) : C .ob × C .ob) → C [ x , y ] → D [ F .F-ob x , F .F-ob y ]
+    F-Mor _ = F .F-hom
+
+    equiv-ob² : C .ob × C .ob ≃ D .ob × D .ob
+    equiv-ob² = ≃-× (_ , isequiv) (_ , isequiv)
+
+    iso-ob  = equivToIso (_ , isequiv)
+    iso-hom = equivOver→IsoOver {P = MorC} {Q = MorD} equiv-ob² F-Mor (λ (x , y) → fullfaith x y)
+
+    w-inv : Functor D C
+    w-inv .F-ob = iso-ob .inv
+    w-inv .F-hom = iso-hom .inv _
+    w-inv .F-id {x = x} = isFullyFaithful→Faithful {F = F} fullfaith _ _ _ _ (p ∙ sym (F .F-id))
+      where
+      p : _
+      p i =
+        comp
+        (λ j → D [ iso-ob .rightInv x (~ j) , iso-ob .rightInv x (~ j) ])
+        (λ j → λ
+          { (i = i0) → iso-hom .rightInv _ (D .id {x = x}) (~ j)
+          ; (i = i1) → D .id {x = iso-ob .rightInv x (~ j)} })
+        (D .id {x = x})
+    w-inv .F-seq {x = x} {z = z} f g = isFullyFaithful→Faithful {F = F} fullfaith _ _ _ _ (p ∙ sym (F .F-seq _ _))
+      where
+      p : _
+      p i =
+        comp
+        (λ j → D [ iso-ob .rightInv x (~ j) , iso-ob .rightInv z (~ j) ])
+        (λ j → λ
+          { (i = i0) → iso-hom .rightInv _ (f ⋆⟨ D ⟩ g) (~ j)
+          ; (i = i1) → iso-hom .rightInv _ f (~ j) ⋆⟨ D ⟩ iso-hom .rightInv _ g (~ j) })
+        (f ⋆⟨ D ⟩ g)
+
+    w-η-path : 𝟙⟨ C ⟩ ≡ w-inv ∘F F
+    w-η-path = Functor≡ (λ x → sym (retIsEq isequiv x)) (λ {x} {y} f → (λ i → iso-hom .leftInv (x , y) f (~ i)))
+
+    w-ε-path : F ∘F w-inv ≡ 𝟙⟨ D ⟩
+    w-ε-path = Functor≡ (λ x → secIsEq isequiv x) (λ {x} {y} f i → iso-hom .rightInv (x , y) f i)
+
+    w : WeakInverse F
+    w .invFunc = w-inv
+    w .η = pathToNatIso w-η-path
+    w .ε = pathToNatIso w-ε-path
+
+
+
+-- equivalence on full subcategories defined by propositions
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) (invF : WeakInverse F) where
+
+  open NatTrans
+  open _≃ᶜ_
+
+  private
+    F⁻¹ = invF .invFunc
+    ηᴱ = invF .η
+    εᴱ = invF .ε
+
+
+  ΣPropCatEquiv : {P : ℙ (ob C)} {Q : ℙ (ob D)}
+                → (presF : ∀ c → c ∈ P → F .F-ob c ∈ Q)
+                → (∀ d → d ∈ Q → F⁻¹ .F-ob d ∈ P)
+                → WeakInverse (ΣPropCatFunc {P = P} {Q = Q} F presF)
+
+  invFunc (ΣPropCatEquiv {P} {Q} _ presF⁻¹) = ΣPropCatFunc {P = Q} {Q = P} F⁻¹ presF⁻¹
+
+  N-ob (trans (η (ΣPropCatEquiv _ _))) (x , _) = ηᴱ .trans .N-ob x
+  N-hom (trans (η (ΣPropCatEquiv _ _))) f = ηᴱ .trans .N-hom f
+  inv (nIso (η (ΣPropCatEquiv _ _)) (x , _)) = ηᴱ .nIso x .inv
+  sec (nIso (η (ΣPropCatEquiv _ _)) (x , _)) = ηᴱ .nIso x .sec
+  ret (nIso (η (ΣPropCatEquiv _ _)) (x , _)) = ηᴱ .nIso x .ret
+
+  N-ob (trans (ε (ΣPropCatEquiv _ _))) (x , _) = εᴱ .trans .N-ob x
+  N-hom (trans (ε (ΣPropCatEquiv _ _))) f = εᴱ .trans .N-hom f
+  inv (nIso (ε (ΣPropCatEquiv _ _)) (x , _)) = εᴱ .nIso x .inv
+  sec (nIso (ε (ΣPropCatEquiv _ _)) (x , _)) = εᴱ .nIso x .sec
+  ret (nIso (ε (ΣPropCatEquiv _ _)) (x , _)) = εᴱ .nIso x .ret
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Equivalence.html b/docs/Cubical.Categories.Equivalence.html new file mode 100644 index 0000000..35b86d2 --- /dev/null +++ b/docs/Cubical.Categories.Equivalence.html @@ -0,0 +1,9 @@ + +Cubical.Categories.Equivalence
+{-# OPTIONS --safe #-}
+
+module Cubical.Categories.Equivalence where
+
+open import Cubical.Categories.Equivalence.Base public
+open import Cubical.Categories.Equivalence.Properties public
+
\ No newline at end of file diff --git a/docs/Cubical.Categories.Functor.Base.html b/docs/Cubical.Categories.Functor.Base.html index 9606cd6..0e922bb 100644 --- a/docs/Cubical.Categories.Functor.Base.html +++ b/docs/Cubical.Categories.Functor.Base.html @@ -28,25 +28,25 @@ F-hom : {x y : C .ob} → C [ x , y ] → D [ F-ob x , F-ob y ] F-id : {x : C .ob} → F-hom (C .id) ≡ D .id {x = F-ob x} F-seq : {x y z : C .ob} (f : C [ x , y ]) (g : C [ y , z ]) - → F-hom (f ⋆⟨ C ⟩ g) ≡ (F-hom f) ⋆⟨ D ⟩ (F-hom g) + → F-hom (f ⋆⟨ C ⟩ g) ≡ (F-hom f) ⋆⟨ D ⟩ (F-hom g) isFull = (x y : _) (F[f] : D [ F-ob x , F-ob y ]) → ∃[ f ∈ C [ x , y ] ] F-hom f ≡ F[f] isFaithful = (x y : _) (f g : C [ x , y ]) → F-hom f ≡ F-hom g → f ≡ g isFullyFaithful = (x y : _) → isEquiv (F-hom {x = x} {y = y}) - isEssentiallySurj = (d : D .ob) → ∃[ c ∈ C .ob ] CatIso D (F-ob c) d + isEssentiallySurj = (d : D .ob) → ∃[ c ∈ C .ob ] CatIso D (F-ob c) d -- preservation of commuting squares and triangles F-square : {x y u v : C .ob} {f : C [ x , y ]} {g : C [ x , u ]} {h : C [ u , v ]} {k : C [ y , v ]} - → f ⋆⟨ C ⟩ k ≡ g ⋆⟨ C ⟩ h - → (F-hom f) ⋆⟨ D ⟩ (F-hom k) ≡ (F-hom g) ⋆⟨ D ⟩ (F-hom h) + → f ⋆⟨ C ⟩ k ≡ g ⋆⟨ C ⟩ h + → (F-hom f) ⋆⟨ D ⟩ (F-hom k) ≡ (F-hom g) ⋆⟨ D ⟩ (F-hom h) F-square Csquare = sym (F-seq _ _) ∙∙ cong F-hom Csquare ∙∙ F-seq _ _ F-triangle : {x y z : C .ob} {f : C [ x , y ]} {g : C [ y , z ]} {h : C [ x , z ]} - → f ⋆⟨ C ⟩ g ≡ h - → (F-hom f) ⋆⟨ D ⟩ (F-hom g) ≡ (F-hom h) + → f ⋆⟨ C ⟩ g ≡ h + → (F-hom f) ⋆⟨ D ⟩ (F-hom g) ≡ (F-hom h) F-triangle Ctriangle = sym (F-seq _ _) ∙ cong F-hom Ctriangle private @@ -64,16 +64,16 @@ F-ob (Functor≡ hOb hHom i) c = hOb c i F-hom (Functor≡ hOb hHom i) f = hHom f i F-id (Functor≡ {C = C} {D = D} {F = F} {G = G} hOb hHom i) = - isProp→PathP (λ j → isSetHom D (hHom (C .id) j) (D .id)) (F-id F) (F-id G) i + isProp→PathP (λ j → isSetHom D (hHom (C .id) j) (D .id)) (F-id F) (F-id G) i F-seq (Functor≡ {C = C} {D = D} {F = F} {G = G} hOb hHom i) f g = - isProp→PathP (λ j → isSetHom D (hHom (f ⋆⟨ C ⟩ g) j) ((hHom f j) ⋆⟨ D ⟩ (hHom g j))) (F-seq F f g) (F-seq G f g) i + isProp→PathP (λ j → isSetHom D (hHom (f ⋆⟨ C ⟩ g) j) ((hHom f j) ⋆⟨ D ⟩ (hHom g j))) (F-seq F f g) (F-seq G f g) i FunctorSquare : {F₀₀ F₀₁ F₁₀ F₁₁ : Functor C D} (F₀₋ : F₀₀ ≡ F₀₁) (F₁₋ : F₁₀ ≡ F₁₁) (F₋₀ : F₀₀ ≡ F₁₀) (F₋₁ : F₀₁ ≡ F₁₁) - → Square (cong F-ob F₀₋) (cong F-ob F₁₋) (cong F-ob F₋₀) (cong F-ob F₋₁) - → Square F₀₋ F₁₋ F₋₀ F₋₁ + → Square (cong F-ob F₀₋) (cong F-ob F₁₋) (cong F-ob F₋₀) (cong F-ob F₋₁) + → Square F₀₋ F₁₋ F₋₀ F₋₁ FunctorSquare {C = C} {D = D} F₀₋ F₁₋ F₋₀ F₋₁ r = sqr where sqr : _ @@ -82,11 +82,11 @@ isSet→SquareP (λ i j → D .isSetHom {x = sqr i j .F-ob x} {y = sqr i j .F-ob y}) (λ i → F₀₋ i .F-hom f) (λ i → F₁₋ i .F-hom f) (λ i → F₋₀ i .F-hom f) (λ i → F₋₁ i .F-hom f) i j sqr i j .F-id {x = x} = - isSet→SquareP (λ i j → isProp→isSet (D .isSetHom (sqr i j .F-hom (C .id)) (D .id))) + isSet→SquareP (λ i j → isProp→isSet (D .isSetHom (sqr i j .F-hom (C .id)) (D .id))) (λ i → F₀₋ i .F-id) (λ i → F₁₋ i .F-id) (λ i → F₋₀ i .F-id) (λ i → F₋₁ i .F-id) i j sqr i j .F-seq f g = isSet→SquareP (λ i j → - isProp→isSet (D .isSetHom (sqr i j .F-hom (f ⋆⟨ C ⟩ g)) ((sqr i j .F-hom f) ⋆⟨ D ⟩ (sqr i j .F-hom g)))) + isProp→isSet (D .isSetHom (sqr i j .F-hom (f ⋆⟨ C ⟩ g)) ((sqr i j .F-hom f) ⋆⟨ D ⟩ (sqr i j .F-hom g)))) (λ i → F₀₋ i .F-seq f g) (λ i → F₁₋ i .F-seq f g) (λ i → F₋₀ i .F-seq f g) (λ i → F₋₁ i .F-seq f g) i j FunctorPath≡ : {F G : Functor C D}{p q : F ≡ G} → cong F-ob p ≡ cong F-ob q → p ≡ q @@ -122,7 +122,7 @@ Id : {C : Category ℓ ℓ'} → Functor C C Id = 𝟙⟨ _ ⟩ -forgetΣPropCat : (C : Category ℓ ℓ') (prop : ℙ (C .ob)) → Functor (ΣPropCat C prop) C +forgetΣPropCat : (C : Category ℓ ℓ') (prop : ℙ (C .ob)) → Functor (ΣPropCat C prop) C forgetΣPropCat _ _ .F-ob x = x .fst forgetΣPropCat _ _ .F-hom f = f forgetΣPropCat _ _ .F-id = refl @@ -145,14 +145,14 @@ funcCompOb≡ G F c = refl -_^opF : Functor C D → Functor (C ^op) (D ^op) +_^opF : Functor C D → Functor (C ^op) (D ^op) (F ^opF) .F-ob = F .F-ob (F ^opF) .F-hom = F .F-hom (F ^opF) .F-id = F .F-id (F ^opF) .F-seq f g = F .F-seq g f open Iso -Iso^opF : Iso (Functor C D) (Functor (C ^op) (D ^op)) +Iso^opF : Iso (Functor C D) (Functor (C ^op) (D ^op)) fun Iso^opF = _^opF inv Iso^opF = _^opF F-ob (rightInv Iso^opF b i) = F-ob b @@ -164,13 +164,13 @@ F-id (leftInv Iso^opF a i) = F-id a F-seq (leftInv Iso^opF a i) = F-seq a -^opFEquiv : Functor C D ≃ Functor (C ^op) (D ^op) +^opFEquiv : Functor C D ≃ Functor (C ^op) (D ^op) ^opFEquiv = isoToEquiv Iso^opF -- Functoriality on full subcategories defined by propositions ΣPropCatFunc : {P : ℙ (ob C)} {Q : ℙ (ob D)} (F : Functor C D) → (∀ c → c ∈ P → F .F-ob c ∈ Q) - → Functor (ΣPropCat C P) (ΣPropCat D Q) + → Functor (ΣPropCat C P) (ΣPropCat D Q) F-ob (ΣPropCatFunc F FPres) (c , c∈P) = F .F-ob c , FPres c c∈P F-hom (ΣPropCatFunc F FPres) = F .F-hom F-id (ΣPropCatFunc F FPres) = F .F-id diff --git a/docs/Cubical.Categories.Functor.Compose.html b/docs/Cubical.Categories.Functor.Compose.html index 617cf53..100f6bd 100644 --- a/docs/Cubical.Categories.Functor.Compose.html +++ b/docs/Cubical.Categories.Functor.Compose.html @@ -1,46 +1,46 @@ -Cubical.Categories.Functor.Compose
{-# OPTIONS --allow-unsolved-metas #-}
-
-module Cubical.Categories.Functor.Compose where
-
-open import Cubical.Foundations.Prelude
-
-open import Cubical.Categories.Category
-open import Cubical.Categories.Functor.Base
-open import Cubical.Categories.NaturalTransformation.Base
-
-open import Cubical.Categories.Instances.Functors
-
-module _ {ℓC ℓC' ℓD ℓD' ℓE ℓE'}
-  {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (E : Category ℓE ℓE')
-  (F : Functor C D)
-  where
-
-  open Functor
-  open NatTrans
-
-  precomposeF : Functor (FUNCTOR D E) (FUNCTOR C E)
-  precomposeF .F-ob G = funcComp G F
-  precomposeF .F-hom α .N-ob c = α .N-ob (F .F-ob c)
-  precomposeF .F-hom α .N-hom f = α .N-hom (F .F-hom f)
-  precomposeF .F-id = refl
-  precomposeF .F-seq f g = refl
-
-module _ {ℓC ℓC' ℓD ℓD' ℓE ℓE'}
-  (C : Category ℓC ℓC') {D : Category ℓD ℓD'} {E : Category ℓE ℓE'}
-  (G : Functor D E)
-  where
-
-  open Functor
-  open NatTrans
-
-  postcomposeF : Functor (FUNCTOR C D) (FUNCTOR C E)
-  postcomposeF .F-ob F = funcComp G F
-  postcomposeF .F-hom α .N-ob c = G. F-hom (α .N-ob c)
-  postcomposeF .F-hom {F₀} {F₁} α .N-hom {x} {y} f =
-    sym (G .F-seq (F₀ ⟪ f ⟫) (α ⟦ y ⟧))
-    ∙∙ cong (G ⟪_⟫) (α .N-hom f)
-    ∙∙ G .F-seq (α ⟦ x ⟧) (F₁ ⟪ f ⟫)
-  postcomposeF .F-id = makeNatTransPath (funExt λ _ → G .F-id)
-  postcomposeF .F-seq f g = makeNatTransPath (funExt λ _ → G .F-seq _ _)
+Cubical.Categories.Functor.Compose
{-# OPTIONS --safe #-}
+
+module Cubical.Categories.Functor.Compose where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor.Base
+open import Cubical.Categories.NaturalTransformation.Base
+
+open import Cubical.Categories.Instances.Functors
+
+module _ {ℓC ℓC' ℓD ℓD' ℓE ℓE'}
+  {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (E : Category ℓE ℓE')
+  (F : Functor C D)
+  where
+
+  open Functor
+  open NatTrans
+
+  precomposeF : Functor (FUNCTOR D E) (FUNCTOR C E)
+  precomposeF .F-ob G = funcComp G F
+  precomposeF .F-hom α .N-ob c = α .N-ob (F .F-ob c)
+  precomposeF .F-hom α .N-hom f = α .N-hom (F .F-hom f)
+  precomposeF .F-id = refl
+  precomposeF .F-seq f g = refl
+
+module _ {ℓC ℓC' ℓD ℓD' ℓE ℓE'}
+  (C : Category ℓC ℓC') {D : Category ℓD ℓD'} {E : Category ℓE ℓE'}
+  (G : Functor D E)
+  where
+
+  open Functor
+  open NatTrans
+
+  postcomposeF : Functor (FUNCTOR C D) (FUNCTOR C E)
+  postcomposeF .F-ob F = funcComp G F
+  postcomposeF .F-hom α .N-ob c = G. F-hom (α .N-ob c)
+  postcomposeF .F-hom {F₀} {F₁} α .N-hom {x} {y} f =
+    sym (G .F-seq (F₀ ⟪ f ⟫) (α ⟦ y ⟧))
+    ∙∙ cong (G ⟪_⟫) (α .N-hom f)
+    ∙∙ G .F-seq (α ⟦ x ⟧) (F₁ ⟪ f ⟫)
+  postcomposeF .F-id = makeNatTransPath (funExt λ _ → G .F-id)
+  postcomposeF .F-seq f g = makeNatTransPath (funExt λ _ → G .F-seq _ _)
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Functor.Properties.html b/docs/Cubical.Categories.Functor.Properties.html
index 5cd7e6e..875aae4 100644
--- a/docs/Cubical.Categories.Functor.Properties.html
+++ b/docs/Cubical.Categories.Functor.Properties.html
@@ -4,233 +4,264 @@
 module Cubical.Categories.Functor.Properties where
 
 open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.Equiv
-open import Cubical.Foundations.Equiv.Properties
-open import Cubical.Foundations.Function hiding (_∘_)
-open import Cubical.Foundations.GroupoidLaws using (lUnit; rUnit; assoc; cong-∙)
-open import Cubical.Foundations.HLevels
-open import Cubical.Functions.Surjection
-open import Cubical.Functions.Embedding
-open import Cubical.HITs.PropositionalTruncation as Prop
-open import Cubical.Data.Sigma
-open import Cubical.Categories.Category
-open import Cubical.Categories.Isomorphism
-open import Cubical.Categories.Morphism
-open import Cubical.Categories.Functor.Base
-
-
-private
-  variable
-    ℓ ℓ' ℓ'' : Level
-    B C D E : Category ℓ ℓ'
-
-open Category
-open Functor
-
-F-assoc : {F : Functor B C} {G : Functor C D} {H : Functor D E}
-        → H ∘F (G ∘F F) ≡ (H ∘F G) ∘F F
-F-assoc = Functor≡ (λ _ → refl) (λ _ → refl)
-
-
--- Results about functors
-
-module _ {F : Functor C D} where
-
-  -- the identity is the identity
-  F-lUnit : F ∘F 𝟙⟨ C ⟩ ≡ F
-  F-lUnit i .F-ob x = F ⟅ x ⟆
-  F-lUnit i .F-hom f = F ⟪ f ⟫
-  F-lUnit i .F-id {x} = lUnit (F .F-id) (~ i)
-  F-lUnit i .F-seq f g = lUnit (F .F-seq f g) (~ i)
-
-  F-rUnit : 𝟙⟨ D ⟩ ∘F F  ≡ F
-  F-rUnit i .F-ob x = F ⟅ x ⟆
-  F-rUnit i .F-hom f = F ⟪ f ⟫
-  F-rUnit i .F-id {x} = rUnit (F .F-id) (~ i)
-  F-rUnit i .F-seq f g = rUnit (F .F-seq f g) (~ i)
-
-  -- functors preserve commutative diagrams (specificallysqures here)
-  preserveCommF : ∀ {x y z w} {f : C [ x , y ]} {g : C [ y , w ]} {h : C [ x , z ]} {k : C [ z , w ]}
-                → f ⋆⟨ C ⟩ g ≡ h ⋆⟨ C ⟩ k
-                → (F ⟪ f ⟫) ⋆⟨ D ⟩ (F ⟪ g ⟫) ≡ (F ⟪ h ⟫) ⋆⟨ D ⟩ (F ⟪ k ⟫)
-  preserveCommF {f = f} {g = g} {h = h} {k = k} eq
-    = (F ⟪ f ⟫) ⋆⟨ D ⟩ (F ⟪ g ⟫)
-    ≡⟨ sym (F .F-seq _ _) ⟩
-      F ⟪ f ⋆⟨ C ⟩ g ⟫
-    ≡⟨ cong (F ⟪_⟫) eq ⟩
-      F ⟪ h ⋆⟨ C ⟩ k ⟫
-    ≡⟨ F .F-seq _ _ ⟩
-      (F ⟪ h ⟫) ⋆⟨ D ⟩ (F ⟪ k ⟫)
-    ∎
-
-  -- functors preserve isomorphisms
-  preserveIsosF : ∀ {x y} → CatIso C x y → CatIso D (F ⟅ x ⟆) (F ⟅ y ⟆)
-  preserveIsosF {x} {y} (f , isiso f⁻¹ sec' ret') =
-    catiso
-      g g⁻¹
-      -- sec
-      ( (g⁻¹ ⋆⟨ D ⟩ g)
-      ≡⟨ sym (F .F-seq f⁻¹ f) ⟩
-        F ⟪ f⁻¹ ⋆⟨ C ⟩ f ⟫
-      ≡⟨ cong (F .F-hom) sec' ⟩
-        F ⟪ C .id ⟫
-      ≡⟨ F .F-id ⟩
-        D .id
-      ∎ )
-      -- ret
-      ( (g ⋆⟨ D ⟩ g⁻¹)
-        ≡⟨ sym (F .F-seq f f⁻¹) ⟩
-      F ⟪ f ⋆⟨ C ⟩ f⁻¹ ⟫
-        ≡⟨ cong (F .F-hom) ret' ⟩
-      F ⟪ C .id ⟫
-      ≡⟨ F .F-id ⟩
-        D .id
-      ∎ )
-
-      where
-        x' : D .ob
-        x' = F ⟅ x ⟆
-        y' : D .ob
-        y' = F ⟅ y ⟆
-
-        g : D [ x' , y' ]
-        g = F ⟪ f ⟫
-        g⁻¹ : D [ y' , x' ]
-        g⁻¹ = F ⟪ f⁻¹ ⟫
-
-  -- hacky lemma helping with type inferences
-  functorCongP : {x y v w : ob C} {p : x ≡ y} {q : v ≡ w} {f : C [ x , v ]} {g : C [ y , w ]}
-               → PathP (λ i → C [ p i , q i ]) f g
-               → PathP (λ i → D [ F .F-ob (p i) , F. F-ob (q i) ]) (F .F-hom f) (F .F-hom g)
-  functorCongP r i = F .F-hom (r i)
-
-isSetFunctor : isSet (D .ob) → isSet (Functor C D)
-isSetFunctor {D = D} {C = C} isSet-D-ob F G p q = w
-  where
-    w : _
-    F-ob (w i i₁) = isSetΠ (λ _ → isSet-D-ob) _ _ (cong F-ob p) (cong F-ob q) i i₁
-    F-hom (w i i₁) z =
-     isSet→SquareP
-       (λ i i₁ → D .isSetHom {(F-ob (w i i₁) _)} {(F-ob (w i i₁) _)})
-        (λ i₁ → F-hom (p i₁) z) (λ i₁ → F-hom (q i₁) z) refl refl i i₁
-
-    F-id (w i i₁) =
-       isSet→SquareP
-       (λ i i₁ → isProp→isSet (D .isSetHom (F-hom (w i i₁) _) (D .id)))
-       (λ i₁ → F-id (p i₁)) (λ i₁ → F-id (q i₁)) refl refl i i₁
-
-    F-seq (w i i₁) _ _ =
-     isSet→SquareP
-       (λ i i₁ → isProp→isSet (D .isSetHom (F-hom (w i i₁) _) ((F-hom (w i i₁) _) ⋆⟨ D ⟩ (F-hom (w i i₁) _))))
-       (λ i₁ → F-seq (p i₁) _ _) (λ i₁ → F-seq (q i₁) _ _) refl refl i i₁
-
-
--- Conservative Functor,
--- namely if a morphism f is mapped to an isomorphism,
--- the morphism f is itself isomorphism.
-
-isConservative : (F : Functor C D) → Type _
-isConservative {C = C} {D = D} F = {x y : C .ob}{f : C [ x , y ]} → isIso D (F .F-hom f) → isIso C f
-
-
--- Fully-faithfulness of functors
-
-module _ {F : Functor C D} where
-
-  isFullyFaithful→Full : isFullyFaithful F → isFull F
-  isFullyFaithful→Full fullfaith x y = isEquiv→isSurjection (fullfaith x y)
-
-  isFullyFaithful→Faithful : isFullyFaithful F → isFaithful F
-  isFullyFaithful→Faithful fullfaith x y = isEmbedding→Inj (isEquiv→isEmbedding (fullfaith x y))
-
-  isFull+Faithful→isFullyFaithful : isFull F → isFaithful F → isFullyFaithful F
-  isFull+Faithful→isFullyFaithful full faith x y = isEmbedding×isSurjection→isEquiv
-    (injEmbedding (D .isSetHom) (faith x y _ _) , full x y)
-
-  isFaithful→reflectsMono : isFaithful F → {x y : C .ob} (f : C [ x , y ])
-    → isMonic D (F ⟪ f ⟫) → isMonic C f
-  isFaithful→reflectsMono F-faithful f Ff-mon {a = a} {a' = a'} a⋆f≡a'⋆f =
-    let Fa⋆Ff≡Fa'⋆Ff = sym (F .F-seq a f)
-                     ∙ cong (F ⟪_⟫) a⋆f≡a'⋆f
-                     ∙ F .F-seq a' f
-    in F-faithful _ _ _ _ (Ff-mon Fa⋆Ff≡Fa'⋆Ff)
-
-
-  -- Fully-faithful functor is conservative
-
-  open isIso
-
-  isFullyFaithful→Conservative : isFullyFaithful F → isConservative F
-  isFullyFaithful→Conservative fullfaith {x = x} {y = y} {f = f} isoFf = w
-    where
-    w : isIso C f
-    w .inv = invIsEq (fullfaith _ _) (isoFf .inv)
-    w .sec = isFullyFaithful→Faithful fullfaith _ _ _ _
-        (F .F-seq _ _
-      ∙ (λ i → secIsEq (fullfaith _ _) (isoFf .inv) i ⋆⟨ D ⟩ F .F-hom f)
-      ∙ isoFf .sec
-      ∙ sym (F .F-id))
-    w .ret = isFullyFaithful→Faithful fullfaith _ _ _ _
-        (F .F-seq _ _
-      ∙ (λ i → F .F-hom f ⋆⟨ D ⟩ secIsEq (fullfaith _ _) (isoFf .inv) i)
-      ∙ isoFf .ret
-      ∙ sym (F .F-id))
+import Cubical.Foundations.Isomorphism as Iso
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Function hiding (_∘_)
+open import Cubical.Foundations.GroupoidLaws using (lUnit; rUnit; assoc; cong-∙)
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Path
+open import Cubical.Functions.Surjection
+open import Cubical.Functions.Embedding
+open import Cubical.HITs.PropositionalTruncation as Prop
+open import Cubical.Data.Sigma
+open import Cubical.Data.Nat using (_+_)
+open import Cubical.Categories.Category
+open import Cubical.Categories.Isomorphism
+open import Cubical.Categories.Morphism
+open import Cubical.Categories.Functor.Base
+
+
+private
+  variable
+    ℓ ℓ' ℓ'' : Level
+    B C D E : Category ℓ ℓ'
+
+open Category
+open Functor
+
+F-assoc : {F : Functor B C} {G : Functor C D} {H : Functor D E}
+        → H ∘F (G ∘F F) ≡ (H ∘F G) ∘F F
+F-assoc = Functor≡ (λ _ → refl) (λ _ → refl)
+
+
+-- Results about functors
+
+module _ {F : Functor C D} where
+
+  -- the identity is the identity
+  F-lUnit : F ∘F 𝟙⟨ C ⟩ ≡ F
+  F-lUnit i .F-ob x = F ⟅ x ⟆
+  F-lUnit i .F-hom f = F ⟪ f ⟫
+  F-lUnit i .F-id {x} = lUnit (F .F-id) (~ i)
+  F-lUnit i .F-seq f g = lUnit (F .F-seq f g) (~ i)
+
+  F-rUnit : 𝟙⟨ D ⟩ ∘F F  ≡ F
+  F-rUnit i .F-ob x = F ⟅ x ⟆
+  F-rUnit i .F-hom f = F ⟪ f ⟫
+  F-rUnit i .F-id {x} = rUnit (F .F-id) (~ i)
+  F-rUnit i .F-seq f g = rUnit (F .F-seq f g) (~ i)
+
+  -- functors preserve commutative diagrams (specificallysqures here)
+  preserveCommF : ∀ {x y z w} {f : C [ x , y ]} {g : C [ y , w ]} {h : C [ x , z ]} {k : C [ z , w ]}
+                → f ⋆⟨ C ⟩ g ≡ h ⋆⟨ C ⟩ k
+                → (F ⟪ f ⟫) ⋆⟨ D ⟩ (F ⟪ g ⟫) ≡ (F ⟪ h ⟫) ⋆⟨ D ⟩ (F ⟪ k ⟫)
+  preserveCommF {f = f} {g = g} {h = h} {k = k} eq
+    = (F ⟪ f ⟫) ⋆⟨ D ⟩ (F ⟪ g ⟫)
+    ≡⟨ sym (F .F-seq _ _) ⟩
+      F ⟪ f ⋆⟨ C ⟩ g ⟫
+    ≡⟨ cong (F ⟪_⟫) eq ⟩
+      F ⟪ h ⋆⟨ C ⟩ k ⟫
+    ≡⟨ F .F-seq _ _ ⟩
+      (F ⟪ h ⟫) ⋆⟨ D ⟩ (F ⟪ k ⟫)
+    ∎
+
+  -- functors preserve isomorphisms
+  preserveIsosF : ∀ {x y} → CatIso C x y → CatIso D (F ⟅ x ⟆) (F ⟅ y ⟆)
+  preserveIsosF {x} {y} (f , isiso f⁻¹ sec' ret') =
+    catiso
+      g g⁻¹
+      -- sec
+      ( (g⁻¹ ⋆⟨ D ⟩ g)
+      ≡⟨ sym (F .F-seq f⁻¹ f) ⟩
+        F ⟪ f⁻¹ ⋆⟨ C ⟩ f ⟫
+      ≡⟨ cong (F .F-hom) sec' ⟩
+        F ⟪ C .id ⟫
+      ≡⟨ F .F-id ⟩
+        D .id
+      ∎ )
+      -- ret
+      ( (g ⋆⟨ D ⟩ g⁻¹)
+        ≡⟨ sym (F .F-seq f f⁻¹) ⟩
+      F ⟪ f ⋆⟨ C ⟩ f⁻¹ ⟫
+        ≡⟨ cong (F .F-hom) ret' ⟩
+      F ⟪ C .id ⟫
+      ≡⟨ F .F-id ⟩
+        D .id
+      ∎ )
+
+      where
+        x' : D .ob
+        x' = F ⟅ x ⟆
+        y' : D .ob
+        y' = F ⟅ y ⟆
+
+        g : D [ x' , y' ]
+        g = F ⟪ f ⟫
+        g⁻¹ : D [ y' , x' ]
+        g⁻¹ = F ⟪ f⁻¹ ⟫
+
+  -- hacky lemma helping with type inferences
+  functorCongP : {x y v w : ob C} {p : x ≡ y} {q : v ≡ w} {f : C [ x , v ]} {g : C [ y , w ]}
+               → PathP (λ i → C [ p i , q i ]) f g
+               → PathP (λ i → D [ F .F-ob (p i) , F. F-ob (q i) ]) (F .F-hom f) (F .F-hom g)
+  functorCongP r i = F .F-hom (r i)
+
+isEquivFunctor≡ : ∀ {F} {G} → isEquiv (uncurry (Functor≡ {C = C} {D = D} {F = F} {G = G}))
+isEquivFunctor≡ {C = C} {D = D} = Iso.isoToIsEquiv isom
+ where
+ open Iso.Iso
+ isom : Iso.Iso _ _
+ fun isom = _
+ inv isom x = (λ c i → F-ob (x i) c) , λ {c} {c'} f i → F-hom (x i) {c} {c'} f
+ F-ob (rightInv isom b _ i₁) = F-ob (b i₁)
+ F-hom (rightInv isom b _ i₁) = F-hom (b i₁)
+ F-id (rightInv isom b i i₁) = isProp→SquareP
+      (λ i i₁ → D .isSetHom (F-hom (b i₁) (C .id)) (D .id)) refl refl
+     (isProp→PathP (λ j → isSetHom D _ _) _ _) (λ i₁ → F-id (b i₁)) i i₁
+ F-seq (rightInv isom b i i₁) f g = isProp→SquareP
+     (λ i i₁ → D .isSetHom (F-hom (b i₁) _) (seq' D (F-hom (b i₁) f) _))
+     refl refl (isProp→PathP (λ j → isSetHom D _ _) _ _) (λ i₁ → F-seq (b i₁) f g) i i₁
+ leftInv isom _ = refl
+
+isOfHLevelFunctor : ∀ hLevel → isOfHLevel (2 + hLevel) (D .ob)
+                             → isOfHLevel (2 + hLevel) (Functor C D)
+isOfHLevelFunctor  {D = D} {C = C} hLevel x _ _ =
+ isOfHLevelRespectEquiv (1 + hLevel) (_ , isEquivFunctor≡)
+   (isOfHLevelΣ (1 + hLevel) (isOfHLevelΠ (1 + hLevel) (λ _ → x _ _))
+     λ _ → isOfHLevelPlus' 1 (isPropImplicitΠ2
+      λ _ _ → isPropΠ λ _ → isOfHLevelPathP' 1 (λ _ _ → D .isSetHom _ _) _ _ ))
+
+isSetFunctor : isSet (D .ob) → isSet (Functor C D)
+isSetFunctor = isOfHLevelFunctor 0
+
+-- Conservative Functor,
+-- namely if a morphism f is mapped to an isomorphism,
+-- the morphism f is itself isomorphism.
+
+isConservative : (F : Functor C D) → Type _
+isConservative {C = C} {D = D} F = {x y : C .ob}{f : C [ x , y ]} → isIso D (F .F-hom f) → isIso C f
+
+
+-- Fully-faithfulness of functors
+
+module _ {F : Functor C D} where
+
+  isFullyFaithful→Full : isFullyFaithful F → isFull F
+  isFullyFaithful→Full fullfaith x y = isEquiv→isSurjection (fullfaith x y)
+
+  isFullyFaithful→Faithful : isFullyFaithful F → isFaithful F
+  isFullyFaithful→Faithful fullfaith x y = isEmbedding→Inj (isEquiv→isEmbedding (fullfaith x y))
+
+  isFull+Faithful→isFullyFaithful : isFull F → isFaithful F → isFullyFaithful F
+  isFull+Faithful→isFullyFaithful full faith x y = isEmbedding×isSurjection→isEquiv
+    (injEmbedding (D .isSetHom) (faith x y _ _) , full x y)
+
+  isFaithful→reflectsMono : isFaithful F → {x y : C .ob} (f : C [ x , y ])
+    → isMonic D (F ⟪ f ⟫) → isMonic C f
+  isFaithful→reflectsMono F-faithful f Ff-mon {a = a} {a' = a'} a⋆f≡a'⋆f =
+    let Fa⋆Ff≡Fa'⋆Ff = sym (F .F-seq a f)
+                     ∙ cong (F ⟪_⟫) a⋆f≡a'⋆f
+                     ∙ F .F-seq a' f
+    in F-faithful _ _ _ _ (Ff-mon Fa⋆Ff≡Fa'⋆Ff)
+
+
+  -- Fully-faithful functor is conservative
+
+  open isIso
+
+  isFullyFaithful→Conservative : isFullyFaithful F → isConservative F
+  isFullyFaithful→Conservative fullfaith {x = x} {y = y} {f = f} isoFf = w
+    where
+    w : isIso C f
+    w .inv = invIsEq (fullfaith _ _) (isoFf .inv)
+    w .sec = isFullyFaithful→Faithful fullfaith _ _ _ _
+        (F .F-seq _ _
+      ∙ (λ i → secIsEq (fullfaith _ _) (isoFf .inv) i ⋆⟨ D ⟩ F .F-hom f)
+      ∙ isoFf .sec
+      ∙ sym (F .F-id))
+    w .ret = isFullyFaithful→Faithful fullfaith _ _ _ _
+        (F .F-seq _ _
+      ∙ (λ i → F .F-hom f ⋆⟨ D ⟩ secIsEq (fullfaith _ _) (isoFf .inv) i)
+      ∙ isoFf .ret
+      ∙ sym (F .F-id))
+
+  -- Lifting isomorphism upwards a fully faithful functor
+
+  module _ (fullfaith : isFullyFaithful F) where
+
+    liftIso : {x y : C .ob} → CatIso D (F .F-ob x) (F .F-ob y) → CatIso C x y
+    liftIso f .fst = invEq (_ , fullfaith _ _) (f .fst)
+    liftIso f .snd = isFullyFaithful→Conservative fullfaith (subst (isIso D) (sym (secEq (_ , fullfaith _ _) (f .fst))) (f .snd))
+
+    liftIso≡ : {x y : C .ob} → (f : CatIso D (F .F-ob x) (F .F-ob y)) → F-Iso {F = F} (liftIso f) ≡ f
+    liftIso≡ f = CatIso≡ _ _ (secEq (_ , fullfaith _ _) (f .fst))
+
+
+-- Functors inducing surjection on objects is essentially surjective
+
+isSurj-ob→isSurj : {F : Functor C D} → isSurjection (F .F-ob) → isEssentiallySurj F
+isSurj-ob→isSurj surj y = Prop.map (λ (x , p) → x , pathToIso p) (surj y)
+
+
+-- Fully-faithful functors induce equivalence on isomorphisms
 
-  -- Lifting isomorphism upwards a fully faithful functor
+isFullyFaithful→isEquivF-Iso : {F : Functor C D}
+  → isFullyFaithful F → ∀ x y → isEquiv (F-Iso {F = F} {x = x} {y = y})
+isFullyFaithful→isEquivF-Iso {F = F} fullfaith x y =
+  Σ-cong-equiv-prop (_ , fullfaith x y) isPropIsIso isPropIsIso _
+    (λ f → isFullyFaithful→Conservative {F = F} fullfaith {f = f}) .snd
 
-  module _ (fullfaith : isFullyFaithful F) where
 
-    liftIso : {x y : C .ob} → CatIso D (F .F-ob x) (F .F-ob y) → CatIso C x y
-    liftIso f .fst = invEq (_ , fullfaith _ _) (f .fst)
-    liftIso f .snd = isFullyFaithful→Conservative fullfaith (subst (isIso D) (sym (secEq (_ , fullfaith _ _) (f .fst))) (f .snd))
+-- Functors involving univalent categories
 
-    liftIso≡ : {x y : C .ob} → (f : CatIso D (F .F-ob x) (F .F-ob y)) → F-Iso {F = F} (liftIso f) ≡ f
-    liftIso≡ f = CatIso≡ _ _ (secEq (_ , fullfaith _ _) (f .fst))
+module _
+  (isUnivD : isUnivalent D)
+  where
 
+  open isUnivalent isUnivD
 
--- Functors inducing surjection on objects is essentially surjective
+  -- Essentially surjective functor with univalent target induces surjection on objects
 
-isSurj-ob→isSurj : {F : Functor C D} → isSurjection (F .F-ob) → isEssentiallySurj F
-isSurj-ob→isSurj surj y = Prop.map (λ (x , p) → x , pathToIso p) (surj y)
+  isSurj→isSurj-ob : {F : Functor C D} → isEssentiallySurj F → isSurjection (F .F-ob)
+  isSurj→isSurj-ob surj y = Prop.map (λ (x , f) → x , CatIsoToPath f) (surj y)
 
 
--- Fully-faithful functors induce equivalence on isomorphisms
+module _
+  (isUnivC : isUnivalent C)
+  (isUnivD : isUnivalent D)
+  {F : Functor C D}
+  where
 
-isFullyFaithful→isEquivF-Iso : {F : Functor C D}
-  → isFullyFaithful F → ∀ x y → isEquiv (F-Iso {F = F} {x = x} {y = y})
-isFullyFaithful→isEquivF-Iso {F = F} fullfaith x y =
-  Σ-cong-equiv-prop (_ , fullfaith x y) isPropIsIso isPropIsIso _
-    (λ f → isFullyFaithful→Conservative {F = F} fullfaith {f = f}) .snd
+  open isUnivalent
 
+  -- Fully-faithful functor between univalent target induces embedding on objects
 
--- Functors involving univalent categories
+  isFullyFaithful→isEmbd-ob : isFullyFaithful F → isEmbedding (F .F-ob)
+  isFullyFaithful→isEmbd-ob fullfaith x y =
+    isEquiv[equivFunA≃B∘f]→isEquiv[f] _ (_ , isUnivD .univ _ _)
+      (subst isEquiv (F-pathToIso-∘ {F = F})
+      (compEquiv (_ , isUnivC .univ _ _)
+        (_ , isFullyFaithful→isEquivF-Iso {F = F} fullfaith x y) .snd))
 
-module _
-  (isUnivD : isUnivalent D)
-  where
+TransportFunctor : (C ≡ D) → Functor C D
+F-ob (TransportFunctor p) = subst ob p
+F-hom (TransportFunctor p) {x} {y} =
+ transport λ i → cong Hom[_,_] p i
+   (transport-filler (cong ob p) x i)
+   (transport-filler (cong ob p) y i)
+F-id (TransportFunctor p) {x} i =
+  transp (λ jj → Hom[ p (i ∨ jj) , transport-filler (λ i₁ → ob (p i₁)) x (i ∨ jj) ]
+          (transport-filler (λ i₁ → ob (p i₁)) x (i ∨ jj))) i
+    (id (p i) {(transport-filler (cong ob p) x i)})
 
-  open isUnivalent isUnivD
-
-  -- Essentially surjective functor with univalent target induces surjection on objects
-
-  isSurj→isSurj-ob : {F : Functor C D} → isEssentiallySurj F → isSurjection (F .F-ob)
-  isSurj→isSurj-ob surj y = Prop.map (λ (x , f) → x , CatIsoToPath f) (surj y)
-
-
-module _
-  (isUnivC : isUnivalent C)
-  (isUnivD : isUnivalent D)
-  {F : Functor C D}
-  where
-
-  open isUnivalent
-
-  -- Fully-faithful functor between univalent target induces embedding on objects
-
-  isFullyFaithful→isEmbd-ob : isFullyFaithful F → isEmbedding (F .F-ob)
-  isFullyFaithful→isEmbd-ob fullfaith x y =
-    isEquiv[equivFunA≃B∘f]→isEquiv[f] _ (_ , isUnivD .univ _ _)
-      (subst isEquiv (F-pathToIso-∘ {F = F})
-      (compEquiv (_ , isUnivC .univ _ _)
-        (_ , isFullyFaithful→isEquivF-Iso {F = F} fullfaith x y) .snd))
+F-seq (TransportFunctor p) {x} {y} {z} f g i =
+  let q : ∀ {x y} → _ ≡ _
+      q = λ {x y} → λ i₁ →
+             Hom[ p i₁ , transport-filler (λ i₂ → ob (p i₂)) x i₁ ]
+                        (transport-filler (λ i₂ → ob (p i₂)) y i₁)
+  in transp (λ jj → Hom[ p (i ∨ jj)
+       , transport-filler (λ i₁ → ob (p i₁)) x (i ∨ jj) ]
+        (transport-filler (λ i₁ → ob (p i₁)) z (i ∨ jj))) i
+     (_⋆_ (p i) (transport-filler q f i) (transport-filler q g i))
\ No newline at end of file diff --git a/docs/Cubical.Categories.Functor.html b/docs/Cubical.Categories.Functor.html index 369e874..a696234 100644 --- a/docs/Cubical.Categories.Functor.html +++ b/docs/Cubical.Categories.Functor.html @@ -1,9 +1,9 @@ -Cubical.Categories.Functor
{-# OPTIONS --allow-unsolved-metas #-}
+Cubical.Categories.Functor
{-# OPTIONS --safe #-}
 
-module Cubical.Categories.Functor where
+module Cubical.Categories.Functor where
 
-open import Cubical.Categories.Functor.Base public
-open import Cubical.Categories.Functor.Compose public
-open import Cubical.Categories.Functor.Properties public
+open import Cubical.Categories.Functor.Base public
+open import Cubical.Categories.Functor.Compose public
+open import Cubical.Categories.Functor.Properties public
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Instances.Cospan.html b/docs/Cubical.Categories.Instances.Cospan.html
index 9c9b56f..42b70a6 100644
--- a/docs/Cubical.Categories.Instances.Cospan.html
+++ b/docs/Cubical.Categories.Instances.Cospan.html
@@ -66,7 +66,7 @@
 
 
 -- makes it easier to write functors into CospanCat
-isPropHomCospanCat : (x y : ob CospanCat) → isProp (CospanCat [ x , y ])
+isPropHomCospanCat : (x y : ob CospanCat) → isProp (CospanCat [ x , y ])
 isPropHomCospanCat ⓪ ⓪ = isPropUnit
 isPropHomCospanCat ⓪ ① = isPropUnit
 isPropHomCospanCat ⓪ ② = isProp⊥
diff --git a/docs/Cubical.Categories.Instances.Functors.html b/docs/Cubical.Categories.Instances.Functors.html
index d87eccc..f5a25ee 100644
--- a/docs/Cubical.Categories.Instances.Functors.html
+++ b/docs/Cubical.Categories.Instances.Functors.html
@@ -1,173 +1,142 @@
 
-Cubical.Categories.Instances.Functors
{-# OPTIONS --allow-unsolved-metas #-}
+Cubical.Categories.Instances.Functors
{-# OPTIONS --safe #-}
 
-{-
+{-
    Category whose objects are functors and morphisms are natural transformations.
 
    Includes the following
    - isos in FUNCTOR are precisely the pointwise isos
    - FUNCTOR C D is univalent when D is
-   - currying of functors
 
-   TODO: show that currying of functors is an isomorphism.
 -}
 
-module Cubical.Categories.Instances.Functors where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.Equiv
-open import Cubical.Foundations.Equiv.Properties
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Isomorphism
-
-open import Cubical.Categories.Category renaming (isIso to isIsoC)
-open import Cubical.Categories.Constructions.BinProduct
-open import Cubical.Categories.Functor.Base
-open import Cubical.Categories.Morphism
-open import Cubical.Categories.NaturalTransformation.Base
-open import Cubical.Categories.NaturalTransformation.Properties
-
-private
-  variable
-    ℓC ℓC' ℓD ℓD' ℓE ℓE' : Level
-
-module _ (C : Category ℓC ℓC') (D : Category ℓD ℓD') where
-  open Category
-  open NatTrans
-  open Functor
-
-  FUNCTOR : Category (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) (ℓ-max (ℓ-max ℓC ℓC') ℓD')
-  ob FUNCTOR           = Functor C D
-  Hom[_,_] FUNCTOR     = NatTrans
-  id FUNCTOR {F}       = idTrans F
-  _⋆_ FUNCTOR          = seqTrans
-  ⋆IdL FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdL (α .N-ob x) i
-  ⋆IdR FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdR (α .N-ob x) i
-  ⋆Assoc FUNCTOR α β γ = makeNatTransPath λ i x → D .⋆Assoc (α .N-ob x) (β .N-ob x) (γ .N-ob x) i
-  isSetHom FUNCTOR     = isSetNatTrans
-
-  open isIsoC renaming (inv to invC)
-  -- componentwise iso is an iso in Functor
-  FUNCTORIso : ∀ {F G : Functor C D} (α : F ⇒ G)
-             → (∀ (c : C .ob) → isIsoC D (α ⟦ c ⟧))
-             → isIsoC FUNCTOR α
-  FUNCTORIso α is .invC .N-ob c = (is c) .invC
-  FUNCTORIso {F} {G} α is .invC .N-hom {c} {d} f
-    = invMoveL areInv-αc
-               ( α ⟦ c ⟧ ⋆⟨ D ⟩ (G ⟪ f ⟫ ⋆⟨ D ⟩ is d .invC)
-               ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
-                 (α ⟦ c ⟧ ⋆⟨ D ⟩ G ⟪ f ⟫) ⋆⟨ D ⟩ is d .invC
-               ≡⟨ sym (invMoveR areInv-αd (α .N-hom f)) ⟩
-                 F ⟪ f ⟫
-               ∎ )
-    where
-      areInv-αc : areInv _ (α ⟦ c ⟧) ((is c) .invC)
-      areInv-αc = isIso→areInv (is c)
-
-      areInv-αd : areInv _ (α ⟦ d ⟧) ((is d) .invC)
-      areInv-αd = isIso→areInv (is d)
-  FUNCTORIso α is .sec = makeNatTransPath (funExt (λ c → (is c) .sec))
-  FUNCTORIso α is .ret = makeNatTransPath (funExt (λ c → (is c) .ret))
-
-  -- iso is componentwise iso in Functor
-  FUNCTORIso' : ∀ {F G : Functor C D} (α : F ⇒ G)
-             → isIsoC FUNCTOR α
-             → ((c : C .ob) → isIsoC D (α ⟦ c ⟧))
-  FUNCTORIso' α isom c .invC = isom .invC .N-ob c
-  FUNCTORIso' α isom c .sec i = isom .sec i .N-ob c
-  FUNCTORIso' α isom c .ret i = isom .ret i .N-ob c
-
-  open Iso
-  open NatIso
-
-  FUNCTORIso→NatIso : {F G : Functor C D} → CatIso FUNCTOR F G → NatIso F G
-  FUNCTORIso→NatIso α .trans = α .fst
-  FUNCTORIso→NatIso α .nIso = FUNCTORIso' _ (α .snd)
-
-  NatIso→FUNCTORIso : {F G : Functor C D} → NatIso F G → CatIso FUNCTOR F G
-  NatIso→FUNCTORIso α = α .trans , FUNCTORIso _ (α .nIso)
-
-  Path→FUNCTORIso→NatIso : {F G : Functor C D} → (p : F ≡ G) → pathToNatIso p ≡ FUNCTORIso→NatIso (pathToIso p)
-  Path→FUNCTORIso→NatIso {F = F} p = J (λ _ p → pathToNatIso p ≡ FUNCTORIso→NatIso (pathToIso p)) (NatIso≡ refl-helper) p
-    where
-    refl-helper : _
-    refl-helper i x = ((λ i → pathToIso-refl {C = D} {x = F .F-ob x} i .fst)
-      ∙ (λ i → pathToIso-refl {C = FUNCTOR} {x = F} (~ i) .fst .N-ob x)) i
-
-  Iso-FUNCTORIso-NatIso : {F G : Functor C D} → Iso (CatIso FUNCTOR F G) (NatIso F G)
-  Iso-FUNCTORIso-NatIso .fun = FUNCTORIso→NatIso
-  Iso-FUNCTORIso-NatIso .inv = NatIso→FUNCTORIso
-  Iso-FUNCTORIso-NatIso .rightInv α i .trans = α .trans
-  Iso-FUNCTORIso-NatIso .rightInv α i .nIso =
-    isProp→PathP (λ i → isPropΠ (λ _ → isPropIsIso _)) (FUNCTORIso' (α .trans) (FUNCTORIso _ (α .nIso))) (α .nIso) i
-  Iso-FUNCTORIso-NatIso .leftInv α i .fst = α .fst
-  Iso-FUNCTORIso-NatIso .leftInv α i .snd =
-    isProp→PathP (λ i → isPropIsIso _) (FUNCTORIso _ (FUNCTORIso' _ (α .snd))) (α .snd) i
-
-  FUNCTORIso≃NatIso : {F G : Functor C D} → CatIso FUNCTOR F G ≃ NatIso F G
-  FUNCTORIso≃NatIso = isoToEquiv Iso-FUNCTORIso-NatIso
-
-
-  -- Functor Category is Univalent if the Target Category is Univalent
-
-  open isUnivalent
-
-  isUnivalentFUNCTOR : isUnivalent D → isUnivalent FUNCTOR
-  isUnivalentFUNCTOR isUnivD .univ _ _ =
-    isEquiv[equivFunA≃B∘f]→isEquiv[f] _ FUNCTORIso≃NatIso
-      (subst isEquiv (λ i p → Path→FUNCTORIso→NatIso p i) (Path≃NatIso isUnivD .snd))
-
-  appF : Functor (FUNCTOR ×C C) D
-  appF .F-ob (F , c) = F ⟅ c ⟆
-  appF .F-hom {F , c} {G , d} (α , f) = α .N-ob d ∘⟨ D ⟩ F .F-hom f
-  appF .F-id {F , c} =
-    D .id ∘⟨ D ⟩ F .F-hom (C .id) ≡⟨ D .⋆IdR (F .F-hom (C .id)) ⟩
-    F .F-hom (C .id) ≡⟨ F .F-id ⟩
-    D .id ∎
-  appF .F-seq {F , c}{G , d}{H , e} (α , f) (β , g ) =
-    (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ F .F-hom (g ∘⟨ C ⟩ f)
-      ≡⟨ (λ i → (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ F .F-seq f g i) ⟩
-    (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ (F .F-hom g ∘⟨ D ⟩ F .F-hom f)
-      ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
-    β .N-ob e ∘⟨ D ⟩ (α .N-ob e ∘⟨ D ⟩ (F .F-hom g ∘⟨ D ⟩ F .F-hom f))
-      ≡⟨ (λ i → β .N-ob e
-                ∘⟨ D ⟩ D .⋆Assoc (F .F-hom f) (F .F-hom g) (α .N-ob e) i) ⟩
-    β .N-ob e ∘⟨ D ⟩ ((α .N-ob e ∘⟨ D ⟩ F .F-hom g) ∘⟨ D ⟩ F .F-hom f)
-      ≡⟨ (λ i → β .N-ob e ∘⟨ D ⟩ α .N-hom g i ∘⟨ D ⟩ F .F-hom f) ⟩
-    β .N-ob e ∘⟨ D ⟩ ((G .F-hom g ∘⟨ D ⟩ α .N-ob d) ∘⟨ D ⟩ F .F-hom f)
-      ≡⟨ (λ i → β .N-ob e
-                ∘⟨ D ⟩ D .⋆Assoc (F .F-hom f) (α .N-ob d) (G .F-hom g) (~ i) ) ⟩
-    β .N-ob e ∘⟨ D ⟩ (G .F-hom g ∘⟨ D ⟩ (α .N-ob d ∘⟨ D ⟩ F .F-hom f))
-      ≡⟨ D .⋆Assoc _ _ _ ⟩
-    (β .N-ob e ∘⟨ D ⟩ G .F-hom g) ∘⟨ D ⟩ (α .N-ob d ∘⟨ D ⟩ F .F-hom f) ∎
-  module _ (E : Category ℓE ℓE') where
-    λF : Functor (E ×C C) D → Functor E FUNCTOR
-    λF F .F-ob e .F-ob c = F ⟅ e , c ⟆
-    λF F .F-ob e .F-hom f = F ⟪ (E .id) , f ⟫
-    λF F .F-ob e .F-id = F .F-id
-    λF F .F-ob e .F-seq f g =
-      F ⟪ E .id , g ∘⟨ C ⟩ f ⟫
-        ≡⟨ (λ i → F ⟪ (E .⋆IdL (E .id) (~ i)) , (g ∘⟨ C ⟩ f) ⟫) ⟩
-      (F ⟪ (E .id ∘⟨ E ⟩ E .id) , g ∘⟨ C ⟩ f ⟫)
-        ≡⟨ F .F-seq (E .id , f) (E .id , g) ⟩
-      (F ⟪ E .id , g ⟫ ∘⟨ D ⟩ F ⟪ E .id , f ⟫) ∎
-    λF F .F-hom h .N-ob c = F ⟪ h , (C .id) ⟫
-    λF F .F-hom h .N-hom f =
-      F ⟪ h , C .id ⟫ ∘⟨ D ⟩ F ⟪ E .id , f ⟫ ≡⟨ sym (F .F-seq _ _) ⟩
-      F ⟪ h ∘⟨ E ⟩ E .id , C .id ∘⟨ C ⟩ f ⟫
-        ≡⟨ (λ i → F ⟪ E .⋆IdL h i , C .⋆IdR f i  ⟫) ⟩
-      F ⟪ h , f ⟫ ≡⟨ (λ i → F ⟪ (E .⋆IdR h (~ i)) , (C .⋆IdL f (~ i)) ⟫) ⟩
-      F ⟪ E .id ∘⟨ E ⟩ h , f ∘⟨ C ⟩ C .id ⟫ ≡⟨ F .F-seq _ _ ⟩
-      F ⟪ E .id , f ⟫ ∘⟨ D ⟩ F ⟪ h , C .id ⟫ ∎
-    λF F .F-id = makeNatTransPath (funExt λ c → F .F-id)
-    λF F .F-seq f g = makeNatTransPath (funExt lem) where
-      lem : (c : C .ob) →
-            F ⟪ g ∘⟨ E ⟩ f , C .id ⟫ ≡
-            F ⟪ g , C .id ⟫ ∘⟨ D ⟩ F ⟪ f , C .id ⟫
-      lem c =
-        F ⟪ g ∘⟨ E ⟩ f , C .id ⟫
-          ≡⟨ (λ i → F ⟪ (g ∘⟨ E ⟩ f) , (C .⋆IdR (C .id) (~ i)) ⟫) ⟩
-        F ⟪ g ∘⟨ E ⟩ f , C .id ∘⟨ C ⟩ C .id ⟫
-          ≡⟨ F .F-seq (f , C .id) (g , C .id) ⟩
-        (F ⟪ g , C .id ⟫) ∘⟨ D ⟩ (F ⟪ f , C .id ⟫) ∎
+module Cubical.Categories.Instances.Functors where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+
+open import Cubical.Categories.Category renaming (isIso to isIsoC)
+open import Cubical.Categories.Constructions.BinProduct
+open import Cubical.Categories.Functor.Base
+open import Cubical.Categories.Morphism
+open import Cubical.Categories.NaturalTransformation.Base
+open import Cubical.Categories.NaturalTransformation.Properties
+
+private
+  variable
+    ℓC ℓC' ℓD ℓD' ℓE ℓE' : Level
+
+module _ (C : Category ℓC ℓC') (D : Category ℓD ℓD') where
+  open Category
+  open NatTrans
+  open Functor
+
+  FUNCTOR : Category (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) (ℓ-max (ℓ-max ℓC ℓC') ℓD')
+  ob FUNCTOR           = Functor C D
+  Hom[_,_] FUNCTOR     = NatTrans
+  id FUNCTOR {F}       = idTrans F
+  _⋆_ FUNCTOR          = seqTrans
+  ⋆IdL FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdL (α .N-ob x) i
+  ⋆IdR FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdR (α .N-ob x) i
+  ⋆Assoc FUNCTOR α β γ = makeNatTransPath λ i x → D .⋆Assoc (α .N-ob x) (β .N-ob x) (γ .N-ob x) i
+  isSetHom FUNCTOR     = isSetNatTrans
+
+  open isIsoC renaming (inv to invC)
+  -- componentwise iso is an iso in Functor
+  FUNCTORIso : ∀ {F G : Functor C D} (α : F ⇒ G)
+             → (∀ (c : C .ob) → isIsoC D (α ⟦ c ⟧))
+             → isIsoC FUNCTOR α
+  FUNCTORIso α is .invC .N-ob c = (is c) .invC
+  FUNCTORIso {F} {G} α is .invC .N-hom {c} {d} f
+    = invMoveL areInv-αc
+               ( α ⟦ c ⟧ ⋆⟨ D ⟩ (G ⟪ f ⟫ ⋆⟨ D ⟩ is d .invC)
+               ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
+                 (α ⟦ c ⟧ ⋆⟨ D ⟩ G ⟪ f ⟫) ⋆⟨ D ⟩ is d .invC
+               ≡⟨ sym (invMoveR areInv-αd (α .N-hom f)) ⟩
+                 F ⟪ f ⟫
+               ∎ )
+    where
+      areInv-αc : areInv _ (α ⟦ c ⟧) ((is c) .invC)
+      areInv-αc = isIso→areInv (is c)
+
+      areInv-αd : areInv _ (α ⟦ d ⟧) ((is d) .invC)
+      areInv-αd = isIso→areInv (is d)
+  FUNCTORIso α is .sec = makeNatTransPath (funExt (λ c → (is c) .sec))
+  FUNCTORIso α is .ret = makeNatTransPath (funExt (λ c → (is c) .ret))
+
+  -- iso is componentwise iso in Functor
+  FUNCTORIso' : ∀ {F G : Functor C D} (α : F ⇒ G)
+             → isIsoC FUNCTOR α
+             → ((c : C .ob) → isIsoC D (α ⟦ c ⟧))
+  FUNCTORIso' α isom c .invC = isom .invC .N-ob c
+  FUNCTORIso' α isom c .sec i = isom .sec i .N-ob c
+  FUNCTORIso' α isom c .ret i = isom .ret i .N-ob c
+
+  open Iso
+  open NatIso
+
+  FUNCTORIso→NatIso : {F G : Functor C D} → CatIso FUNCTOR F G → NatIso F G
+  FUNCTORIso→NatIso α .trans = α .fst
+  FUNCTORIso→NatIso α .nIso = FUNCTORIso' _ (α .snd)
+
+  NatIso→FUNCTORIso : {F G : Functor C D} → NatIso F G → CatIso FUNCTOR F G
+  NatIso→FUNCTORIso α = α .trans , FUNCTORIso _ (α .nIso)
+
+  Path→FUNCTORIso→NatIso : {F G : Functor C D} → (p : F ≡ G) → pathToNatIso p ≡ FUNCTORIso→NatIso (pathToIso p)
+  Path→FUNCTORIso→NatIso {F = F} p = J (λ _ p → pathToNatIso p ≡ FUNCTORIso→NatIso (pathToIso p)) (NatIso≡ refl-helper) p
+    where
+    refl-helper : _
+    refl-helper i x = ((λ i → pathToIso-refl {C = D} {x = F .F-ob x} i .fst)
+      ∙ (λ i → pathToIso-refl {C = FUNCTOR} {x = F} (~ i) .fst .N-ob x)) i
+
+  Iso-FUNCTORIso-NatIso : {F G : Functor C D} → Iso (CatIso FUNCTOR F G) (NatIso F G)
+  Iso-FUNCTORIso-NatIso .fun = FUNCTORIso→NatIso
+  Iso-FUNCTORIso-NatIso .inv = NatIso→FUNCTORIso
+  Iso-FUNCTORIso-NatIso .rightInv α i .trans = α .trans
+  Iso-FUNCTORIso-NatIso .rightInv α i .nIso =
+    isProp→PathP (λ i → isPropΠ (λ _ → isPropIsIso _)) (FUNCTORIso' (α .trans) (FUNCTORIso _ (α .nIso))) (α .nIso) i
+  Iso-FUNCTORIso-NatIso .leftInv α i .fst = α .fst
+  Iso-FUNCTORIso-NatIso .leftInv α i .snd =
+    isProp→PathP (λ i → isPropIsIso _) (FUNCTORIso _ (FUNCTORIso' _ (α .snd))) (α .snd) i
+
+  FUNCTORIso≃NatIso : {F G : Functor C D} → CatIso FUNCTOR F G ≃ NatIso F G
+  FUNCTORIso≃NatIso = isoToEquiv Iso-FUNCTORIso-NatIso
+
+
+  -- Functor Category is Univalent if the Target Category is Univalent
+
+  open isUnivalent
+
+  isUnivalentFUNCTOR : isUnivalent D → isUnivalent FUNCTOR
+  isUnivalentFUNCTOR isUnivD .univ _ _ =
+    isEquiv[equivFunA≃B∘f]→isEquiv[f] _ FUNCTORIso≃NatIso
+      (subst isEquiv (λ i p → Path→FUNCTORIso→NatIso p i) (Path≃NatIso isUnivD .snd))
+
+  appF : Functor (FUNCTOR ×C C) D
+  appF .F-ob (F , c) = F ⟅ c ⟆
+  appF .F-hom {F , c} {G , d} (α , f) = α .N-ob d ∘⟨ D ⟩ F .F-hom f
+  appF .F-id {F , c} =
+    D .id ∘⟨ D ⟩ F .F-hom (C .id) ≡⟨ D .⋆IdR (F .F-hom (C .id)) ⟩
+    F .F-hom (C .id) ≡⟨ F .F-id ⟩
+    D .id ∎
+  appF .F-seq {F , c}{G , d}{H , e} (α , f) (β , g ) =
+    (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ F .F-hom (g ∘⟨ C ⟩ f)
+      ≡⟨ (λ i → (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ F .F-seq f g i) ⟩
+    (β .N-ob e ∘⟨ D ⟩ α .N-ob e) ∘⟨ D ⟩ (F .F-hom g ∘⟨ D ⟩ F .F-hom f)
+      ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
+    β .N-ob e ∘⟨ D ⟩ (α .N-ob e ∘⟨ D ⟩ (F .F-hom g ∘⟨ D ⟩ F .F-hom f))
+      ≡⟨ (λ i → β .N-ob e
+                ∘⟨ D ⟩ D .⋆Assoc (F .F-hom f) (F .F-hom g) (α .N-ob e) i) ⟩
+    β .N-ob e ∘⟨ D ⟩ ((α .N-ob e ∘⟨ D ⟩ F .F-hom g) ∘⟨ D ⟩ F .F-hom f)
+      ≡⟨ (λ i → β .N-ob e ∘⟨ D ⟩ α .N-hom g i ∘⟨ D ⟩ F .F-hom f) ⟩
+    β .N-ob e ∘⟨ D ⟩ ((G .F-hom g ∘⟨ D ⟩ α .N-ob d) ∘⟨ D ⟩ F .F-hom f)
+      ≡⟨ (λ i → β .N-ob e
+                ∘⟨ D ⟩ D .⋆Assoc (F .F-hom f) (α .N-ob d) (G .F-hom g) (~ i) ) ⟩
+    β .N-ob e ∘⟨ D ⟩ (G .F-hom g ∘⟨ D ⟩ (α .N-ob d ∘⟨ D ⟩ F .F-hom f))
+      ≡⟨ D .⋆Assoc _ _ _ ⟩
+    (β .N-ob e ∘⟨ D ⟩ G .F-hom g) ∘⟨ D ⟩ (α .N-ob d ∘⟨ D ⟩ F .F-hom f) ∎
+
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Instances.Sets.html b/docs/Cubical.Categories.Instances.Sets.html
new file mode 100644
index 0000000..327af33
--- /dev/null
+++ b/docs/Cubical.Categories.Instances.Sets.html
@@ -0,0 +1,139 @@
+
+Cubical.Categories.Instances.Sets
{-# OPTIONS --safe #-}
+
+module Cubical.Categories.Instances.Sets where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.Properties
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Data.Unit
+open import Cubical.Data.Sigma
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.NaturalTransformation
+
+open import Cubical.Categories.Limits
+
+open Category
+
+module _ ℓ where
+  SET : Category (ℓ-suc ℓ) ℓ
+  ob SET = hSet ℓ
+  Hom[_,_] SET (A , _) (B , _) = A → B
+  id SET x = x
+  _⋆_ SET f g x = g (f x)
+  ⋆IdL SET f = refl
+  ⋆IdR SET f = refl
+  ⋆Assoc SET f g h = refl
+  isSetHom SET {A} {B} = isSetΠ (λ _ → snd B)
+
+private
+  variable
+    ℓ ℓ' : Level
+
+open Functor
+
+-- Hom functors
+_[-,_] : (C : Category ℓ ℓ') → (c : C .ob) → Functor (C ^op) (SET ℓ')
+(C [-, c ]) .F-ob x    = (C [ x , c ]) , C .isSetHom
+(C [-, c ]) .F-hom f k = f ⋆⟨ C ⟩ k
+(C [-, c ]) .F-id      = funExt λ _ → C .⋆IdL _
+(C [-, c ]) .F-seq _ _ = funExt λ _ → C .⋆Assoc _ _ _
+
+_[_,-] : (C : Category ℓ ℓ') → (c : C .ob)→ Functor C (SET ℓ')
+(C [ c ,-]) .F-ob x    = (C [ c , x ]) , C .isSetHom
+(C [ c ,-]) .F-hom f k = k ⋆⟨ C ⟩ f
+(C [ c ,-]) .F-id      = funExt λ _ → C .⋆IdR _
+(C [ c ,-]) .F-seq _ _ = funExt λ _ → sym (C .⋆Assoc _ _ _)
+
+-- Lift functor
+LiftF : Functor (SET ℓ) (SET (ℓ-max ℓ ℓ'))
+LiftF {ℓ}{ℓ'} .F-ob A = (Lift {ℓ}{ℓ'} (A .fst)) , isOfHLevelLift 2 (A .snd)
+LiftF .F-hom f x = lift (f (x .lower))
+LiftF .F-id = refl
+LiftF .F-seq f g = funExt λ x → refl
+
+module _ {C : Category ℓ ℓ'} {F : Functor C (SET ℓ')} where
+  open NatTrans
+
+  -- natural transformations by pre/post composition
+  preComp : {x y : C .ob}
+          → (f : C [ x , y ])
+          → C [ x ,-] ⇒ F
+          → C [ y ,-] ⇒ F
+  preComp f α .N-ob c k = (α ⟦ c ⟧) (f ⋆⟨ C ⟩ k)
+  preComp f α .N-hom {x = c} {d} k
+    = (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ (l ⋆⟨ C ⟩ k)))
+    ≡[ i ]⟨ (λ l → (α ⟦ d ⟧) (⋆Assoc C f l k (~ i))) ⟩
+      (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ l ⋆⟨ C ⟩ k))
+    ≡[ i ]⟨ (λ l → (α .N-hom k) i (f ⋆⟨ C ⟩ l)) ⟩
+      (λ l → (F ⟪ k ⟫) ((α ⟦ c ⟧) (f ⋆⟨ C ⟩ l)))
+    ∎
+
+-- properties
+-- TODO: move to own file
+open isIso renaming (inv to cInv)
+open Iso
+
+module _ {A B : (SET ℓ) .ob } where
+
+  Iso→CatIso : Iso (fst A) (fst B)
+             → CatIso (SET ℓ) A B
+  Iso→CatIso is .fst = is .fun
+  Iso→CatIso is .snd .cInv = is .inv
+  Iso→CatIso is .snd .sec = funExt λ b → is .rightInv b -- is .rightInv
+  Iso→CatIso is .snd .ret = funExt λ b → is .leftInv b -- is .rightInv
+
+  CatIso→Iso : CatIso (SET ℓ) A B
+             → Iso (fst A) (fst B)
+  CatIso→Iso cis .fun = cis .fst
+  CatIso→Iso cis .inv = cis .snd .cInv
+  CatIso→Iso cis .rightInv = funExt⁻ λ b → cis .snd .sec b
+  CatIso→Iso cis .leftInv  = funExt⁻ λ b → cis .snd .ret b
+
+
+  Iso-Iso-CatIso : Iso (Iso (fst A) (fst B)) (CatIso (SET ℓ) A B)
+  fun Iso-Iso-CatIso = Iso→CatIso
+  inv Iso-Iso-CatIso = CatIso→Iso
+  rightInv Iso-Iso-CatIso b = refl
+  fun (leftInv Iso-Iso-CatIso a i) = fun a
+  inv (leftInv Iso-Iso-CatIso a i) = inv a
+  rightInv (leftInv Iso-Iso-CatIso a i) = rightInv a
+  leftInv (leftInv Iso-Iso-CatIso a i) = leftInv a
+
+  Iso-CatIso-≡ : Iso (CatIso (SET ℓ) A B) (A ≡ B)
+  Iso-CatIso-≡ = compIso (invIso Iso-Iso-CatIso) (hSet-Iso-Iso-≡ _ _)
+
+-- SET is univalent
+
+isUnivalentSET : isUnivalent {ℓ' = ℓ} (SET _)
+isUnivalent.univ isUnivalentSET (A , isSet-A) (B , isSet-B)  =
+   precomposesToId→Equiv
+      pathToIso _ (funExt w) (isoToIsEquiv Iso-CatIso-≡)
+   where
+     w : _
+     w ci =
+       invEq
+         (congEquiv (isoToEquiv (invIso Iso-Iso-CatIso)))
+         (SetsIso≡-ext isSet-A isSet-B
+            (λ x i → transp (λ _ → B) i (ci .fst (transp (λ _ → A) i x)))
+            (λ x i → transp (λ _ → A) i (ci .snd .cInv (transp (λ _ → B) i x))))
+
+-- SET is complete
+
+open LimCone
+open Cone
+
+completeSET : ∀ {ℓJ ℓJ'} → Limits {ℓJ} {ℓJ'} (SET (ℓ-max ℓJ ℓJ'))
+lim (completeSET J D) = Cone D (Unit* , isOfHLevelLift 2 isSetUnit) , isSetCone D _
+coneOut (limCone (completeSET J D)) j e = coneOut e j tt*
+coneOutCommutes (limCone (completeSET J D)) j i e = coneOutCommutes e j i tt*
+univProp (completeSET J D) c cc =
+  uniqueExists
+    (λ x → cone (λ v _ → coneOut cc v x) (λ e i _ → coneOutCommutes cc e i x))
+    (λ _ → funExt (λ _ → refl))
+    (λ x → isPropIsConeMor cc (limCone (completeSET J D)) x)
+    (λ x hx → funExt (λ d → cone≡ λ u → funExt (λ _ → sym (funExt⁻ (hx u) d))))
+

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Isomorphism.html b/docs/Cubical.Categories.Isomorphism.html
index 03fb5f2..9361388 100644
--- a/docs/Cubical.Categories.Isomorphism.html
+++ b/docs/Cubical.Categories.Isomorphism.html
@@ -17,228 +17,228 @@
 module _ {C : Category ℓC ℓC'} where
 
   open Category C
-  open isIso
+  open isIso
 
 
-  invIso : {x y : ob} → CatIso C x y → CatIso C y x
-  invIso f .fst = f .snd .inv
-  invIso f .snd .inv = f .fst
-  invIso f .snd .sec = f .snd .ret
-  invIso f .snd .ret = f .snd .sec
+  invIso : {x y : ob} → CatIso C x y → CatIso C y x
+  invIso f .fst = f .snd .inv
+  invIso f .snd .inv = f .fst
+  invIso f .snd .sec = f .snd .ret
+  invIso f .snd .ret = f .snd .sec
 
-  invIsoIdem : {x y : ob} → (f : CatIso C x y) → invIso (invIso f) ≡ f
+  invIsoIdem : {x y : ob} → (f : CatIso C x y) → invIso (invIso f) ≡ f
   invIsoIdem f = refl
 
 
-  ⋆Iso : {x y z : ob} → (f : CatIso C x y)(g : CatIso C y z) → CatIso C x z
+  ⋆Iso : {x y z : ob} → (f : CatIso C x y)(g : CatIso C y z) → CatIso C x z
   ⋆Iso f g .fst = f .fst ⋆ g .fst
-  ⋆Iso f g .snd .inv = g .snd .inv ⋆ f .snd .inv
-  ⋆Iso f g .snd .sec = sym (⋆Assoc _ _ _)
-    ∙ (λ i → ⋆Assoc (g .snd .inv) (f .snd .inv) (f .fst) i ⋆ g .fst)
-    ∙ (λ i → (g .snd .inv ⋆ f .snd .sec i) ⋆ g .fst)
-    ∙ (λ i → ⋆IdR (g .snd .inv) i ⋆ g .fst)
-    ∙ g .snd .sec
-  ⋆Iso f g .snd .ret = sym (⋆Assoc _ _ _)
-    ∙ (λ i → ⋆Assoc (f .fst) (g .fst) (g .snd .inv) i ⋆ f .snd .inv)
-    ∙ (λ i → (f .fst ⋆ g .snd .ret i) ⋆ f .snd .inv)
-    ∙ (λ i → ⋆IdR (f .fst) i ⋆ f .snd .inv)
-    ∙ f .snd .ret
-
-  compIso : {x y z : ob} → (g : CatIso C y z)(f : CatIso C x y) → CatIso C x z
+  ⋆Iso f g .snd .inv = g .snd .inv ⋆ f .snd .inv
+  ⋆Iso f g .snd .sec = sym (⋆Assoc _ _ _)
+    ∙ (λ i → ⋆Assoc (g .snd .inv) (f .snd .inv) (f .fst) i ⋆ g .fst)
+    ∙ (λ i → (g .snd .inv ⋆ f .snd .sec i) ⋆ g .fst)
+    ∙ (λ i → ⋆IdR (g .snd .inv) i ⋆ g .fst)
+    ∙ g .snd .sec
+  ⋆Iso f g .snd .ret = sym (⋆Assoc _ _ _)
+    ∙ (λ i → ⋆Assoc (f .fst) (g .fst) (g .snd .inv) i ⋆ f .snd .inv)
+    ∙ (λ i → (f .fst ⋆ g .snd .ret i) ⋆ f .snd .inv)
+    ∙ (λ i → ⋆IdR (f .fst) i ⋆ f .snd .inv)
+    ∙ f .snd .ret
+
+  compIso : {x y z : ob} → (g : CatIso C y z)(f : CatIso C x y) → CatIso C x z
   compIso g f = ⋆Iso f g
 
 
-  ⋆IsoIdL : {x y : ob} → (f : CatIso C x y) → ⋆Iso idCatIso f ≡ f
-  ⋆IsoIdL _ = CatIso≡ _ _ (⋆IdL _)
+  ⋆IsoIdL : {x y : ob} → (f : CatIso C x y) → ⋆Iso idCatIso f ≡ f
+  ⋆IsoIdL _ = CatIso≡ _ _ (⋆IdL _)
 
-  ⋆IsoIdR : {x y : ob} → (f : CatIso C x y) → ⋆Iso f idCatIso ≡ f
-  ⋆IsoIdR _ = CatIso≡ _ _ (⋆IdR _)
+  ⋆IsoIdR : {x y : ob} → (f : CatIso C x y) → ⋆Iso f idCatIso ≡ f
+  ⋆IsoIdR _ = CatIso≡ _ _ (⋆IdR _)
 
-  ⋆IsoInvRev : {x y z : ob} → (f : CatIso C x y)(g : CatIso C y z) → invIso (⋆Iso f g) ≡ ⋆Iso (invIso g) (invIso f)
+  ⋆IsoInvRev : {x y z : ob} → (f : CatIso C x y)(g : CatIso C y z) → invIso (⋆Iso f g) ≡ ⋆Iso (invIso g) (invIso f)
   ⋆IsoInvRev _ _ = refl
 
 
-  pathToIso-∙ : {x y z : ob}(p : x ≡ y)(q : y ≡ z) → pathToIso (p ∙ q) ≡ ⋆Iso (pathToIso p) (pathToIso q)
-  pathToIso-∙ p q = J2 (λ y p z q → pathToIso (p ∙ q) ≡ ⋆Iso (pathToIso p) (pathToIso q)) pathToIso-∙-refl p q
+  pathToIso-∙ : {x y z : ob}(p : x ≡ y)(q : y ≡ z) → pathToIso (p ∙ q) ≡ ⋆Iso (pathToIso p) (pathToIso q)
+  pathToIso-∙ p q = J2 (λ y p z q → pathToIso (p ∙ q) ≡ ⋆Iso (pathToIso p) (pathToIso q)) pathToIso-∙-refl p q
     where
-    pathToIso-∙-refl : {x : ob} → pathToIso {x = x} (refl ∙ refl) ≡ ⋆Iso (pathToIso refl) (pathToIso refl)
-    pathToIso-∙-refl = cong pathToIso (sym compPathRefl)
+    pathToIso-∙-refl : {x : ob} → pathToIso {x = x} (refl ∙ refl) ≡ ⋆Iso (pathToIso refl) (pathToIso refl)
+    pathToIso-∙-refl = cong pathToIso (sym compPathRefl)
       ∙ sym (⋆IsoIdL _)
-      ∙ (λ i → ⋆Iso (pathToIso-refl (~ i)) (pathToIso refl))
+      ∙ (λ i → ⋆Iso (pathToIso-refl (~ i)) (pathToIso refl))
 
 
-  transportPathToIso : {x y z : ob}(f : C [ x , y ])(p : y ≡ z) → PathP (λ i → C [ x , p i ]) f (f ⋆ pathToIso {C = C} p .fst)
-  transportPathToIso {x = x} f = J (λ _ p → PathP (λ i → C [ x , p i ]) f (f ⋆ pathToIso {C = C} p .fst))
-    (sym (⋆IdR _) ∙ cong (λ x → f ⋆ x) (sym (cong fst (pathToIso-refl {C = C}))))
+  transportPathToIso : {x y z : ob}(f : C [ x , y ])(p : y ≡ z) → PathP (λ i → C [ x , p i ]) f (f ⋆ pathToIso {C = C} p .fst)
+  transportPathToIso {x = x} f = J (λ _ p → PathP (λ i → C [ x , p i ]) f (f ⋆ pathToIso {C = C} p .fst))
+    (sym (⋆IdR _) ∙ cong (λ x → f ⋆ x) (sym (cong fst (pathToIso-refl {C = C}))))
 
 
   pathToIso-Comm : {x y z w : ob}
     → (p : x ≡ y)(q : z ≡ w)
     → (f : Hom[ x , z ])(g : Hom[ y , w ])
     → PathP (λ i → Hom[ p i , q i ]) f g
-    → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
+    → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
   pathToIso-Comm {x = x} {z = z} p q =
-    J2 (λ y p w q →
+    J2 (λ y p w q →
         (f : Hom[ x , z ])(g : Hom[ y , w ])
       → PathP (λ i → Hom[ p i , q i ]) f g
-      → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g)
+      → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g)
     sqr-refl p q
     where
     sqr-refl : (f g : Hom[ x , z ]) → f ≡ g
-      → f ⋆ pathToIso {C = C} refl .fst ≡ pathToIso {C = C} refl .fst ⋆ g
-    sqr-refl f g p = (λ i → f ⋆ pathToIso-refl {C = C} i .fst)
+      → f ⋆ pathToIso {C = C} refl .fst ≡ pathToIso {C = C} refl .fst ⋆ g
+    sqr-refl f g p = (λ i → f ⋆ pathToIso-refl {C = C} i .fst)
       ∙ ⋆IdR _ ∙ p ∙ sym (⋆IdL _)
-      ∙ (λ i → pathToIso-refl {C = C} (~ i) .fst ⋆ g)
+      ∙ (λ i → pathToIso-refl {C = C} (~ i) .fst ⋆ g)
 
   pathToIso-Square : {x y z w : ob}
     → (p : x ≡ y)(q : z ≡ w)
     → (f : Hom[ x , z ])(g : Hom[ y , w ])
-    → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
+    → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
     → PathP (λ i → Hom[ p i , q i ]) f g
   pathToIso-Square {x = x} {z = z} p q =
-    J2 (λ y p w q →
+    J2 (λ y p w q →
         (f : Hom[ x , z ])(g : Hom[ y , w ])
-      → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
+      → f ⋆ pathToIso {C = C} q .fst ≡ pathToIso {C = C} p .fst ⋆ g
       → PathP (λ i → Hom[ p i , q i ]) f g)
     sqr-refl p q
     where
     sqr-refl : (f g : Hom[ x , z ])
-      → f ⋆ pathToIso {C = C} refl .fst ≡ pathToIso {C = C} refl .fst ⋆ g
+      → f ⋆ pathToIso {C = C} refl .fst ≡ pathToIso {C = C} refl .fst ⋆ g
       → f ≡ g
     sqr-refl f g p = sym (⋆IdR _)
-      ∙ (λ i → f ⋆ pathToIso-refl {C = C} (~ i) .fst)
+      ∙ (λ i → f ⋆ pathToIso-refl {C = C} (~ i) .fst)
       ∙ p
-      ∙ (λ i → pathToIso-refl {C = C} i .fst ⋆ g)
+      ∙ (λ i → pathToIso-refl {C = C} i .fst ⋆ g)
       ∙ ⋆IdL _
 
-  module _ (isUnivC : isUnivalent C) where
+  module _ (isUnivC : isUnivalent C) where
 
-    open isUnivalent isUnivC
+    open isUnivalent isUnivC
 
 
-    transportIsoToPath : {x y z : ob}(f : C [ x , y ])(p : CatIso C y z)
-      → PathP (λ i → C [ x , CatIsoToPath p i ]) f (f ⋆ p .fst)
+    transportIsoToPath : {x y z : ob}(f : C [ x , y ])(p : CatIso C y z)
+      → PathP (λ i → C [ x , CatIsoToPath p i ]) f (f ⋆ p .fst)
     transportIsoToPath f p i =
       hcomp (λ j → λ
         { (i = i0) → f
-        ; (i = i1) → f ⋆ secEq (univEquiv _ _) p j .fst })
-      (transportPathToIso f (CatIsoToPath p) i)
+        ; (i = i1) → f ⋆ secEq (univEquiv _ _) p j .fst })
+      (transportPathToIso f (CatIsoToPath p) i)
 
-    transportIsoToPathIso : {x y z : ob}(f : CatIso C x y)(p : CatIso C y z)
-      → PathP (λ i → CatIso C x (CatIsoToPath p i)) f (⋆Iso f p)
+    transportIsoToPathIso : {x y z : ob}(f : CatIso C x y)(p : CatIso C y z)
+      → PathP (λ i → CatIso C x (CatIsoToPath p i)) f (⋆Iso f p)
     transportIsoToPathIso f p i .fst = transportIsoToPath (f .fst) p i
     transportIsoToPathIso f p i .snd =
-      isProp→PathP (λ i → isPropIsIso (transportIsoToPath (f .fst) p i)) (f .snd) (⋆Iso f p .snd) i
+      isProp→PathP (λ i → isPropIsIso (transportIsoToPath (f .fst) p i)) (f .snd) (⋆Iso f p .snd) i
 
 
     isoToPath-Square : {x y z w : ob}
-      → (p : CatIso C x y)(q : CatIso C z w)
+      → (p : CatIso C x y)(q : CatIso C z w)
       → (f : Hom[ x , z ])(g : Hom[ y , w ])
       → f ⋆ q .fst ≡ p .fst ⋆ g
-      → PathP (λ i → Hom[ CatIsoToPath p i , CatIsoToPath q i ]) f g
+      → PathP (λ i → Hom[ CatIsoToPath p i , CatIsoToPath q i ]) f g
     isoToPath-Square p q f g comm =
-      pathToIso-Square (CatIsoToPath p) (CatIsoToPath q) _ _
-        ((λ i → f ⋆ secEq (univEquiv _ _) q i .fst) ∙ comm ∙ (λ i → secEq (univEquiv _ _) p (~ i) .fst ⋆ g))
+      pathToIso-Square (CatIsoToPath p) (CatIsoToPath q) _ _
+        ((λ i → f ⋆ secEq (univEquiv _ _) q i .fst) ∙ comm ∙ (λ i → secEq (univEquiv _ _) p (~ i) .fst ⋆ g))
 
 
 module _ {C : Category ℓC ℓC'} where
 
   open Category C
-  open isIso
+  open isIso
 
   ⋆InvLMove : {x y z : ob}
-    (f : CatIso C x y)
+    (f : CatIso C x y)
     {g : Hom[ y , z ]}{h : Hom[ x , z ]}
     → f .fst ⋆ g ≡ h
-    → g ≡ f .snd .inv ⋆ h
+    → g ≡ f .snd .inv ⋆ h
   ⋆InvLMove f {g = g} p =
       sym (⋆IdL _)
-    ∙ (λ i → f .snd .sec (~ i) ⋆ g)
+    ∙ (λ i → f .snd .sec (~ i) ⋆ g)
     ∙ ⋆Assoc _ _ _
-    ∙ (λ i → f .snd .inv ⋆ p i)
+    ∙ (λ i → f .snd .inv ⋆ p i)
 
   ⋆InvRMove : {x y z : ob}
-    (f : CatIso C y z)
+    (f : CatIso C y z)
     {g : Hom[ x , y ]}{h : Hom[ x , z ]}
     → g ⋆ f .fst ≡ h
-    → g ≡ h ⋆ f .snd .inv
+    → g ≡ h ⋆ f .snd .inv
   ⋆InvRMove f {g = g} p =
       sym (⋆IdR _)
-    ∙ (λ i → g ⋆ f .snd .ret (~ i))
+    ∙ (λ i → g ⋆ f .snd .ret (~ i))
     ∙ sym (⋆Assoc _ _ _)
-    ∙ (λ i → p i ⋆ f .snd .inv)
+    ∙ (λ i → p i ⋆ f .snd .inv)
 
   ⋆CancelL : {x y z : ob}
-    (f : CatIso C x y){g h : Hom[ y , z ]}
+    (f : CatIso C x y){g h : Hom[ y , z ]}
     → f .fst ⋆ g ≡ f .fst ⋆ h
     → g ≡ h
   ⋆CancelL f {g = g} {h = h} p =
       sym (⋆IdL _)
-    ∙ (λ i → f .snd .sec (~ i) ⋆ g)
+    ∙ (λ i → f .snd .sec (~ i) ⋆ g)
     ∙ ⋆Assoc _ _ _
-    ∙ (λ i → f .snd .inv ⋆ p i)
+    ∙ (λ i → f .snd .inv ⋆ p i)
     ∙ sym (⋆Assoc _ _ _)
-    ∙ (λ i → f .snd .sec i ⋆ h)
+    ∙ (λ i → f .snd .sec i ⋆ h)
     ∙ ⋆IdL _
 
   ⋆CancelR : {x y z : ob}
-    (f : CatIso C y z){g h : Hom[ x , y ]}
+    (f : CatIso C y z){g h : Hom[ x , y ]}
     → g ⋆ f .fst ≡ h ⋆ f .fst
     → g ≡ h
   ⋆CancelR f {g = g} {h = h} p =
       sym (⋆IdR _)
-    ∙ (λ i → g ⋆ f .snd .ret (~ i))
+    ∙ (λ i → g ⋆ f .snd .ret (~ i))
     ∙ sym (⋆Assoc _ _ _)
-    ∙ (λ i → p i ⋆ f .snd .inv)
+    ∙ (λ i → p i ⋆ f .snd .inv)
     ∙ ⋆Assoc _ _ _
-    ∙ (λ i → h ⋆ f .snd .ret i)
+    ∙ (λ i → h ⋆ f .snd .ret i)
     ∙ ⋆IdR _
 
 
 module _ {C : Category ℓC ℓC'} where
 
   open Category
-  open isIso
+  open isIso
 
-  op-Iso : {x y : C .ob} → CatIso C x y → CatIso (C ^op) x y
-  op-Iso f .fst = f .snd .inv
-  op-Iso f .snd .inv = f .fst
-  op-Iso f .snd .sec = f .snd .sec
-  op-Iso f .snd .ret = f .snd .ret
+  op-Iso : {x y : C .ob} → CatIso C x y → CatIso (C ^op) x y
+  op-Iso f .fst = f .snd .inv
+  op-Iso f .snd .inv = f .fst
+  op-Iso f .snd .sec = f .snd .sec
+  op-Iso f .snd .ret = f .snd .ret
 
 
 module _ {C : Category ℓC ℓC'}{D : Category ℓD ℓD'}{F : Functor C D} where
 
   open Category hiding (_∘_)
-  open isIso
+  open isIso
   open Functor
 
 
-  F-PresIsIso : {x y : C .ob}{f : C [ x , y ]} → isIso C f → isIso D (F .F-hom f)
-  F-PresIsIso f .inv = F . F-hom (f .inv)
-  F-PresIsIso f .sec = sym (F .F-seq (f .inv) _) ∙ cong (F .F-hom) (f .sec) ∙ F .F-id
-  F-PresIsIso f .ret = sym (F .F-seq _ (f .inv)) ∙ cong (F .F-hom) (f .ret) ∙ F .F-id
+  F-PresIsIso : {x y : C .ob}{f : C [ x , y ]} → isIso C f → isIso D (F .F-hom f)
+  F-PresIsIso f .inv = F . F-hom (f .inv)
+  F-PresIsIso f .sec = sym (F .F-seq (f .inv) _) ∙ cong (F .F-hom) (f .sec) ∙ F .F-id
+  F-PresIsIso f .ret = sym (F .F-seq _ (f .inv)) ∙ cong (F .F-hom) (f .ret) ∙ F .F-id
 
 
-  F-Iso : {x y : C .ob} → CatIso C x y → CatIso D (F .F-ob x) (F .F-ob y)
+  F-Iso : {x y : C .ob} → CatIso C x y → CatIso D (F .F-ob x) (F .F-ob y)
   F-Iso f .fst = F . F-hom (f .fst)
   F-Iso f .snd = F-PresIsIso (f .snd)
 
-  F-Iso-PresId : {x : C .ob} → F-Iso (idCatIso {x = x}) ≡ idCatIso
-  F-Iso-PresId = CatIso≡ _ _ (F .F-id)
+  F-Iso-PresId : {x : C .ob} → F-Iso (idCatIso {x = x}) ≡ idCatIso
+  F-Iso-PresId = CatIso≡ _ _ (F .F-id)
 
-  F-Iso-Pres⋆ : {x y z : C .ob} → (f : CatIso C x y)(g : CatIso C y z) → F-Iso (⋆Iso f g) ≡ ⋆Iso (F-Iso f) (F-Iso g)
-  F-Iso-Pres⋆ _ _ = CatIso≡ _ _ (F .F-seq _ _)
+  F-Iso-Pres⋆ : {x y z : C .ob} → (f : CatIso C x y)(g : CatIso C y z) → F-Iso (⋆Iso f g) ≡ ⋆Iso (F-Iso f) (F-Iso g)
+  F-Iso-Pres⋆ _ _ = CatIso≡ _ _ (F .F-seq _ _)
 
 
-  F-pathToIso : {x y : C .ob} → (p : x ≡ y) → F-Iso (pathToIso p) ≡ pathToIso (cong (F .F-ob) p)
-  F-pathToIso p = J (λ y p → F-Iso (pathToIso p) ≡ pathToIso (cong (F .F-ob) p)) F-pathToIso-refl p
+  F-pathToIso : {x y : C .ob} → (p : x ≡ y) → F-Iso (pathToIso p) ≡ pathToIso (cong (F .F-ob) p)
+  F-pathToIso p = J (λ y p → F-Iso (pathToIso p) ≡ pathToIso (cong (F .F-ob) p)) F-pathToIso-refl p
     where
-    F-pathToIso-refl : {x : C .ob} → F-Iso (pathToIso {x = x} refl) ≡ pathToIso (cong (F .F-ob) refl)
-    F-pathToIso-refl = cong F-Iso pathToIso-refl
+    F-pathToIso-refl : {x : C .ob} → F-Iso (pathToIso {x = x} refl) ≡ pathToIso (cong (F .F-ob) refl)
+    F-pathToIso-refl = cong F-Iso pathToIso-refl
       ∙ F-Iso-PresId
-      ∙ sym pathToIso-refl
+      ∙ sym pathToIso-refl
 
-  F-pathToIso-∘ : {x y : C .ob} → F-Iso ∘ pathToIso {x = x} {y = y} ≡ pathToIso ∘ cong (F .F-ob)
+  F-pathToIso-∘ : {x y : C .ob} → F-Iso ∘ pathToIso {x = x} {y = y} ≡ pathToIso ∘ cong (F .F-ob)
   F-pathToIso-∘ i p = F-pathToIso p i
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.BinCoproduct.html b/docs/Cubical.Categories.Limits.BinCoproduct.html
index efe694f..258ce54 100644
--- a/docs/Cubical.Categories.Limits.BinCoproduct.html
+++ b/docs/Cubical.Categories.Limits.BinCoproduct.html
@@ -25,8 +25,8 @@
     isBinCoproduct = ∀ {z : ob} (f₁ : Hom[ x , z ]) (f₂ : Hom[ y , z ]) →
         ∃![ f ∈ Hom[ x+y , z ] ] (i₁ ⋆ f ≡ f₁) × (i₂ ⋆ f ≡ f₂)
 
-    isPropIsBinCoproduct : isProp (isBinCoproduct)
-    isPropIsBinCoproduct = isPropImplicitΠ (λ _ → isPropΠ2 (λ _ _ → isPropIsContr))
+    isPropIsBinCoproduct : isProp (isBinCoproduct)
+    isPropIsBinCoproduct = isPropImplicitΠ (λ _ → isPropΠ2 (λ _ _ → isPropIsContr))
 
 
   record BinCoproduct (x y : ob) : Type (ℓ-max ℓ ℓ') where
diff --git a/docs/Cubical.Categories.Limits.BinProduct.html b/docs/Cubical.Categories.Limits.BinProduct.html
index 2e8f4d3..fc8bdd2 100644
--- a/docs/Cubical.Categories.Limits.BinProduct.html
+++ b/docs/Cubical.Categories.Limits.BinProduct.html
@@ -1,90 +1,45 @@
 
 Cubical.Categories.Limits.BinProduct
-- Binary products
-{-# OPTIONS --allow-unsolved-metas #-}
+{-# OPTIONS --safe #-}
 
-module Cubical.Categories.Limits.BinProduct where
+module Cubical.Categories.Limits.BinProduct where
 
-open import Cubical.Categories.Category.Base
-open import Cubical.Categories.Constructions.BinProduct
-open import Cubical.Categories.Functor.Base
-open import Cubical.Data.Sigma.Base
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Prelude
-open import Cubical.HITs.PropositionalTruncation.Base
+open import Cubical.Categories.Category.Base
+open import Cubical.Data.Sigma.Base
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Prelude
+open import Cubical.HITs.PropositionalTruncation.Base
 
-private
-  variable
-    ℓ ℓ' : Level
+private
+  variable
+    ℓ ℓ' : Level
 
-module _ (C : Category ℓ ℓ') where
-  open Category C
+module _ (C : Category ℓ ℓ') where
+  open Category C
 
-  module _ {x y x×y : ob}
-           (π₁ : Hom[ x×y , x ])
-           (π₂ : Hom[ x×y , y ]) where
+  module _ {x y x×y : ob}
+           (π₁ : Hom[ x×y , x ])
+           (π₂ : Hom[ x×y , y ]) where
 
-    isBinProduct : Type (ℓ-max ℓ ℓ')
-    isBinProduct = ∀ {z : ob} (f₁ : Hom[ z , x ]) (f₂ : Hom[ z , y ]) →
-        ∃![ f ∈ Hom[ z , x×y ] ] (f ⋆ π₁ ≡ f₁) × (f ⋆ π₂ ≡ f₂)
+    isBinProduct : Type (ℓ-max ℓ ℓ')
+    isBinProduct = ∀ {z : ob} (f₁ : Hom[ z , x ]) (f₂ : Hom[ z , y ]) →
+        ∃![ f ∈ Hom[ z , x×y ] ] (f ⋆ π₁ ≡ f₁) × (f ⋆ π₂ ≡ f₂)
 
-    isPropIsBinProduct : isProp (isBinProduct)
-    isPropIsBinProduct = isPropImplicitΠ (λ _ → isPropΠ2 (λ _ _ → isPropIsContr))
+    isPropIsBinProduct : isProp (isBinProduct)
+    isPropIsBinProduct = isPropImplicitΠ (λ _ → isPropΠ2 (λ _ _ → isPropIsContr))
 
 
-  record BinProduct (x y : ob) : Type (ℓ-max ℓ ℓ') where
-    field
-      binProdOb : ob
-      binProdPr₁ : Hom[ binProdOb , x ]
-      binProdPr₂ : Hom[ binProdOb , y ]
-      univProp : isBinProduct binProdPr₁ binProdPr₂
+  record BinProduct (x y : ob) : Type (ℓ-max ℓ ℓ') where
+    field
+      binProdOb : ob
+      binProdPr₁ : Hom[ binProdOb , x ]
+      binProdPr₂ : Hom[ binProdOb , y ]
+      univProp : isBinProduct binProdPr₁ binProdPr₂
 
 
-  BinProducts : Type (ℓ-max ℓ ℓ')
-  BinProducts = (x y : ob) → BinProduct x y
+  BinProducts : Type (ℓ-max ℓ ℓ')
+  BinProducts = (x y : ob) → BinProduct x y
 
-  hasBinProducts : Type (ℓ-max ℓ ℓ')
-  hasBinProducts = ∥ BinProducts ∥₁
-
-  module _ (binProducts : BinProducts) where
-    {-
-      Given morphisms f : Hom[ a , b ] and g : Hom[ c , d ]
-      we can construct a morphism f×g : Hom[ a × c , b × d ].
-      This is given by f , g ⟨ a , c ⟩ ⊢ ⟨ f a , g c ⟩
-      Here the ⊢ and ⟨⟩ notation have their obvious meanings
-    -}
-    open BinProduct
-    private variable
-      a b c d : ob
-    infix 20 _⊗₀_
-    _⊗₀_ : ob → ob → ob
-    x ⊗₀ y = binProducts x y .binProdOb
-    
-    _⊗₁_ : (f : Hom[ a , b ]) (g : Hom[ c , d ]) → Hom[ a ⊗₀ c , b ⊗₀ d ]
-    _⊗₁_ {a} {b} {c} {d} f g = b⊗d .univProp (a⊗c .binProdPr₁ ⋆ f) (a⊗c .binProdPr₂ ⋆ g) .fst .fst where
-         b⊗d = binProducts b d
-         a⊗c = binProducts a c
-
-    open Functor
-    prodFunctor : Functor (C ×C C) C
-    prodFunctor .F-ob (x , y) = x ⊗₀ y
-    prodFunctor .F-hom {x , y} {x' , y'} (f , g) = f ⊗₁ g
-    prodFunctor .F-id {x , y} i =
-      (isContr→isProp
-        (x×y .univProp
-          (x×y .binProdPr₁ ⋆ id)
-          (x×y .binProdPr₂ ⋆ id))
-        ( id {x} ⊗₁ id {y}
-        , x×y .univProp (x×y .binProdPr₁ ⋆ id) (x×y .binProdPr₂ ⋆ id) .fst .snd .fst
-        , x×y .univProp (x×y .binProdPr₁ ⋆ id) (x×y .binProdPr₂ ⋆ id) .fst .snd .snd)
-        ( id {x ⊗₀ y}
-        , (id ⋆ (x×y .binProdPr₁) ≡⟨ ⋆IdL _ ⟩
-          x×y .binProdPr₁ ≡⟨ sym (⋆IdR _) ⟩
-          x×y .binProdPr₁ ⋆ id ∎)
-        , (id ⋆ (x×y .binProdPr₂) ≡⟨ ⋆IdL _ ⟩
-          x×y .binProdPr₂ ≡⟨ sym (⋆IdR _) ⟩
-          x×y .binProdPr₂ ⋆ id ∎)))
-        i .fst where
-          x×y = binProducts x y
-    prodFunctor .F-seq {a , b} {c , d} {e , f} (α , β) (δ , γ) =
-      {!!}
+  hasBinProducts : Type (ℓ-max ℓ ℓ')
+  hasBinProducts = ∥ BinProducts ∥₁
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.Initial.html b/docs/Cubical.Categories.Limits.Initial.html
index 0a638be..3bcf23e 100644
--- a/docs/Cubical.Categories.Limits.Initial.html
+++ b/docs/Cubical.Categories.Limits.Initial.html
@@ -1,86 +1,86 @@
 
-Cubical.Categories.Limits.Initial
{-# OPTIONS --allow-unsolved-metas #-}
-module Cubical.Categories.Limits.Initial where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Isomorphism renaming (Iso to _≅_)
-open import Cubical.HITs.PropositionalTruncation.Base
-
-open import Cubical.Data.Sigma
-
-open import Cubical.Categories.Category
-open import Cubical.Categories.Functor
-open import Cubical.Categories.Adjoint
-
-private
-  variable
-    ℓ ℓ' : Level
-    ℓC ℓC' ℓD ℓD' : Level
-
-module _ (C : Category ℓ ℓ') where
-  open Category C
-
-  isInitial : (x : ob) → Type (ℓ-max ℓ ℓ')
-  isInitial x = ∀ (y : ob) → isContr (C [ x , y ])
-
-  Initial : Type (ℓ-max ℓ ℓ')
-  Initial = Σ[ x ∈ ob ] isInitial x
-
-  initialOb : Initial → ob
-  initialOb = fst
-
-  initialArrow : (T : Initial) (y : ob) → C [ initialOb T , y ]
-  initialArrow T y = T .snd y .fst
-
-  initialArrowUnique : {T : Initial} {y : ob} (f : C [ initialOb T , y ])
-                      → initialArrow T y ≡ f
-  initialArrowUnique {T} {y} f = T .snd y .snd f
-
-  initialEndoIsId : (T : Initial) (f : C [ initialOb T , initialOb T ])
-                   → f ≡ id
-  initialEndoIsId T f = isContr→isProp (T .snd (initialOb T)) f id
-
-  hasInitial : Type (ℓ-max ℓ ℓ')
-  hasInitial = ∥ Initial ∥₁
-
-  -- Initiality of an object is a proposition.
-  isPropIsInitial : (x : ob) → isProp (isInitial x)
-  isPropIsInitial _ = isPropΠ λ _ → isPropIsContr
-
-  open isIso
-
-  -- Objects that are initial are isomorphic.
-  initialToIso : (x y : Initial) → CatIso C (initialOb x) (initialOb y)
-  initialToIso x y .fst = initialArrow x (initialOb y)
-  initialToIso x y .snd .inv = initialArrow y (initialOb x)
-  initialToIso x y .snd .sec = initialEndoIsId y _
-  initialToIso x y .snd .ret = initialEndoIsId x _
-
-  open isUnivalent
-
-  -- The type of initial objects of a univalent category is a proposition,
-  -- i.e. all initial objects are equal.
-  isPropInitial : (hC : isUnivalent C) → isProp Initial
-  isPropInitial hC x y =
-    Σ≡Prop isPropIsInitial (CatIsoToPath hC (initialToIso x y))
-
-module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) where
-  open Category
-  open Functor
-  open NaturalBijection
-  open _⊣_
-  open _≅_
-
-  preservesInitial : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
-  preservesInitial = ∀ (x : ob C) → isInitial C x → isInitial D (F-ob F x)
-
-  isLeftAdjoint→preservesInitial : isLeftAdjoint F → preservesInitial
-  fst (isLeftAdjoint→preservesInitial (G , F⊣G) x initX y) = _♯ F⊣G (fst (initX (F-ob G y)))
-  snd (isLeftAdjoint→preservesInitial (G , F⊣G) x initX y) ψ =
-    _♯ F⊣G (fst (initX (F-ob G y)))
-      ≡⟨ cong (F⊣G ♯) (snd (initX (F-ob G y)) (_♭ F⊣G ψ)) ⟩
-    _♯ F⊣G (_♭ F⊣G ψ)
-      ≡⟨ leftInv (adjIso F⊣G) ψ ⟩
-    ψ ∎
+Cubical.Categories.Limits.Initial
{-# OPTIONS --safe #-}
+module Cubical.Categories.Limits.Initial where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism renaming (Iso to _≅_)
+open import Cubical.HITs.PropositionalTruncation.Base
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Adjoint
+
+private
+  variable
+    ℓ ℓ' : Level
+    ℓC ℓC' ℓD ℓD' : Level
+
+module _ (C : Category ℓ ℓ') where
+  open Category C
+
+  isInitial : (x : ob) → Type (ℓ-max ℓ ℓ')
+  isInitial x = ∀ (y : ob) → isContr (C [ x , y ])
+
+  Initial : Type (ℓ-max ℓ ℓ')
+  Initial = Σ[ x ∈ ob ] isInitial x
+
+  initialOb : Initial → ob
+  initialOb = fst
+
+  initialArrow : (T : Initial) (y : ob) → C [ initialOb T , y ]
+  initialArrow T y = T .snd y .fst
+
+  initialArrowUnique : {T : Initial} {y : ob} (f : C [ initialOb T , y ])
+                      → initialArrow T y ≡ f
+  initialArrowUnique {T} {y} f = T .snd y .snd f
+
+  initialEndoIsId : (T : Initial) (f : C [ initialOb T , initialOb T ])
+                   → f ≡ id
+  initialEndoIsId T f = isContr→isProp (T .snd (initialOb T)) f id
+
+  hasInitial : Type (ℓ-max ℓ ℓ')
+  hasInitial = ∥ Initial ∥₁
+
+  -- Initiality of an object is a proposition.
+  isPropIsInitial : (x : ob) → isProp (isInitial x)
+  isPropIsInitial _ = isPropΠ λ _ → isPropIsContr
+
+  open isIso
+
+  -- Objects that are initial are isomorphic.
+  initialToIso : (x y : Initial) → CatIso C (initialOb x) (initialOb y)
+  initialToIso x y .fst = initialArrow x (initialOb y)
+  initialToIso x y .snd .inv = initialArrow y (initialOb x)
+  initialToIso x y .snd .sec = initialEndoIsId y _
+  initialToIso x y .snd .ret = initialEndoIsId x _
+
+  open isUnivalent
+
+  -- The type of initial objects of a univalent category is a proposition,
+  -- i.e. all initial objects are equal.
+  isPropInitial : (hC : isUnivalent C) → isProp Initial
+  isPropInitial hC x y =
+    Σ≡Prop isPropIsInitial (CatIsoToPath hC (initialToIso x y))
+
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} (F : Functor C D) where
+  open Category
+  open Functor
+  open NaturalBijection
+  open _⊣_
+  open _≅_
+
+  preservesInitial : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD'))
+  preservesInitial = ∀ (x : ob C) → isInitial C x → isInitial D (F-ob F x)
+
+  isLeftAdjoint→preservesInitial : isLeftAdjoint F → preservesInitial
+  fst (isLeftAdjoint→preservesInitial (G , F⊣G) x initX y) = _♯ F⊣G (fst (initX (F-ob G y)))
+  snd (isLeftAdjoint→preservesInitial (G , F⊣G) x initX y) ψ =
+    _♯ F⊣G (fst (initX (F-ob G y)))
+      ≡⟨ cong (F⊣G ♯) (snd (initX (F-ob G y)) (_♭ F⊣G ψ)) ⟩
+    _♯ F⊣G (_♭ F⊣G ψ)
+      ≡⟨ leftInv (adjIso F⊣G) ψ ⟩
+    ψ ∎
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.Limits.html b/docs/Cubical.Categories.Limits.Limits.html
index eba4c32..72d598d 100644
--- a/docs/Cubical.Categories.Limits.Limits.html
+++ b/docs/Cubical.Categories.Limits.Limits.html
@@ -3,405 +3,405 @@
 -- Heavily inspired by https://github.com/UniMath/UniMath/blob/master/UniMath/CategoryTheory/limits/graphs/limits.v
 -- (except we're using categories instead of graphs to index limits)
 
-{-# OPTIONS #-}
-module Cubical.Categories.Limits.Limits where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Function
-
-open import Cubical.Data.Sigma
-
-open import Cubical.Categories.Category
-open import Cubical.Categories.Isomorphism
-open import Cubical.Categories.Functor
-open import Cubical.Categories.NaturalTransformation
-
-open import Cubical.Categories.Limits.Initial
-
-open import Cubical.HITs.PropositionalTruncation.Base
-
-module _ {ℓJ ℓJ' ℓC ℓC' : Level} {J : Category ℓJ ℓJ'} {C : Category ℓC ℓC'} where
-  open Category
-  open Functor
-  open NatTrans
-
-  private
-    ℓ = ℓ-max (ℓ-max (ℓ-max ℓJ ℓJ') ℓC) ℓC'
-
-  record Cone (D : Functor J C) (c : ob C) : Type (ℓ-max (ℓ-max ℓJ ℓJ') ℓC') where
-    constructor cone
-
-    field
-      coneOut : (v : ob J) → C [ c , F-ob D v ]
-      coneOutCommutes : {u v : ob J} (e : J [ u , v ]) →
-                        coneOut u ⋆⟨ C ⟩ D .F-hom e ≡ coneOut v
-
-  open Cone
-
-  cone≡ : {D : Functor J C} {c : ob C} → {c1 c2 : Cone D c}
-        → ((v : ob J) → coneOut c1 v ≡ coneOut c2 v) → c1 ≡ c2
-  coneOut (cone≡ h i) v = h v i
-  coneOutCommutes (cone≡ {D} {_} {c1} {c2} h i) {u} {v} e =
-    isProp→PathP (λ j → isSetHom C (h u j ⋆⟨ C ⟩ D .F-hom e) (h v j))
-                 (coneOutCommutes c1 e) (coneOutCommutes c2 e) i
-
-  -- dependent versions
-  conePathP : {D₁ D₂ : Functor J C} {c₁ c₂ : ob C} {cc₁ : Cone D₁ c₁} {cc₂ : Cone D₂ c₂}
-              {p : D₁ ≡ D₂} {q : c₁ ≡ c₂}
-            → (∀ v → PathP (λ i → C [ q i , p i .F-ob v ]) (cc₁ .coneOut v) (cc₂ .coneOut v))
-            → PathP (λ i → Cone (p i) (q i)) cc₁ cc₂
-  coneOut (conePathP coneOutPathP i) v = coneOutPathP v i
-  coneOutCommutes (conePathP {cc₁ = cc₁} {cc₂ = cc₂} {p = p} coneOutPathP i) {u} {v} e =
-    isProp→PathP (λ j → isSetHom C (coneOutPathP u j ⋆⟨ C ⟩ p j .F-hom e)
-                                   (coneOutPathP v j))
-                 (coneOutCommutes cc₁ e) (coneOutCommutes cc₂ e) i
-
-  conePathPOb : {D : Functor J C} {c c' : ob C} {c1 : Cone D c} {c2 : Cone D c'} {p : c ≡ c'}
-            → (∀ (v : ob J) → PathP (λ i → C [ p i , F-ob D v ]) (coneOut c1 v) (coneOut c2 v))
-            → PathP (λ i → Cone D (p i)) c1 c2
-  conePathPOb coneOutPathP = conePathP {p = refl} coneOutPathP
-
-  conePathPDiag : {D₁ D₂ : Functor J C} {c : ob C} {cc₁ : Cone D₁ c} {cc₂ : Cone D₂ c} {p : D₁ ≡ D₂}
-                → (∀ v → PathP (λ i → C [ c , p i .F-ob v ]) (cc₁ .coneOut v) (cc₂ .coneOut v))
-                → PathP (λ i → Cone (p i) c) cc₁ cc₂
-  conePathPDiag coneOutPathP = conePathP {q = refl} coneOutPathP
-
-
-  -- TODO: can we automate this a bit?
-  isSetCone : (D : Functor J C) (c : ob C) → isSet (Cone D c)
-  isSetCone D c = isSetRetract toConeΣ fromConeΣ (λ _ → refl)
-                               (isSetΣSndProp (isSetΠ (λ _ → isSetHom C))
-                                              (λ _ → isPropImplicitΠ2 (λ _ _ → isPropΠ (λ _ → isSetHom C _ _))))
-    where
-    ConeΣ = Σ[ f ∈ ((v : ob J) → C [ c , F-ob D v ]) ]
-               ({u v : ob J} (e : J [ u , v ]) → f u ⋆⟨ C ⟩ D .F-hom e ≡ f v)
-
-    toConeΣ : Cone D c → ConeΣ
-    fst (toConeΣ x) = coneOut x
-    snd (toConeΣ x) = coneOutCommutes x
-
-    fromConeΣ : ConeΣ → Cone D c
-    coneOut (fromConeΣ x) = fst x
-    coneOutCommutes (fromConeΣ x) = snd x
-
-  preCompCone : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C}
-              → Cone D c2 → Cone D c1
-  coneOut (preCompCone f cc) v = f ⋆⟨ C ⟩ coneOut cc v
-  coneOutCommutes (preCompCone f cc) e = ⋆Assoc C _ _ _
-                                       ∙ cong (λ x → f ⋆⟨ C ⟩ x) (coneOutCommutes cc e)
-
-  _★_ : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} → Cone D c2 → Cone D c1
-  _★_ = preCompCone
-
-  natTransPostCompCone : {c : ob C} {D₁ D₂ : Functor J C} (α : NatTrans D₁ D₂)
-                       → Cone D₁ c → Cone D₂ c
-  coneOut (natTransPostCompCone α cc) u = cc .coneOut u ⋆⟨ C ⟩ α .N-ob u
-  coneOutCommutes (natTransPostCompCone {D₁ = D₁} {D₂ = D₂} α cc) {u = u} {v = v}  e =
-      cc .coneOut u ⋆⟨ C ⟩ α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e
-    ≡⟨ ⋆Assoc C _ _ _ ⟩
-      cc .coneOut u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e)
-    ≡⟨ cong (λ x → cc .coneOut u ⋆⟨ C ⟩ x) (sym (α .N-hom e)) ⟩
-      cc .coneOut u ⋆⟨ C ⟩ (D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v)
-    ≡⟨ sym (⋆Assoc C _ _ _) ⟩
-      cc .coneOut u ⋆⟨ C ⟩ D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v
-    ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob v) (cc .coneOutCommutes e) ⟩
-      cc .coneOut v ⋆⟨ C ⟩ α .N-ob v ∎
-
-  _★ₙₜ_ : {c : ob C} {D₁ D₂ : Functor J C} → Cone D₁ c → NatTrans D₁ D₂ → Cone D₂ c
-  _★ₙₜ_ = flip natTransPostCompCone
-
-  isConeMor : {c1 c2 : ob C} {D : Functor J C}
-              (cc1 : Cone D c1) (cc2 : Cone D c2)
-            → C [ c1 , c2 ] → Type (ℓ-max ℓJ ℓC')
-  isConeMor cc1 cc2 f = (v : ob J) → f ⋆⟨ C ⟩ coneOut cc2 v ≡ coneOut cc1 v
-
-  isPropIsConeMor : {c1 c2 : ob C} {D : Functor J C}
-                    (cc1 : Cone D c1) (cc2 : Cone D c2) (f : C [ c1 , c2 ])
-                  → isProp (isConeMor cc1 cc2 f)
-  isPropIsConeMor cc1 cc2 f = isPropΠ (λ _ → isSetHom C _ _)
-
-  isConeMorId : {c : ob C} {D : Functor J C} (cc : Cone D c)
-              → isConeMor cc cc (id C)
-  isConeMorId _ _ = ⋆IdL C _
-
-  isConeMorSeq : {c1 c2 c3 : ob C} {D : Functor J C}
-                 (cc1 : Cone D c1) (cc2 : Cone D c2) (cc3  : Cone D c3)
-                 {f : C [ c1 , c2 ]} {g : C [ c2 , c3 ]}
-               → isConeMor cc1 cc2 f → isConeMor cc2 cc3 g → isConeMor cc1 cc3 (f ⋆⟨ C ⟩ g)
-  isConeMorSeq cc1 cc2 cc3 {f} {g} isConeMorF isConeMorG v =
-    ⋆Assoc C _ _ _ ∙∙ cong (λ x → f ⋆⟨ C ⟩ x) (isConeMorG v) ∙∙ isConeMorF v
-
-  preCompConeMor : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} (cc : Cone D c2)
-                 → isConeMor (f ★ cc) cc f
-  preCompConeMor f cc v = refl
-
-  isLimCone : (D : Functor J C) (c0 : ob C) → Cone D c0 → Type ℓ
-  isLimCone D c0 cc0 = (c : ob C) → (cc : Cone D c)
-                     → ∃![ f ∈ C [ c , c0 ] ] isConeMor cc cc0 f
-
-  isPropIsLimCone : (D : Functor J C) (c0 : ob C) (cc0 : Cone D c0)
-                  → isProp (isLimCone D c0 cc0)
-  isPropIsLimCone D c0 cc0 = isPropΠ2 λ _ _ → isProp∃!
-
-  preCompUnique : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} (cc : Cone D c2)
-                → isLimCone D c2 cc
-                → ∀ (g : C [ c1 , c2 ]) → isConeMor (f ★ cc) cc g → g ≡ f
-  preCompUnique f cc ccIsLimCone g gIsConeMor =
-     cong fst (isContr→isProp (ccIsLimCone _ (f ★ cc)) (g , gIsConeMor) (f , preCompConeMor f cc))
-
-  record LimCone (D : Functor J C) : Type ℓ where
-    constructor climCone
-
-    field
-      lim : ob C
-      limCone : Cone D lim
-      univProp : isLimCone D lim limCone
-
-    limOut : (v : ob J) → C [ lim , D .F-ob v ]
-    limOut = coneOut limCone
-
-    limOutCommutes : {u v : ob J} (e : J [ u , v ])
-                   → limOut u ⋆⟨ C ⟩ D .F-hom e ≡ limOut v
-    limOutCommutes = coneOutCommutes limCone
-
-    limArrow : (c : ob C) → (cc : Cone D c) → C [ c , lim ]
-    limArrow c cc = univProp c cc .fst .fst
-
-    limArrowCommutes : (c : ob C) → (cc : Cone D c) (u : ob J)
-                     → limArrow c cc ⋆⟨ C ⟩ limOut u ≡ coneOut cc u
-    limArrowCommutes c cc = univProp c cc .fst .snd
-
-    limArrowUnique : (c : ob C) → (cc : Cone D c) (k : C [ c , lim ])
-                   → isConeMor cc limCone k → limArrow c cc ≡ k
-    limArrowUnique c cc k hk = cong fst (univProp c cc .snd (k , hk))
-
-  open LimCone
-  limOfArrowsCone : {D₁ D₂ : Functor J C}
-                    (CC₁ : LimCone D₁)
-                  → NatTrans D₁ D₂
-                  → Cone D₂ (CC₁ .lim)
-  coneOut (limOfArrowsCone {D₁} {D₂} CC₁ α) v = limOut CC₁ v ⋆⟨ C ⟩ α .N-ob v
-  coneOutCommutes (limOfArrowsCone {D₁} {D₂} CC₁ α) {u = u} {v = v} e =
-     limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e   ≡⟨ ⋆Assoc C _ _ _ ⟩
-     limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e) ≡⟨ cong (λ x → seq' C (limOut CC₁ u) x) (sym (α .N-hom e)) ⟩
-     limOut CC₁ u ⋆⟨ C ⟩ (D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v) ≡⟨ sym (⋆Assoc C _ _ _) ⟩
-     limOut CC₁ u ⋆⟨ C ⟩ D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v   ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob v) (limOutCommutes CC₁ e) ⟩
-     limOut CC₁ v ⋆⟨ C ⟩ α .N-ob v ∎
-
-  limOfArrows : {D₁ D₂ : Functor J C}
-                (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
-              → NatTrans D₁ D₂
-              → C [ CC₁ .lim , CC₂ .lim ]
-  limOfArrows {D₁} {D₂} CC₁ CC₂ α = limArrow CC₂ (CC₁ .lim) (limOfArrowsCone CC₁ α)
-
-  limOfArrowsOut : {D₁ D₂ : Functor J C}
-                   (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
-                   (α : NatTrans D₁ D₂) (u : ob J)
-                 → limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u ≡ limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u
-  limOfArrowsOut _ CC₂ _ _ = limArrowCommutes CC₂ _ _ _
-
-  limOfArrowsId : {D : Functor J C} (CC : LimCone D)
-                → limOfArrows CC CC (idTrans D) ≡ id C
-  limOfArrowsId CC = limArrowUnique CC _ _ _ λ v → ⋆IdL C _ ∙ sym (⋆IdR C _)
-
-  limOfArrowsSeq : {D₁ D₂ D₃ : Functor J C}
-                   (CC₁ : LimCone D₁) (CC₂ : LimCone D₂) (CC₃ : LimCone D₃)
-                   (α : NatTrans D₁ D₂) (β : NatTrans D₂ D₃)
-                 → limOfArrows CC₁ CC₃ (α ●ᵛ β)
-                 ≡ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β
-  limOfArrowsSeq CC₁ CC₂ CC₃ α β = limArrowUnique CC₃ _ _ _ path
-    where
-    path : ∀ u
-         → (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β) ⋆⟨ C ⟩ limOut CC₃ u
-         ≡ limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ β .N-ob u)
-    path u = (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β) ⋆⟨ C ⟩ limOut CC₃ u
-           ≡⟨ ⋆Assoc C _ _ _ ⟩
-             limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ (limOfArrows CC₂ CC₃ β ⋆⟨ C ⟩ limOut CC₃ u)
-           ≡⟨ cong (λ x → limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ x) (limOfArrowsOut CC₂ CC₃ β u) ⟩
-             limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ (limOut CC₂ u ⋆⟨ C ⟩ β .N-ob u)
-           ≡⟨ sym (⋆Assoc C _ _ _) ⟩
-             (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u) ⋆⟨ C ⟩ β .N-ob u
-           ≡⟨ cong (λ x → x ⋆⟨ C ⟩ β .N-ob u) (limOfArrowsOut CC₁ CC₂ α u) ⟩
-             (limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u) ⋆⟨ C ⟩ β .N-ob u
-           ≡⟨ ⋆Assoc C _ _ _ ⟩
-             limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ β .N-ob u) ∎
-
-  limArrowCompLimOfArrows : {D₁ D₂ : Functor J C}
-                            (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
-                            (α : NatTrans D₁ D₂)
-                            (c : ob C) (cc : Cone D₁ c)
-    → limArrow CC₂ _ (cc ★ₙₜ α) ≡ limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α
-  limArrowCompLimOfArrows CC₁ CC₂ α c cc = limArrowUnique CC₂ _ _ _ isConeMorComp
-    where
-    isConeMorComp : ∀ (u : ob J)
-                  → limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u
-                  ≡ cc .coneOut u ⋆⟨ C ⟩ α .N-ob u
-    isConeMorComp u =
-        limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u
-      ≡⟨ ⋆Assoc C _ _ _ ⟩
-        limArrow CC₁ _ cc ⋆⟨ C ⟩ (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u)
-      ≡⟨ cong (λ x → limArrow CC₁ _ cc ⋆⟨ C ⟩ x) (limOfArrowsOut CC₁ CC₂ α u) ⟩
-        limArrow CC₁ _ cc ⋆⟨ C ⟩ (limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u)
-      ≡⟨ sym (⋆Assoc C _ _ _) ⟩
-        limArrow CC₁ _ cc ⋆⟨ C ⟩ limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u
-      ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob u) (limArrowCommutes CC₁ _ cc u) ⟩
-        cc .coneOut u ⋆⟨ C ⟩ α .N-ob u ∎
-
-  -- any two limits are isomorphic up to a unique cone isomorphism
-  open isIso
-  LimIso : (D : Functor J C) (L₁ L₂ : LimCone D)
-         → ∃![ e ∈ CatIso C (lim L₁) (lim L₂) ] isConeMor (limCone L₁) (limCone L₂) (fst e)
-  fst (fst (fst (LimIso D L₁ L₂))) = limArrow L₂ _ (limCone L₁)
-  inv (snd (fst (fst (LimIso D L₁ L₂)))) = limArrow L₁ _ (limCone L₂)
-  sec (snd (fst (fst (LimIso D L₁ L₂)))) = cong fst (isContr→isProp (univProp L₂ _ (limCone L₂))
-                                            (_ , isConeMorComp) (id C , isConeMorId (limCone L₂)))
-    where
-    isConeMorComp : isConeMor (limCone L₂) (limCone L₂)
-                      (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ limArrow L₂ (lim L₁) (limCone L₁))
-    isConeMorComp v =
-        (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ limArrow L₂ (lim L₁) (limCone L₁))
-                                          ⋆⟨ C ⟩ coneOut (limCone L₂) v
-      ≡⟨ ⋆Assoc C _ _ _ ⟩
-        limArrow L₁ (lim L₂) (limCone L₂)
-          ⋆⟨ C ⟩ (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ coneOut (limCone L₂) v)
-      ≡⟨ cong (λ x → limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ x)
-              (limArrowCommutes L₂ _ (limCone L₁) v) ⟩
-        limArrow L₁ (lim L₂) (limCone L₂)
-          ⋆⟨ C ⟩ (coneOut (limCone L₁) v)
-      ≡⟨ limArrowCommutes L₁ _ (limCone L₂) v ⟩
-        coneOut (limCone L₂) v ∎
-  ret (snd (fst (fst (LimIso D L₁ L₂)))) = cong fst (isContr→isProp (univProp L₁ _ (limCone L₁))
-                                            (_ , isConeMorComp) (id C , isConeMorId (limCone L₁)))
-    where
-    isConeMorComp : isConeMor (limCone L₁) (limCone L₁)
-                      (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ limArrow L₁ (lim L₂) (limCone L₂))
-    isConeMorComp v =
-        (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ limArrow L₁ (lim L₂) (limCone L₂))
-                                          ⋆⟨ C ⟩ coneOut (limCone L₁) v
-      ≡⟨ ⋆Assoc C _ _ _ ⟩
-        limArrow L₂ (lim L₁) (limCone L₁)
-          ⋆⟨ C ⟩ (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ coneOut (limCone L₁) v)
-      ≡⟨ cong (λ x → limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ x)
-              (limArrowCommutes L₁ _ (limCone L₂) v) ⟩
-        limArrow L₂ (lim L₁) (limCone L₁)
-          ⋆⟨ C ⟩ (coneOut (limCone L₂) v)
-      ≡⟨ limArrowCommutes L₂ _ (limCone L₁) v ⟩
-        coneOut (limCone L₁) v ∎
-
-  snd (fst (LimIso D L₁ L₂)) = limArrowCommutes L₂ _ _
-  snd (LimIso D L₁ L₂) (e , isConeMorE) = Σ≡Prop
-      (λ _ → isPropIsConeMor (limCone L₁) (limCone L₂) _)
-      (CatIso≡ _ _ (limArrowUnique L₂ _ _ (fst e) isConeMorE))
-
-  -- if the index category of the diagram has an initial object,
-  -- we get a canonical limiting cone
-  Initial→LimCone : (D : Functor J C) → Initial J → LimCone D
-  lim (Initial→LimCone D (j , isInitJ)) = D .F-ob j
-  coneOut (limCone (Initial→LimCone D (j , isInitJ))) k = D .F-hom (isInitJ k .fst)
-  coneOutCommutes (limCone (Initial→LimCone D (j , isInitJ))) f =
-                      sym (D .F-seq _ _) ∙ cong (D .F-hom) (sym (isInitJ _ .snd _))
-  fst (fst (univProp (Initial→LimCone D (j , isInitJ)) c cc)) = cc .coneOut j
-                                                                -- canonical arrow c → D(j)
-  snd (fst (univProp (Initial→LimCone D (j , isInitJ)) c cc)) k =
-                                                         cc .coneOutCommutes (isInitJ k .fst)
-                                                         -- is a cone morphism
-  snd (univProp (Initial→LimCone D (j , isInitJ)) c cc) (f , isConeMorF) = -- and indeed unique
-    Σ≡Prop
-      (λ _ → isPropIsConeMor cc (limCone (Initial→LimCone D (j , isInitJ))) _)
-        (sym (isConeMorF j) ∙∙ cong (λ x → f ⋆⟨ C ⟩ x) (subst (λ x → D .F-hom x ≡ id C)
-                                                              (sym (isInitJ j .snd _)) (D .F-id))
-                            ∙∙ ⋆IdR C f)
-
-  -- cones that respect isomorphisms are limiting cones
-  Iso→LimCone : {D : Functor J C} {c₁ c₂ : ob C} (cc₁ : Cone D c₁) (e : CatIso C c₁ c₂)
-              → isLimCone _ _ cc₁
-              → (cc₂ : Cone D c₂)
-              → isConeMor cc₁ cc₂ (e .fst)
-              → isLimCone _ _ cc₂
-  fst (fst (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd)) =
-    isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst
-  snd (fst (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd)) =
-    isConeMorSeq cd cc₁ cc₂ (isLimConeCC₁ d cd .fst .snd) isConeMorE
-  snd (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd) (f , isConeMorF) =
-    Σ≡Prop (isPropIsConeMor cd cc₂) path
-    where
-    isConeMorE⁻¹ : isConeMor cc₂ cc₁ (e .snd .inv)
-    isConeMorE⁻¹ v =
-      e .snd .inv ⋆⟨ C ⟩ coneOut cc₁ v ≡⟨ cong (λ x → e .snd .inv ⋆⟨ C ⟩ x) (sym (isConeMorE v)) ⟩
-      e .snd .inv ⋆⟨ C ⟩ (e .fst ⋆⟨ C ⟩ coneOut cc₂ v) ≡⟨ sym (⋆Assoc C _ _ _) ⟩
-      (e .snd .inv ⋆⟨ C ⟩ e .fst) ⋆⟨ C ⟩ coneOut cc₂ v ≡⟨ cong (λ x → x ⋆⟨ C ⟩ coneOut cc₂ v)
-                                                              (e .snd .sec) ⟩
-      id C ⋆⟨ C ⟩ coneOut cc₂ v ≡⟨ ⋆IdL C _ ⟩
-      coneOut cc₂ v ∎
-
-    p : isLimConeCC₁ d cd .fst .fst ≡ f ⋆⟨ C ⟩ e .snd .inv
-    p = cong fst (isLimConeCC₁ d cd .snd ( f ⋆⟨ C ⟩ e .snd .inv
-                                         , isConeMorSeq cd cc₂ cc₁ isConeMorF isConeMorE⁻¹))
-
-    path : isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst ≡ f
-    path = isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst ≡⟨ cong (λ x → x ⋆⟨ C ⟩ e .fst) p ⟩
-           (f ⋆⟨ C ⟩ e .snd .inv) ⋆⟨ C ⟩ e .fst ≡⟨ ⋆Assoc C _ _ _ ⟩
-           f ⋆⟨ C ⟩ (e .snd .inv ⋆⟨ C ⟩ e .fst) ≡⟨ cong (λ x → f ⋆⟨ C ⟩ x) (e .snd .sec) ⟩
-           f ⋆⟨ C ⟩ id C ≡⟨ ⋆IdR C _ ⟩
-           f ∎
-
--- A category is complete if it has all limits
-Limits : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓC ℓC' → Type _
-Limits {ℓJ} {ℓJ'} C = (J : Category ℓJ ℓJ') → (D : Functor J C) → LimCone D
-
-hasLimits : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓC ℓC' → Type _
-hasLimits {ℓJ} {ℓJ'} C = (J : Category ℓJ ℓJ') → (D : Functor J C) → ∥ LimCone D ∥₁
-
--- Limits of a specific shape J in a category C
-LimitsOfShape : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓJ ℓJ' → Category ℓC ℓC' → Type _
-LimitsOfShape J C = (D : Functor J C) → LimCone D
-
-
--- precomposition with a functor and preservation of limits
-module _ {ℓJ ℓJ' ℓC1 ℓC1' ℓC2 ℓC2' : Level}
-         {C1 : Category ℓC1 ℓC1'} {C2 : Category ℓC2 ℓC2'}
-         (F : Functor C1 C2) where
-  open Category
-  open Functor
-  open Cone
-
-  -- same as F-cone!!!
-  F-cone : {J : Category ℓJ ℓJ'} {D : Functor J C1} {x : ob C1}
-          → Cone D x → Cone (funcComp F D) (F .F-ob x)
-  coneOut (F-cone ccx) v = F .F-hom (coneOut ccx v)
-  coneOutCommutes (F-cone ccx) e =
-    sym (F-seq F (coneOut ccx _) _) ∙ cong (F .F-hom) (coneOutCommutes ccx e)
-
-  preservesLimits : Type _
-  preservesLimits = ∀ {J : Category ℓJ ℓJ'} {D : Functor J C1} {L : ob C1}
-                      (ccL : Cone D L)
-                  → isLimCone _ _ ccL → isLimCone (funcComp F D) (F .F-ob L) (F-cone ccL)
-
-  -- characterizing limit preserving functors
-  open LimCone
-
-  preservesLimitsChar : (L₁ : Limits {ℓJ} {ℓJ'} C1) (L₂ : Limits {ℓJ} {ℓJ'} C2)
-     → (e : ∀ J D → CatIso C2 (L₂ J (F ∘F D) .lim) (F .F-ob (L₁ J D .lim)))
-     → (∀ J D → isConeMor (L₂ J (F ∘F D) .limCone) (F-cone (L₁ J D .limCone)) (e J D .fst))
-     → preservesLimits
-  preservesLimitsChar L₁ L₂ e isConeMorE {J = J} {D = D} {L = c} cc isLimConeCC =
-    Iso→LimCone (L₂ J (F ∘F D) .limCone) f (L₂ J (F ∘F D) .univProp) (F-cone cc) isConeMorF
-    where
-    theCLimCone : LimCone D
-    lim theCLimCone = c
-    limCone theCLimCone = cc
-    univProp theCLimCone = isLimConeCC
-
-    f : CatIso C2 (lim (L₂ J (funcComp F D))) (F .F-ob c)
-    f = ⋆Iso (e J D) (F-Iso {F = F} (LimIso D (L₁ J D) theCLimCone .fst .fst))
-
-    isConeMorF : isConeMor (L₂ J (funcComp F D) .limCone) (F-cone cc) (f .fst)
-    isConeMorF = isConeMorSeq (L₂ J (funcComp F D) .limCone)
-                              (F-cone (L₁ J D .limCone))
-                              (F-cone cc)
-                  (isConeMorE J D)
-                  (λ v → F-triangle F (limArrowCommutes theCLimCone _ _ _))
-
-  -- TODO: prove that right adjoints preserve limits
+{-# OPTIONS --safe #-}
+module Cubical.Categories.Limits.Limits where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Function
+
+open import Cubical.Data.Sigma
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Isomorphism
+open import Cubical.Categories.Functor
+open import Cubical.Categories.NaturalTransformation
+
+open import Cubical.Categories.Limits.Initial
+
+open import Cubical.HITs.PropositionalTruncation.Base
+
+module _ {ℓJ ℓJ' ℓC ℓC' : Level} {J : Category ℓJ ℓJ'} {C : Category ℓC ℓC'} where
+  open Category
+  open Functor
+  open NatTrans
+
+  private
+    ℓ = ℓ-max (ℓ-max (ℓ-max ℓJ ℓJ') ℓC) ℓC'
+
+  record Cone (D : Functor J C) (c : ob C) : Type (ℓ-max (ℓ-max ℓJ ℓJ') ℓC') where
+    constructor cone
+
+    field
+      coneOut : (v : ob J) → C [ c , F-ob D v ]
+      coneOutCommutes : {u v : ob J} (e : J [ u , v ]) →
+                        coneOut u ⋆⟨ C ⟩ D .F-hom e ≡ coneOut v
+
+  open Cone
+
+  cone≡ : {D : Functor J C} {c : ob C} → {c1 c2 : Cone D c}
+        → ((v : ob J) → coneOut c1 v ≡ coneOut c2 v) → c1 ≡ c2
+  coneOut (cone≡ h i) v = h v i
+  coneOutCommutes (cone≡ {D} {_} {c1} {c2} h i) {u} {v} e =
+    isProp→PathP (λ j → isSetHom C (h u j ⋆⟨ C ⟩ D .F-hom e) (h v j))
+                 (coneOutCommutes c1 e) (coneOutCommutes c2 e) i
+
+  -- dependent versions
+  conePathP : {D₁ D₂ : Functor J C} {c₁ c₂ : ob C} {cc₁ : Cone D₁ c₁} {cc₂ : Cone D₂ c₂}
+              {p : D₁ ≡ D₂} {q : c₁ ≡ c₂}
+            → (∀ v → PathP (λ i → C [ q i , p i .F-ob v ]) (cc₁ .coneOut v) (cc₂ .coneOut v))
+            → PathP (λ i → Cone (p i) (q i)) cc₁ cc₂
+  coneOut (conePathP coneOutPathP i) v = coneOutPathP v i
+  coneOutCommutes (conePathP {cc₁ = cc₁} {cc₂ = cc₂} {p = p} coneOutPathP i) {u} {v} e =
+    isProp→PathP (λ j → isSetHom C (coneOutPathP u j ⋆⟨ C ⟩ p j .F-hom e)
+                                   (coneOutPathP v j))
+                 (coneOutCommutes cc₁ e) (coneOutCommutes cc₂ e) i
+
+  conePathPOb : {D : Functor J C} {c c' : ob C} {c1 : Cone D c} {c2 : Cone D c'} {p : c ≡ c'}
+            → (∀ (v : ob J) → PathP (λ i → C [ p i , F-ob D v ]) (coneOut c1 v) (coneOut c2 v))
+            → PathP (λ i → Cone D (p i)) c1 c2
+  conePathPOb coneOutPathP = conePathP {p = refl} coneOutPathP
+
+  conePathPDiag : {D₁ D₂ : Functor J C} {c : ob C} {cc₁ : Cone D₁ c} {cc₂ : Cone D₂ c} {p : D₁ ≡ D₂}
+                → (∀ v → PathP (λ i → C [ c , p i .F-ob v ]) (cc₁ .coneOut v) (cc₂ .coneOut v))
+                → PathP (λ i → Cone (p i) c) cc₁ cc₂
+  conePathPDiag coneOutPathP = conePathP {q = refl} coneOutPathP
+
+
+  -- TODO: can we automate this a bit?
+  isSetCone : (D : Functor J C) (c : ob C) → isSet (Cone D c)
+  isSetCone D c = isSetRetract toConeΣ fromConeΣ (λ _ → refl)
+                               (isSetΣSndProp (isSetΠ (λ _ → isSetHom C))
+                                              (λ _ → isPropImplicitΠ2 (λ _ _ → isPropΠ (λ _ → isSetHom C _ _))))
+    where
+    ConeΣ = Σ[ f ∈ ((v : ob J) → C [ c , F-ob D v ]) ]
+               ({u v : ob J} (e : J [ u , v ]) → f u ⋆⟨ C ⟩ D .F-hom e ≡ f v)
+
+    toConeΣ : Cone D c → ConeΣ
+    fst (toConeΣ x) = coneOut x
+    snd (toConeΣ x) = coneOutCommutes x
+
+    fromConeΣ : ConeΣ → Cone D c
+    coneOut (fromConeΣ x) = fst x
+    coneOutCommutes (fromConeΣ x) = snd x
+
+  preCompCone : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C}
+              → Cone D c2 → Cone D c1
+  coneOut (preCompCone f cc) v = f ⋆⟨ C ⟩ coneOut cc v
+  coneOutCommutes (preCompCone f cc) e = ⋆Assoc C _ _ _
+                                       ∙ cong (λ x → f ⋆⟨ C ⟩ x) (coneOutCommutes cc e)
+
+  _★_ : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} → Cone D c2 → Cone D c1
+  _★_ = preCompCone
+
+  natTransPostCompCone : {c : ob C} {D₁ D₂ : Functor J C} (α : NatTrans D₁ D₂)
+                       → Cone D₁ c → Cone D₂ c
+  coneOut (natTransPostCompCone α cc) u = cc .coneOut u ⋆⟨ C ⟩ α .N-ob u
+  coneOutCommutes (natTransPostCompCone {D₁ = D₁} {D₂ = D₂} α cc) {u = u} {v = v}  e =
+      cc .coneOut u ⋆⟨ C ⟩ α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e
+    ≡⟨ ⋆Assoc C _ _ _ ⟩
+      cc .coneOut u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e)
+    ≡⟨ cong (λ x → cc .coneOut u ⋆⟨ C ⟩ x) (sym (α .N-hom e)) ⟩
+      cc .coneOut u ⋆⟨ C ⟩ (D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v)
+    ≡⟨ sym (⋆Assoc C _ _ _) ⟩
+      cc .coneOut u ⋆⟨ C ⟩ D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v
+    ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob v) (cc .coneOutCommutes e) ⟩
+      cc .coneOut v ⋆⟨ C ⟩ α .N-ob v ∎
+
+  _★ₙₜ_ : {c : ob C} {D₁ D₂ : Functor J C} → Cone D₁ c → NatTrans D₁ D₂ → Cone D₂ c
+  _★ₙₜ_ = flip natTransPostCompCone
+
+  isConeMor : {c1 c2 : ob C} {D : Functor J C}
+              (cc1 : Cone D c1) (cc2 : Cone D c2)
+            → C [ c1 , c2 ] → Type (ℓ-max ℓJ ℓC')
+  isConeMor cc1 cc2 f = (v : ob J) → f ⋆⟨ C ⟩ coneOut cc2 v ≡ coneOut cc1 v
+
+  isPropIsConeMor : {c1 c2 : ob C} {D : Functor J C}
+                    (cc1 : Cone D c1) (cc2 : Cone D c2) (f : C [ c1 , c2 ])
+                  → isProp (isConeMor cc1 cc2 f)
+  isPropIsConeMor cc1 cc2 f = isPropΠ (λ _ → isSetHom C _ _)
+
+  isConeMorId : {c : ob C} {D : Functor J C} (cc : Cone D c)
+              → isConeMor cc cc (id C)
+  isConeMorId _ _ = ⋆IdL C _
+
+  isConeMorSeq : {c1 c2 c3 : ob C} {D : Functor J C}
+                 (cc1 : Cone D c1) (cc2 : Cone D c2) (cc3  : Cone D c3)
+                 {f : C [ c1 , c2 ]} {g : C [ c2 , c3 ]}
+               → isConeMor cc1 cc2 f → isConeMor cc2 cc3 g → isConeMor cc1 cc3 (f ⋆⟨ C ⟩ g)
+  isConeMorSeq cc1 cc2 cc3 {f} {g} isConeMorF isConeMorG v =
+    ⋆Assoc C _ _ _ ∙∙ cong (λ x → f ⋆⟨ C ⟩ x) (isConeMorG v) ∙∙ isConeMorF v
+
+  preCompConeMor : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} (cc : Cone D c2)
+                 → isConeMor (f ★ cc) cc f
+  preCompConeMor f cc v = refl
+
+  isLimCone : (D : Functor J C) (c0 : ob C) → Cone D c0 → Type ℓ
+  isLimCone D c0 cc0 = (c : ob C) → (cc : Cone D c)
+                     → ∃![ f ∈ C [ c , c0 ] ] isConeMor cc cc0 f
+
+  isPropIsLimCone : (D : Functor J C) (c0 : ob C) (cc0 : Cone D c0)
+                  → isProp (isLimCone D c0 cc0)
+  isPropIsLimCone D c0 cc0 = isPropΠ2 λ _ _ → isProp∃!
+
+  preCompUnique : {c1 c2 : ob C} (f : C [ c1 , c2 ]) {D : Functor J C} (cc : Cone D c2)
+                → isLimCone D c2 cc
+                → ∀ (g : C [ c1 , c2 ]) → isConeMor (f ★ cc) cc g → g ≡ f
+  preCompUnique f cc ccIsLimCone g gIsConeMor =
+     cong fst (isContr→isProp (ccIsLimCone _ (f ★ cc)) (g , gIsConeMor) (f , preCompConeMor f cc))
+
+  record LimCone (D : Functor J C) : Type ℓ where
+    constructor climCone
+
+    field
+      lim : ob C
+      limCone : Cone D lim
+      univProp : isLimCone D lim limCone
+
+    limOut : (v : ob J) → C [ lim , D .F-ob v ]
+    limOut = coneOut limCone
+
+    limOutCommutes : {u v : ob J} (e : J [ u , v ])
+                   → limOut u ⋆⟨ C ⟩ D .F-hom e ≡ limOut v
+    limOutCommutes = coneOutCommutes limCone
+
+    limArrow : (c : ob C) → (cc : Cone D c) → C [ c , lim ]
+    limArrow c cc = univProp c cc .fst .fst
+
+    limArrowCommutes : (c : ob C) → (cc : Cone D c) (u : ob J)
+                     → limArrow c cc ⋆⟨ C ⟩ limOut u ≡ coneOut cc u
+    limArrowCommutes c cc = univProp c cc .fst .snd
+
+    limArrowUnique : (c : ob C) → (cc : Cone D c) (k : C [ c , lim ])
+                   → isConeMor cc limCone k → limArrow c cc ≡ k
+    limArrowUnique c cc k hk = cong fst (univProp c cc .snd (k , hk))
+
+  open LimCone
+  limOfArrowsCone : {D₁ D₂ : Functor J C}
+                    (CC₁ : LimCone D₁)
+                  → NatTrans D₁ D₂
+                  → Cone D₂ (CC₁ .lim)
+  coneOut (limOfArrowsCone {D₁} {D₂} CC₁ α) v = limOut CC₁ v ⋆⟨ C ⟩ α .N-ob v
+  coneOutCommutes (limOfArrowsCone {D₁} {D₂} CC₁ α) {u = u} {v = v} e =
+     limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e   ≡⟨ ⋆Assoc C _ _ _ ⟩
+     limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ D₂ .F-hom e) ≡⟨ cong (λ x → seq' C (limOut CC₁ u) x) (sym (α .N-hom e)) ⟩
+     limOut CC₁ u ⋆⟨ C ⟩ (D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v) ≡⟨ sym (⋆Assoc C _ _ _) ⟩
+     limOut CC₁ u ⋆⟨ C ⟩ D₁ .F-hom e ⋆⟨ C ⟩ α .N-ob v   ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob v) (limOutCommutes CC₁ e) ⟩
+     limOut CC₁ v ⋆⟨ C ⟩ α .N-ob v ∎
+
+  limOfArrows : {D₁ D₂ : Functor J C}
+                (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
+              → NatTrans D₁ D₂
+              → C [ CC₁ .lim , CC₂ .lim ]
+  limOfArrows {D₁} {D₂} CC₁ CC₂ α = limArrow CC₂ (CC₁ .lim) (limOfArrowsCone CC₁ α)
+
+  limOfArrowsOut : {D₁ D₂ : Functor J C}
+                   (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
+                   (α : NatTrans D₁ D₂) (u : ob J)
+                 → limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u ≡ limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u
+  limOfArrowsOut _ CC₂ _ _ = limArrowCommutes CC₂ _ _ _
+
+  limOfArrowsId : {D : Functor J C} (CC : LimCone D)
+                → limOfArrows CC CC (idTrans D) ≡ id C
+  limOfArrowsId CC = limArrowUnique CC _ _ _ λ v → ⋆IdL C _ ∙ sym (⋆IdR C _)
+
+  limOfArrowsSeq : {D₁ D₂ D₃ : Functor J C}
+                   (CC₁ : LimCone D₁) (CC₂ : LimCone D₂) (CC₃ : LimCone D₃)
+                   (α : NatTrans D₁ D₂) (β : NatTrans D₂ D₃)
+                 → limOfArrows CC₁ CC₃ (α ●ᵛ β)
+                 ≡ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β
+  limOfArrowsSeq CC₁ CC₂ CC₃ α β = limArrowUnique CC₃ _ _ _ path
+    where
+    path : ∀ u
+         → (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β) ⋆⟨ C ⟩ limOut CC₃ u
+         ≡ limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ β .N-ob u)
+    path u = (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOfArrows CC₂ CC₃ β) ⋆⟨ C ⟩ limOut CC₃ u
+           ≡⟨ ⋆Assoc C _ _ _ ⟩
+             limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ (limOfArrows CC₂ CC₃ β ⋆⟨ C ⟩ limOut CC₃ u)
+           ≡⟨ cong (λ x → limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ x) (limOfArrowsOut CC₂ CC₃ β u) ⟩
+             limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ (limOut CC₂ u ⋆⟨ C ⟩ β .N-ob u)
+           ≡⟨ sym (⋆Assoc C _ _ _) ⟩
+             (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u) ⋆⟨ C ⟩ β .N-ob u
+           ≡⟨ cong (λ x → x ⋆⟨ C ⟩ β .N-ob u) (limOfArrowsOut CC₁ CC₂ α u) ⟩
+             (limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u) ⋆⟨ C ⟩ β .N-ob u
+           ≡⟨ ⋆Assoc C _ _ _ ⟩
+             limOut CC₁ u ⋆⟨ C ⟩ (α .N-ob u ⋆⟨ C ⟩ β .N-ob u) ∎
+
+  limArrowCompLimOfArrows : {D₁ D₂ : Functor J C}
+                            (CC₁ : LimCone D₁) (CC₂ : LimCone D₂)
+                            (α : NatTrans D₁ D₂)
+                            (c : ob C) (cc : Cone D₁ c)
+    → limArrow CC₂ _ (cc ★ₙₜ α) ≡ limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α
+  limArrowCompLimOfArrows CC₁ CC₂ α c cc = limArrowUnique CC₂ _ _ _ isConeMorComp
+    where
+    isConeMorComp : ∀ (u : ob J)
+                  → limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u
+                  ≡ cc .coneOut u ⋆⟨ C ⟩ α .N-ob u
+    isConeMorComp u =
+        limArrow CC₁ _ cc ⋆⟨ C ⟩ limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u
+      ≡⟨ ⋆Assoc C _ _ _ ⟩
+        limArrow CC₁ _ cc ⋆⟨ C ⟩ (limOfArrows CC₁ CC₂ α ⋆⟨ C ⟩ limOut CC₂ u)
+      ≡⟨ cong (λ x → limArrow CC₁ _ cc ⋆⟨ C ⟩ x) (limOfArrowsOut CC₁ CC₂ α u) ⟩
+        limArrow CC₁ _ cc ⋆⟨ C ⟩ (limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u)
+      ≡⟨ sym (⋆Assoc C _ _ _) ⟩
+        limArrow CC₁ _ cc ⋆⟨ C ⟩ limOut CC₁ u ⋆⟨ C ⟩ α .N-ob u
+      ≡⟨ cong (λ x → x ⋆⟨ C ⟩ α .N-ob u) (limArrowCommutes CC₁ _ cc u) ⟩
+        cc .coneOut u ⋆⟨ C ⟩ α .N-ob u ∎
+
+  -- any two limits are isomorphic up to a unique cone isomorphism
+  open isIso
+  LimIso : (D : Functor J C) (L₁ L₂ : LimCone D)
+         → ∃![ e ∈ CatIso C (lim L₁) (lim L₂) ] isConeMor (limCone L₁) (limCone L₂) (fst e)
+  fst (fst (fst (LimIso D L₁ L₂))) = limArrow L₂ _ (limCone L₁)
+  inv (snd (fst (fst (LimIso D L₁ L₂)))) = limArrow L₁ _ (limCone L₂)
+  sec (snd (fst (fst (LimIso D L₁ L₂)))) = cong fst (isContr→isProp (univProp L₂ _ (limCone L₂))
+                                            (_ , isConeMorComp) (id C , isConeMorId (limCone L₂)))
+    where
+    isConeMorComp : isConeMor (limCone L₂) (limCone L₂)
+                      (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ limArrow L₂ (lim L₁) (limCone L₁))
+    isConeMorComp v =
+        (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ limArrow L₂ (lim L₁) (limCone L₁))
+                                          ⋆⟨ C ⟩ coneOut (limCone L₂) v
+      ≡⟨ ⋆Assoc C _ _ _ ⟩
+        limArrow L₁ (lim L₂) (limCone L₂)
+          ⋆⟨ C ⟩ (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ coneOut (limCone L₂) v)
+      ≡⟨ cong (λ x → limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ x)
+              (limArrowCommutes L₂ _ (limCone L₁) v) ⟩
+        limArrow L₁ (lim L₂) (limCone L₂)
+          ⋆⟨ C ⟩ (coneOut (limCone L₁) v)
+      ≡⟨ limArrowCommutes L₁ _ (limCone L₂) v ⟩
+        coneOut (limCone L₂) v ∎
+  ret (snd (fst (fst (LimIso D L₁ L₂)))) = cong fst (isContr→isProp (univProp L₁ _ (limCone L₁))
+                                            (_ , isConeMorComp) (id C , isConeMorId (limCone L₁)))
+    where
+    isConeMorComp : isConeMor (limCone L₁) (limCone L₁)
+                      (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ limArrow L₁ (lim L₂) (limCone L₂))
+    isConeMorComp v =
+        (limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ limArrow L₁ (lim L₂) (limCone L₂))
+                                          ⋆⟨ C ⟩ coneOut (limCone L₁) v
+      ≡⟨ ⋆Assoc C _ _ _ ⟩
+        limArrow L₂ (lim L₁) (limCone L₁)
+          ⋆⟨ C ⟩ (limArrow L₁ (lim L₂) (limCone L₂) ⋆⟨ C ⟩ coneOut (limCone L₁) v)
+      ≡⟨ cong (λ x → limArrow L₂ (lim L₁) (limCone L₁) ⋆⟨ C ⟩ x)
+              (limArrowCommutes L₁ _ (limCone L₂) v) ⟩
+        limArrow L₂ (lim L₁) (limCone L₁)
+          ⋆⟨ C ⟩ (coneOut (limCone L₂) v)
+      ≡⟨ limArrowCommutes L₂ _ (limCone L₁) v ⟩
+        coneOut (limCone L₁) v ∎
+
+  snd (fst (LimIso D L₁ L₂)) = limArrowCommutes L₂ _ _
+  snd (LimIso D L₁ L₂) (e , isConeMorE) = Σ≡Prop
+      (λ _ → isPropIsConeMor (limCone L₁) (limCone L₂) _)
+      (CatIso≡ _ _ (limArrowUnique L₂ _ _ (fst e) isConeMorE))
+
+  -- if the index category of the diagram has an initial object,
+  -- we get a canonical limiting cone
+  Initial→LimCone : (D : Functor J C) → Initial J → LimCone D
+  lim (Initial→LimCone D (j , isInitJ)) = D .F-ob j
+  coneOut (limCone (Initial→LimCone D (j , isInitJ))) k = D .F-hom (isInitJ k .fst)
+  coneOutCommutes (limCone (Initial→LimCone D (j , isInitJ))) f =
+                      sym (D .F-seq _ _) ∙ cong (D .F-hom) (sym (isInitJ _ .snd _))
+  fst (fst (univProp (Initial→LimCone D (j , isInitJ)) c cc)) = cc .coneOut j
+                                                                -- canonical arrow c → D(j)
+  snd (fst (univProp (Initial→LimCone D (j , isInitJ)) c cc)) k =
+                                                         cc .coneOutCommutes (isInitJ k .fst)
+                                                         -- is a cone morphism
+  snd (univProp (Initial→LimCone D (j , isInitJ)) c cc) (f , isConeMorF) = -- and indeed unique
+    Σ≡Prop
+      (λ _ → isPropIsConeMor cc (limCone (Initial→LimCone D (j , isInitJ))) _)
+        (sym (isConeMorF j) ∙∙ cong (λ x → f ⋆⟨ C ⟩ x) (subst (λ x → D .F-hom x ≡ id C)
+                                                              (sym (isInitJ j .snd _)) (D .F-id))
+                            ∙∙ ⋆IdR C f)
+
+  -- cones that respect isomorphisms are limiting cones
+  Iso→LimCone : {D : Functor J C} {c₁ c₂ : ob C} (cc₁ : Cone D c₁) (e : CatIso C c₁ c₂)
+              → isLimCone _ _ cc₁
+              → (cc₂ : Cone D c₂)
+              → isConeMor cc₁ cc₂ (e .fst)
+              → isLimCone _ _ cc₂
+  fst (fst (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd)) =
+    isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst
+  snd (fst (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd)) =
+    isConeMorSeq cd cc₁ cc₂ (isLimConeCC₁ d cd .fst .snd) isConeMorE
+  snd (Iso→LimCone cc₁ e isLimConeCC₁ cc₂ isConeMorE d cd) (f , isConeMorF) =
+    Σ≡Prop (isPropIsConeMor cd cc₂) path
+    where
+    isConeMorE⁻¹ : isConeMor cc₂ cc₁ (e .snd .inv)
+    isConeMorE⁻¹ v =
+      e .snd .inv ⋆⟨ C ⟩ coneOut cc₁ v ≡⟨ cong (λ x → e .snd .inv ⋆⟨ C ⟩ x) (sym (isConeMorE v)) ⟩
+      e .snd .inv ⋆⟨ C ⟩ (e .fst ⋆⟨ C ⟩ coneOut cc₂ v) ≡⟨ sym (⋆Assoc C _ _ _) ⟩
+      (e .snd .inv ⋆⟨ C ⟩ e .fst) ⋆⟨ C ⟩ coneOut cc₂ v ≡⟨ cong (λ x → x ⋆⟨ C ⟩ coneOut cc₂ v)
+                                                              (e .snd .sec) ⟩
+      id C ⋆⟨ C ⟩ coneOut cc₂ v ≡⟨ ⋆IdL C _ ⟩
+      coneOut cc₂ v ∎
+
+    p : isLimConeCC₁ d cd .fst .fst ≡ f ⋆⟨ C ⟩ e .snd .inv
+    p = cong fst (isLimConeCC₁ d cd .snd ( f ⋆⟨ C ⟩ e .snd .inv
+                                         , isConeMorSeq cd cc₂ cc₁ isConeMorF isConeMorE⁻¹))
+
+    path : isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst ≡ f
+    path = isLimConeCC₁ d cd .fst .fst ⋆⟨ C ⟩ e .fst ≡⟨ cong (λ x → x ⋆⟨ C ⟩ e .fst) p ⟩
+           (f ⋆⟨ C ⟩ e .snd .inv) ⋆⟨ C ⟩ e .fst ≡⟨ ⋆Assoc C _ _ _ ⟩
+           f ⋆⟨ C ⟩ (e .snd .inv ⋆⟨ C ⟩ e .fst) ≡⟨ cong (λ x → f ⋆⟨ C ⟩ x) (e .snd .sec) ⟩
+           f ⋆⟨ C ⟩ id C ≡⟨ ⋆IdR C _ ⟩
+           f ∎
+
+-- A category is complete if it has all limits
+Limits : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓC ℓC' → Type _
+Limits {ℓJ} {ℓJ'} C = (J : Category ℓJ ℓJ') → (D : Functor J C) → LimCone D
+
+hasLimits : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓC ℓC' → Type _
+hasLimits {ℓJ} {ℓJ'} C = (J : Category ℓJ ℓJ') → (D : Functor J C) → ∥ LimCone D ∥₁
+
+-- Limits of a specific shape J in a category C
+LimitsOfShape : {ℓJ ℓJ' ℓC ℓC' : Level} → Category ℓJ ℓJ' → Category ℓC ℓC' → Type _
+LimitsOfShape J C = (D : Functor J C) → LimCone D
+
+
+-- precomposition with a functor and preservation of limits
+module _ {ℓJ ℓJ' ℓC1 ℓC1' ℓC2 ℓC2' : Level}
+         {C1 : Category ℓC1 ℓC1'} {C2 : Category ℓC2 ℓC2'}
+         (F : Functor C1 C2) where
+  open Category
+  open Functor
+  open Cone
+
+  -- same as F-cone!!!
+  F-cone : {J : Category ℓJ ℓJ'} {D : Functor J C1} {x : ob C1}
+          → Cone D x → Cone (funcComp F D) (F .F-ob x)
+  coneOut (F-cone ccx) v = F .F-hom (coneOut ccx v)
+  coneOutCommutes (F-cone ccx) e =
+    sym (F-seq F (coneOut ccx _) _) ∙ cong (F .F-hom) (coneOutCommutes ccx e)
+
+  preservesLimits : Type _
+  preservesLimits = ∀ {J : Category ℓJ ℓJ'} {D : Functor J C1} {L : ob C1}
+                      (ccL : Cone D L)
+                  → isLimCone _ _ ccL → isLimCone (funcComp F D) (F .F-ob L) (F-cone ccL)
+
+  -- characterizing limit preserving functors
+  open LimCone
+
+  preservesLimitsChar : (L₁ : Limits {ℓJ} {ℓJ'} C1) (L₂ : Limits {ℓJ} {ℓJ'} C2)
+     → (e : ∀ J D → CatIso C2 (L₂ J (F ∘F D) .lim) (F .F-ob (L₁ J D .lim)))
+     → (∀ J D → isConeMor (L₂ J (F ∘F D) .limCone) (F-cone (L₁ J D .limCone)) (e J D .fst))
+     → preservesLimits
+  preservesLimitsChar L₁ L₂ e isConeMorE {J = J} {D = D} {L = c} cc isLimConeCC =
+    Iso→LimCone (L₂ J (F ∘F D) .limCone) f (L₂ J (F ∘F D) .univProp) (F-cone cc) isConeMorF
+    where
+    theCLimCone : LimCone D
+    lim theCLimCone = c
+    limCone theCLimCone = cc
+    univProp theCLimCone = isLimConeCC
+
+    f : CatIso C2 (lim (L₂ J (funcComp F D))) (F .F-ob c)
+    f = ⋆Iso (e J D) (F-Iso {F = F} (LimIso D (L₁ J D) theCLimCone .fst .fst))
+
+    isConeMorF : isConeMor (L₂ J (funcComp F D) .limCone) (F-cone cc) (f .fst)
+    isConeMorF = isConeMorSeq (L₂ J (funcComp F D) .limCone)
+                              (F-cone (L₁ J D .limCone))
+                              (F-cone cc)
+                  (isConeMorE J D)
+                  (λ v → F-triangle F (limArrowCommutes theCLimCone _ _ _))
+
+  -- TODO: prove that right adjoints preserve limits
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.Pullback.html b/docs/Cubical.Categories.Limits.Pullback.html
index 02501cb..4152123 100644
--- a/docs/Cubical.Categories.Limits.Pullback.html
+++ b/docs/Cubical.Categories.Limits.Pullback.html
@@ -1,155 +1,155 @@
 
-Cubical.Categories.Limits.Pullback
{-# OPTIONS --allow-unsolved-metas #-}
-module Cubical.Categories.Limits.Pullback where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.HITs.PropositionalTruncation.Base
-
-open import Cubical.Data.Sigma
-open import Cubical.Data.Unit
-
-open import Cubical.Categories.Category
-open import Cubical.Categories.Functor
-open import Cubical.Categories.Instances.Cospan
-open import Cubical.Categories.Limits.Limits
-
-private
-  variable
-    ℓ ℓ' : Level
-
-module _ (C : Category ℓ ℓ') where
-
-  open Category C
-  open Functor
-
-  record Cospan : Type (ℓ-max ℓ ℓ') where
-    constructor cospan
-    field
-      l m r : ob
-      s₁ : C [ l , m ]
-      s₂ : C [ r , m ]
-
-  open Cospan
-
-  isPullback : (cspn : Cospan) →
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → Type (ℓ-max ℓ ℓ')
-  isPullback cspn {c} p₁ p₂ H =
-    ∀ {d} (h : C [ d , cspn .l ]) (k : C [ d , cspn .r ])
-          (H' : h ⋆ cspn .s₁ ≡ k ⋆ cspn .s₂)
-    → ∃![ hk ∈ C [ d , c ] ] (h ≡ hk ⋆ p₁) × (k ≡ hk ⋆ p₂)
-
-  isPropIsPullback : (cspn : Cospan) →
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → isProp (isPullback cspn p₁ p₂ H)
-  isPropIsPullback cspn p₁ p₂ H =
-    isPropImplicitΠ (λ x → isPropΠ3 λ h k H' → isPropIsContr)
-
-  record Pullback (cspn : Cospan) : Type (ℓ-max ℓ ℓ') where
-    field
-      pbOb  : ob
-      pbPr₁ : C [ pbOb , cspn .l ]
-      pbPr₂ : C [ pbOb , cspn .r ]
-      pbCommutes : pbPr₁ ⋆ cspn .s₁ ≡ pbPr₂ ⋆ cspn .s₂
-      univProp : isPullback cspn pbPr₁ pbPr₂ pbCommutes
-
-  open Pullback
-
-  pullbackArrow :
-    {cspn : Cospan} (pb : Pullback cspn)
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → C [ c , pb . pbOb ]
-  pullbackArrow pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .fst
-
-  pullbackArrowPr₁ :
-    {cspn : Cospan} (pb : Pullback cspn)
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
-    p₁ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₁ pb
-  pullbackArrowPr₁ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .fst
-
-  pullbackArrowPr₂ :
-    {cspn : Cospan} (pb : Pullback cspn)
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
-    p₂ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₂ pb
-  pullbackArrowPr₂ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .snd
-
-  pullbackArrowUnique :
-    {cspn : Cospan} (pb : Pullback cspn)
-    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
-    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂)
-    (pbArrow' : C [ c , pb .pbOb ])
-    (H₁ : p₁ ≡ pbArrow' ⋆ pbPr₁ pb) (H₂ : p₂ ≡ pbArrow' ⋆ pbPr₂ pb)
-    → pullbackArrow pb p₁ p₂ H ≡ pbArrow'
-  pullbackArrowUnique pb p₁ p₂ H pbArrow' H₁ H₂ =
-    cong fst (pb .univProp p₁ p₂ H .snd (pbArrow' , (H₁ , H₂)))
-
-  Pullbacks : Type (ℓ-max ℓ ℓ')
-  Pullbacks = (cspn : Cospan) → Pullback cspn
-
-  hasPullbacks : Type (ℓ-max ℓ ℓ')
-  hasPullbacks = ∥ Pullbacks ∥₁
-
-
--- Pullbacks from limits
-module _ {C : Category ℓ ℓ'} where
-  open Category C
-  open Functor
-  open Pullback
-  open LimCone
-  open Cone
-  open Cospan
-
-  Cospan→Func : Cospan C → Functor CospanCat C
-  Cospan→Func (cospan l m r f g) .F-ob ⓪ = l
-  Cospan→Func (cospan l m r f g) .F-ob ① = m
-  Cospan→Func (cospan l m r f g) .F-ob ② = r
-  Cospan→Func (cospan l m r f g) .F-hom {⓪} {①} k = f
-  Cospan→Func (cospan l m r f g) .F-hom {②} {①} k = g
-  Cospan→Func (cospan l m r f g) .F-hom {⓪} {⓪} k = id
-  Cospan→Func (cospan l m r f g) .F-hom {①} {①} k = id
-  Cospan→Func (cospan l m r f g) .F-hom {②} {②} k = id
-  Cospan→Func (cospan l m r f g) .F-id {⓪} = refl
-  Cospan→Func (cospan l m r f g) .F-id {①} = refl
-  Cospan→Func (cospan l m r f g) .F-id {②} = refl
-  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {⓪} φ ψ = sym (⋆IdL _)
-  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {①} φ ψ = sym (⋆IdL _)
-  Cospan→Func (cospan l m r f g) .F-seq {⓪} {①} {①} φ ψ = sym (⋆IdR _)
-  Cospan→Func (cospan l m r f g) .F-seq {①} {①} {①} φ ψ = sym (⋆IdL _)
-  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {②} φ ψ = sym (⋆IdL _)
-  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {①} φ ψ = sym (⋆IdL _)
-  Cospan→Func (cospan l m r f g) .F-seq {②} {①} {①} φ ψ = sym (⋆IdR _)
-
-  LimitsOfShapeCospanCat→Pullbacks : LimitsOfShape CospanCat C → Pullbacks C
-  pbOb (LimitsOfShapeCospanCat→Pullbacks H cspn) = lim (H (Cospan→Func cspn))
-  pbPr₁ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ⓪
-  pbPr₂ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ②
-  pbCommutes (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOutCommutes (H (Cospan→Func cspn)) {v = ①} tt
-                          ∙ sym (limOutCommutes (H (Cospan→Func cspn)) tt)
-  univProp (LimitsOfShapeCospanCat→Pullbacks H cspn) {d = d} h k H' =
-    uniqueExists (limArrow (H (Cospan→Func cspn)) d cc)
-                 ( sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ⓪)
-                 , sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ②))
-                 (λ _ → isProp× (isSetHom _ _) (isSetHom _ _))
-                 λ a' ha' → limArrowUnique (H (Cospan→Func cspn)) d cc a'
-                               (λ { ⓪ → sym (ha' .fst)
-                                  ; ① → cong (a' ⋆_) (sym (limOutCommutes (H (Cospan→Func cspn)) {⓪} {①} tt))
-                                      ∙∙ sym (⋆Assoc _ _ _)
-                                      ∙∙ cong (_⋆ cspn .s₁) (sym (ha' .fst))
-                                  ; ② → sym (ha' .snd) })
-    where
-    cc : Cone (Cospan→Func cspn) d
-    coneOut cc ⓪ = h
-    coneOut cc ① = h ⋆ cspn .s₁
-    coneOut cc ② = k
-    coneOutCommutes cc {⓪} {⓪} e = ⋆IdR h
-    coneOutCommutes cc {⓪} {①} e = refl
-    coneOutCommutes cc {①} {①} e = ⋆IdR _
-    coneOutCommutes cc {②} {①} e = sym H'
-    coneOutCommutes cc {②} {②} e = ⋆IdR k
-
-  Limits→Pullbacks : Limits C → Pullbacks C
-  Limits→Pullbacks H = LimitsOfShapeCospanCat→Pullbacks (H CospanCat)
+Cubical.Categories.Limits.Pullback
{-# OPTIONS --safe #-}
+module Cubical.Categories.Limits.Pullback where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.HITs.PropositionalTruncation.Base
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Unit
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Instances.Cospan
+open import Cubical.Categories.Limits.Limits
+
+private
+  variable
+    ℓ ℓ' : Level
+
+module _ (C : Category ℓ ℓ') where
+
+  open Category C
+  open Functor
+
+  record Cospan : Type (ℓ-max ℓ ℓ') where
+    constructor cospan
+    field
+      l m r : ob
+      s₁ : C [ l , m ]
+      s₂ : C [ r , m ]
+
+  open Cospan
+
+  isPullback : (cspn : Cospan) →
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → Type (ℓ-max ℓ ℓ')
+  isPullback cspn {c} p₁ p₂ H =
+    ∀ {d} (h : C [ d , cspn .l ]) (k : C [ d , cspn .r ])
+          (H' : h ⋆ cspn .s₁ ≡ k ⋆ cspn .s₂)
+    → ∃![ hk ∈ C [ d , c ] ] (h ≡ hk ⋆ p₁) × (k ≡ hk ⋆ p₂)
+
+  isPropIsPullback : (cspn : Cospan) →
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → isProp (isPullback cspn p₁ p₂ H)
+  isPropIsPullback cspn p₁ p₂ H =
+    isPropImplicitΠ (λ x → isPropΠ3 λ h k H' → isPropIsContr)
+
+  record Pullback (cspn : Cospan) : Type (ℓ-max ℓ ℓ') where
+    field
+      pbOb  : ob
+      pbPr₁ : C [ pbOb , cspn .l ]
+      pbPr₂ : C [ pbOb , cspn .r ]
+      pbCommutes : pbPr₁ ⋆ cspn .s₁ ≡ pbPr₂ ⋆ cspn .s₂
+      univProp : isPullback cspn pbPr₁ pbPr₂ pbCommutes
+
+  open Pullback
+
+  pullbackArrow :
+    {cspn : Cospan} (pb : Pullback cspn)
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → C [ c , pb . pbOb ]
+  pullbackArrow pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .fst
+
+  pullbackArrowPr₁ :
+    {cspn : Cospan} (pb : Pullback cspn)
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
+    p₁ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₁ pb
+  pullbackArrowPr₁ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .fst
+
+  pullbackArrowPr₂ :
+    {cspn : Cospan} (pb : Pullback cspn)
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
+    p₂ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₂ pb
+  pullbackArrowPr₂ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .snd
+
+  pullbackArrowUnique :
+    {cspn : Cospan} (pb : Pullback cspn)
+    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
+    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂)
+    (pbArrow' : C [ c , pb .pbOb ])
+    (H₁ : p₁ ≡ pbArrow' ⋆ pbPr₁ pb) (H₂ : p₂ ≡ pbArrow' ⋆ pbPr₂ pb)
+    → pullbackArrow pb p₁ p₂ H ≡ pbArrow'
+  pullbackArrowUnique pb p₁ p₂ H pbArrow' H₁ H₂ =
+    cong fst (pb .univProp p₁ p₂ H .snd (pbArrow' , (H₁ , H₂)))
+
+  Pullbacks : Type (ℓ-max ℓ ℓ')
+  Pullbacks = (cspn : Cospan) → Pullback cspn
+
+  hasPullbacks : Type (ℓ-max ℓ ℓ')
+  hasPullbacks = ∥ Pullbacks ∥₁
+
+
+-- Pullbacks from limits
+module _ {C : Category ℓ ℓ'} where
+  open Category C
+  open Functor
+  open Pullback
+  open LimCone
+  open Cone
+  open Cospan
+
+  Cospan→Func : Cospan C → Functor CospanCat C
+  Cospan→Func (cospan l m r f g) .F-ob ⓪ = l
+  Cospan→Func (cospan l m r f g) .F-ob ① = m
+  Cospan→Func (cospan l m r f g) .F-ob ② = r
+  Cospan→Func (cospan l m r f g) .F-hom {⓪} {①} k = f
+  Cospan→Func (cospan l m r f g) .F-hom {②} {①} k = g
+  Cospan→Func (cospan l m r f g) .F-hom {⓪} {⓪} k = id
+  Cospan→Func (cospan l m r f g) .F-hom {①} {①} k = id
+  Cospan→Func (cospan l m r f g) .F-hom {②} {②} k = id
+  Cospan→Func (cospan l m r f g) .F-id {⓪} = refl
+  Cospan→Func (cospan l m r f g) .F-id {①} = refl
+  Cospan→Func (cospan l m r f g) .F-id {②} = refl
+  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {⓪} φ ψ = sym (⋆IdL _)
+  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {①} φ ψ = sym (⋆IdL _)
+  Cospan→Func (cospan l m r f g) .F-seq {⓪} {①} {①} φ ψ = sym (⋆IdR _)
+  Cospan→Func (cospan l m r f g) .F-seq {①} {①} {①} φ ψ = sym (⋆IdL _)
+  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {②} φ ψ = sym (⋆IdL _)
+  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {①} φ ψ = sym (⋆IdL _)
+  Cospan→Func (cospan l m r f g) .F-seq {②} {①} {①} φ ψ = sym (⋆IdR _)
+
+  LimitsOfShapeCospanCat→Pullbacks : LimitsOfShape CospanCat C → Pullbacks C
+  pbOb (LimitsOfShapeCospanCat→Pullbacks H cspn) = lim (H (Cospan→Func cspn))
+  pbPr₁ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ⓪
+  pbPr₂ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ②
+  pbCommutes (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOutCommutes (H (Cospan→Func cspn)) {v = ①} tt
+                          ∙ sym (limOutCommutes (H (Cospan→Func cspn)) tt)
+  univProp (LimitsOfShapeCospanCat→Pullbacks H cspn) {d = d} h k H' =
+    uniqueExists (limArrow (H (Cospan→Func cspn)) d cc)
+                 ( sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ⓪)
+                 , sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ②))
+                 (λ _ → isProp× (isSetHom _ _) (isSetHom _ _))
+                 λ a' ha' → limArrowUnique (H (Cospan→Func cspn)) d cc a'
+                               (λ { ⓪ → sym (ha' .fst)
+                                  ; ① → cong (a' ⋆_) (sym (limOutCommutes (H (Cospan→Func cspn)) {⓪} {①} tt))
+                                      ∙∙ sym (⋆Assoc _ _ _)
+                                      ∙∙ cong (_⋆ cspn .s₁) (sym (ha' .fst))
+                                  ; ② → sym (ha' .snd) })
+    where
+    cc : Cone (Cospan→Func cspn) d
+    coneOut cc ⓪ = h
+    coneOut cc ① = h ⋆ cspn .s₁
+    coneOut cc ② = k
+    coneOutCommutes cc {⓪} {⓪} e = ⋆IdR h
+    coneOutCommutes cc {⓪} {①} e = refl
+    coneOutCommutes cc {①} {①} e = ⋆IdR _
+    coneOutCommutes cc {②} {①} e = sym H'
+    coneOutCommutes cc {②} {②} e = ⋆IdR k
+
+  Limits→Pullbacks : Limits C → Pullbacks C
+  Limits→Pullbacks H = LimitsOfShapeCospanCat→Pullbacks (H CospanCat)
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.Terminal.html b/docs/Cubical.Categories.Limits.Terminal.html
index 13b3edd..1cc508c 100644
--- a/docs/Cubical.Categories.Limits.Terminal.html
+++ b/docs/Cubical.Categories.Limits.Terminal.html
@@ -1,85 +1,85 @@
 
-Cubical.Categories.Limits.Terminal
{-# OPTIONS #-}
-module Cubical.Categories.Limits.Terminal where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.HITs.PropositionalTruncation.Base
-open import Cubical.Data.Sigma
-
-open import Cubical.Categories.Category
-open import Cubical.Categories.Functor
-open import Cubical.Categories.Isomorphism
-
-private
-  variable
-    ℓ ℓ' ℓc ℓc' ℓd ℓd' : Level
-
-module _ (C : Category ℓ ℓ') where
-  open Category C
-
-  isTerminal : (x : ob) → Type (ℓ-max ℓ ℓ')
-  isTerminal x = ∀ (y : ob) → isContr (C [ y , x ])
-
-  Terminal : Type (ℓ-max ℓ ℓ')
-  Terminal = Σ[ x ∈ ob ] isTerminal x
-
-  terminalOb : Terminal → ob
-  terminalOb = fst
-
-  terminalArrow : (T : Terminal) (y : ob) → C [ y , terminalOb T ]
-  terminalArrow T y = T .snd y .fst
-
-  terminalArrowUnique : {T : Terminal} {y : ob} (f : C [ y , terminalOb T ])
-                      → terminalArrow T y ≡ f
-  terminalArrowUnique {T} {y} f = T .snd y .snd f
-
-  terminalEndoIsId : (T : Terminal) (f : C [ terminalOb T , terminalOb T ])
-                   → f ≡ id
-  terminalEndoIsId T f = isContr→isProp (T .snd (terminalOb T)) f id
-
-  hasTerminal : Type (ℓ-max ℓ ℓ')
-  hasTerminal = ∥ Terminal ∥₁
-
-  -- Terminality of an object is a proposition.
-  isPropIsTerminal : (x : ob) → isProp (isTerminal x)
-  isPropIsTerminal _ = isPropΠ λ _ → isPropIsContr
-
-  open isIso
-
-  -- Objects that are terminal are isomorphic.
-  terminalToIso : (x y : Terminal) → CatIso C (terminalOb x) (terminalOb y)
-  terminalToIso x y .fst = terminalArrow y (terminalOb x)
-  terminalToIso x y .snd .inv = terminalArrow x (terminalOb y)
-  terminalToIso x y .snd .sec = terminalEndoIsId y _
-  terminalToIso x y .snd .ret = terminalEndoIsId x _
-
-  isoToTerminal : ∀ (x : Terminal) y → CatIso C (terminalOb x) y → isTerminal y
-  isoToTerminal x y x≅y y' .fst = x≅y .fst ∘⟨ C ⟩ terminalArrow x y'
-  isoToTerminal x y x≅y y' .snd f =
-    sym (⋆InvRMove
-          (invIso x≅y)
-          (sym (terminalArrowUnique {T = x} (invIso x≅y .fst ∘⟨ C ⟩ f))))
-
-  open isUnivalent
-
-  -- The type of terminal objects of a univalent category is a proposition,
-  -- i.e. all terminal objects are equal.
-  isPropTerminal : (hC : isUnivalent C) → isProp Terminal
-  isPropTerminal hC x y =
-    Σ≡Prop isPropIsTerminal (CatIsoToPath hC (terminalToIso x y))
-
-preservesTerminals : ∀ (C : Category ℓc ℓc')(D : Category ℓd ℓd')
-                   → Functor C D
-                   → Type (ℓ-max (ℓ-max (ℓ-max ℓc ℓc') ℓd) ℓd')
-preservesTerminals C D F = ∀ (term : Terminal C) → isTerminal D (F ⟅ term .fst ⟆)
-
-preserveAnyTerminal→PreservesTerminals : ∀ (C : Category ℓc ℓc')(D : Category ℓd ℓd')
-  → (F : Functor C D)
-  → (term : Terminal C) → isTerminal D (F ⟅ term .fst ⟆)
-  → preservesTerminals C D F
-preserveAnyTerminal→PreservesTerminals C D F term D-preserves-term term' =
-  isoToTerminal D
-                ((F ⟅ term .fst ⟆) , D-preserves-term) (F ⟅ term' .fst ⟆)
-                (F-Iso {F = F} (terminalToIso C term term'))
+Cubical.Categories.Limits.Terminal
{-# OPTIONS --safe #-}
+module Cubical.Categories.Limits.Terminal where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.HITs.PropositionalTruncation.Base
+open import Cubical.Data.Sigma
+
+open import Cubical.Categories.Category
+open import Cubical.Categories.Functor
+open import Cubical.Categories.Isomorphism
+
+private
+  variable
+    ℓ ℓ' ℓc ℓc' ℓd ℓd' : Level
+
+module _ (C : Category ℓ ℓ') where
+  open Category C
+
+  isTerminal : (x : ob) → Type (ℓ-max ℓ ℓ')
+  isTerminal x = ∀ (y : ob) → isContr (C [ y , x ])
+
+  Terminal : Type (ℓ-max ℓ ℓ')
+  Terminal = Σ[ x ∈ ob ] isTerminal x
+
+  terminalOb : Terminal → ob
+  terminalOb = fst
+
+  terminalArrow : (T : Terminal) (y : ob) → C [ y , terminalOb T ]
+  terminalArrow T y = T .snd y .fst
+
+  terminalArrowUnique : {T : Terminal} {y : ob} (f : C [ y , terminalOb T ])
+                      → terminalArrow T y ≡ f
+  terminalArrowUnique {T} {y} f = T .snd y .snd f
+
+  terminalEndoIsId : (T : Terminal) (f : C [ terminalOb T , terminalOb T ])
+                   → f ≡ id
+  terminalEndoIsId T f = isContr→isProp (T .snd (terminalOb T)) f id
+
+  hasTerminal : Type (ℓ-max ℓ ℓ')
+  hasTerminal = ∥ Terminal ∥₁
+
+  -- Terminality of an object is a proposition.
+  isPropIsTerminal : (x : ob) → isProp (isTerminal x)
+  isPropIsTerminal _ = isPropΠ λ _ → isPropIsContr
+
+  open isIso
+
+  -- Objects that are terminal are isomorphic.
+  terminalToIso : (x y : Terminal) → CatIso C (terminalOb x) (terminalOb y)
+  terminalToIso x y .fst = terminalArrow y (terminalOb x)
+  terminalToIso x y .snd .inv = terminalArrow x (terminalOb y)
+  terminalToIso x y .snd .sec = terminalEndoIsId y _
+  terminalToIso x y .snd .ret = terminalEndoIsId x _
+
+  isoToTerminal : ∀ (x : Terminal) y → CatIso C (terminalOb x) y → isTerminal y
+  isoToTerminal x y x≅y y' .fst = x≅y .fst ∘⟨ C ⟩ terminalArrow x y'
+  isoToTerminal x y x≅y y' .snd f =
+    sym (⋆InvRMove
+          (invIso x≅y)
+          (sym (terminalArrowUnique {T = x} (invIso x≅y .fst ∘⟨ C ⟩ f))))
+
+  open isUnivalent
+
+  -- The type of terminal objects of a univalent category is a proposition,
+  -- i.e. all terminal objects are equal.
+  isPropTerminal : (hC : isUnivalent C) → isProp Terminal
+  isPropTerminal hC x y =
+    Σ≡Prop isPropIsTerminal (CatIsoToPath hC (terminalToIso x y))
+
+preservesTerminals : ∀ (C : Category ℓc ℓc')(D : Category ℓd ℓd')
+                   → Functor C D
+                   → Type (ℓ-max (ℓ-max (ℓ-max ℓc ℓc') ℓd) ℓd')
+preservesTerminals C D F = ∀ (term : Terminal C) → isTerminal D (F ⟅ term .fst ⟆)
+
+preserveAnyTerminal→PreservesTerminals : ∀ (C : Category ℓc ℓc')(D : Category ℓd ℓd')
+  → (F : Functor C D)
+  → (term : Terminal C) → isTerminal D (F ⟅ term .fst ⟆)
+  → preservesTerminals C D F
+preserveAnyTerminal→PreservesTerminals C D F term D-preserves-term term' =
+  isoToTerminal D
+                ((F ⟅ term .fst ⟆) , D-preserves-term) (F ⟅ term' .fst ⟆)
+                (F-Iso {F = F} (terminalToIso C term term'))
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Limits.html b/docs/Cubical.Categories.Limits.html
new file mode 100644
index 0000000..04e0ccf
--- /dev/null
+++ b/docs/Cubical.Categories.Limits.html
@@ -0,0 +1,11 @@
+
+Cubical.Categories.Limits
{-# OPTIONS --safe #-}
+module Cubical.Categories.Limits where
+
+open import Cubical.Categories.Limits.Limits public
+open import Cubical.Categories.Limits.BinProduct public
+open import Cubical.Categories.Limits.BinCoproduct public
+open import Cubical.Categories.Limits.Initial public
+open import Cubical.Categories.Limits.Terminal public
+open import Cubical.Categories.Limits.Pullback public
+

\ No newline at end of file
diff --git a/docs/Cubical.Categories.Morphism.html b/docs/Cubical.Categories.Morphism.html
index a2b32e9..84f91c2 100644
--- a/docs/Cubical.Categories.Morphism.html
+++ b/docs/Cubical.Categories.Morphism.html
@@ -24,9 +24,9 @@
   isMonic {x} {y} f =
     ∀ {z} {a a' : Hom[ z , x ]} → f ∘ a ≡ f ∘ a' → a ≡ a'
 
-  isPropIsMonic : (f : Hom[ x , y ]) → isProp (isMonic f)
+  isPropIsMonic : (f : Hom[ x , y ]) → isProp (isMonic f)
   isPropIsMonic _ = isPropImplicitΠ (λ _ → (isPropImplicitΠ2
-    (λ a a' → (isProp→ (isOfHLevelPath' 1 isSetHom a a')))))
+    (λ a a' → (isProp→ (isOfHLevelPath' 1 isSetHom a a')))))
 
   postcompCreatesMonic : (f : Hom[ x , y ]) (g : Hom[ y , z ])
     → isMonic (f ⋆ g) → isMonic f
@@ -41,135 +41,129 @@
   monicId : {x : ob} → isMonic (id {x})
   monicId {a = a} {a' = a'} eq = sym (⋆IdR a) ∙ eq ∙ ⋆IdR a'
 
-  isJointMono : ∀ {ℓ''} {a : ob} (I : Type ℓ'') → (b : I → ob) → ((i : I) → Hom[ a , b i ]) → Type _
-  isJointMono {a = a} I b f = ∀ {c} → (g₁ g₂ : Hom[ c , a ]) → ((i : I) → (f i) ∘ g₁ ≡ (f i) ∘ g₂) → g₁ ≡ g₂
-
-  retraction⇒monic : (f : Hom[ x , y ]) (lInv : Hom[ y , x ])
-    → (lInv ∘ f ≡ id) → isMonic f
-  retraction⇒monic f lInv eq =
-    postcompCreatesMonic f lInv (subst isMonic (sym eq) monicId)
-
-  isEpic : (Hom[ x , y ]) → Type (ℓ-max ℓ ℓ')
-  isEpic {x} {y} g =
-    ∀ {z} {b b' : Hom[ y , z ]} → b ∘ g ≡ b' ∘ g → b ≡ b'
-
-  isPropIsEpic : (f : Hom[ x , y ]) → isProp (isEpic f)
-  isPropIsEpic _ = isPropImplicitΠ (λ _ → (isPropImplicitΠ2
-    (λ a a' → (isProp→ (isOfHLevelPath' 1 isSetHom a a')))))
-
-  precompCreatesEpic : (f : Hom[ x , y ]) (g : Hom[ z , x ])
-    → isEpic (g ⋆ f) → isEpic f
-  precompCreatesEpic f g epic {b = b} {b' = b'} bf≡b'f =
-    epic (⋆Assoc g f b ∙ cong (g ⋆_) bf≡b'f ∙ sym (⋆Assoc g f b'))
-
-  isJointEpic : ∀ {ℓ''} {b : ob} (I : Type ℓ'') → (a : I → ob) → ((i : I) → Hom[ a i , b ]) → Type _
-  isJointEpic {b = b} I a f = ∀ {c : ob} (g₁ g₂ : Hom[ b , c ]) → ((i : I) → g₁ ∘ (f i) ≡ g₂ ∘ (f i)) → g₁ ≡ g₂
-
-  -- A morphism is split monic if it has a *retraction*
-  isSplitMon : (Hom[ x , y ]) → Type ℓ'
-  isSplitMon {x} {y} f = ∃[ r ∈ Hom[ y , x ] ] r ∘ f ≡ id
-
-  -- A morphism is split epic if it has a *section*
-  isSplitEpi : (Hom[ x , y ]) → Type ℓ'
-  isSplitEpi {x} {y} g = ∃[ s ∈ Hom[ y , x ] ] g ∘ s ≡ id
-
-  record areInv (f : Hom[ x , y ]) (g : Hom[ y , x ]) : Type ℓ' where
-    field
-      sec : g ⋆ f ≡ id
-      ret : f ⋆ g ≡ id
-
-
--- C can be implicit here
-module _ {C : Category ℓ ℓ'} where
-  open Category C
-
-  private
-    variable
-      x y z v w : ob
-
-  open areInv
-
-  symAreInv : {f : Hom[ x , y ]} {g : Hom[ y , x ]} → areInv C f g → areInv C g f
-  sec (symAreInv x) = ret x
-  ret (symAreInv x) = sec x
-
-  -- equational reasoning with inverses
-  invMoveR : ∀ {f : Hom[ x , y ]} {g : Hom[ y , x ]} {h : Hom[ z , x ]} {k : Hom[ z , y ]}
-           → areInv C f g
-           → h ⋆ f ≡ k
-           → h ≡ k ⋆ g
-  invMoveR {f = f} {g} {h} {k} ai p
-    = h
-    ≡⟨ sym (⋆IdR _) ⟩
-      (h ⋆ id)
-    ≡⟨ cong (h ⋆_) (sym (ai .ret)) ⟩
-      (h ⋆ (f ⋆ g))
-    ≡⟨ sym (⋆Assoc _ _ _) ⟩
-      ((h ⋆ f) ⋆ g)
-    ≡⟨ cong (_⋆ g) p ⟩
-      k ⋆ g
-    ∎
-
-  invMoveL : ∀ {f : Hom[ x , y ]} {g : Hom[ y , x ]} {h : Hom[ y , z ]} {k : Hom[ x , z ]}
-          → areInv C f g
-          → f ⋆ h ≡ k
-          → h ≡ g ⋆ k
-  invMoveL {f = f} {g} {h} {k} ai p
-    = h
-    ≡⟨ sym (⋆IdL _) ⟩
-      id ⋆ h
-    ≡⟨ cong (_⋆ h) (sym (ai .sec)) ⟩
-      (g ⋆ f) ⋆ h
-    ≡⟨ ⋆Assoc _ _ _ ⟩
-      g ⋆ (f ⋆ h)
-    ≡⟨ cong (g ⋆_) p ⟩
-      (g ⋆ k)
-    ∎
-
-  invFlipSq : {f₁⁻¹ : Hom[ x , y ]} {f₁ : Hom[ y , x ]}
-              {f₂⁻¹ : Hom[ v , w ]} {f₂ : Hom[ w , v ]}
-              {g : Hom[ x , v ]} {h : Hom[ y , w ]}
-            → areInv C f₁ f₁⁻¹ → areInv C f₂ f₂⁻¹
-            → h ⋆ f₂ ≡ f₁ ⋆ g
-            → g ⋆ f₂⁻¹ ≡ f₁⁻¹ ⋆ h
-  invFlipSq {f₁⁻¹ = f₁⁻¹} {f₁} {f₂⁻¹} {f₂} {g} {h} inv₁ inv₂ sq =
-    g ⋆ f₂⁻¹                ≡⟨ cong (_⋆ f₂⁻¹) (sym (⋆IdL _)) ⟩
-    (id ⋆ g) ⋆ f₂⁻¹         ≡⟨ cong (λ m → (m ⋆ g) ⋆ f₂⁻¹) (sym (inv₁ .sec)) ⟩
-    ((f₁⁻¹ ⋆ f₁) ⋆ g) ⋆ f₂⁻¹ ≡⟨ cong (_⋆ f₂⁻¹) (⋆Assoc _ _ _) ⟩
-    (f₁⁻¹ ⋆ (f₁ ⋆ g)) ⋆ f₂⁻¹ ≡⟨ ⋆Assoc _ _ _ ⟩
-    f₁⁻¹ ⋆ ((f₁ ⋆ g) ⋆ f₂⁻¹) ≡⟨ cong (λ m → f₁⁻¹ ⋆ (m ⋆ f₂⁻¹)) (sym sq) ⟩
-    f₁⁻¹ ⋆ ((h ⋆ f₂) ⋆ f₂⁻¹) ≡⟨ cong (f₁⁻¹ ⋆_) (⋆Assoc _ _ _) ⟩
-    f₁⁻¹ ⋆ (h ⋆ (f₂ ⋆ f₂⁻¹)) ≡⟨ cong (λ m → f₁⁻¹ ⋆ (h ⋆ m)) (inv₂ .ret) ⟩
-    f₁⁻¹ ⋆ (h ⋆ id)         ≡⟨ cong (f₁⁻¹ ⋆_) (⋆IdR _) ⟩
-    f₁⁻¹ ⋆ h ∎
-
-  open isIso
-
-  isIso→areInv : ∀ {f : Hom[ x , y ]}
-               → (isI : isIso C f)
-               → areInv C f (isI .inv)
-  sec (isIso→areInv isI) = sec isI
-  ret (isIso→areInv isI) = ret isI
-
-
-  -- Back and forth between isIso and CatIso
-
-  isIso→CatIso : ∀ {f : C [ x , y ]}
-               → isIso C f
-               → CatIso C x y
-  isIso→CatIso x = _ , x
-
-  CatIso→isIso : (cIso : CatIso C x y)
-               → isIso C (cIso .fst)
-  CatIso→isIso = snd
-
-  CatIso→areInv : (cIso : CatIso C x y)
-                → areInv C (cIso .fst) (cIso .snd .inv)
-  CatIso→areInv cIso = isIso→areInv (CatIso→isIso cIso)
-
-  -- reverse of an iso is also an iso
-  symCatIso : ∀ {x y}
-             → CatIso C x y
-             → CatIso C y x
-  symCatIso (mor , isiso inv sec ret) = inv , isiso mor ret sec
+  retraction⇒monic : (f : Hom[ x , y ]) (lInv : Hom[ y , x ])
+    → (lInv ∘ f ≡ id) → isMonic f
+  retraction⇒monic f lInv eq =
+    postcompCreatesMonic f lInv (subst isMonic (sym eq) monicId)
+
+  isEpic : (Hom[ x , y ]) → Type (ℓ-max ℓ ℓ')
+  isEpic {x} {y} g =
+    ∀ {z} {b b' : Hom[ y , z ]} → b ∘ g ≡ b' ∘ g → b ≡ b'
+
+  isPropIsEpic : (f : Hom[ x , y ]) → isProp (isEpic f)
+  isPropIsEpic _ = isPropImplicitΠ (λ _ → (isPropImplicitΠ2
+    (λ a a' → (isProp→ (isOfHLevelPath' 1 isSetHom a a')))))
+
+  precompCreatesEpic : (f : Hom[ x , y ]) (g : Hom[ z , x ])
+    → isEpic (g ⋆ f) → isEpic f
+  precompCreatesEpic f g epic {b = b} {b' = b'} bf≡b'f =
+    epic (⋆Assoc g f b ∙ cong (g ⋆_) bf≡b'f ∙ sym (⋆Assoc g f b'))
+
+  -- A morphism is split monic if it has a *retraction*
+  isSplitMon : (Hom[ x , y ]) → Type ℓ'
+  isSplitMon {x} {y} f = ∃[ r ∈ Hom[ y , x ] ] r ∘ f ≡ id
+
+  -- A morphism is split epic if it has a *section*
+  isSplitEpi : (Hom[ x , y ]) → Type ℓ'
+  isSplitEpi {x} {y} g = ∃[ s ∈ Hom[ y , x ] ] g ∘ s ≡ id
+
+  record areInv (f : Hom[ x , y ]) (g : Hom[ y , x ]) : Type ℓ' where
+    field
+      sec : g ⋆ f ≡ id
+      ret : f ⋆ g ≡ id
+
+
+-- C can be implicit here
+module _ {C : Category ℓ ℓ'} where
+  open Category C
+
+  private
+    variable
+      x y z v w : ob
+
+  open areInv
+
+  symAreInv : {f : Hom[ x , y ]} {g : Hom[ y , x ]} → areInv C f g → areInv C g f
+  sec (symAreInv x) = ret x
+  ret (symAreInv x) = sec x
+
+  -- equational reasoning with inverses
+  invMoveR : ∀ {f : Hom[ x , y ]} {g : Hom[ y , x ]} {h : Hom[ z , x ]} {k : Hom[ z , y ]}
+           → areInv C f g
+           → h ⋆ f ≡ k
+           → h ≡ k ⋆ g
+  invMoveR {f = f} {g} {h} {k} ai p
+    = h
+    ≡⟨ sym (⋆IdR _) ⟩
+      (h ⋆ id)
+    ≡⟨ cong (h ⋆_) (sym (ai .ret)) ⟩
+      (h ⋆ (f ⋆ g))
+    ≡⟨ sym (⋆Assoc _ _ _) ⟩
+      ((h ⋆ f) ⋆ g)
+    ≡⟨ cong (_⋆ g) p ⟩
+      k ⋆ g
+    ∎
+
+  invMoveL : ∀ {f : Hom[ x , y ]} {g : Hom[ y , x ]} {h : Hom[ y , z ]} {k : Hom[ x , z ]}
+          → areInv C f g
+          → f ⋆ h ≡ k
+          → h ≡ g ⋆ k
+  invMoveL {f = f} {g} {h} {k} ai p
+    = h
+    ≡⟨ sym (⋆IdL _) ⟩
+      id ⋆ h
+    ≡⟨ cong (_⋆ h) (sym (ai .sec)) ⟩
+      (g ⋆ f) ⋆ h
+    ≡⟨ ⋆Assoc _ _ _ ⟩
+      g ⋆ (f ⋆ h)
+    ≡⟨ cong (g ⋆_) p ⟩
+      (g ⋆ k)
+    ∎
+
+  invFlipSq : {f₁⁻¹ : Hom[ x , y ]} {f₁ : Hom[ y , x ]}
+              {f₂⁻¹ : Hom[ v , w ]} {f₂ : Hom[ w , v ]}
+              {g : Hom[ x , v ]} {h : Hom[ y , w ]}
+            → areInv C f₁ f₁⁻¹ → areInv C f₂ f₂⁻¹
+            → h ⋆ f₂ ≡ f₁ ⋆ g
+            → g ⋆ f₂⁻¹ ≡ f₁⁻¹ ⋆ h
+  invFlipSq {f₁⁻¹ = f₁⁻¹} {f₁} {f₂⁻¹} {f₂} {g} {h} inv₁ inv₂ sq =
+    g ⋆ f₂⁻¹                ≡⟨ cong (_⋆ f₂⁻¹) (sym (⋆IdL _)) ⟩
+    (id ⋆ g) ⋆ f₂⁻¹         ≡⟨ cong (λ m → (m ⋆ g) ⋆ f₂⁻¹) (sym (inv₁ .sec)) ⟩
+    ((f₁⁻¹ ⋆ f₁) ⋆ g) ⋆ f₂⁻¹ ≡⟨ cong (_⋆ f₂⁻¹) (⋆Assoc _ _ _) ⟩
+    (f₁⁻¹ ⋆ (f₁ ⋆ g)) ⋆ f₂⁻¹ ≡⟨ ⋆Assoc _ _ _ ⟩
+    f₁⁻¹ ⋆ ((f₁ ⋆ g) ⋆ f₂⁻¹) ≡⟨ cong (λ m → f₁⁻¹ ⋆ (m ⋆ f₂⁻¹)) (sym sq) ⟩
+    f₁⁻¹ ⋆ ((h ⋆ f₂) ⋆ f₂⁻¹) ≡⟨ cong (f₁⁻¹ ⋆_) (⋆Assoc _ _ _) ⟩
+    f₁⁻¹ ⋆ (h ⋆ (f₂ ⋆ f₂⁻¹)) ≡⟨ cong (λ m → f₁⁻¹ ⋆ (h ⋆ m)) (inv₂ .ret) ⟩
+    f₁⁻¹ ⋆ (h ⋆ id)         ≡⟨ cong (f₁⁻¹ ⋆_) (⋆IdR _) ⟩
+    f₁⁻¹ ⋆ h ∎
+
+  open isIso
+
+  isIso→areInv : ∀ {f : Hom[ x , y ]}
+               → (isI : isIso C f)
+               → areInv C f (isI .inv)
+  sec (isIso→areInv isI) = sec isI
+  ret (isIso→areInv isI) = ret isI
+
+
+  -- Back and forth between isIso and CatIso
+
+  isIso→CatIso : ∀ {f : C [ x , y ]}
+               → isIso C f
+               → CatIso C x y
+  isIso→CatIso x = _ , x
+
+  CatIso→isIso : (cIso : CatIso C x y)
+               → isIso C (cIso .fst)
+  CatIso→isIso = snd
+
+  CatIso→areInv : (cIso : CatIso C x y)
+                → areInv C (cIso .fst) (cIso .snd .inv)
+  CatIso→areInv cIso = isIso→areInv (CatIso→isIso cIso)
+
+  -- reverse of an iso is also an iso
+  symCatIso : ∀ {x y}
+             → CatIso C x y
+             → CatIso C y x
+  symCatIso (mor , isiso inv sec ret) = inv , isiso mor ret sec
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.NaturalTransformation.Base.html b/docs/Cubical.Categories.NaturalTransformation.Base.html
index 84a9837..086c4d9 100644
--- a/docs/Cubical.Categories.NaturalTransformation.Base.html
+++ b/docs/Cubical.Categories.NaturalTransformation.Base.html
@@ -7,7 +7,7 @@
 open import Cubical.Foundations.HLevels
 open import Cubical.Foundations.Isomorphism renaming (iso to iIso)
 open import Cubical.Data.Sigma
-open import Cubical.Categories.Category renaming (isIso to isIsoC)
+open import Cubical.Categories.Category renaming (isIso to isIsoC)
 open import Cubical.Categories.Functor.Base
 open import Cubical.Categories.Functor.Properties
 open import Cubical.Categories.Commutativity
@@ -23,7 +23,7 @@
   infixl 15 _⋆ᴰ_
   private
     _⋆ᴰ_ : ∀ {x y z} (f : D [ x , y ]) (g : D [ y , z ]) → D [ x , z ]
-    f ⋆ᴰ g = f ⋆⟨ D ⟩ g
+    f ⋆ᴰ g = f ⋆⟨ D ⟩ g
 
   open Category
   open Functor
@@ -55,19 +55,19 @@
 
     -- the three other commuting squares
     sqRL : ∀ {x y : C .ob} {f : C [ x , y ]}
-         → F ⟪ f ⟫ ≡ (N-ob x) ⋆ᴰ G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv
-    sqRL {x} {y} {f} = invMoveR (isIso→areInv (nIso y)) (N-hom f)
+         → F ⟪ f ⟫ ≡ (N-ob x) ⋆ᴰ G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv
+    sqRL {x} {y} {f} = invMoveR (isIso→areInv (nIso y)) (N-hom f)
 
     sqLL : ∀ {x y : C .ob} {f : C [ x , y ]}
-         → G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv ≡ (nIso x) .inv ⋆ᴰ F ⟪ f ⟫
-    sqLL {x} {y} {f} = invMoveL (isIso→areInv (nIso x)) (sym sqRL')
+         → G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv ≡ (nIso x) .inv ⋆ᴰ F ⟪ f ⟫
+    sqLL {x} {y} {f} = invMoveL (isIso→areInv (nIso x)) (sym sqRL')
       where
-        sqRL' : F ⟪ f ⟫ ≡ (N-ob x) ⋆ᴰ ( G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv )
+        sqRL' : F ⟪ f ⟫ ≡ (N-ob x) ⋆ᴰ ( G ⟪ f ⟫ ⋆ᴰ (nIso y) .inv )
         sqRL' = sqRL ∙ (D .⋆Assoc _ _ _)
 
     sqLR : ∀ {x y : C .ob} {f : C [ x , y ]}
-         → G ⟪ f ⟫ ≡ (nIso x) .inv ⋆ᴰ F ⟪ f ⟫ ⋆ᴰ (N-ob y)
-    sqLR {x} {y} {f} = invMoveR (symAreInv (isIso→areInv (nIso y))) sqLL
+         → G ⟪ f ⟫ ≡ (nIso x) .inv ⋆ᴰ F ⟪ f ⟫ ⋆ᴰ (N-ob y)
+    sqLR {x} {y} {f} = invMoveR (symAreInv (isIso→areInv (nIso y))) sqLL
 
   open NatTrans
   open NatIso
@@ -101,19 +101,19 @@
 
   idNatIso : (F : Functor C D) → NatIso F F
   idNatIso F .trans = idTrans F
-  idNatIso F .nIso _ = idCatIso .snd
+  idNatIso F .nIso _ = idCatIso .snd
 
 
   -- Natural isomorphism induced by path of functors
 
   pathToNatTrans : {F G : Functor C D} → F ≡ G → NatTrans F G
-  pathToNatTrans p .N-ob x = pathToIso {C = D} (λ i → p i .F-ob x) .fst
+  pathToNatTrans p .N-ob x = pathToIso {C = D} (λ i → p i .F-ob x) .fst
   pathToNatTrans {F = F} {G = G} p .N-hom {x = x} {y = y} f =
     pathToIso-Comm {C = D} _ _ _ _ (λ i → p i .F-hom f)
 
   pathToNatIso : {F G : Functor C D} → F ≡ G → NatIso F G
   pathToNatIso p .trans = pathToNatTrans p
-  pathToNatIso p .nIso x = pathToIso {C = D} _ .snd
+  pathToNatIso p .nIso x = pathToIso {C = D} _ .snd
 
 
   -- vertical sequencing
@@ -174,21 +174,21 @@
 
       -- extensions are equal to originals
       βy'≡βy : PathP (λ i → D [ Gy≡G'y i , H ⟅ y ⟆ ]) βy' (β ⟦ y ⟧)
-      βy'≡βy = symP (toPathP {A = λ i → D [ Gy≡G'y (~ i) , H ⟅ y ⟆ ]} refl)
+      βy'≡βy = symP (toPathP {A = λ i → D [ Gy≡G'y (~ i) , H ⟅ y ⟆ ]} refl)
 
       βx≡βx' : PathP (λ i → D [ Gx≡G'x (~ i) , H ⟅ x ⟆ ]) (β ⟦ x ⟧) βx'
-      βx≡βx' = toPathP refl
+      βx≡βx' = toPathP refl
 
       -- left wall of square
-      left : PathP (λ i → D [ Gx≡G'x i , H ⟅ y ⟆ ]) (G ⟪ f ⟫ ⋆⟨ D ⟩ βy') (G' ⟪ f ⟫ ⋆⟨ D ⟩ β ⟦ y ⟧)
-      left i = Gf≡G'f i ⋆⟨ D ⟩ βy'≡βy i
+      left : PathP (λ i → D [ Gx≡G'x i , H ⟅ y ⟆ ]) (G ⟪ f ⟫ ⋆⟨ D ⟩ βy') (G' ⟪ f ⟫ ⋆⟨ D ⟩ β ⟦ y ⟧)
+      left i = Gf≡G'f i ⋆⟨ D ⟩ βy'≡βy i
 
       -- right wall of square
-      right : PathP (λ i → D [ Gx≡G'x (~ i) , H ⟅ y ⟆ ]) (β ⟦ x ⟧ ⋆⟨ D ⟩ H ⟪ f ⟫) (βx' ⋆⟨ D ⟩ H ⟪ f ⟫)
-      right i = βx≡βx' i ⋆⟨ D ⟩ refl {x = H ⟪ f ⟫} i
+      right : PathP (λ i → D [ Gx≡G'x (~ i) , H ⟅ y ⟆ ]) (β ⟦ x ⟧ ⋆⟨ D ⟩ H ⟪ f ⟫) (βx' ⋆⟨ D ⟩ H ⟪ f ⟫)
+      right i = βx≡βx' i ⋆⟨ D ⟩ refl {x = H ⟪ f ⟫} i
 
       -- putting it all together
-      βSq : G ⟪ f ⟫ ⋆⟨ D ⟩ βy' ≡ βx' ⋆⟨ D ⟩ H ⟪ f ⟫
+      βSq : G ⟪ f ⟫ ⋆⟨ D ⟩ βy' ≡ βx' ⋆⟨ D ⟩ H ⟪ f ⟫
       βSq i = comp (λ k → D [ Gx≡G'x (~ k) , H ⟅ y ⟆ ])
                    (λ j → λ { (i = i0) → left (~ j)
                             ; (i = i1) → right j })
@@ -205,14 +205,14 @@
       where
         rem : PathP (λ i → (F .F-hom f) ⋆ᴰ (p i _) ≡ (p i _) ⋆ᴰ (G .F-hom f))
                     (α .N-hom f) (β .N-hom f)
-        rem = toPathP (D .isSetHom _ _ _ _)
+        rem = toPathP (D .isSetHom _ _ _ _)
 
 
   -- `constructor` for path of natural isomorphisms
   NatIso≡ : {F G : Functor C D}{f g : NatIso F G} → f .trans .N-ob ≡ g .trans .N-ob → f ≡ g
   NatIso≡ {f = f} {g} p i .trans = makeNatTransPath {α = f .trans} {β = g .trans} p i
   NatIso≡ {f = f} {g} p i .nIso x =
-    isProp→PathP (λ i → isPropIsIso (NatIso≡ {f = f} {g} p i .trans .N-ob x)) (f .nIso _) (g .nIso _) i
+    isProp→PathP (λ i → isPropIsIso (NatIso≡ {f = f} {g} p i .trans .N-ob x)) (f .nIso _) (g .nIso _) i
 
 
   module _  {F F' G G' : Functor C D} {α : NatTrans F G} {β : NatTrans F' G'} where
@@ -228,7 +228,7 @@
       where
         rem : PathP (λ i → ((p i) .F-hom f) ⋆ᴰ (P i _) ≡ (P i _) ⋆ᴰ ((q i) .F-hom f))
                     (α .N-hom f) (β .N-hom f)
-        rem = toPathP (D .isSetHom _ _ _ _)
+        rem = toPathP (D .isSetHom _ _ _ _)
 
 module _ {B : Category ℓB ℓB'} {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
   open NatTrans
@@ -243,7 +243,7 @@
   _∘ʳ_ : ∀ (K : Functor C D) → {G H : Functor B C} (β : NatTrans G H)
        → NatTrans (K ∘F G) (K ∘F H)
   (_∘ʳ_ K {G} {H} β) .N-ob x = K ⟪ β ⟦ x ⟧ ⟫
-  (_∘ʳ_ K {G} {H} β) .N-hom f = preserveCommF {C = C} {D = D} {K} (β .N-hom f)
+  (_∘ʳ_ K {G} {H} β) .N-hom f = preserveCommF {C = C} {D = D} {K} (β .N-hom f)
 
   whiskerTrans : {F F' : Functor B C} {G G' : Functor C D} (β : NatTrans G G') (α : NatTrans F F')
     → NatTrans (G ∘F F) (G' ∘F F')
diff --git a/docs/Cubical.Categories.NaturalTransformation.Properties.html b/docs/Cubical.Categories.NaturalTransformation.Properties.html
index 4d4f5b0..63e6cad 100644
--- a/docs/Cubical.Categories.NaturalTransformation.Properties.html
+++ b/docs/Cubical.Categories.NaturalTransformation.Properties.html
@@ -1,197 +1,197 @@
 
 Cubical.Categories.NaturalTransformation.Properties
-{-# OPTIONS --allow-unsolved-metas #-}
-
-module Cubical.Categories.NaturalTransformation.Properties where
-
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.Equiv
-open import Cubical.Foundations.Isomorphism
-open import Cubical.Foundations.Univalence
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Isomorphism renaming (iso to iIso)
-open import Cubical.Data.Sigma
-open import Cubical.Categories.Category renaming (isIso to isIsoC)
-open import Cubical.Categories.Functor.Base
-open import Cubical.Categories.Functor.Properties
-open import Cubical.Categories.Morphism
-open import Cubical.Categories.Isomorphism
-open import Cubical.Categories.NaturalTransformation.Base
-
-private
-  variable
-    ℓB ℓB' ℓC ℓC' ℓD ℓD' ℓE ℓE' : Level
-    C : Category ℓC ℓC'
-    D : Category ℓD ℓD'
-    F F' : Functor C D
-
-open isIsoC
-open NatIso
-open NatTrans
-open Category
-open Functor
-open Iso
-
-module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
-  private
-    _⋆ᴰ_ : ∀ {x y z} (f : D [ x , y ]) (g : D [ y , z ]) → D [ x , z ]
-    f ⋆ᴰ g = f ⋆⟨ D ⟩ g
-
-  -- natural isomorphism is symmetric
-  symNatIso : ∀ {F G : Functor C D}
-            → F ≅ᶜ G
-            → G ≅ᶜ F
-  symNatIso η .trans .N-ob x = η .nIso x .inv
-  symNatIso η .trans .N-hom _ = sqLL η
-  symNatIso η .nIso x .inv = η .trans .N-ob x
-  symNatIso η .nIso x .sec = η .nIso x .ret
-  symNatIso η .nIso x .ret = η .nIso x .sec
-
-  -- Properties
-
-  -- path helpers
-  module NatTransP where
-
-    module _ {F G : Functor C D} where
-
-      -- same as Sigma version
-      NatTransΣ : Type (ℓ-max (ℓ-max ℓC ℓC') ℓD')
-      NatTransΣ = Σ[ ob ∈ ((x : C .ob) → D [(F .F-ob x) , (G .F-ob x)]) ]
-                     ({x y : _ } (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (ob y) ≡ (ob x) ⋆ᴰ (G .F-hom f))
-
-      NatTransIsoΣ : Iso (NatTrans F G) NatTransΣ
-      NatTransIsoΣ .fun (natTrans N-ob N-hom) = N-ob , N-hom
-      NatTransIsoΣ .inv (N-ob , N-hom) = (natTrans N-ob N-hom)
-      NatTransIsoΣ .rightInv _ = refl
-      NatTransIsoΣ .leftInv _ = refl
-
-      NatTrans≡Σ : NatTrans F G ≡ NatTransΣ
-      NatTrans≡Σ = isoToPath NatTransIsoΣ
-
-      -- introducing paths
-      NatTrans-≡-intro : ∀ {αo βo : N-ob-Type F G}
-                           {αh : N-hom-Type F G αo}
-                           {βh : N-hom-Type F G βo}
-                       → (p : αo ≡ βo)
-                       → PathP (λ i → ({x y : C .ob} (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ (G .F-hom f))) αh βh
-                       → natTrans {F = F} {G} αo αh ≡ natTrans βo βh
-      NatTrans-≡-intro p q i = natTrans (p i) (q i)
-
-  module _ {F G : Functor C D} {α β : NatTrans F G} where
-      open Iso
-      private
-        αOb = α .N-ob
-        βOb = β .N-ob
-        αHom = α .N-hom
-        βHom = β .N-hom
-      -- path between natural transformations is the same as a pair of paths (between ob and hom)
-      NTPathIsoPathΣ : Iso (α ≡ β)
-                         (Σ[ p ∈ (αOb ≡ βOb) ]
-                              (PathP (λ i → ({x y : _} (f : _) → F ⟪ f ⟫ ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ G ⟪ f ⟫))
-                                  αHom
-                                  βHom))
-      NTPathIsoPathΣ .fun p = (λ i → p i .N-ob) , (λ i → p i .N-hom)
-      NTPathIsoPathΣ .inv (po , ph) i = record { N-ob = po i ; N-hom = ph i }
-      NTPathIsoPathΣ .rightInv pσ = refl
-      NTPathIsoPathΣ .leftInv p = refl
-
-      NTPath≃PathΣ = isoToEquiv NTPathIsoPathΣ
-
-      NTPath≡PathΣ = ua NTPath≃PathΣ
-
-  module _ where
-    open NatTransP
-
-    isSetNatTrans : {F G : Functor C D} → isSet (NatTrans F G)
-    isSetNatTrans =
-      isSetRetract (fun NatTransIsoΣ) (inv NatTransIsoΣ) (leftInv NatTransIsoΣ)
-                   (isSetΣSndProp (isSetΠ (λ _ → isSetHom D))
-                                  (λ _ → isPropImplicitΠ2 (λ _ _ → isPropΠ (λ _ → isSetHom D _ _))))
-
-
--- Natural isomorphism is path when the target category is univalent.
-
-module _
-  (isUnivD : isUnivalent D)
-  {F G : Functor C D} where
-
-  open isUnivalent isUnivD
-
-  NatIsoToPath : NatIso F G → F ≡ G
-  NatIsoToPath niso =
-    Functor≡ (λ x → CatIsoToPath (_ , niso .nIso x))
-      (λ f → isoToPath-Square isUnivD _ _ _ _ (niso .trans .N-hom f))
-
-  NatIso→Path→NatIso : (niso : NatIso F G) → pathToNatIso (NatIsoToPath niso) ≡ niso
-  NatIso→Path→NatIso niso = NatIso≡ (λ i x → secEq (univEquiv _ _) (_ , niso .nIso x) i .fst)
-
-  Path→NatIso→Path : (p : F ≡ G) → NatIsoToPath (pathToNatIso p) ≡ p
-  Path→NatIso→Path p = FunctorPath≡ (λ i j x → retEq (univEquiv _ _) (λ i → p i .F-ob x) i j)
-
-  Iso-Path-NatIso : Iso (F ≡ G) (NatIso F G)
-  Iso-Path-NatIso = iso pathToNatIso NatIsoToPath NatIso→Path→NatIso Path→NatIso→Path
-
-  Path≃NatIso : (F ≡ G) ≃ NatIso F G
-  Path≃NatIso = isoToEquiv Iso-Path-NatIso
-module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
-  seqNatIso : {F G H : Functor C D} → NatIso F G → NatIso G H → NatIso F H
-  seqNatIso ı ı' .trans = seqTrans (ı .trans) (ı' .trans)
-  seqNatIso ı ı' .nIso x .inv = ı' .nIso x .inv ⋆⟨ D ⟩ ı .nIso x .inv
-  seqNatIso ı ı' .nIso x .sec =
-    D .⋆Assoc _ _ _
-    ∙ cong (_⋆_ D (ı' .nIso x .inv))
-      (sym (D .⋆Assoc _ _ _)
-      ∙ cong (D ∘ ı' .trans .N-ob x) (ı .nIso x .sec)
-      ∙ D .⋆IdL (ı' .trans .N-ob x))
-    ∙ ı' .nIso x .sec
-  seqNatIso ı ı' .nIso x .ret =
-    (sym (D .⋆Assoc _ _ _))
-    ∙ cong (_∘_ D (ı .nIso x .inv))
-      (D .⋆Assoc _ _ _
-      ∙ cong (D ⋆ ı .trans .N-ob x) (ı' .nIso x .ret)
-      ∙ D .⋆IdR (ı .trans .N-ob x))
-    ∙ ı .nIso x .ret
-
-  CAT⋆IdR : {F : Functor C D} → NatIso (Id ∘F F) F
-  CAT⋆IdR {F} .trans .N-ob = idTrans F .N-ob
-  CAT⋆IdR {F} .trans .N-hom = idTrans F .N-hom
-  CAT⋆IdR {F} .nIso = idNatIso F .nIso
-
-module _ {B : Category ℓB ℓB'}{C : Category ℓC ℓC'}{D : Category ℓD ℓD'} where
-  _∘ʳi_ : ∀ (K : Functor C D) → {G H : Functor B C} (β : NatIso G H)
-       → NatIso (K ∘F G) (K ∘F H)
-  _∘ʳi_ K β .trans = K ∘ʳ β .trans
-  _∘ʳi_ K β .nIso x = preserveIsosF {F = K} (β .trans .N-ob _ , β .nIso x) .snd
-
-  open Functor
-  _∘ˡi_ : ∀ (K : Functor B C) → {G H : Functor C D} (β : NatIso G H)
-       → NatIso (G ∘F K) (H ∘F K)
-  _∘ˡi_ K β .trans = β .trans ∘ˡ K
-  _∘ˡi_ K β .nIso b  = β .nIso (K ⟅ b ⟆)
-
-  CAT⋆Assoc : {E : Category ℓE ℓE'}
-            (F : Functor B C)(G : Functor C D)(H : Functor D E)
-            → NatIso (H ∘F (G ∘F F)) ((H ∘F G) ∘F F)
-  CAT⋆Assoc F G H .trans .N-ob = idTrans ((H ∘F G) ∘F F) .N-ob
-  CAT⋆Assoc F G H .trans .N-hom = idTrans ((H ∘F G) ∘F F) .N-hom
-  CAT⋆Assoc F G H .nIso = idNatIso ((H ∘F G) ∘F F) .nIso
-
-
-
-⇒^opFiso : Iso (F ⇒ F') (_^opF {C = C} {D = D} F' ⇒ F ^opF )
-N-ob (fun ⇒^opFiso x) = N-ob x
-N-hom (fun ⇒^opFiso x) f = sym (N-hom x f)
-inv ⇒^opFiso = _
-rightInv ⇒^opFiso _ = refl
-leftInv ⇒^opFiso _ = refl
-
-congNatIso^opFiso : Iso (F ≅ᶜ F') (_^opF  {C = C} {D = D} F'  ≅ᶜ F ^opF )
-trans (fun congNatIso^opFiso x) = Iso.fun ⇒^opFiso (trans x)
-inv (nIso (fun congNatIso^opFiso x) x₁) = _
-sec (nIso (fun congNatIso^opFiso x) x₁) = ret (nIso x x₁)
-ret (nIso (fun congNatIso^opFiso x) x₁) = sec (nIso x x₁)
-inv congNatIso^opFiso = _
-rightInv congNatIso^opFiso _ = refl
-leftInv congNatIso^opFiso _ = refl
+{-# OPTIONS --safe #-}
+
+module Cubical.Categories.NaturalTransformation.Properties where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism renaming (iso to iIso)
+open import Cubical.Data.Sigma
+open import Cubical.Categories.Category renaming (isIso to isIsoC)
+open import Cubical.Categories.Functor.Base
+open import Cubical.Categories.Functor.Properties
+open import Cubical.Categories.Morphism
+open import Cubical.Categories.Isomorphism
+open import Cubical.Categories.NaturalTransformation.Base
+
+private
+  variable
+    ℓB ℓB' ℓC ℓC' ℓD ℓD' ℓE ℓE' : Level
+    C : Category ℓC ℓC'
+    D : Category ℓD ℓD'
+    F F' : Functor C D
+
+open isIsoC
+open NatIso
+open NatTrans
+open Category
+open Functor
+open Iso
+
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
+  private
+    _⋆ᴰ_ : ∀ {x y z} (f : D [ x , y ]) (g : D [ y , z ]) → D [ x , z ]
+    f ⋆ᴰ g = f ⋆⟨ D ⟩ g
+
+  -- natural isomorphism is symmetric
+  symNatIso : ∀ {F G : Functor C D}
+            → F ≅ᶜ G
+            → G ≅ᶜ F
+  symNatIso η .trans .N-ob x = η .nIso x .inv
+  symNatIso η .trans .N-hom _ = sqLL η
+  symNatIso η .nIso x .inv = η .trans .N-ob x
+  symNatIso η .nIso x .sec = η .nIso x .ret
+  symNatIso η .nIso x .ret = η .nIso x .sec
+
+  -- Properties
+
+  -- path helpers
+  module NatTransP where
+
+    module _ {F G : Functor C D} where
+
+      -- same as Sigma version
+      NatTransΣ : Type (ℓ-max (ℓ-max ℓC ℓC') ℓD')
+      NatTransΣ = Σ[ ob ∈ ((x : C .ob) → D [(F .F-ob x) , (G .F-ob x)]) ]
+                     ({x y : _ } (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (ob y) ≡ (ob x) ⋆ᴰ (G .F-hom f))
+
+      NatTransIsoΣ : Iso (NatTrans F G) NatTransΣ
+      NatTransIsoΣ .fun (natTrans N-ob N-hom) = N-ob , N-hom
+      NatTransIsoΣ .inv (N-ob , N-hom) = (natTrans N-ob N-hom)
+      NatTransIsoΣ .rightInv _ = refl
+      NatTransIsoΣ .leftInv _ = refl
+
+      NatTrans≡Σ : NatTrans F G ≡ NatTransΣ
+      NatTrans≡Σ = isoToPath NatTransIsoΣ
+
+      -- introducing paths
+      NatTrans-≡-intro : ∀ {αo βo : N-ob-Type F G}
+                           {αh : N-hom-Type F G αo}
+                           {βh : N-hom-Type F G βo}
+                       → (p : αo ≡ βo)
+                       → PathP (λ i → ({x y : C .ob} (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ (G .F-hom f))) αh βh
+                       → natTrans {F = F} {G} αo αh ≡ natTrans βo βh
+      NatTrans-≡-intro p q i = natTrans (p i) (q i)
+
+  module _ {F G : Functor C D} {α β : NatTrans F G} where
+      open Iso
+      private
+        αOb = α .N-ob
+        βOb = β .N-ob
+        αHom = α .N-hom
+        βHom = β .N-hom
+      -- path between natural transformations is the same as a pair of paths (between ob and hom)
+      NTPathIsoPathΣ : Iso (α ≡ β)
+                         (Σ[ p ∈ (αOb ≡ βOb) ]
+                              (PathP (λ i → ({x y : _} (f : _) → F ⟪ f ⟫ ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ G ⟪ f ⟫))
+                                  αHom
+                                  βHom))
+      NTPathIsoPathΣ .fun p = (λ i → p i .N-ob) , (λ i → p i .N-hom)
+      NTPathIsoPathΣ .inv (po , ph) i = record { N-ob = po i ; N-hom = ph i }
+      NTPathIsoPathΣ .rightInv pσ = refl
+      NTPathIsoPathΣ .leftInv p = refl
+
+      NTPath≃PathΣ = isoToEquiv NTPathIsoPathΣ
+
+      NTPath≡PathΣ = ua NTPath≃PathΣ
+
+  module _ where
+    open NatTransP
+
+    isSetNatTrans : {F G : Functor C D} → isSet (NatTrans F G)
+    isSetNatTrans =
+      isSetRetract (fun NatTransIsoΣ) (inv NatTransIsoΣ) (leftInv NatTransIsoΣ)
+                   (isSetΣSndProp (isSetΠ (λ _ → isSetHom D))
+                                  (λ _ → isPropImplicitΠ2 (λ _ _ → isPropΠ (λ _ → isSetHom D _ _))))
+
+
+-- Natural isomorphism is path when the target category is univalent.
+
+module _
+  (isUnivD : isUnivalent D)
+  {F G : Functor C D} where
+
+  open isUnivalent isUnivD
+
+  NatIsoToPath : NatIso F G → F ≡ G
+  NatIsoToPath niso =
+    Functor≡ (λ x → CatIsoToPath (_ , niso .nIso x))
+      (λ f → isoToPath-Square isUnivD _ _ _ _ (niso .trans .N-hom f))
+
+  NatIso→Path→NatIso : (niso : NatIso F G) → pathToNatIso (NatIsoToPath niso) ≡ niso
+  NatIso→Path→NatIso niso = NatIso≡ (λ i x → secEq (univEquiv _ _) (_ , niso .nIso x) i .fst)
+
+  Path→NatIso→Path : (p : F ≡ G) → NatIsoToPath (pathToNatIso p) ≡ p
+  Path→NatIso→Path p = FunctorPath≡ (λ i j x → retEq (univEquiv _ _) (λ i → p i .F-ob x) i j)
+
+  Iso-Path-NatIso : Iso (F ≡ G) (NatIso F G)
+  Iso-Path-NatIso = iso pathToNatIso NatIsoToPath NatIso→Path→NatIso Path→NatIso→Path
+
+  Path≃NatIso : (F ≡ G) ≃ NatIso F G
+  Path≃NatIso = isoToEquiv Iso-Path-NatIso
+module _ {C : Category ℓC ℓC'} {D : Category ℓD ℓD'} where
+  seqNatIso : {F G H : Functor C D} → NatIso F G → NatIso G H → NatIso F H
+  seqNatIso ı ı' .trans = seqTrans (ı .trans) (ı' .trans)
+  seqNatIso ı ı' .nIso x .inv = ı' .nIso x .inv ⋆⟨ D ⟩ ı .nIso x .inv
+  seqNatIso ı ı' .nIso x .sec =
+    D .⋆Assoc _ _ _
+    ∙ cong (_⋆_ D (ı' .nIso x .inv))
+      (sym (D .⋆Assoc _ _ _)
+      ∙ cong (D ∘ ı' .trans .N-ob x) (ı .nIso x .sec)
+      ∙ D .⋆IdL (ı' .trans .N-ob x))
+    ∙ ı' .nIso x .sec
+  seqNatIso ı ı' .nIso x .ret =
+    (sym (D .⋆Assoc _ _ _))
+    ∙ cong (_∘_ D (ı .nIso x .inv))
+      (D .⋆Assoc _ _ _
+      ∙ cong (D ⋆ ı .trans .N-ob x) (ı' .nIso x .ret)
+      ∙ D .⋆IdR (ı .trans .N-ob x))
+    ∙ ı .nIso x .ret
+
+  CAT⋆IdR : {F : Functor C D} → NatIso (Id ∘F F) F
+  CAT⋆IdR {F} .trans .N-ob = idTrans F .N-ob
+  CAT⋆IdR {F} .trans .N-hom = idTrans F .N-hom
+  CAT⋆IdR {F} .nIso = idNatIso F .nIso
+
+module _ {B : Category ℓB ℓB'}{C : Category ℓC ℓC'}{D : Category ℓD ℓD'} where
+  _∘ʳi_ : ∀ (K : Functor C D) → {G H : Functor B C} (β : NatIso G H)
+       → NatIso (K ∘F G) (K ∘F H)
+  _∘ʳi_ K β .trans = K ∘ʳ β .trans
+  _∘ʳi_ K β .nIso x = preserveIsosF {F = K} (β .trans .N-ob _ , β .nIso x) .snd
+
+  open Functor
+  _∘ˡi_ : ∀ (K : Functor B C) → {G H : Functor C D} (β : NatIso G H)
+       → NatIso (G ∘F K) (H ∘F K)
+  _∘ˡi_ K β .trans = β .trans ∘ˡ K
+  _∘ˡi_ K β .nIso b  = β .nIso (K ⟅ b ⟆)
+
+  CAT⋆Assoc : {E : Category ℓE ℓE'}
+            (F : Functor B C)(G : Functor C D)(H : Functor D E)
+            → NatIso (H ∘F (G ∘F F)) ((H ∘F G) ∘F F)
+  CAT⋆Assoc F G H .trans .N-ob = idTrans ((H ∘F G) ∘F F) .N-ob
+  CAT⋆Assoc F G H .trans .N-hom = idTrans ((H ∘F G) ∘F F) .N-hom
+  CAT⋆Assoc F G H .nIso = idNatIso ((H ∘F G) ∘F F) .nIso
+
+
+
+⇒^opFiso : Iso (F ⇒ F') (_^opF {C = C} {D = D} F' ⇒ F ^opF )
+N-ob (fun ⇒^opFiso x) = N-ob x
+N-hom (fun ⇒^opFiso x) f = sym (N-hom x f)
+inv ⇒^opFiso = _
+rightInv ⇒^opFiso _ = refl
+leftInv ⇒^opFiso _ = refl
+
+congNatIso^opFiso : Iso (F ≅ᶜ F') (_^opF  {C = C} {D = D} F'  ≅ᶜ F ^opF )
+trans (fun congNatIso^opFiso x) = Iso.fun ⇒^opFiso (trans x)
+inv (nIso (fun congNatIso^opFiso x) x₁) = _
+sec (nIso (fun congNatIso^opFiso x) x₁) = ret (nIso x x₁)
+ret (nIso (fun congNatIso^opFiso x) x₁) = sec (nIso x x₁)
+inv congNatIso^opFiso = _
+rightInv congNatIso^opFiso _ = refl
+leftInv congNatIso^opFiso _ = refl
 
 

\ No newline at end of file
diff --git a/docs/Cubical.Categories.NaturalTransformation.html b/docs/Cubical.Categories.NaturalTransformation.html
index e6c830b..dae3d9d 100644
--- a/docs/Cubical.Categories.NaturalTransformation.html
+++ b/docs/Cubical.Categories.NaturalTransformation.html
@@ -1,8 +1,8 @@
 
-Cubical.Categories.NaturalTransformation
{-# OPTIONS --allow-unsolved-metas #-}
+Cubical.Categories.NaturalTransformation
{-# OPTIONS --safe #-}
 
-module Cubical.Categories.NaturalTransformation where
+module Cubical.Categories.NaturalTransformation where
 
-open import Cubical.Categories.NaturalTransformation.Base public
-open import Cubical.Categories.NaturalTransformation.Properties public
+open import Cubical.Categories.NaturalTransformation.Base public
+open import Cubical.Categories.NaturalTransformation.Properties public
 

\ No newline at end of file
diff --git a/docs/Cubical.Data.Bool.Base.html b/docs/Cubical.Data.Bool.Base.html
index 2094232..fe4a9cb 100644
--- a/docs/Cubical.Data.Bool.Base.html
+++ b/docs/Cubical.Data.Bool.Base.html
@@ -88,13 +88,13 @@
 
 -- Universe lifted booleans
 Bool* : ∀ {ℓ} → Type ℓ
-Bool* = Lift Bool
+Bool* = Lift Bool
 
 true* : ∀ {ℓ} → Bool* {ℓ}
-true* = lift true
+true* = lift true
 
 false* : ∀ {ℓ} → Bool* {ℓ}
-false* = lift false
+false* = lift false
 
 -- Pointed version
 Bool*∙ : ∀ {ℓ} → Σ[ X ∈ Type ℓ ] X
diff --git a/docs/Cubical.Data.Bool.Properties.html b/docs/Cubical.Data.Bool.Properties.html
index 41d4b08..b7ee834 100644
--- a/docs/Cubical.Data.Bool.Properties.html
+++ b/docs/Cubical.Data.Bool.Properties.html
@@ -70,11 +70,11 @@
   : (P : {b : Bool} → b ≡ b → Type ℓ)
   → (∀{b} → P {b} refl)
   → ∀{b} → (q : b ≡ b) → P q
-K-Bool P Pr {false} = J (λ{ false q → P q ; true _ → Lift ⊥ }) Pr
-K-Bool P Pr {true}  = J (λ{ true q → P q ; false _ → Lift ⊥ }) Pr
+K-Bool P Pr {false} = J (λ{ false q → P q ; true _ → Lift ⊥ }) Pr
+K-Bool P Pr {true}  = J (λ{ true q → P q ; false _ → Lift ⊥ }) Pr
 
-isSetBool : isSet Bool
-isSetBool a b = J (λ _ p → ∀ q → p ≡ q) (K-Bool (refl ≡_) refl)
+isSetBool : isSet Bool
+isSetBool a b = J (λ _ p → ∀ q → p ≡ q) (K-Bool (refl ≡_) refl)
 
 true≢false : ¬ true ≡ false
 true≢false p = subst (λ b → if b then Bool else ⊥) p true
@@ -200,7 +200,7 @@
             → Table A P
 
   table : ∀ P → Table Bool P
-  table = J Table (inspect false true refl refl)
+  table = J Table (inspect false true refl refl)
 
   reflLemma : (P : Bool ≡ Bool)
          → transport P false ≡ false
@@ -252,24 +252,24 @@
 false ≥ true = ⊥
 _ ≥ _ = Unit
 
-isProp≤ : ∀ b c → isProp (b ≤ c)
+isProp≤ : ∀ b c → isProp (b ≤ c)
 isProp≤  true false = isProp⊥
 isProp≤  true  true = isPropUnit
 isProp≤ false false = isPropUnit
 isProp≤ false  true = isPropUnit
 
-isProp≥ : ∀ b c → isProp (b ≥ c)
+isProp≥ : ∀ b c → isProp (b ≥ c)
 isProp≥ false  true = isProp⊥
 isProp≥  true  true = isPropUnit
 isProp≥ false false = isPropUnit
 isProp≥  true false = isPropUnit
 
-isProp-Bool→Type : ∀ b → isProp (Bool→Type b)
+isProp-Bool→Type : ∀ b → isProp (Bool→Type b)
 isProp-Bool→Type false = isProp⊥
 isProp-Bool→Type true = isPropUnit
 
-isPropDep-Bool→Type : isPropDep Bool→Type
-isPropDep-Bool→Type = isOfHLevel→isOfHLevelDep 1 isProp-Bool→Type
+isPropDep-Bool→Type : isPropDep Bool→Type
+isPropDep-Bool→Type = isOfHLevel→isOfHLevelDep 1 isProp-Bool→Type
 
 IsoBool→∙ : ∀ {ℓ} {A : Pointed ℓ} → Iso ((Bool , true) →∙ A) (typ A)
 Iso.fun IsoBool→∙ f = fst f false
@@ -293,20 +293,20 @@
 Bool→TypeInj : (a b : Bool) → Bool→Type a ≃ Bool→Type b → a ≡ b
 Bool→TypeInj true true _ = refl
 Bool→TypeInj true false p = Empty.rec (p .fst tt)
-Bool→TypeInj false true p = Empty.rec (invEq p tt)
+Bool→TypeInj false true p = Empty.rec (invEq p tt)
 Bool→TypeInj false false _ = refl
 
 Bool→TypeInj* : (a b : Bool) → Bool→Type* {ℓ} a ≃ Bool→Type* {ℓ} b → a ≡ b
 Bool→TypeInj* true true _ = refl
 Bool→TypeInj* true false p = Empty.rec* (p .fst tt*)
-Bool→TypeInj* false true p = Empty.rec* (invEq p tt*)
+Bool→TypeInj* false true p = Empty.rec* (invEq p tt*)
 Bool→TypeInj* false false _ = refl
 
-isPropBool→Type : {a : Bool} → isProp (Bool→Type a)
+isPropBool→Type : {a : Bool} → isProp (Bool→Type a)
 isPropBool→Type {a = true} = isPropUnit
 isPropBool→Type {a = false} = isProp⊥
 
-isPropBool→Type* : {a : Bool} → isProp (Bool→Type* {ℓ} a)
+isPropBool→Type* : {a : Bool} → isProp (Bool→Type* {ℓ} a)
 isPropBool→Type* {a = true} = isPropUnit*
 isPropBool→Type* {a = false} = isProp⊥*
 
@@ -316,7 +316,7 @@
 
 DecBool→Type* : {a : Bool} → Dec (Bool→Type* {ℓ} a)
 DecBool→Type* {a = true} = yes tt*
-DecBool→Type* {a = false} = no (λ (lift x) → x)
+DecBool→Type* {a = false} = no (λ (lift x) → x)
 
 Dec→DecBool : {P : Type ℓ} → (dec : Dec P) → P → Bool→Type (Dec→Bool dec)
 Dec→DecBool (yes p) _ = tt
@@ -325,8 +325,8 @@
 DecBool→Dec : {P : Type ℓ} → (dec : Dec P) → Bool→Type (Dec→Bool dec) → P
 DecBool→Dec (yes p) _ = p
 
-Dec≃DecBool : {P : Type ℓ} → (h : isProp P)(dec : Dec P) → P ≃ Bool→Type (Dec→Bool dec)
-Dec≃DecBool h dec = propBiimpl→Equiv h isPropBool→Type (Dec→DecBool dec) (DecBool→Dec dec)
+Dec≃DecBool : {P : Type ℓ} → (h : isProp P)(dec : Dec P) → P ≃ Bool→Type (Dec→Bool dec)
+Dec≃DecBool h dec = propBiimpl→Equiv h isPropBool→Type (Dec→DecBool dec) (DecBool→Dec dec)
 
 Bool≡BoolDec : {a : Bool} → a ≡ Dec→Bool (DecBool→Type {a = a})
 Bool≡BoolDec {a = true} = refl
@@ -339,8 +339,8 @@
 DecBool→Dec* : {P : Type ℓ} → (dec : Dec P) → Bool→Type* {ℓ} (Dec→Bool dec) → P
 DecBool→Dec* (yes p) _ = p
 
-Dec≃DecBool* : {P : Type ℓ} → (h : isProp P)(dec : Dec P) → P ≃ Bool→Type* {ℓ} (Dec→Bool dec)
-Dec≃DecBool* h dec = propBiimpl→Equiv h isPropBool→Type* (Dec→DecBool* dec) (DecBool→Dec* dec)
+Dec≃DecBool* : {P : Type ℓ} → (h : isProp P)(dec : Dec P) → P ≃ Bool→Type* {ℓ} (Dec→Bool dec)
+Dec≃DecBool* h dec = propBiimpl→Equiv h isPropBool→Type* (Dec→DecBool* dec) (DecBool→Dec* dec)
 
 Bool≡BoolDec* : {a : Bool} → a ≡ Dec→Bool (DecBool→Type* {ℓ} {a = a})
 Bool≡BoolDec* {a = true} = refl
@@ -360,7 +360,7 @@
 
 Bool→Type×≃ : (a b : Bool) → Bool→Type a × Bool→Type b ≃ Bool→Type (a and b)
 Bool→Type×≃ a b =
-  propBiimpl→Equiv (isProp× isPropBool→Type isPropBool→Type) isPropBool→Type
+  propBiimpl→Equiv (isProp× isPropBool→Type isPropBool→Type) isPropBool→Type
     (Bool→Type×' a b) (Bool→Type× a b)
 
 Bool→Type⊎ : (a b : Bool) → Bool→Type (a or b) → Bool→Type a ⊎ Bool→Type b
@@ -390,10 +390,10 @@
 Bool≡ false false = true
 
 Bool≡≃ : (a b : Bool) → (a ≡ b) ≃ Bool→Type (Bool≡ a b)
-Bool≡≃ true true = isContr→≃Unit (inhProp→isContr refl (isSetBool _ _))
+Bool≡≃ true true = isContr→≃Unit (inhProp→isContr refl (isSetBool _ _))
 Bool≡≃ true false = uninhabEquiv true≢false Empty.rec
 Bool≡≃ false true = uninhabEquiv false≢true Empty.rec
-Bool≡≃ false false = isContr→≃Unit (inhProp→isContr refl (isSetBool _ _))
+Bool≡≃ false false = isContr→≃Unit (inhProp→isContr refl (isSetBool _ _))
 open Iso
 
 -- Bool is equivalent to bi-point type
@@ -410,4 +410,24 @@
 
 separatedBool : Separated Bool
 separatedBool = Discrete→Separated _≟_
+
+
+Bool→Bool→∙Bool : Bool → (Bool , true) →∙ (Bool , true)
+Bool→Bool→∙Bool false = idfun∙ _
+Bool→Bool→∙Bool true = const∙ _ _
+
+Iso-Bool→∙Bool-Bool : Iso ((Bool , true) →∙ (Bool , true)) Bool
+Iso.fun Iso-Bool→∙Bool-Bool f = fst f false
+Iso.inv Iso-Bool→∙Bool-Bool = Bool→Bool→∙Bool
+Iso.rightInv Iso-Bool→∙Bool-Bool false = refl
+Iso.rightInv Iso-Bool→∙Bool-Bool true = refl
+Iso.leftInv Iso-Bool→∙Bool-Bool f = Σ≡Prop (λ _ → isSetBool _ _) (help _ refl)
+  where
+  help : (x : Bool) → fst f false ≡ x
+    → Bool→Bool→∙Bool (fst f false) .fst ≡ f .fst
+  help false p = funExt
+    λ { false → (λ j → Bool→Bool→∙Bool (p j) .fst false) ∙ sym p
+      ; true → (λ j → Bool→Bool→∙Bool (p j) .fst true) ∙ sym (snd f)}
+  help true p = (λ j → Bool→Bool→∙Bool (p j) .fst)
+              ∙ funExt λ { false → sym p ; true → sym (snd f)}
 

\ No newline at end of file
diff --git a/docs/Cubical.Data.Bool.SwitchStatement.html b/docs/Cubical.Data.Bool.SwitchStatement.html
new file mode 100644
index 0000000..64fc02b
--- /dev/null
+++ b/docs/Cubical.Data.Bool.SwitchStatement.html
@@ -0,0 +1,44 @@
+
+Cubical.Data.Bool.SwitchStatement
{-# OPTIONS --safe #-}
+module Cubical.Data.Bool.SwitchStatement where
+
+open import Cubical.Core.Everything
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.Bool.Base
+open import Cubical.Data.Nat
+
+{-
+  Switch-case:
+
+    _==_ : A → A → Bool
+
+    _ : B
+    _ = switch (λ x → x == fixedValue) cases
+           case value1 ⇒ result1 break
+           case value2 ⇒ result2 break
+           ...
+           case valueN ⇒ resultN break
+           default⇒ defaultResult
+-}
+
+
+private
+  variable
+    ℓ ℓ' : Level
+
+
+infixr 6 default⇒_
+infixr 5 case_⇒_break_
+infixr 4 switch_cases_
+
+switch_cases_ : {A : Type ℓ} {B : Type ℓ'} → (A → Bool) → ((A → Bool) → B) → B
+switch caseIndicator cases caseData = caseData caseIndicator
+
+case_⇒_break_ : {A : Type ℓ} {B : Type ℓ'} → A → B → (otherCases : (A → Bool) → B) → (A → Bool) → B
+case forValue ⇒ result break otherCases = λ caseIndicator → if (caseIndicator forValue) then result else (otherCases caseIndicator)
+
+default⇒_ : {A : Type ℓ} {B : Type ℓ'} → B → (A → Bool) → B
+default⇒_ value caseIndicator = value
+

\ No newline at end of file
diff --git a/docs/Cubical.Data.Empty.Base.html b/docs/Cubical.Data.Empty.Base.html
index ac0fa90..488b385 100644
--- a/docs/Cubical.Data.Empty.Base.html
+++ b/docs/Cubical.Data.Empty.Base.html
@@ -11,7 +11,7 @@
 data ⊥ : Type₀ where
 
 ⊥* : Type ℓ
-⊥* = Lift ⊥
+⊥* = Lift ⊥
 
 rec : {A : Type ℓ} → ⊥ → A
 rec ()
@@ -21,4 +21,7 @@
 
 elim : {A : ⊥ → Type ℓ} → (x : ⊥) → A x
 elim ()
+
+elim* : {A : ⊥* {ℓ'} → Type ℓ} → (x : ⊥* {ℓ'}) → A x
+elim* ()
 

\ No newline at end of file
diff --git a/docs/Cubical.Data.Empty.Properties.html b/docs/Cubical.Data.Empty.Properties.html
index b9e7ccf..51261d3 100644
--- a/docs/Cubical.Data.Empty.Properties.html
+++ b/docs/Cubical.Data.Empty.Properties.html
@@ -8,21 +8,21 @@
 
 open import Cubical.Data.Empty.Base
 
-isProp⊥ : isProp ⊥
+isProp⊥ : isProp ⊥
 isProp⊥ ()
 
-isProp⊥* : ∀ {ℓ} → isProp {ℓ} ⊥*
+isProp⊥* : ∀ {ℓ} → isProp {ℓ} ⊥*
 isProp⊥* _ ()
 
-isContr⊥→A : ∀ {ℓ} {A : Type ℓ} → isContr (⊥ → A)
+isContr⊥→A : ∀ {ℓ} {A : Type ℓ} → isContr (⊥ → A)
 fst isContr⊥→A ()
 snd isContr⊥→A f i ()
 
-isContrΠ⊥ : ∀ {ℓ} {A : ⊥ → Type ℓ} → isContr ((x : ⊥) → A x)
+isContrΠ⊥ : ∀ {ℓ} {A : ⊥ → Type ℓ} → isContr ((x : ⊥) → A x)
 fst isContrΠ⊥ ()
 snd isContrΠ⊥ f i ()
 
-isContrΠ⊥* : ∀ {ℓ ℓ'} {A : ⊥* {ℓ} → Type ℓ'} → isContr ((x : ⊥*) → A x)
+isContrΠ⊥* : ∀ {ℓ ℓ'} {A : ⊥* {ℓ} → Type ℓ'} → isContr ((x : ⊥*) → A x)
 fst isContrΠ⊥* ()
 snd isContrΠ⊥* f i ()
 
diff --git a/docs/Cubical.Data.Fin.Base.html b/docs/Cubical.Data.Fin.Base.html
index 5bc2121..b0bca88 100644
--- a/docs/Cubical.Data.Fin.Base.html
+++ b/docs/Cubical.Data.Fin.Base.html
@@ -6,108 +6,138 @@
 open import Cubical.Foundations.Prelude
 open import Cubical.Foundations.Function
 open import Cubical.Foundations.HLevels
-
-import Cubical.Data.Empty as ⊥
-open import Cubical.Data.Nat using (ℕ ; zero ; suc ; _+_ ; znots)
-open import Cubical.Data.Nat.Order
-open import Cubical.Data.Nat.Order.Recursive using () renaming (_≤_ to _≤′_)
-open import Cubical.Data.Sigma
-open import Cubical.Data.Sum using (_⊎_; _⊎?_; inl; inr)
-
-open import Cubical.Relation.Nullary
-
--- Finite types.
---
--- Currently it is most convenient to define these as a subtype of the
--- natural numbers, because indexed inductive definitions don't behave
--- well with cubical Agda. This definition also has some more general
--- attractive properties, of course, such as easy conversion back to
--- ℕ.
-Fin : ℕ → Type₀
-Fin n = Σ[ k ∈ ℕ ] k < n
-
-private
-  variable
-    ℓ : Level
-    k : ℕ
-
-fzero : Fin (suc k)
-fzero = (0 , suc-≤-suc zero-≤)
-
-fone : Fin (suc (suc k))
-fone = (1 , suc-≤-suc (suc-≤-suc zero-≤))
-
-fzero≠fone : ¬ fzero {k = suc k} ≡ fone
-fzero≠fone p = znots (cong fst p)
-
--- It is easy, using this representation, to take the successor of a
--- number as a number in the next largest finite type.
-fsuc : Fin k → Fin (suc k)
-fsuc (k , l) = (suc k , suc-≤-suc l)
-
--- Conversion back to ℕ is trivial...
-toℕ : Fin k → ℕ
-toℕ = fst
-
--- ... and injective.
-toℕ-injective : ∀{fj fk : Fin k} → toℕ fj ≡ toℕ fk → fj ≡ fk
-toℕ-injective {fj = fj} {fk} = Σ≡Prop (λ _ → isProp≤)
-
--- Conversion from ℕ with a recursive definition of ≤
-
-fromℕ≤ : (m n : ℕ) → m ≤′ n → Fin (suc n)
-fromℕ≤ zero    _       _    = fzero
-fromℕ≤ (suc m) (suc n) m≤n = fsuc (fromℕ≤ m n m≤n)
-
--- A case analysis helper for induction.
-fsplit
-  : ∀(fj : Fin (suc k))
-  → (fzero ≡ fj) ⊎ (Σ[ fk ∈ Fin k ] fsuc fk ≡ fj)
-fsplit (0 , k<sn) = inl (toℕ-injective refl)
-fsplit (suc k , k<sn) = inr ((k , pred-≤-pred k<sn) , toℕ-injective refl)
-
-inject< : ∀ {m n} (m<n : m < n) → Fin m → Fin n
-inject< m<n (k , k<m) = k , <-trans k<m m<n
-
-flast : Fin (suc k)
-flast {k = k} = k , suc-≤-suc ≤-refl
-
--- Fin 0 is empty
-¬Fin0 : ¬ Fin 0
-¬Fin0 (k , k<0) = ¬-<-zero k<0
-
--- The full inductive family eliminator for finite types.
-elim
-  : ∀(P : ∀{k} → Fin k → Type ℓ)
-  → (∀{k} → P {suc k} fzero)
-  → (∀{k} {fn : Fin k} → P fn → P (fsuc fn))
-  → {k : ℕ} → (fn : Fin k) → P fn
-elim P fz fs {zero} = ⊥.rec ∘ ¬Fin0
-elim P fz fs {suc k} fj
-  = case fsplit fj return (λ _ → P fj) of λ
-  { (inl p) → subst P p fz
-  ; (inr (fk , p)) → subst P p (fs (elim P fz fs fk))
-  }
-
-any? : ∀ {n} {P : Fin n → Type ℓ} → (∀ i → Dec (P i)) → Dec (Σ (Fin n) P)
-any? {n = zero}  {P = _} P? = no (λ (x , _) → ¬Fin0 x)
-any? {n = suc n} {P = P} P? =
-  mapDec
-    (λ
-      { (inl P0) → fzero , P0
-      ; (inr (x , Px)) → fsuc x , Px
-      }
-    )
-    (λ n h → n (helper h))
-    (P? fzero ⊎? any? (P? ∘ fsuc))
-  where
-    helper : Σ (Fin (suc n)) P → P fzero ⊎ Σ (Fin n) λ z → P (fsuc z)
-    helper (x , Px) with fsplit x
-    ... | inl x≡0 = inl (subst P (sym x≡0) Px)
-    ... | inr (k , x≡sk) = inr (k , subst P (sym x≡sk) Px)
-
-FinPathℕ : {n : ℕ} (x : Fin n) (y : ℕ) → fst x ≡ y → Σ[ p ∈ _ ] (x ≡ (y , p))
-FinPathℕ {n = n} x y p =
-    ((fst (snd x)) , (cong (λ y → fst (snd x) + y) (cong suc (sym p)) ∙ snd (snd x)))
-  , (Σ≡Prop (λ _ → isProp≤) p)
+open import Cubical.Foundations.Pointed
+
+import Cubical.Data.Empty as ⊥
+open import Cubical.Data.Nat using (ℕ ; zero ; suc ; _+_ ; znots)
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.Nat.Order.Recursive using () renaming (_≤_ to _≤′_)
+open import Cubical.Data.Sigma
+open import Cubical.Data.Sum using (_⊎_; _⊎?_; inl; inr)
+
+open import Cubical.Relation.Nullary
+
+-- Finite types.
+--
+-- Currently it is most convenient to define these as a subtype of the
+-- natural numbers, because indexed inductive definitions don't behave
+-- well with cubical Agda. This definition also has some more general
+-- attractive properties, of course, such as easy conversion back to
+-- ℕ.
+Fin : ℕ → Type₀
+Fin n = Σ[ k ∈ ℕ ] k < n
+
+private
+  variable
+    ℓ : Level
+    k : ℕ
+
+fzero : Fin (suc k)
+fzero = (0 , suc-≤-suc zero-≤)
+
+fone : Fin (suc (suc k))
+fone = (1 , suc-≤-suc (suc-≤-suc zero-≤))
+
+fzero≠fone : ¬ fzero {k = suc k} ≡ fone
+fzero≠fone p = znots (cong fst p)
+
+-- It is easy, using this representation, to take the successor of a
+-- number as a number in the next largest finite type.
+fsuc : Fin k → Fin (suc k)
+fsuc (k , l) = (suc k , suc-≤-suc l)
+
+finj : Fin k → Fin (suc k)
+finj (k , l) = k , ≤-trans l (1 , refl)
+
+-- Conversion back to ℕ is trivial...
+toℕ : Fin k → ℕ
+toℕ = fst
+
+-- ... and injective.
+toℕ-injective : ∀{fj fk : Fin k} → toℕ fj ≡ toℕ fk → fj ≡ fk
+toℕ-injective {fj = fj} {fk} = Σ≡Prop (λ _ → isProp≤)
+
+-- Conversion from ℕ with a recursive definition of ≤
+
+fromℕ≤ : (m n : ℕ) → m ≤′ n → Fin (suc n)
+fromℕ≤ zero    _       _    = fzero
+fromℕ≤ (suc m) (suc n) m≤n = fsuc (fromℕ≤ m n m≤n)
+
+-- A case analysis helper for induction.
+fsplit
+  : ∀(fj : Fin (suc k))
+  → (fzero ≡ fj) ⊎ (Σ[ fk ∈ Fin k ] fsuc fk ≡ fj)
+fsplit (0 , k<sn) = inl (toℕ-injective refl)
+fsplit (suc k , k<sn) = inr ((k , pred-≤-pred k<sn) , toℕ-injective refl)
+
+inject< : ∀ {m n} (m<n : m < n) → Fin m → Fin n
+inject< m<n (k , k<m) = k , <-trans k<m m<n
+
+flast : Fin (suc k)
+flast {k = k} = k , suc-≤-suc ≤-refl
+
+-- Fin 0 is empty
+¬Fin0 : ¬ Fin 0
+¬Fin0 (k , k<0) = ¬-<-zero k<0
+
+-- The full inductive family eliminator for finite types.
+elim
+  : ∀(P : ∀{k} → Fin k → Type ℓ)
+  → (∀{k} → P {suc k} fzero)
+  → (∀{k} {fn : Fin k} → P fn → P (fsuc fn))
+  → {k : ℕ} → (fn : Fin k) → P fn
+elim P fz fs {zero} = ⊥.rec ∘ ¬Fin0
+elim P fz fs {suc k} fj
+  = case fsplit fj return (λ _ → P fj) of λ
+  { (inl p) → subst P p fz
+  ; (inr (fk , p)) → subst P p (fs (elim P fz fs fk))
+  }
+
+any? : ∀ {n} {P : Fin n → Type ℓ} → (∀ i → Dec (P i)) → Dec (Σ (Fin n) P)
+any? {n = zero}  {P = _} P? = no (λ (x , _) → ¬Fin0 x)
+any? {n = suc n} {P = P} P? =
+  mapDec
+    (λ
+      { (inl P0) → fzero , P0
+      ; (inr (x , Px)) → fsuc x , Px
+      }
+    )
+    (λ n h → n (helper h))
+    (P? fzero ⊎? any? (P? ∘ fsuc))
+  where
+    helper : Σ (Fin (suc n)) P → P fzero ⊎ Σ (Fin n) λ z → P (fsuc z)
+    helper (x , Px) with fsplit x
+    ... | inl x≡0 = inl (subst P (sym x≡0) Px)
+    ... | inr (k , x≡sk) = inr (k , subst P (sym x≡sk) Px)
+
+FinPathℕ : {n : ℕ} (x : Fin n) (y : ℕ) → fst x ≡ y → Σ[ p ∈ _ ] (x ≡ (y , p))
+FinPathℕ {n = n} x y p =
+    ((fst (snd x)) , (cong (λ y → fst (snd x) + y) (cong suc (sym p)) ∙ snd (snd x)))
+  , (Σ≡Prop (λ _ → isProp≤) p)
+
+FinVec : (A : Type ℓ) (n : ℕ) → Type ℓ
+FinVec A n = Fin n → A
+
+FinFamily : (n : ℕ) (ℓ : Level) → Type (ℓ-suc ℓ)
+FinFamily n ℓ = FinVec (Type ℓ) n
+
+FinFamily∙ : (n : ℕ) (ℓ : Level) → Type (ℓ-suc ℓ)
+FinFamily∙ n ℓ = FinVec (Pointed ℓ) n
+
+predFinFamily : {n : ℕ} → FinFamily (suc n) ℓ → FinFamily n ℓ
+predFinFamily A n = A (finj n)
+
+predFinFamily∙ : {n : ℕ} → FinFamily∙ (suc n) ℓ → FinFamily∙ n ℓ
+fst (predFinFamily∙ A x) = predFinFamily (fst ∘ A) x
+snd (predFinFamily∙ A x) = snd (A _)
+
+prodFinFamily : (n : ℕ) → FinFamily (suc n) ℓ → Type ℓ
+prodFinFamily zero A = A fzero
+prodFinFamily (suc n) A = prodFinFamily n (predFinFamily A) × A flast
+
+prodFinFamily∙ : (n : ℕ) → FinFamily∙ (suc n) ℓ → Pointed ℓ
+fst (prodFinFamily∙ n A) = prodFinFamily n (fst ∘ A)
+snd (prodFinFamily∙ zero A) = snd (A fzero)
+snd (prodFinFamily∙ (suc n) A) =
+  snd (prodFinFamily∙ n (predFinFamily∙ A)) , snd (A flast)
\ No newline at end of file diff --git a/docs/Cubical.Data.Fin.Literals.html b/docs/Cubical.Data.Fin.Literals.html index 724f3f2..ae4578a 100644 --- a/docs/Cubical.Data.Fin.Literals.html +++ b/docs/Cubical.Data.Fin.Literals.html @@ -7,14 +7,14 @@ open import Agda.Builtin.FromNat renaming (Number to HasFromNat) open import Cubical.Data.Fin.Base - using (Fin; fromℕ≤) + using (Fin; fromℕ≤) open import Cubical.Data.Nat.Order.Recursive using (_≤_) instance - fromNatFin : {n : _} → HasFromNat (Fin (suc n)) + fromNatFin : {n : _} → HasFromNat (Fin (suc n)) fromNatFin {n} = record { Constraint = λ m → m ≤ n - ; fromNat = λ m ⦃ m≤n ⦄ → fromℕ≤ m n m≤n + ; fromNat = λ m ⦃ m≤n ⦄ → fromℕ≤ m n m≤n } \ No newline at end of file diff --git a/docs/Cubical.Data.Fin.Properties.html b/docs/Cubical.Data.Fin.Properties.html index a53ed38..e1292fe 100644 --- a/docs/Cubical.Data.Fin.Properties.html +++ b/docs/Cubical.Data.Fin.Properties.html @@ -39,71 +39,71 @@ A : Type a -- Fin 0 is empty, and thus a proposition. -isPropFin0 : isProp (Fin 0) -isPropFin0 = Empty.rec ∘ ¬Fin0 +isPropFin0 : isProp (Fin 0) +isPropFin0 = Empty.rec ∘ ¬Fin0 -- Fin 1 has only one value. -isContrFin1 : isContr (Fin 1) +isContrFin1 : isContr (Fin 1) isContrFin1 - = fzero , λ - { (zero , _) → toℕ-injective refl + = fzero , λ + { (zero , _) → toℕ-injective refl ; (suc k , sk<1) → Empty.rec (¬-<-zero (pred-≤-pred sk<1)) } -Unit≃Fin1 : Unit ≃ Fin 1 +Unit≃Fin1 : Unit ≃ Fin 1 Unit≃Fin1 = isoToEquiv (iso - (const fzero) + (const fzero) (const tt) (isContrFin1 .snd) (isContrUnit .snd) ) -- Regardless of k, Fin k is a set. -isSetFin : ∀{k} → isSet (Fin k) -isSetFin {k} = isSetΣ isSetℕ (λ _ → isProp→isSet isProp≤) +isSetFin : ∀{k} → isSet (Fin k) +isSetFin {k} = isSetΣ isSetℕ (λ _ → isProp→isSet isProp≤) -discreteFin : ∀ {n} → Discrete (Fin n) +discreteFin : ∀ {n} → Discrete (Fin n) discreteFin {n} (x , hx) (y , hy) with discreteℕ x y ... | yes prf = yes (Σ≡Prop (λ _ → isProp≤) prf) ... | no prf = no λ h → prf (cong fst h) -inject<-ne : ∀ {n} (i : Fin n) → ¬ inject< ≤-refl i ≡ (n , ≤-refl) -inject<-ne {n} (k , k<n) p = <→≢ k<n (cong fst p) +inject<-ne : ∀ {n} (i : Fin n) → ¬ inject< ≤-refl i ≡ (n , ≤-refl) +inject<-ne {n} (k , k<n) p = <→≢ k<n (cong fst p) -Fin-fst-≡ : ∀ {n} {i j : Fin n} → fst i ≡ fst j → i ≡ j +Fin-fst-≡ : ∀ {n} {i j : Fin n} → fst i ≡ fst j → i ≡ j Fin-fst-≡ = Σ≡Prop (λ _ → isProp≤) private subst-app : (B : A → Type b) (f : (x : A) → B x) {x y : A} (x≡y : x ≡ y) → subst B x≡y (f x) ≡ f y subst-app B f {x = x} = - J (λ y e → subst B e (f x) ≡ f y) (substRefl {B = B} (f x)) + J (λ y e → subst B e (f x) ≡ f y) (substRefl {B = B} (f x)) -- Computation rules for the eliminator. -module _ (P : ∀ {k} → Fin k → Type ℓ) - (fz : ∀ {k} → P {suc k} fzero) - (fs : ∀ {k} {fn : Fin k} → P fn → P (fsuc fn)) +module _ (P : ∀ {k} → Fin k → Type ℓ) + (fz : ∀ {k} → P {suc k} fzero) + (fs : ∀ {k} {fn : Fin k} → P fn → P (fsuc fn)) {k : ℕ} where - elim-fzero : Fin.elim P fz fs {k = suc k} fzero ≡ fz + elim-fzero : Fin.elim P fz fs {k = suc k} fzero ≡ fz elim-fzero = - subst P (toℕ-injective _) fz ≡⟨ cong (λ p → subst P p fz) (isSetFin _ _ _ _) ⟩ + subst P (toℕ-injective _) fz ≡⟨ cong (λ p → subst P p fz) (isSetFin _ _ _ _) ⟩ subst P refl fz ≡⟨ substRefl {B = P} fz ⟩ fz ∎ - elim-fsuc : (fk : Fin k) → Fin.elim P fz fs (fsuc fk) ≡ fs (Fin.elim P fz fs fk) + elim-fsuc : (fk : Fin k) → Fin.elim P fz fs (fsuc fk) ≡ fs (Fin.elim P fz fs fk) elim-fsuc fk = - subst P (toℕ-injective (λ _ → toℕ (fsuc fk′))) (fs (Fin.elim P fz fs fk′)) - ≡⟨ cong (λ p → subst P p (fs (Fin.elim P fz fs fk′)) ) (isSetFin _ _ _ _) ⟩ - subst P (cong fsuc fk′≡fk) (fs (Fin.elim P fz fs fk′)) - ≡⟨ subst-app _ (λ fj → fs (Fin.elim P fz fs fj)) fk′≡fk ⟩ - fs (Fin.elim P fz fs fk) + subst P (toℕ-injective (λ _ → toℕ (fsuc fk′))) (fs (Fin.elim P fz fs fk′)) + ≡⟨ cong (λ p → subst P p (fs (Fin.elim P fz fs fk′)) ) (isSetFin _ _ _ _) ⟩ + subst P (cong fsuc fk′≡fk) (fs (Fin.elim P fz fs fk′)) + ≡⟨ subst-app _ (λ fj → fs (Fin.elim P fz fs fj)) fk′≡fk ⟩ + fs (Fin.elim P fz fs fk) ∎ where - fk′ = fst fk , pred-≤-pred (snd (fsuc fk)) + fk′ = fst fk , pred-≤-pred (snd (fsuc fk)) fk′≡fk : fk′ ≡ fk - fk′≡fk = toℕ-injective refl + fk′≡fk = toℕ-injective refl -- Helper function for the reduction procedure below. -- @@ -119,16 +119,16 @@ -- Expand a pair. This is useful because the whole function is -- injective. -expand× : ∀{k} → (Fin k × ℕ) → ℕ -expand× {k} (f , o) = expand o k (toℕ f) +expand× : ∀{k} → (Fin k × ℕ) → ℕ +expand× {k} (f , o) = expand o k (toℕ f) private lemma₀ : ∀{k m n r} → r ≡ n → k + m ≡ n → k ≤ r lemma₀ {k = k} {m} p q = m , +-comm m k ∙ q ∙ sym p - expand×Inj : ∀ k → {t1 t2 : Fin (suc k) × ℕ} → expand× t1 ≡ expand× t2 → t1 ≡ t2 + expand×Inj : ∀ k → {t1 t2 : Fin (suc k) × ℕ} → expand× t1 ≡ expand× t2 → t1 ≡ t2 expand×Inj k {f1 , zero} {f2 , zero} p i - = toℕ-injective {fj = f1} {f2} p i , zero + = toℕ-injective {fj = f1} {f2} p i , zero expand×Inj k {f1 , suc o1} {(r , r<sk) , zero} p = Empty.rec (<-asym r<sk (lemma₀ refl p)) expand×Inj k {(r , r<sk) , zero} {f2 , suc o2} p @@ -139,22 +139,22 @@ ∘ inj-m+ {suc k} expand×Emb : ∀ k → isEmbedding (expand× {k}) - expand×Emb 0 = Empty.rec ∘ ¬Fin0 ∘ fst + expand×Emb 0 = Empty.rec ∘ ¬Fin0 ∘ fst expand×Emb (suc k) = injEmbedding isSetℕ (expand×Inj k) -- A Residue is a family of types representing evidence that a -- natural is congruent to a value of a finite type. Residue : ℕ → ℕ → Type₀ -Residue k n = Σ[ tup ∈ Fin k × ℕ ] expand× tup ≡ n +Residue k n = Σ[ tup ∈ Fin k × ℕ ] expand× tup ≡ n -- There is at most one canonical finite value congruent to each -- natural. -isPropResidue : ∀ k n → isProp (Residue k n) +isPropResidue : ∀ k n → isProp (Residue k n) isPropResidue k = isEmbedding→hasPropFibers (expand×Emb k) -- A value of a finite type is its own residue. -Fin→Residue : ∀{k} → (f : Fin k) → Residue k (toℕ f) +Fin→Residue : ∀{k} → (f : Fin k) → Residue k (toℕ f) Fin→Residue f = (f , 0) , refl -- Fibers of numbers that differ by k are equivalent in a more obvious @@ -203,20 +203,20 @@ step n = transport (Residue≡ k n) reduce : ∀ n → Residue k n - reduce = +induction k₀ (Residue k) base step + reduce = +induction k₀ (Residue k) base step reduce≡ : ∀ n → transport (Residue≡ k n) (reduce n) ≡ reduce (k + n) reduce≡ n - = sym (+inductionStep k₀ _ base step n) + = sym (+inductionStep k₀ _ base step n) reduceP : ∀ n → PathP (λ i → Residue≡ k n i) (reduce n) (reduce (k + n)) - reduceP n = toPathP (reduce≡ n) + reduceP n = toPathP (reduce≡ n) open Reduce using (reduce; reduce≡) public -extract : ∀{k n} → Residue k n → Fin k +extract : ∀{k n} → Residue k n → Fin k extract = fst ∘ fst private @@ -230,14 +230,14 @@ extract≡ k n = lemma₅ (suc k) n (reduce k n) ∙ cong extract (Reduce.reduce≡ k n) -isContrResidue : ∀{k n} → isContr (Residue (suc k) n) -isContrResidue {k} {n} = inhProp→isContr (reduce k n) (isPropResidue (suc k) n) +isContrResidue : ∀{k n} → isContr (Residue (suc k) n) +isContrResidue {k} {n} = inhProp→isContr (reduce k n) (isPropResidue (suc k) n) -- the modulo operator on ℕ _%_ : ℕ → ℕ → ℕ n % zero = n -n % (suc k) = toℕ (extract (reduce k n)) +n % (suc k) = toℕ (extract (reduce k n)) _/_ : ℕ → ℕ → ℕ n / zero = zero @@ -253,20 +253,20 @@ n%sk<sk : (n k : ℕ) → (n % suc k) < suc k n%sk<sk n k = extract (reduce k n) .snd -fznotfs : ∀ {m : ℕ} {k : Fin m} → ¬ fzero ≡ fsuc k +fznotfs : ∀ {m : ℕ} {k : Fin m} → ¬ fzero ≡ fsuc k fznotfs {m} p = subst F p tt where - F : Fin (suc m) → Type₀ + F : Fin (suc m) → Type₀ F (zero , _) = Unit F (suc _ , _) = ⊥ -fsuc-inj : {fj fk : Fin n} → fsuc fj ≡ fsuc fk → fj ≡ fk -fsuc-inj = toℕ-injective ∘ injSuc ∘ cong toℕ +fsuc-inj : {fj fk : Fin n} → fsuc fj ≡ fsuc fk → fj ≡ fk +fsuc-inj = toℕ-injective ∘ injSuc ∘ cong toℕ -punchOut : ∀ {m} {i j : Fin (suc m)} → (¬ i ≡ j) → Fin m -punchOut {_} {i} {j} p with fsplit i | fsplit j +punchOut : ∀ {m} {i j : Fin (suc m)} → (¬ i ≡ j) → Fin m +punchOut {_} {i} {j} p with fsplit i | fsplit j punchOut {_} {i} {j} p | inl prfi | inl prfj = - Empty.elim (p (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎)) + Empty.elim (p (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎)) punchOut {_} {i} {j} p | inl prfi | inr (kj , prfj) = kj punchOut {zero} {i} {j} p | inr (ki , prfi) | inl prfj = @@ -277,7 +277,7 @@ )) where c = isContrFin1 .fst punchOut {suc _} {i} {j} p | inr (ki , prfi) | inl prfj = - fzero + fzero punchOut {zero} {i} {j} p | inr (ki , prfi) | inr (kj , prfj) = Empty.elim ((p ( i ≡⟨ sym (isContrFin1 .snd i) ⟩ @@ -286,38 +286,38 @@ )) where c = isContrFin1 .fst punchOut {suc _} {i} {j} p | inr (ki , prfi) | inr (kj , prfj) = - fsuc (punchOut {i = ki} {j = kj} - (λ q → p (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎)) + fsuc (punchOut {i = ki} {j = kj} + (λ q → p (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎)) ) punchOut-inj - : ∀ {m} {i j k : Fin (suc m)} (i≢j : ¬ i ≡ j) (i≢k : ¬ i ≡ k) + : ∀ {m} {i j k : Fin (suc m)} (i≢j : ¬ i ≡ j) (i≢k : ¬ i ≡ k) → punchOut i≢j ≡ punchOut i≢k → j ≡ k -punchOut-inj {_} {i} {j} {k} i≢j i≢k p with fsplit i | fsplit j | fsplit k +punchOut-inj {_} {i} {j} {k} i≢j i≢k p with fsplit i | fsplit j | fsplit k punchOut-inj {zero} {i} {j} {k} i≢j i≢k p | _ | _ | _ = Empty.elim (i≢j (i ≡⟨ sym (isContrFin1 .snd i) ⟩ c ≡⟨ isContrFin1 .snd j ⟩ j ∎)) where c = isContrFin1 .fst punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | inl prfj | _ = - Empty.elim (i≢j (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎)) + Empty.elim (i≢j (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎)) punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | _ | inl prfk = - Empty.elim (i≢k (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfk ⟩ k ∎)) + Empty.elim (i≢k (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfk ⟩ k ∎)) punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | inr (kj , prfj) | inr (kk , prfk) = j ≡⟨ sym prfj ⟩ - fsuc kj ≡⟨ cong fsuc p ⟩ - fsuc kk ≡⟨ prfk ⟩ + fsuc kj ≡⟨ cong fsuc p ⟩ + fsuc kk ≡⟨ prfk ⟩ k ∎ punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inl prfj | inl prfk = j ≡⟨ sym prfj ⟩ - fzero ≡⟨ prfk ⟩ + fzero ≡⟨ prfk ⟩ k ∎ punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inr (kj , prfj) | inr (kk , prfk) = j ≡⟨ sym prfj ⟩ - fsuc kj ≡⟨ cong fsuc lemma4 ⟩ - fsuc kk ≡⟨ prfk ⟩ + fsuc kj ≡⟨ cong fsuc lemma4 ⟩ + fsuc kk ≡⟨ prfk ⟩ k ∎ where - lemma1 = λ q → i≢j (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎) - lemma2 = λ q → i≢k (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kk ≡⟨ prfk ⟩ k ∎) + lemma1 = λ q → i≢j (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎) + lemma2 = λ q → i≢k (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kk ≡⟨ prfk ⟩ k ∎) lemma3 = fsuc-inj p lemma4 = punchOut-inj lemma1 lemma2 lemma3 punchOut-inj {suc m} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inl prfj | inr (kk , prfk) = @@ -327,35 +327,35 @@ pigeonhole-special : ∀ {n} - → (f : Fin (suc n) → Fin n) - → Σ[ i ∈ Fin (suc n) ] Σ[ j ∈ Fin (suc n) ] (¬ i ≡ j) × (f i ≡ f j) -pigeonhole-special {zero} f = Empty.rec (¬Fin0 (f fzero)) + → (f : Fin (suc n) → Fin n) + → Σ[ i ∈ Fin (suc n) ] Σ[ j ∈ Fin (suc n) ] (¬ i ≡ j) × (f i ≡ f j) +pigeonhole-special {zero} f = Empty.rec (¬Fin0 (f fzero)) pigeonhole-special {suc n} f = - proof (any? - (λ (i : Fin (suc n)) → - discreteFin (f (inject< ≤-refl i)) (f (suc n , ≤-refl)) + proof (any? + (λ (i : Fin (suc n)) → + discreteFin (f (inject< ≤-refl i)) (f (suc n , ≤-refl)) )) where proof - : Dec (Σ (Fin (suc n)) (λ z → f (inject< ≤-refl z) ≡ f (suc n , ≤-refl))) - → Σ[ i ∈ Fin (suc (suc n)) ] Σ[ j ∈ Fin (suc (suc n)) ] (¬ i ≡ j) × (f i ≡ f j) - proof (yes (i , prf)) = inject< ≤-refl i , (suc n , ≤-refl) , inject<-ne i , prf + : Dec (Σ (Fin (suc n)) (λ z → f (inject< ≤-refl z) ≡ f (suc n , ≤-refl))) + → Σ[ i ∈ Fin (suc (suc n)) ] Σ[ j ∈ Fin (suc (suc n)) ] (¬ i ≡ j) × (f i ≡ f j) + proof (yes (i , prf)) = inject< ≤-refl i , (suc n , ≤-refl) , inject<-ne i , prf proof (no h) = let - g : Fin (suc n) → Fin n + g : Fin (suc n) → Fin n g k = punchOut {i = f (suc n , ≤-refl)} - {j = f (inject< ≤-refl k)} + {j = f (inject< ≤-refl k)} (λ p → h (k , Fin-fst-≡ (sym (cong fst p)))) i , j , i≢j , p = pigeonhole-special g in - inject< ≤-refl i - , inject< ≤-refl j + inject< ≤-refl i + , inject< ≤-refl j , (λ q → i≢j (Fin-fst-≡ (cong fst q))) , punchOut-inj {i = f (suc n , ≤-refl)} - {j = f (inject< ≤-refl i)} - {k = f (inject< ≤-refl j)} + {j = f (inject< ≤-refl i)} + {k = f (inject< ≤-refl j)} (λ q → h (i , Fin-fst-≡ (sym (cong fst q)))) (λ q → h (j , Fin-fst-≡ (sym (cong fst q)))) (Fin-fst-≡ (cong fst p)) @@ -363,26 +363,26 @@ pigeonhole : ∀ {m n} → m < n - → (f : Fin n → Fin m) - → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j) + → (f : Fin n → Fin m) + → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j) pigeonhole {m} {n} (zero , sm≡n) f = transport transport-prf (pigeonhole-special f′) where - f′ : Fin (suc m) → Fin m - f′ = subst (λ h → Fin h → Fin m) (sym sm≡n) f + f′ : Fin (suc m) → Fin m + f′ = subst (λ h → Fin h → Fin m) (sym sm≡n) f - f′≡f : PathP (λ i → Fin (sm≡n i) → Fin m) f′ f - f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) (sym sm≡n)) (~ i) f + f′≡f : PathP (λ i → Fin (sm≡n i) → Fin m) f′ f + f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) (sym sm≡n)) (~ i) f transport-prf - : (Σ[ i ∈ Fin (suc m) ] Σ[ j ∈ Fin (suc m) ] (¬ i ≡ j) × (f′ i ≡ f′ j)) - ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j)) + : (Σ[ i ∈ Fin (suc m) ] Σ[ j ∈ Fin (suc m) ] (¬ i ≡ j) × (f′ i ≡ f′ j)) + ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j)) transport-prf φ = - Σ[ i ∈ Fin (sm≡n φ) ] Σ[ j ∈ Fin (sm≡n φ) ] + Σ[ i ∈ Fin (sm≡n φ) ] Σ[ j ∈ Fin (sm≡n φ) ] (¬ i ≡ j) × (f′≡f φ i ≡ f′≡f φ j) pigeonhole {m} {n} (suc k , prf) f = let - g : Fin (suc n′) → Fin n′ + g : Fin (suc n′) → Fin n′ g k = fst (f′ k) , <-trans (snd (f′ k)) m<n′ i , j , ¬q , r = pigeonhole-special g in transport transport-prf (i , j , ¬q , Σ≡Prop (λ _ → isProp≤) (cong fst r)) @@ -399,20 +399,20 @@ m<n′ : m < n′ m<n′ = k , injSuc (suc (k + suc m) ≡⟨ prf ⟩ n ≡⟨ n≡sn′ ⟩ suc n′ ∎) - f′ : Fin (suc n′) → Fin m - f′ = subst (λ h → Fin h → Fin m) n≡sn′ f + f′ : Fin (suc n′) → Fin m + f′ = subst (λ h → Fin h → Fin m) n≡sn′ f - f′≡f : PathP (λ i → Fin (n≡sn′ (~ i)) → Fin m) f′ f - f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) n≡sn′) (~ i) f + f′≡f : PathP (λ i → Fin (n≡sn′ (~ i)) → Fin m) f′ f + f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) n≡sn′) (~ i) f transport-prf - : (Σ[ i ∈ Fin (suc n′) ] Σ[ j ∈ Fin (suc n′) ] (¬ i ≡ j) × (f′ i ≡ f′ j)) - ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j)) + : (Σ[ i ∈ Fin (suc n′) ] Σ[ j ∈ Fin (suc n′) ] (¬ i ≡ j) × (f′ i ≡ f′ j)) + ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j)) transport-prf φ = - Σ[ i ∈ Fin (n≡sn′ (~ φ)) ] Σ[ j ∈ Fin (n≡sn′ (~ φ)) ] + Σ[ i ∈ Fin (n≡sn′ (~ φ)) ] Σ[ j ∈ Fin (n≡sn′ (~ φ)) ] (¬ i ≡ j) × (f′≡f φ i ≡ f′≡f φ j) -Fin-inj′ : {n m : ℕ} → n < m → ¬ Fin m ≡ Fin n +Fin-inj′ : {n m : ℕ} → n < m → ¬ Fin m ≡ Fin n Fin-inj′ n<m p = let i , j , i≢j , q = pigeonhole n<m (transport p) @@ -433,7 +433,7 @@ transport (sym p) (transport p y) ≡⟨ transport⁻Transport p y ⟩ y ∎ -Fin-inj : (n m : ℕ) → Fin n ≡ Fin m → n ≡ m +Fin-inj : (n m : ℕ) → Fin n ≡ Fin m → n ≡ m Fin-inj n m p with n ≟ m ... | eq prf = prf ... | lt n<m = Empty.rec (Fin-inj′ n<m (sym p)) @@ -452,11 +452,11 @@ d + m · suc k ≡⟨ p ⟩ n · suc k ∎ - residuek·n : ∀ k n → (r : Residue (suc k) (n · suc k)) → ((fzero , n) , expand≡ (suc k) 0 n ∙ +-zero _) ≡ r - residuek·n _ _ = isContr→isProp isContrResidue _ + residuek·n : ∀ k n → (r : Residue (suc k) (n · suc k)) → ((fzero , n) , expand≡ (suc k) 0 n ∙ +-zero _) ≡ r + residuek·n _ _ = isContr→isProp isContrResidue _ r≡0 : r ≡ 0 - r≡0 = cong (toℕ ∘ extract) (sym (residuek·n k n resn·k)) + r≡0 = cong (toℕ ∘ extract) (sym (residuek·n k n resn·k)) d≡o·sk : d ≡ o · suc k d≡o·sk = sym (moddiv d (suc k)) ∙∙ cong (o · suc k +_) r≡0 ∙∙ +-zero _ goal : (o + m) · suc k ≡ n · suc k @@ -467,51 +467,51 @@ ≤-helper : m ≤ n ≤-helper = ≤-·sk-cancel (pred-≤-pred (<≤-trans p (≤-suc ≤-refl))) goal : m < n - goal = case <-split (suc-≤-suc ≤-helper) of λ + goal = case <-split (suc-≤-suc ≤-helper) of λ { (inl g) → g ; (inr e) → Empty.rec (¬m<m (subst (λ m → m · suc k < n · suc k) e p)) } -factorEquiv : ∀ {n} {m} → Fin n × Fin m ≃ Fin (n · m) -factorEquiv {zero} {m} = uninhabEquiv (¬Fin0 ∘ fst) ¬Fin0 +factorEquiv : ∀ {n} {m} → Fin n × Fin m ≃ Fin (n · m) +factorEquiv {zero} {m} = uninhabEquiv (¬Fin0 ∘ fst) ¬Fin0 factorEquiv {suc n} {m} = intro , isEmbedding×isSurjection→isEquiv (isEmbeddingIntro , isSurjectionIntro) where - intro : Fin (suc n) × Fin m → Fin (suc n · m) - intro (nn , mm) = nm , subst (λ nm₁ → nm₁ < suc n · m) (sym (expand≡ _ (toℕ nn) (toℕ mm))) nm<n·m where + intro : Fin (suc n) × Fin m → Fin (suc n · m) + intro (nn , mm) = nm , subst (λ nm₁ → nm₁ < suc n · m) (sym (expand≡ _ (toℕ nn) (toℕ mm))) nm<n·m where nm : ℕ - nm = expand× (nn , toℕ mm) - nm<n·m : toℕ mm · suc n + toℕ nn < suc n · m + nm = expand× (nn , toℕ mm) + nm<n·m : toℕ mm · suc n + toℕ nn < suc n · m nm<n·m = - toℕ mm · suc n + toℕ nn <≤⟨ <-k+ (snd nn) ⟩ - toℕ mm · suc n + suc n ≡≤⟨ +-comm _ (suc n) ⟩ - suc (toℕ mm) · suc n ≤≡⟨ ≤-·k (snd mm) ⟩ + toℕ mm · suc n + toℕ nn <≤⟨ <-k+ (snd nn) ⟩ + toℕ mm · suc n + suc n ≡≤⟨ +-comm _ (suc n) ⟩ + suc (toℕ mm) · suc n ≤≡⟨ ≤-·k (snd mm) ⟩ m · suc n ≡⟨ ·-comm _ (suc n) ⟩ - suc n · m ∎ where open <-Reasoning + suc n · m ∎ where open <-Reasoning intro-injective : ∀ {o} {p} → intro o ≡ intro p → o ≡ p - intro-injective {o} {p} io≡ip = λ i → io′≡ip′ i .fst , toℕ-injective {fj = snd o} {fk = snd p} (cong snd io′≡ip′) i where - io′≡ip′ : (fst o , toℕ (snd o)) ≡ (fst p , toℕ (snd p)) + intro-injective {o} {p} io≡ip = λ i → io′≡ip′ i .fst , toℕ-injective {fj = snd o} {fk = snd p} (cong snd io′≡ip′) i where + io′≡ip′ : (fst o , toℕ (snd o)) ≡ (fst p , toℕ (snd p)) io′≡ip′ = expand×Inj _ (cong fst io≡ip) isEmbeddingIntro : isEmbedding intro isEmbeddingIntro = injEmbedding isSetFin intro-injective elimF : ∀ nm → fiber intro nm - elimF nm = ((nn , nn<n) , (mm , mm<m)) , toℕ-injective (reduce n (toℕ nm) .snd) where - mm = toℕ nm / suc n - nn = toℕ nm % suc n + elimF nm = ((nn , nn<n) , (mm , mm<m)) , toℕ-injective (reduce n (toℕ nm) .snd) where + mm = toℕ nm / suc n + nn = toℕ nm % suc n - nmmoddiv : mm · suc n + nn ≡ toℕ nm + nmmoddiv : mm · suc n + nn ≡ toℕ nm nmmoddiv = moddiv _ (suc n) nn<n : nn < suc n - nn<n = n%sk<sk (toℕ nm) _ + nn<n = n%sk<sk (toℕ nm) _ nmsnd : mm · suc n + nn < suc n · m nmsnd = subst (λ l → l < suc n · m) (sym nmmoddiv) (snd nm) mm·sn<m·sn : mm · suc n < m · suc n mm·sn<m·sn = - mm · suc n ≤<⟨ nn , +-comm nn (mm · suc n) ⟩ - mm · suc n + nn <≡⟨ nmsnd ⟩ + mm · suc n ≤<⟨ nn , +-comm nn (mm · suc n) ⟩ + mm · suc n + nn <≡⟨ nmsnd ⟩ suc n · m ≡⟨ ·-comm (suc n) m ⟩ - m · suc n ∎ where open <-Reasoning + m · suc n ∎ where open <-Reasoning mm<m : mm < m mm<m = <-·sk-cancel mm·sn<m·sn @@ -562,16 +562,16 @@ suc (m + (k ∸ m)) ≡⟨ cong suc (∸-lemma (pred-≤-pred m≤k)) ⟩ suc k ∎ -Fin+≅Fin⊎Fin : (m n : ℕ) → Iso (Fin (m + n)) (Fin m ⊎ Fin n) +Fin+≅Fin⊎Fin : (m n : ℕ) → Iso (Fin (m + n)) (Fin m ⊎ Fin n) Iso.fun (Fin+≅Fin⊎Fin m n) = f where - f : Fin (m + n) → Fin m ⊎ Fin n + f : Fin (m + n) → Fin m ⊎ Fin n f (k , k<m+n) with k ≤? m f (k , k<m+n) | inl k<m = inl (k , k<m) f (k , k<m+n) | inr k≥m = inr (k ∸ m , ∸-<-lemma m n k k<m+n k≥m) Iso.inv (Fin+≅Fin⊎Fin m n) = g where - g : Fin m ⊎ Fin n → Fin (m + n) + g : Fin m ⊎ Fin n → Fin (m + n) g (inl (k , k<m)) = k , o<m→o<m+n m n k k<m g (inr (k , k<n)) = m + k , <-k+ k<n Iso.rightInv (Fin+≅Fin⊎Fin m n) = sec-f-g @@ -593,20 +593,20 @@ ret-f-g (k , k<m+n) | inl _ = Σ≡Prop (λ _ → isProp≤) refl ret-f-g (k , k<m+n) | inr m≥k = Σ≡Prop (λ _ → isProp≤) (∸-lemma m≥k) -Fin+≡Fin⊎Fin : (m n : ℕ) → Fin (m + n) ≡ Fin m ⊎ Fin n +Fin+≡Fin⊎Fin : (m n : ℕ) → Fin (m + n) ≡ Fin m ⊎ Fin n Fin+≡Fin⊎Fin m n = isoToPath (Fin+≅Fin⊎Fin m n) -- Equivalence between FinData and Fin -sucFin : {N : ℕ} → Fin N → Fin (suc N) +sucFin : {N : ℕ} → Fin N → Fin (suc N) sucFin (k , n , p) = suc k , n , (+-suc _ _ ∙ cong suc p) -FinData→Fin : (N : ℕ) → FinData N → Fin N +FinData→Fin : (N : ℕ) → FinData N → Fin N FinData→Fin zero () FinData→Fin (suc N) zero = 0 , suc-≤-suc zero-≤ FinData→Fin (suc N) (suc k) = sucFin (FinData→Fin N k) -Fin→FinData : (N : ℕ) → Fin N → FinData N +Fin→FinData : (N : ℕ) → Fin N → FinData N Fin→FinData zero (k , n , p) = Empty.rec (snotz (sym (+-suc n k) ∙ p)) Fin→FinData (suc N) (0 , n , p) = zero Fin→FinData (suc N) ((suc k) , n , p) = suc (Fin→FinData N (k , n , p')) where @@ -625,60 +625,60 @@ retFin (suc N) zero = refl retFin (suc N) (suc k) = cong FinData.suc (cong (Fin→FinData N) (Fin-fst-≡ refl) ∙ retFin N k) -FinDataIsoFin : (N : ℕ) → Iso (FinData N) (Fin N) +FinDataIsoFin : (N : ℕ) → Iso (FinData N) (Fin N) Iso.fun (FinDataIsoFin N) = FinData→Fin N Iso.inv (FinDataIsoFin N) = Fin→FinData N Iso.rightInv (FinDataIsoFin N) = secFin N Iso.leftInv (FinDataIsoFin N) = retFin N -FinData≃Fin : (N : ℕ) → FinData N ≃ Fin N +FinData≃Fin : (N : ℕ) → FinData N ≃ Fin N FinData≃Fin N = isoToEquiv (FinDataIsoFin N) -FinData≡Fin : (N : ℕ) → FinData N ≡ Fin N +FinData≡Fin : (N : ℕ) → FinData N ≡ Fin N FinData≡Fin N = ua (FinData≃Fin N) -- decidability of Fin -DecFin : (n : ℕ) → Dec (Fin n) -DecFin 0 = no ¬Fin0 -DecFin (suc n) = yes fzero +DecFin : (n : ℕ) → Dec (Fin n) +DecFin 0 = no ¬Fin0 +DecFin (suc n) = yes fzero -- propositional truncation of Fin -Dec∥Fin∥ : (n : ℕ) → Dec ∥ Fin n ∥₁ +Dec∥Fin∥ : (n : ℕ) → Dec ∥ Fin n ∥₁ Dec∥Fin∥ n = Dec∥∥ (DecFin n) -- some properties about cardinality -Fin>0→isInhab : (n : ℕ) → 0 < n → Fin n +Fin>0→isInhab : (n : ℕ) → 0 < n → Fin n Fin>0→isInhab 0 p = Empty.rec (¬-<-zero p) -Fin>0→isInhab (suc n) p = fzero +Fin>0→isInhab (suc n) p = fzero -Fin>1→hasNonEqualTerm : (n : ℕ) → 1 < n → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ¬ i ≡ j +Fin>1→hasNonEqualTerm : (n : ℕ) → 1 < n → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ¬ i ≡ j Fin>1→hasNonEqualTerm 0 p = Empty.rec (snotz (≤0→≡0 p)) Fin>1→hasNonEqualTerm 1 p = Empty.rec (snotz (≤0→≡0 (pred-≤-pred p))) -Fin>1→hasNonEqualTerm (suc (suc n)) _ = fzero , fone , fzero≠fone +Fin>1→hasNonEqualTerm (suc (suc n)) _ = fzero , fone , fzero≠fone -isEmpty→Fin≡0 : (n : ℕ) → ¬ Fin n → 0 ≡ n +isEmpty→Fin≡0 : (n : ℕ) → ¬ Fin n → 0 ≡ n isEmpty→Fin≡0 0 _ = refl -isEmpty→Fin≡0 (suc n) p = Empty.rec (p fzero) +isEmpty→Fin≡0 (suc n) p = Empty.rec (p fzero) -isInhab→Fin>0 : (n : ℕ) → Fin n → 0 < n -isInhab→Fin>0 0 i = Empty.rec (¬Fin0 i) +isInhab→Fin>0 : (n : ℕ) → Fin n → 0 < n +isInhab→Fin>0 0 i = Empty.rec (¬Fin0 i) isInhab→Fin>0 (suc n) _ = suc-≤-suc zero-≤ -hasNonEqualTerm→Fin>1 : (n : ℕ) → (i j : Fin n) → ¬ i ≡ j → 1 < n -hasNonEqualTerm→Fin>1 0 i _ _ = Empty.rec (¬Fin0 i) -hasNonEqualTerm→Fin>1 1 i j p = Empty.rec (p (isContr→isProp isContrFin1 i j)) +hasNonEqualTerm→Fin>1 : (n : ℕ) → (i j : Fin n) → ¬ i ≡ j → 1 < n +hasNonEqualTerm→Fin>1 0 i _ _ = Empty.rec (¬Fin0 i) +hasNonEqualTerm→Fin>1 1 i j p = Empty.rec (p (isContr→isProp isContrFin1 i j)) hasNonEqualTerm→Fin>1 (suc (suc n)) _ _ _ = suc-≤-suc (suc-≤-suc zero-≤) -Fin≤1→isProp : (n : ℕ) → n ≤ 1 → isProp (Fin n) +Fin≤1→isProp : (n : ℕ) → n ≤ 1 → isProp (Fin n) Fin≤1→isProp 0 _ = isPropFin0 -Fin≤1→isProp 1 _ = isContr→isProp isContrFin1 +Fin≤1→isProp 1 _ = isContr→isProp isContrFin1 Fin≤1→isProp (suc (suc n)) p = Empty.rec (¬-<-zero (pred-≤-pred p)) -isProp→Fin≤1 : (n : ℕ) → isProp (Fin n) → n ≤ 1 -isProp→Fin≤1 0 _ = ≤-solver 0 1 -isProp→Fin≤1 1 _ = ≤-solver 1 1 -isProp→Fin≤1 (suc (suc n)) p = Empty.rec (fzero≠fone (p fzero fone)) +isProp→Fin≤1 : (n : ℕ) → isProp (Fin n) → n ≤ 1 +isProp→Fin≤1 0 _ = ≤-solver 0 1 +isProp→Fin≤1 1 _ = ≤-solver 1 1 +isProp→Fin≤1 (suc (suc n)) p = Empty.rec (fzero≠fone (p fzero fone)) \ No newline at end of file diff --git a/docs/Cubical.Data.FinData.Properties.html b/docs/Cubical.Data.FinData.Properties.html index b92439d..e798c23 100644 --- a/docs/Cubical.Data.FinData.Properties.html +++ b/docs/Cubical.Data.FinData.Properties.html @@ -75,10 +75,10 @@ inj-cong : {n : ℕ} → {k l : Fin n} → (p : toℕ k ≡ toℕ l) → cong toℕ (inj-toℕ p) ≡ p inj-cong p = isSetℕ _ _ _ _ -isPropFin0 : isProp (Fin 0) +isPropFin0 : isProp (Fin 0) isPropFin0 = ⊥.rec ∘ ¬Fin0 -isContrFin1 : isContr (Fin 1) +isContrFin1 : isContr (Fin 1) isContrFin1 .fst = zero isContrFin1 .snd zero = refl @@ -114,7 +114,7 @@ ... | yes p = yes (cong suc p) ... | no ¬p = no (λ q → ¬p (injSucFin q)) -isSetFin : ∀{k} → isSet (Fin k) +isSetFin : ∀{k} → isSet (Fin k) isSetFin = Discrete→isSet discreteFin isWeaken? : ∀ {n} (p : Fin (ℕsuc n)) → Dec (Σ[ q ∈ Fin n ] p ≡ weakenFin q) @@ -157,13 +157,13 @@ toFin : {n : ℕ} (m : ℕ) → m < n → Fin n toFin {n = ℕzero} _ m<0 = ⊥.rec (¬-<-zero m<0) toFin {n = ℕsuc n} _ (ℕzero , _) = fromℕ n --in this case we have m≡n -toFin {n = ℕsuc n} m (ℕsuc k , p) = weakenFin (toFin m (k , cong predℕ p)) +toFin {n = ℕsuc n} m (ℕsuc k , p) = weakenFin (toFin m (k , cong predℕ p)) toFin0≡0 : {n : ℕ} (p : 0 < ℕsuc n) → toFin 0 p ≡ zero -toFin0≡0 (ℕzero , p) = subst (λ x → fromℕ x ≡ zero) (cong predℕ p) refl -toFin0≡0 {ℕzero} (ℕsuc k , p) = ⊥.rec (ℕsnotz (+-comm 1 k ∙ (cong predℕ p))) +toFin0≡0 (ℕzero , p) = subst (λ x → fromℕ x ≡ zero) (cong predℕ p) refl +toFin0≡0 {ℕzero} (ℕsuc k , p) = ⊥.rec (ℕsnotz (+-comm 1 k ∙ (cong predℕ p))) toFin0≡0 {ℕsuc n} (ℕsuc k , p) = - subst (λ x → weakenFin x ≡ zero) (sym (toFin0≡0 (k , cong predℕ p))) refl + subst (λ x → weakenFin x ≡ zero) (sym (toFin0≡0 (k , cong predℕ p))) refl genδ-FinVec : (n k : ℕ) → (a b : A) → FinVec A n genδ-FinVec (ℕsuc n) ℕzero a b zero = a @@ -196,7 +196,7 @@ toℕ∘enum {n = ℕsuc n} (ℕsuc m) p i = ℕsuc (toℕ∘enum m (pred-≤-pred p) i) enumExt : {m m' : ℕ}(p : m < n)(p' : m' < n) → m ≡ m' → enum m p ≡ enum m' p' -enumExt p p' q i = enum (q i) (isProp→PathP (λ i → isProp≤ {m = ℕsuc (q i)}) p p' i) +enumExt p p' q i = enum (q i) (isProp→PathP (λ i → isProp≤ {m = ℕsuc (q i)}) p p' i) enumInj : (p : m < k) (q : n < k) → enum m p ≡ enum n q → m ≡ n enumInj p q path = sym (toℕ∘enum _ p) ∙ cong toℕ path ∙ toℕ∘enum _ q @@ -208,7 +208,7 @@ → P (enum (ℕsuc k) p) → ((m : ℕ)(q : m < n)(q' : m ≤ ℕsuc k) → P (enum m q)) enumIndStep P k p f x m q q' = - case (≤-split q') return (λ _ → P (enum m q)) of + case (≤-split q') return (λ _ → P (enum m q)) of λ { (inl r') → f m q (pred-≤-pred r') ; (inr r') → subst P (enumExt p q (sym r')) x } @@ -336,10 +336,10 @@ Equiv : (n m : ℕ) → (Fin n × Fin m) ≃ Fin (n · m) Equiv ℕzero m = uninhabEquiv (λ x → ¬Fin0 (fst x)) ¬Fin0 - Equiv (ℕsuc n) m = Fin (ℕsuc n) × Fin m ≃⟨ isoToEquiv (sucProdToSumIso n m) ⟩ - Fin m ⊎ (Fin n × Fin m) ≃⟨ isoToEquiv (⊎Iso idIso (equivToIso (Equiv n m))) ⟩ - Fin m ⊎ Fin (n · m) ≃⟨ FinSumChar.Equiv m (n · m) ⟩ - Fin (m + n · m) ■ + Equiv (ℕsuc n) m = Fin (ℕsuc n) × Fin m ≃⟨ isoToEquiv (sucProdToSumIso n m) ⟩ + Fin m ⊎ (Fin n × Fin m) ≃⟨ isoToEquiv (⊎Iso idIso (equivToIso (Equiv n m))) ⟩ + Fin m ⊎ Fin (n · m) ≃⟨ FinSumChar.Equiv m (n · m) ⟩ + Fin (m + n · m) ■ -- Exhaustion of decidable predicate diff --git a/docs/Cubical.Data.List.Properties.html b/docs/Cubical.Data.List.Properties.html index a17298c..90eb2d7 100644 --- a/docs/Cubical.Data.List.Properties.html +++ b/docs/Cubical.Data.List.Properties.html @@ -40,7 +40,7 @@ rev-rev (x ∷ xs) = rev-snoc (rev xs) x ∙ cong (_∷_ x) (rev-rev xs) rev-rev-snoc : (xs : List A) (y : A) → - Square (rev-rev (xs ++ [ y ])) (cong (_++ [ y ]) (rev-rev xs)) (cong rev (rev-snoc xs y)) refl + Square (rev-rev (xs ++ [ y ])) (cong (_++ [ y ]) (rev-rev xs)) (cong rev (rev-snoc xs y)) refl rev-rev-snoc [] y = sym (lUnit refl) rev-rev-snoc (x ∷ xs) y i j = hcomp @@ -66,25 +66,25 @@ module ListPath {ℓ} {A : Type ℓ} where Cover : List A → List A → Type ℓ - Cover [] [] = Lift Unit - Cover [] (_ ∷ _) = Lift ⊥ - Cover (_ ∷ _) [] = Lift ⊥ + Cover [] [] = Lift Unit + Cover [] (_ ∷ _) = Lift ⊥ + Cover (_ ∷ _) [] = Lift ⊥ Cover (x ∷ xs) (y ∷ ys) = (x ≡ y) × Cover xs ys reflCode : ∀ xs → Cover xs xs - reflCode [] = lift tt + reflCode [] = lift tt reflCode (_ ∷ xs) = refl , reflCode xs encode : ∀ xs ys → (p : xs ≡ ys) → Cover xs ys - encode xs _ = J (λ ys _ → Cover xs ys) (reflCode xs) + encode xs _ = J (λ ys _ → Cover xs ys) (reflCode xs) encodeRefl : ∀ xs → encode xs xs refl ≡ reflCode xs - encodeRefl xs = JRefl (λ ys _ → Cover xs ys) (reflCode xs) + encodeRefl xs = JRefl (λ ys _ → Cover xs ys) (reflCode xs) decode : ∀ xs ys → Cover xs ys → xs ≡ ys decode [] [] _ = refl - decode [] (_ ∷ _) (lift ()) - decode (x ∷ xs) [] (lift ()) + decode [] (_ ∷ _) (lift ()) + decode (x ∷ xs) [] (lift ()) decode (x ∷ xs) (y ∷ ys) (p , c) = cong₂ _∷_ p (decode xs ys c) decodeRefl : ∀ xs → decode xs xs (reflCode xs) ≡ refl @@ -93,17 +93,17 @@ decodeEncode : ∀ xs ys → (p : xs ≡ ys) → decode xs ys (encode xs ys p) ≡ p decodeEncode xs _ = - J (λ ys p → decode xs ys (encode xs ys p) ≡ p) + J (λ ys p → decode xs ys (encode xs ys p) ≡ p) (cong (decode xs xs) (encodeRefl xs) ∙ decodeRefl xs) isOfHLevelCover : (n : HLevel) (p : isOfHLevel (suc (suc n)) A) (xs ys : List A) → isOfHLevel (suc n) (Cover xs ys) isOfHLevelCover n p [] [] = - isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isPropUnit) + isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isPropUnit) isOfHLevelCover n p [] (y ∷ ys) = - isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) isOfHLevelCover n p (x ∷ xs) [] = - isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) isOfHLevelCover n p (x ∷ xs) (y ∷ ys) = isOfHLevelΣ (suc n) (p x y) (\ _ → isOfHLevelCover n p xs ys) @@ -140,10 +140,10 @@ cons-inj₂ = cong safe-tail ¬cons≡nil : ∀ {x : A} {xs} → ¬ (x ∷ xs ≡ []) -¬cons≡nil {A = A} p = lower (subst (caseList (Lift ⊥) (List A)) p []) +¬cons≡nil {A = A} p = lower (subst (caseList (Lift ⊥) (List A)) p []) ¬nil≡cons : ∀ {x : A} {xs} → ¬ ([] ≡ x ∷ xs) -¬nil≡cons {A = A} p = lower (subst (caseList (List A) (Lift ⊥)) p []) +¬nil≡cons {A = A} p = lower (subst (caseList (List A) (Lift ⊥)) p []) ¬snoc≡nil : ∀ {x : A} {xs} → ¬ (xs ∷ʳ x ≡ []) ¬snoc≡nil {xs = []} contra = ¬cons≡nil contra @@ -156,10 +156,10 @@ cons≡rev-snoc _ [] = refl cons≡rev-snoc x (y ∷ ys) = λ i → cons≡rev-snoc x ys i ++ y ∷ [] -isContr[]≡[] : isContr (Path (List A) [] []) +isContr[]≡[] : isContr (Path (List A) [] []) isContr[]≡[] = refl , ListPath.decodeEncode [] [] -isPropXs≡[] : {xs : List A} → isProp (xs ≡ []) +isPropXs≡[] : {xs : List A} → isProp (xs ≡ []) isPropXs≡[] {xs = []} = isOfHLevelSuc 0 isContr[]≡[] isPropXs≡[] {xs = x ∷ xs} = λ p _ → ⊥.rec (¬cons≡nil p) diff --git a/docs/Cubical.Data.Maybe.Properties.html b/docs/Cubical.Data.Maybe.Properties.html index 76ab4dd..7b52822 100644 --- a/docs/Cubical.Data.Maybe.Properties.html +++ b/docs/Cubical.Data.Maybe.Properties.html @@ -46,20 +46,20 @@ -- Path space of Maybe type module MaybePath {ℓ} {A : Type ℓ} where Cover : Maybe A → Maybe A → Type ℓ - Cover nothing nothing = Lift Unit - Cover nothing (just _) = Lift ⊥ - Cover (just _) nothing = Lift ⊥ + Cover nothing nothing = Lift Unit + Cover nothing (just _) = Lift ⊥ + Cover (just _) nothing = Lift ⊥ Cover (just a) (just a') = a ≡ a' reflCode : (c : Maybe A) → Cover c c - reflCode nothing = lift tt + reflCode nothing = lift tt reflCode (just b) = refl encode : ∀ c c' → c ≡ c' → Cover c c' - encode c _ = J (λ c' _ → Cover c c') (reflCode c) + encode c _ = J (λ c' _ → Cover c c') (reflCode c) encodeRefl : ∀ c → encode c c refl ≡ reflCode c - encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c) + encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c) decode : ∀ c c' → Cover c c' → c ≡ c' decode nothing nothing _ = refl @@ -71,13 +71,13 @@ decodeEncode : ∀ c c' → (p : c ≡ c') → decode c c' (encode c c' p) ≡ p decodeEncode c _ = - J (λ c' p → decode c c' (encode c c' p) ≡ p) + J (λ c' p → decode c c' (encode c c' p) ≡ p) (cong (decode c c) (encodeRefl c) ∙ decodeRefl c) encodeDecode : ∀ c c' → (d : Cover c c') → encode c c' (decode c c' d) ≡ d encodeDecode nothing nothing _ = refl encodeDecode (just a) (just a') = - J (λ a' p → encode (just a) (just a') (cong just p) ≡ p) (encodeRefl (just a)) + J (λ a' p → encode (just a) (just a') (cong just p) ≡ p) (encodeRefl (just a)) Cover≃Path : ∀ c c' → Cover c c' ≃ (c ≡ c') Cover≃Path c c' = isoToEquiv @@ -90,9 +90,9 @@ isOfHLevelCover : (n : HLevel) → isOfHLevel (suc (suc n)) A → ∀ c c' → isOfHLevel (suc n) (Cover c c') - isOfHLevelCover n p nothing nothing = isOfHLevelLift (suc n) (isOfHLevelUnit (suc n)) - isOfHLevelCover n p nothing (just a') = isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) - isOfHLevelCover n p (just a) nothing = isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelCover n p nothing nothing = isOfHLevelLift (suc n) (isOfHLevelUnit (suc n)) + isOfHLevelCover n p nothing (just a') = isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelCover n p (just a) nothing = isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) isOfHLevelCover n p (just a) (just a') = p a a' isOfHLevelMaybe : ∀ {ℓ} (n : HLevel) {A : Type ℓ} @@ -121,23 +121,23 @@ isEmbedding-just w z = MaybePath.Cover≃Path (just w) (just z) .snd ¬nothing≡just : ∀ {x : A} → ¬ (nothing ≡ just x) -¬nothing≡just {A = A} {x = x} p = lower (subst (caseMaybe (Maybe A) (Lift ⊥)) p (just x)) +¬nothing≡just {A = A} {x = x} p = lower (subst (caseMaybe (Maybe A) (Lift ⊥)) p (just x)) ¬just≡nothing : ∀ {x : A} → ¬ (just x ≡ nothing) -¬just≡nothing {A = A} {x = x} p = lower (subst (caseMaybe (Lift ⊥) (Maybe A)) p (just x)) +¬just≡nothing {A = A} {x = x} p = lower (subst (caseMaybe (Lift ⊥) (Maybe A)) p (just x)) -isProp-x≡nothing : (x : Maybe A) → isProp (x ≡ nothing) +isProp-x≡nothing : (x : Maybe A) → isProp (x ≡ nothing) isProp-x≡nothing nothing x w = - subst isProp (MaybePath.Cover≡Path nothing nothing) (isOfHLevelLift 1 isPropUnit) x w + subst isProp (MaybePath.Cover≡Path nothing nothing) (isOfHLevelLift 1 isPropUnit) x w isProp-x≡nothing (just _) p _ = ⊥.rec (¬just≡nothing p) -isProp-nothing≡x : (x : Maybe A) → isProp (nothing ≡ x) +isProp-nothing≡x : (x : Maybe A) → isProp (nothing ≡ x) isProp-nothing≡x nothing x w = - subst isProp (MaybePath.Cover≡Path nothing nothing) (isOfHLevelLift 1 isPropUnit) x w + subst isProp (MaybePath.Cover≡Path nothing nothing) (isOfHLevelLift 1 isPropUnit) x w isProp-nothing≡x (just _) p _ = ⊥.rec (¬nothing≡just p) -isContr-nothing≡nothing : isContr (nothing {A = A} ≡ nothing) -isContr-nothing≡nothing = inhProp→isContr refl (isProp-x≡nothing _) +isContr-nothing≡nothing : isContr (nothing {A = A} ≡ nothing) +isContr-nothing≡nothing = inhProp→isContr refl (isProp-x≡nothing _) discreteMaybe : Discrete A → Discrete (Maybe A) discreteMaybe eqA nothing nothing = yes refl @@ -175,9 +175,9 @@ open Iso isom : Iso _ _ isom .fun = map-Maybe (equivFun e) - isom .inv = map-Maybe (invEq e) + isom .inv = map-Maybe (invEq e) isom .rightInv nothing = refl - isom .rightInv (just b) = cong just (secEq e b) + isom .rightInv (just b) = cong just (secEq e b) isom .leftInv nothing = refl - isom .leftInv (just a) = cong just (retEq e a) + isom .leftInv (just a) = cong just (retEq e a) \ No newline at end of file diff --git a/docs/Cubical.Data.Nat.Base.html b/docs/Cubical.Data.Nat.Base.html index b06be8d..b2ad75f 100644 --- a/docs/Cubical.Data.Nat.Base.html +++ b/docs/Cubical.Data.Nat.Base.html @@ -13,69 +13,80 @@ open import Cubical.Data.Sum.Base hiding (elim) open import Cubical.Data.Empty.Base hiding (elim) open import Cubical.Data.Unit.Base - -predℕ : ℕ → ℕ -predℕ zero = zero -predℕ (suc n) = n - -caseNat : ∀ {ℓ} → {A : Type ℓ} → (a0 aS : A) → ℕ → A -caseNat a0 aS zero = a0 -caseNat a0 aS (suc n) = aS - -doubleℕ : ℕ → ℕ -doubleℕ zero = zero -doubleℕ (suc x) = suc (suc (doubleℕ x)) - --- doublesℕ n m = 2^n · m -doublesℕ : ℕ → ℕ → ℕ -doublesℕ zero m = m -doublesℕ (suc n) m = doublesℕ n (doubleℕ m) - --- iterate -iter : ∀ {ℓ} {A : Type ℓ} → ℕ → (A → A) → A → A -iter zero f z = z -iter (suc n) f z = f (iter n f z) - -elim : ∀ {ℓ} {A : ℕ → Type ℓ} - → A zero - → ((n : ℕ) → A n → A (suc n)) - → (n : ℕ) → A n -elim a₀ _ zero = a₀ -elim a₀ f (suc n) = f n (elim a₀ f n) - -elim+2 : ∀ {ℓ} {A : ℕ → Type ℓ} → A 0 → A 1 - → ((n : ℕ) → (A (suc n) → A (suc (suc n)))) - → (n : ℕ) → A n -elim+2 a0 a1 ind zero = a0 -elim+2 a0 a1 ind (suc zero) = a1 -elim+2 {A = A} a0 a1 ind (suc (suc n)) = - ind n (elim+2 {A = A} a0 a1 ind (suc n)) - -isEven isOdd : ℕ → Bool -isEven zero = true -isEven (suc n) = isOdd n -isOdd zero = false -isOdd (suc n) = isEven n - ---Typed version -private - toType : Bool → Type - toType false = ⊥ - toType true = Unit - -isEvenT : ℕ → Type -isEvenT n = toType (isEven n) - -isOddT : ℕ → Type -isOddT n = isEvenT (suc n) - -isZero : ℕ → Bool -isZero zero = true -isZero (suc n) = false - --- exponential - -_^_ : ℕ → ℕ → ℕ -m ^ 0 = 1 -m ^ (suc n) = m · m ^ n +open import Cubical.Data.Sigma.Base + +predℕ : ℕ → ℕ +predℕ zero = zero +predℕ (suc n) = n + +caseNat : ∀ {ℓ} → {A : Type ℓ} → (a0 aS : A) → ℕ → A +caseNat a0 aS zero = a0 +caseNat a0 aS (suc n) = aS + +doubleℕ : ℕ → ℕ +doubleℕ zero = zero +doubleℕ (suc x) = suc (suc (doubleℕ x)) + +-- doublesℕ n m = 2^n · m +doublesℕ : ℕ → ℕ → ℕ +doublesℕ zero m = m +doublesℕ (suc n) m = doublesℕ n (doubleℕ m) + +-- iterate +iter : ∀ {ℓ} {A : Type ℓ} → ℕ → (A → A) → A → A +iter zero f z = z +iter (suc n) f z = f (iter n f z) + +elim : ∀ {ℓ} {A : ℕ → Type ℓ} + → A zero + → ((n : ℕ) → A n → A (suc n)) + → (n : ℕ) → A n +elim a₀ _ zero = a₀ +elim a₀ f (suc n) = f n (elim a₀ f n) + +elim+2 : ∀ {ℓ} {A : ℕ → Type ℓ} → A 0 → A 1 + → ((n : ℕ) → (A (suc n) → A (suc (suc n)))) + → (n : ℕ) → A n +elim+2 a0 a1 ind zero = a0 +elim+2 a0 a1 ind (suc zero) = a1 +elim+2 {A = A} a0 a1 ind (suc (suc n)) = + ind n (elim+2 {A = A} a0 a1 ind (suc n)) + +isEven isOdd : ℕ → Bool +isEven zero = true +isEven (suc n) = isOdd n +isOdd zero = false +isOdd (suc n) = isEven n + +--Typed version +private + toType : Bool → Type + toType false = ⊥ + toType true = Unit + +isEvenT : ℕ → Type +isEvenT n = toType (isEven n) + +isOddT : ℕ → Type +isOddT n = isEvenT (suc n) + +isZero : ℕ → Bool +isZero zero = true +isZero (suc n) = false + +-- exponential + +_^_ : ℕ → ℕ → ℕ +m ^ 0 = 1 +m ^ (suc n) = m · m ^ n + + +-- Iterated product +_ˣ_ : ∀ {ℓ} (A : ℕ → Type ℓ) (n : ℕ) → Type ℓ +A ˣ zero = A zero +A ˣ suc n = (A ˣ n) × A (suc n) + +0ˣ : ∀ {ℓ} (A : ℕ → Type ℓ) (0A : (n : ℕ) → A n) → (n : ℕ) → A ˣ n +0ˣ A 0A zero = 0A zero +0ˣ A 0A (suc n) = (0ˣ A 0A n) , (0A (suc n)) \ No newline at end of file diff --git a/docs/Cubical.Data.Nat.Order.Recursive.html b/docs/Cubical.Data.Nat.Order.Recursive.html index b244adf..8e8fe28 100644 --- a/docs/Cubical.Data.Nat.Order.Recursive.html +++ b/docs/Cubical.Data.Nat.Order.Recursive.html @@ -46,7 +46,7 @@ P : ℕ → Type ℓ k l m n : ℕ -isProp≤ : isProp (m ≤ n) +isProp≤ : isProp (m ≤ n) isProp≤ {zero} = isPropUnit isProp≤ {suc m} {zero} = isProp⊥ isProp≤ {suc m} {suc n} = isProp≤ {m} {n} @@ -127,17 +127,17 @@ = Sum.map (idfun _) (cong suc) (≤-split {m} {n} m≤n) module WellFounded where - wf-< : WellFounded _<_ - wf-rec-< : ∀ n → WFRec _<_ (Acc _<_) n + wf-< : WellFounded _<_ + wf-rec-< : ∀ n → WFRec _<_ (Acc _<_) n - wf-< n = acc (wf-rec-< n) + wf-< n = acc (wf-rec-< n) wf-rec-< (suc n) m m≤n with ≤-split {m} {n} m≤n ... | inl m<n = wf-rec-< n m m<n - ... | inr m≡n = subst⁻ (Acc _<_) m≡n (wf-< n) + ... | inr m≡n = subst⁻ (Acc _<_) m≡n (wf-< n) wf-elim : (∀ n → (∀ m → m < n → P m) → P n) → ∀ n → P n -wf-elim = WFI.induction WellFounded.wf-< +wf-elim = WFI.induction WellFounded.wf-< wf-rec : (∀ n → (∀ m → m < n → R) → R) → ℕ → R wf-rec {R = R} = wf-elim {P = λ _ → R} @@ -146,7 +146,7 @@ Least : ∀{ℓ} → (ℕ → Type ℓ) → (ℕ → Type ℓ) Least P m = P m × (∀ n → n < m → ¬ P n) - isPropLeast : (∀ m → isProp (P m)) → ∀ m → isProp (Least P m) + isPropLeast : (∀ m → isProp (P m)) → ∀ m → isProp (Least P m) isPropLeast pP m = isPropΣ (pP m) (λ _ → isPropΠ3 λ _ _ _ → isProp⊥) @@ -177,15 +177,15 @@ ... | eq m≡n = m≡n ... | gt n<m = Empty.rec (¬P<m n n<m Pn) - isPropΣLeast : (∀ m → isProp (P m)) → isProp (Σ _ (Least P)) + isPropΣLeast : (∀ m → isProp (P m)) → isProp (Σ _ (Least P)) isPropΣLeast pP (m , LPm) (n , LPn) = ΣPathP λ where .fst → Least-unique m n LPm LPn - .snd → isOfHLevel→isOfHLevelDep 1 (isPropLeast pP) + .snd → isOfHLevel→isOfHLevelDep 1 (isPropLeast pP) LPm LPn (Least-unique m n LPm LPn) Decidable→Collapsible - : (∀ m → isProp (P m)) → (∀ m → Dec (P m)) → Collapsible (Σ ℕ P) + : (∀ m → isProp (P m)) → (∀ m → Dec (P m)) → Collapsible (Σ ℕ P) Decidable→Collapsible pP dP = λ where .fst → Least→ ∘ →Least dP .snd x y → cong Least→ (isPropΣLeast pP (→Least dP x) (→Least dP y)) diff --git a/docs/Cubical.Data.Nat.Order.html b/docs/Cubical.Data.Nat.Order.html index ea393bd..88e1038 100644 --- a/docs/Cubical.Data.Nat.Order.html +++ b/docs/Cubical.Data.Nat.Order.html @@ -46,10 +46,10 @@ k l m n : ℕ private - witness-prop : ∀ j → isProp (j + m ≡ n) + witness-prop : ∀ j → isProp (j + m ≡ n) witness-prop {m} {n} j = isSetℕ (j + m) n -isProp≤ : isProp (m ≤ n) +isProp≤ : isProp (m ≤ n) isProp≤ {m} {n} (k , p) (l , q) = Σ≡Prop witness-prop lemma where @@ -93,7 +93,7 @@ ≤-sucℕ : n ≤ suc n ≤-sucℕ = ≤-suc ≤-refl -≤-predℕ : predℕ n ≤ n +≤-predℕ : predℕ n ≤ n ≤-predℕ {zero} = ≤-refl ≤-predℕ {suc n} = ≤-suc ≤-refl @@ -156,7 +156,7 @@ ≤0→≡0 {zero} ineq = refl ≤0→≡0 {suc n} ineq = ⊥.rec (¬-<-zero ineq) -predℕ-≤-predℕ : m ≤ n → (predℕ m) ≤ (predℕ n) +predℕ-≤-predℕ : m ≤ n → (predℕ m) ≤ (predℕ n) predℕ-≤-predℕ {zero} {zero} ineq = ≤-refl predℕ-≤-predℕ {zero} {suc n} ineq = zero-≤ predℕ-≤-predℕ {suc m} {zero} ineq = ⊥.rec (¬-<-zero ineq) @@ -273,253 +273,259 @@ suc m ≟ zero = gt (m , +-comm m 1) suc m ≟ suc n = Trichotomy-suc (m ≟ n) -splitℕ-≤ : (m n : ℕ) → (m ≤ n) ⊎ (n < m) -splitℕ-≤ m n with m ≟ n -... | lt x = inl (<-weaken x) -... | eq x = inl (0 , x) -... | gt x = inr x - -splitℕ-< : (m n : ℕ) → (m < n) ⊎ (n ≤ m) -splitℕ-< m n with m ≟ n -... | lt x = inl x -... | eq x = inr (0 , (sym x)) -... | gt x = inr (<-weaken x) - -≤CaseInduction : {P : ℕ → ℕ → Type ℓ} {n m : ℕ} - → (n ≤ m → P n m) → (m ≤ n → P n m) - → P n m -≤CaseInduction {n = n} {m = m} p q with n ≟ m -... | lt x = p (<-weaken x) -... | eq x = p (subst (n ≤_) x ≤-refl) -... | gt x = q (<-weaken x) - -<-split : m < suc n → (m < n) ⊎ (m ≡ n) -<-split {n = zero} = inr ∘ snd ∘ m+n≡0→m≡0×n≡0 ∘ snd ∘ pred-≤-pred -<-split {zero} {suc n} = λ _ → inl (suc-≤-suc zero-≤) -<-split {suc m} {suc n} = ⊎.map suc-≤-suc (cong suc) ∘ <-split ∘ pred-≤-pred - -≤-split : m ≤ n → (m < n) ⊎ (m ≡ n) -≤-split p = <-split (suc-≤-suc p) - -≤→< : m ≤ n → ¬ m ≡ n → m < n -≤→< p q = - case (≤-split p) of - λ { (inl r) → r - ; (inr r) → ⊥.rec (q r) } - -≤-suc-≢ : m ≤ suc n → (m ≡ suc n → ⊥ ) → m ≤ n -≤-suc-≢ p ¬q = pred-≤-pred (≤→< p ¬q) - -≤-+-split : ∀ n m k → k ≤ n + m → (n ≤ k) ⊎ (m ≤ (n + m) ∸ k) -≤-+-split n m k k≤n+m with n ≟ k -... | eq p = inl (0 , p) -... | lt n<k = inl (<-weaken n<k) -... | gt k<n with m ≟ ((n + m) ∸ k) -... | eq p = inr (0 , p) -... | lt m<n+m∸k = inr (<-weaken m<n+m∸k) -... | gt n+m∸k<m = - ⊥.rec (¬m<m (transport (λ i → ≤-∸-+-cancel k≤n+m i < +-comm m n i) (<-+-< n+m∸k<m k<n))) - -<-asym'-case : Trichotomy m n → ¬ m < n → n ≤ m -<-asym'-case (lt p) q = ⊥.rec (q p) -<-asym'-case (eq p) _ = _ , sym p -<-asym'-case (gt p) _ = <-weaken p - -<-asym' : ¬ m < n → n ≤ m -<-asym' = <-asym'-case (_≟_ _ _) - -private - acc-suc : Acc _<_ n → Acc _<_ (suc n) - acc-suc a - = acc λ y y<sn - → case <-split y<sn of λ - { (inl y<n) → access a y y<n - ; (inr y≡n) → subst _ (sym y≡n) a - } - -<-wellfounded : WellFounded _<_ -<-wellfounded zero = acc λ _ → ⊥.rec ∘ ¬-<-zero -<-wellfounded (suc n) = acc-suc (<-wellfounded n) - -<→≢ : n < m → ¬ n ≡ m -<→≢ {n} {m} p q = ¬m<m (subst (_< m) q p) - -module _ - (b₀ : ℕ) - (P : ℕ → Type₀) - (base : ∀ n → n < suc b₀ → P n) - (step : ∀ n → P n → P (suc b₀ + n)) - where - open WFI (<-wellfounded) - - private - dichotomy : ∀ b n → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m) - dichotomy b n - = case n ≟ b return (λ _ → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m)) of λ - { (lt o) → inl o - ; (eq p) → inr (0 , p ∙ sym (+-zero b)) - ; (gt (m , p)) → inr (suc m , sym p ∙ +-suc m b ∙ +-comm (suc m) b) - } - - dichotomy<≡ : ∀ b n → (n<b : n < b) → dichotomy b n ≡ inl n<b - dichotomy<≡ b n n<b - = case dichotomy b n return (λ d → d ≡ inl n<b) of λ - { (inl x) → cong inl (isProp≤ x n<b) - ; (inr (m , p)) → ⊥.rec (<-asym n<b (m , sym (p ∙ +-comm b m))) - } - - dichotomy+≡ : ∀ b m n → (p : n ≡ b + m) → dichotomy b n ≡ inr (m , p) - dichotomy+≡ b m n p - = case dichotomy b n return (λ d → d ≡ inr (m , p)) of λ - { (inl n<b) → ⊥.rec (<-asym n<b (m , +-comm m b ∙ sym p)) - ; (inr (m' , q)) - → cong inr (Σ≡Prop (λ x → isSetℕ n (b + x)) (inj-m+ {m = b} (sym q ∙ p))) - } - - b = suc b₀ - - lemma₁ : ∀{x y z} → x ≡ suc z + y → y < x - lemma₁ {y = y} {z} p = z , +-suc z y ∙ sym p - - subStep : (n : ℕ) → (∀ m → m < n → P m) → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m) → P n - subStep n _ (inl l) = base n l - subStep n rec (inr (m , p)) - = transport (cong P (sym p)) (step m (rec m (lemma₁ p))) - - wfStep : (n : ℕ) → (∀ m → m < n → P m) → P n - wfStep n rec = subStep n rec (dichotomy b n) - - wfStepLemma₀ : ∀ n (n<b : n < b) rec → wfStep n rec ≡ base n n<b - wfStepLemma₀ n n<b rec = cong (subStep n rec) (dichotomy<≡ b n n<b) - - wfStepLemma₁ : ∀ n rec → wfStep (b + n) rec ≡ step n (rec n (lemma₁ refl)) - wfStepLemma₁ n rec - = cong (subStep (b + n) rec) (dichotomy+≡ b n (b + n) refl) - ∙ transportRefl _ - - +induction : ∀ n → P n - +induction = induction wfStep - - +inductionBase : ∀ n → (l : n < b) → +induction n ≡ base n l - +inductionBase n l = induction-compute wfStep n ∙ wfStepLemma₀ n l _ - - +inductionStep : ∀ n → +induction (b + n) ≡ step n (+induction n) - +inductionStep n = induction-compute wfStep (b + n) ∙ wfStepLemma₁ n _ - -module <-Reasoning where - -- TODO: would it be better to mirror the way it is done in the agda-stdlib? - infixr 2 _<⟨_⟩_ _≤<⟨_⟩_ _≤⟨_⟩_ _<≤⟨_⟩_ _≡<⟨_⟩_ _≡≤⟨_⟩_ _<≡⟨_⟩_ _≤≡⟨_⟩_ - _<⟨_⟩_ : ∀ k → k < n → n < m → k < m - _ <⟨ p ⟩ q = <-trans p q - - _≤<⟨_⟩_ : ∀ k → k ≤ n → n < m → k < m - _ ≤<⟨ p ⟩ q = ≤<-trans p q - - _≤⟨_⟩_ : ∀ k → k ≤ n → n ≤ m → k ≤ m - _ ≤⟨ p ⟩ q = ≤-trans p q - - _<≤⟨_⟩_ : ∀ k → k < n → n ≤ m → k < m - _ <≤⟨ p ⟩ q = <≤-trans p q - - _≡≤⟨_⟩_ : ∀ k → k ≡ l → l ≤ m → k ≤ m - _ ≡≤⟨ p ⟩ q = subst (λ k → k ≤ _) (sym p) q - - _≡<⟨_⟩_ : ∀ k → k ≡ l → l < m → k < m - _ ≡<⟨ p ⟩ q = _ ≡≤⟨ cong suc p ⟩ q - - _≤≡⟨_⟩_ : ∀ k → k ≤ l → l ≡ m → k ≤ m - _ ≤≡⟨ p ⟩ q = subst (λ l → _ ≤ l) q p - - _<≡⟨_⟩_ : ∀ k → k < l → l ≡ m → k < m - _ <≡⟨ p ⟩ q = _ ≤≡⟨ p ⟩ q - - --- Some lemmas about ∸ -suc∸-fst : (n m : ℕ) → m < n → suc (n ∸ m) ≡ (suc n) ∸ m -suc∸-fst zero zero p = refl -suc∸-fst zero (suc m) p = ⊥.rec (¬-<-zero p) -suc∸-fst (suc n) zero p = refl -suc∸-fst (suc n) (suc m) p = (suc∸-fst n m (pred-≤-pred p)) - -n∸m≡0 : (n m : ℕ) → n ≤ m → (n ∸ m) ≡ 0 -n∸m≡0 zero zero p = refl -n∸m≡0 (suc n) zero p = ⊥.rec (¬-<-zero p) -n∸m≡0 zero (suc m) p = refl -n∸m≡0 (suc n) (suc m) p = n∸m≡0 n m (pred-≤-pred p) - -n∸n≡0 : (n : ℕ) → n ∸ n ≡ 0 -n∸n≡0 zero = refl -n∸n≡0 (suc n) = n∸n≡0 n - -n∸l>0 : (n l : ℕ) → (l < n) → 0 < (n ∸ l) -n∸l>0 zero zero r = ⊥.rec (¬-<-zero r) -n∸l>0 zero (suc l) r = ⊥.rec (¬-<-zero r) -n∸l>0 (suc n) zero r = suc-≤-suc zero-≤ -n∸l>0 (suc n) (suc l) r = n∸l>0 n l (pred-≤-pred r) - --- automation - -≤-solver-type : (m n : ℕ) → Trichotomy m n → Type -≤-solver-type m n (lt p) = m ≤ n -≤-solver-type m n (eq p) = m ≤ n -≤-solver-type m n (gt p) = n < m - -≤-solver-case : (m n : ℕ) → (p : Trichotomy m n) → ≤-solver-type m n p -≤-solver-case m n (lt p) = <-weaken p -≤-solver-case m n (eq p) = _ , p -≤-solver-case m n (gt p) = p - -≤-solver : (m n : ℕ) → ≤-solver-type m n (m ≟ n) -≤-solver m n = ≤-solver-case m n (m ≟ n) +Dichotomyℕ : ∀ (n m : ℕ) → (n ≤ m) ⊎ (n > m) +Dichotomyℕ n m with (n ≟ m) +... | lt x = inl (<-weaken x) +... | Trichotomy.eq x = inl (0 , x) +... | gt x = inr x + +splitℕ-≤ : (m n : ℕ) → (m ≤ n) ⊎ (n < m) +splitℕ-≤ m n with m ≟ n +... | lt x = inl (<-weaken x) +... | eq x = inl (0 , x) +... | gt x = inr x + +splitℕ-< : (m n : ℕ) → (m < n) ⊎ (n ≤ m) +splitℕ-< m n with m ≟ n +... | lt x = inl x +... | eq x = inr (0 , (sym x)) +... | gt x = inr (<-weaken x) + +≤CaseInduction : {P : ℕ → ℕ → Type ℓ} {n m : ℕ} + → (n ≤ m → P n m) → (m ≤ n → P n m) + → P n m +≤CaseInduction {n = n} {m = m} p q with n ≟ m +... | lt x = p (<-weaken x) +... | eq x = p (subst (n ≤_) x ≤-refl) +... | gt x = q (<-weaken x) + +<-split : m < suc n → (m < n) ⊎ (m ≡ n) +<-split {n = zero} = inr ∘ snd ∘ m+n≡0→m≡0×n≡0 ∘ snd ∘ pred-≤-pred +<-split {zero} {suc n} = λ _ → inl (suc-≤-suc zero-≤) +<-split {suc m} {suc n} = ⊎.map suc-≤-suc (cong suc) ∘ <-split ∘ pred-≤-pred + +≤-split : m ≤ n → (m < n) ⊎ (m ≡ n) +≤-split p = <-split (suc-≤-suc p) + +≤→< : m ≤ n → ¬ m ≡ n → m < n +≤→< p q = + case (≤-split p) of + λ { (inl r) → r + ; (inr r) → ⊥.rec (q r) } + +≤-suc-≢ : m ≤ suc n → (m ≡ suc n → ⊥ ) → m ≤ n +≤-suc-≢ p ¬q = pred-≤-pred (≤→< p ¬q) + +≤-+-split : ∀ n m k → k ≤ n + m → (n ≤ k) ⊎ (m ≤ (n + m) ∸ k) +≤-+-split n m k k≤n+m with n ≟ k +... | eq p = inl (0 , p) +... | lt n<k = inl (<-weaken n<k) +... | gt k<n with m ≟ ((n + m) ∸ k) +... | eq p = inr (0 , p) +... | lt m<n+m∸k = inr (<-weaken m<n+m∸k) +... | gt n+m∸k<m = + ⊥.rec (¬m<m (transport (λ i → ≤-∸-+-cancel k≤n+m i < +-comm m n i) (<-+-< n+m∸k<m k<n))) + +<-asym'-case : Trichotomy m n → ¬ m < n → n ≤ m +<-asym'-case (lt p) q = ⊥.rec (q p) +<-asym'-case (eq p) _ = _ , sym p +<-asym'-case (gt p) _ = <-weaken p + +<-asym' : ¬ m < n → n ≤ m +<-asym' = <-asym'-case (_≟_ _ _) + +private + acc-suc : Acc _<_ n → Acc _<_ (suc n) + acc-suc a + = acc λ y y<sn + → case <-split y<sn of λ + { (inl y<n) → access a y y<n + ; (inr y≡n) → subst _ (sym y≡n) a + } + +<-wellfounded : WellFounded _<_ +<-wellfounded zero = acc λ _ → ⊥.rec ∘ ¬-<-zero +<-wellfounded (suc n) = acc-suc (<-wellfounded n) + +<→≢ : n < m → ¬ n ≡ m +<→≢ {n} {m} p q = ¬m<m (subst (_< m) q p) + +module _ + (b₀ : ℕ) + (P : ℕ → Type₀) + (base : ∀ n → n < suc b₀ → P n) + (step : ∀ n → P n → P (suc b₀ + n)) + where + open WFI (<-wellfounded) + + private + dichotomy : ∀ b n → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m) + dichotomy b n + = case n ≟ b return (λ _ → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m)) of λ + { (lt o) → inl o + ; (eq p) → inr (0 , p ∙ sym (+-zero b)) + ; (gt (m , p)) → inr (suc m , sym p ∙ +-suc m b ∙ +-comm (suc m) b) + } + + dichotomy<≡ : ∀ b n → (n<b : n < b) → dichotomy b n ≡ inl n<b + dichotomy<≡ b n n<b + = case dichotomy b n return (λ d → d ≡ inl n<b) of λ + { (inl x) → cong inl (isProp≤ x n<b) + ; (inr (m , p)) → ⊥.rec (<-asym n<b (m , sym (p ∙ +-comm b m))) + } + + dichotomy+≡ : ∀ b m n → (p : n ≡ b + m) → dichotomy b n ≡ inr (m , p) + dichotomy+≡ b m n p + = case dichotomy b n return (λ d → d ≡ inr (m , p)) of λ + { (inl n<b) → ⊥.rec (<-asym n<b (m , +-comm m b ∙ sym p)) + ; (inr (m' , q)) + → cong inr (Σ≡Prop (λ x → isSetℕ n (b + x)) (inj-m+ {m = b} (sym q ∙ p))) + } + + b = suc b₀ + + lemma₁ : ∀{x y z} → x ≡ suc z + y → y < x + lemma₁ {y = y} {z} p = z , +-suc z y ∙ sym p + + subStep : (n : ℕ) → (∀ m → m < n → P m) → (n < b) ⊎ (Σ[ m ∈ ℕ ] n ≡ b + m) → P n + subStep n _ (inl l) = base n l + subStep n rec (inr (m , p)) + = transport (cong P (sym p)) (step m (rec m (lemma₁ p))) + + wfStep : (n : ℕ) → (∀ m → m < n → P m) → P n + wfStep n rec = subStep n rec (dichotomy b n) + + wfStepLemma₀ : ∀ n (n<b : n < b) rec → wfStep n rec ≡ base n n<b + wfStepLemma₀ n n<b rec = cong (subStep n rec) (dichotomy<≡ b n n<b) + + wfStepLemma₁ : ∀ n rec → wfStep (b + n) rec ≡ step n (rec n (lemma₁ refl)) + wfStepLemma₁ n rec + = cong (subStep (b + n) rec) (dichotomy+≡ b n (b + n) refl) + ∙ transportRefl _ + + +induction : ∀ n → P n + +induction = induction wfStep + + +inductionBase : ∀ n → (l : n < b) → +induction n ≡ base n l + +inductionBase n l = induction-compute wfStep n ∙ wfStepLemma₀ n l _ + + +inductionStep : ∀ n → +induction (b + n) ≡ step n (+induction n) + +inductionStep n = induction-compute wfStep (b + n) ∙ wfStepLemma₁ n _ + +module <-Reasoning where + -- TODO: would it be better to mirror the way it is done in the agda-stdlib? + infixr 2 _<⟨_⟩_ _≤<⟨_⟩_ _≤⟨_⟩_ _<≤⟨_⟩_ _≡<⟨_⟩_ _≡≤⟨_⟩_ _<≡⟨_⟩_ _≤≡⟨_⟩_ + _<⟨_⟩_ : ∀ k → k < n → n < m → k < m + _ <⟨ p ⟩ q = <-trans p q + + _≤<⟨_⟩_ : ∀ k → k ≤ n → n < m → k < m + _ ≤<⟨ p ⟩ q = ≤<-trans p q + + _≤⟨_⟩_ : ∀ k → k ≤ n → n ≤ m → k ≤ m + _ ≤⟨ p ⟩ q = ≤-trans p q + + _<≤⟨_⟩_ : ∀ k → k < n → n ≤ m → k < m + _ <≤⟨ p ⟩ q = <≤-trans p q + + _≡≤⟨_⟩_ : ∀ k → k ≡ l → l ≤ m → k ≤ m + _ ≡≤⟨ p ⟩ q = subst (λ k → k ≤ _) (sym p) q + + _≡<⟨_⟩_ : ∀ k → k ≡ l → l < m → k < m + _ ≡<⟨ p ⟩ q = _ ≡≤⟨ cong suc p ⟩ q + + _≤≡⟨_⟩_ : ∀ k → k ≤ l → l ≡ m → k ≤ m + _ ≤≡⟨ p ⟩ q = subst (λ l → _ ≤ l) q p + + _<≡⟨_⟩_ : ∀ k → k < l → l ≡ m → k < m + _ <≡⟨ p ⟩ q = _ ≤≡⟨ p ⟩ q + + +-- Some lemmas about ∸ +suc∸-fst : (n m : ℕ) → m < n → suc (n ∸ m) ≡ (suc n) ∸ m +suc∸-fst zero zero p = refl +suc∸-fst zero (suc m) p = ⊥.rec (¬-<-zero p) +suc∸-fst (suc n) zero p = refl +suc∸-fst (suc n) (suc m) p = (suc∸-fst n m (pred-≤-pred p)) + +n∸m≡0 : (n m : ℕ) → n ≤ m → (n ∸ m) ≡ 0 +n∸m≡0 zero zero p = refl +n∸m≡0 (suc n) zero p = ⊥.rec (¬-<-zero p) +n∸m≡0 zero (suc m) p = refl +n∸m≡0 (suc n) (suc m) p = n∸m≡0 n m (pred-≤-pred p) + +n∸n≡0 : (n : ℕ) → n ∸ n ≡ 0 +n∸n≡0 zero = refl +n∸n≡0 (suc n) = n∸n≡0 n + +n∸l>0 : (n l : ℕ) → (l < n) → 0 < (n ∸ l) +n∸l>0 zero zero r = ⊥.rec (¬-<-zero r) +n∸l>0 zero (suc l) r = ⊥.rec (¬-<-zero r) +n∸l>0 (suc n) zero r = suc-≤-suc zero-≤ +n∸l>0 (suc n) (suc l) r = n∸l>0 n l (pred-≤-pred r) + +-- automation + +≤-solver-type : (m n : ℕ) → Trichotomy m n → Type +≤-solver-type m n (lt p) = m ≤ n +≤-solver-type m n (eq p) = m ≤ n +≤-solver-type m n (gt p) = n < m + +≤-solver-case : (m n : ℕ) → (p : Trichotomy m n) → ≤-solver-type m n p +≤-solver-case m n (lt p) = <-weaken p +≤-solver-case m n (eq p) = _ , p +≤-solver-case m n (gt p) = p + +≤-solver : (m n : ℕ) → ≤-solver-type m n (m ≟ n) +≤-solver m n = ≤-solver-case m n (m ≟ n) --- inductive order relation taken from agda-stdlib -data _≤'_ : ℕ → ℕ → Type where - z≤ : ∀ {n} → zero ≤' n - s≤s : ∀ {m n} → m ≤' n → suc m ≤' suc n - -_<'_ : ℕ → ℕ → Type -m <' n = suc m ≤' n - --- Smart constructors of _<_ -pattern z<s {n} = s≤s (z≤ {n}) -pattern s<s {m} {n} m<n = s≤s {m} {n} m<n +-- inductive order relation taken from agda-stdlib +data _≤'_ : ℕ → ℕ → Type where + z≤ : ∀ {n} → zero ≤' n + s≤s : ∀ {m n} → m ≤' n → suc m ≤' suc n + +_<'_ : ℕ → ℕ → Type +m <' n = suc m ≤' n + +-- Smart constructors of _<_ +pattern z<s {n} = s≤s (z≤ {n}) +pattern s<s {m} {n} m<n = s≤s {m} {n} m<n -¬-<'-zero : ¬ m <' 0 -¬-<'-zero {zero} () -¬-<'-zero {suc m} () - -≤'Dec : ∀ m n → Dec (m ≤' n) -≤'Dec zero n = yes z≤ -≤'Dec (suc m) zero = no ¬-<'-zero -≤'Dec (suc m) (suc n) with ≤'Dec m n -... | yes m≤'n = yes (s≤s m≤'n) -... | no m≰'n = no λ { (s≤s m≤'n) → m≰'n m≤'n } +¬-<'-zero : ¬ m <' 0 +¬-<'-zero {zero} () +¬-<'-zero {suc m} () + +≤'Dec : ∀ m n → Dec (m ≤' n) +≤'Dec zero n = yes z≤ +≤'Dec (suc m) zero = no ¬-<'-zero +≤'Dec (suc m) (suc n) with ≤'Dec m n +... | yes m≤'n = yes (s≤s m≤'n) +... | no m≰'n = no λ { (s≤s m≤'n) → m≰'n m≤'n } -≤'IsPropValued : ∀ m n → isProp (m ≤' n) -≤'IsPropValued zero n z≤ z≤ = refl -≤'IsPropValued (suc m) zero () -≤'IsPropValued (suc m) (suc n) (s≤s x) (s≤s y) = cong s≤s (≤'IsPropValued m n x y) - -≤-∸-≤ : ∀ m n l → m ≤ n → m ∸ l ≤ n ∸ l -≤-∸-≤ m n zero r = r -≤-∸-≤ zero zero (suc l) r = ≤-refl -≤-∸-≤ zero (suc n) (suc l) r = (n ∸ l) , (+-zero _) -≤-∸-≤ (suc m) zero (suc l) r = ⊥.rec (¬-<-zero r) -≤-∸-≤ (suc m) (suc n) (suc l) r = ≤-∸-≤ m n l (pred-≤-pred r) - -<-∸-< : ∀ m n l → m < n → l < n → m ∸ l < n ∸ l -<-∸-< m n zero r q = r -<-∸-< zero zero (suc l) r q = ⊥.rec (¬-<-zero r) -<-∸-< zero (suc n) (suc l) r q = n∸l>0 (suc n) (suc l) q -<-∸-< (suc m) zero (suc l) r q = ⊥.rec (¬-<-zero r) -<-∸-< (suc m) (suc n) (suc l) r q = <-∸-< m n l (pred-≤-pred r) (pred-≤-pred q) - -≤-∸-≥ : ∀ n l k → l ≤ k → n ∸ k ≤ n ∸ l -≤-∸-≥ n zero zero r = ≤-refl -≤-∸-≥ n zero (suc k) r = ∸-≤ n (suc k) -≤-∸-≥ n (suc l) zero r = ⊥.rec (¬-<-zero r) -≤-∸-≥ zero (suc l) (suc k) r = ≤-refl -≤-∸-≥ (suc n) (suc l) (suc k) r = ≤-∸-≥ n l k (pred-≤-pred r) +≤'IsPropValued : ∀ m n → isProp (m ≤' n) +≤'IsPropValued zero n z≤ z≤ = refl +≤'IsPropValued (suc m) zero () +≤'IsPropValued (suc m) (suc n) (s≤s x) (s≤s y) = cong s≤s (≤'IsPropValued m n x y) + +≤-∸-≤ : ∀ m n l → m ≤ n → m ∸ l ≤ n ∸ l +≤-∸-≤ m n zero r = r +≤-∸-≤ zero zero (suc l) r = ≤-refl +≤-∸-≤ zero (suc n) (suc l) r = (n ∸ l) , (+-zero _) +≤-∸-≤ (suc m) zero (suc l) r = ⊥.rec (¬-<-zero r) +≤-∸-≤ (suc m) (suc n) (suc l) r = ≤-∸-≤ m n l (pred-≤-pred r) + +<-∸-< : ∀ m n l → m < n → l < n → m ∸ l < n ∸ l +<-∸-< m n zero r q = r +<-∸-< zero zero (suc l) r q = ⊥.rec (¬-<-zero r) +<-∸-< zero (suc n) (suc l) r q = n∸l>0 (suc n) (suc l) q +<-∸-< (suc m) zero (suc l) r q = ⊥.rec (¬-<-zero r) +<-∸-< (suc m) (suc n) (suc l) r q = <-∸-< m n l (pred-≤-pred r) (pred-≤-pred q) + +≤-∸-≥ : ∀ n l k → l ≤ k → n ∸ k ≤ n ∸ l +≤-∸-≥ n zero zero r = ≤-refl +≤-∸-≥ n zero (suc k) r = ∸-≤ n (suc k) +≤-∸-≥ n (suc l) zero r = ⊥.rec (¬-<-zero r) +≤-∸-≥ zero (suc l) (suc k) r = ≤-refl +≤-∸-≥ (suc n) (suc l) (suc k) r = ≤-∸-≥ n l k (pred-≤-pred r) \ No newline at end of file diff --git a/docs/Cubical.Data.Nat.Properties.html b/docs/Cubical.Data.Nat.Properties.html index 6db4d26..33cb8c5 100644 --- a/docs/Cubical.Data.Nat.Properties.html +++ b/docs/Cubical.Data.Nat.Properties.html @@ -42,13 +42,13 @@ maxComm (suc n) (suc m) = cong suc (maxComm n m) znots : ¬ (0 ≡ suc n) -znots eq = subst (caseNat ℕ ⊥) eq 0 +znots eq = subst (caseNat ℕ ⊥) eq 0 snotz : ¬ (suc n ≡ 0) -snotz eq = subst (caseNat ⊥ ℕ) eq 0 +snotz eq = subst (caseNat ⊥ ℕ) eq 0 injSuc : suc m ≡ suc n → m ≡ n -injSuc p = cong predℕ p +injSuc p = cong predℕ p -- encode decode caracterisation of equality codeℕ : (n m : ℕ) → Type ℓ-zero @@ -96,7 +96,7 @@ reflRetr (suc n) i = cong suc (reflRetr n i) retr : (n m : ℕ) → (p : n ≡ m) → (decodeℕ n m (encodeℕ n m p) ≡ p) - retr n m p = J (λ m p → decodeℕ n m (encodeℕ n m p) ≡ p) (reflRetr n) p + retr n m p = J (λ m p → decodeℕ n m (encodeℕ n m p) ≡ p) (reflRetr n) p ≡ℕ≃Codeℕ' : (n m : ℕ) → (n ≡ m) ≃ codeℕ n m @@ -117,7 +117,7 @@ reflRetr (suc n) i = cong suc (reflRetr n i) retr : (n m : ℕ) → (p : n ≡ m) → decodeℕ n m (compute-eqℕ n m p) ≡ p - retr n m p = J (λ m p → decodeℕ n m (compute-eqℕ n m p) ≡ p) (reflRetr n) p + retr n m p = J (λ m p → decodeℕ n m (compute-eqℕ n m p) ≡ p) (reflRetr n) p discreteℕ : Discrete ℕ @@ -131,12 +131,12 @@ separatedℕ : Separated ℕ separatedℕ = Discrete→Separated discreteℕ -isSetℕ : isSet ℕ +isSetℕ : isSet ℕ isSetℕ = Discrete→isSet discreteℕ -- Arithmetic facts about predℕ -suc-predℕ : ∀ n → ¬ n ≡ 0 → n ≡ suc (predℕ n) +suc-predℕ : ∀ n → ¬ n ≡ 0 → n ≡ suc (predℕ n) suc-predℕ zero p = ⊥.rec (p refl) suc-predℕ (suc n) p = refl @@ -274,25 +274,25 @@ zero choose suc k = 0 suc n choose suc k = n choose (suc k) + n choose k -evenOrOdd : (n : ℕ) → isEvenT n ⊎ isOddT n +evenOrOdd : (n : ℕ) → isEvenT n ⊎ isOddT n evenOrOdd zero = inl tt evenOrOdd (suc zero) = inr tt evenOrOdd (suc (suc n)) = evenOrOdd n -¬evenAndOdd : (n : ℕ) → ¬ isEvenT n × isOddT n +¬evenAndOdd : (n : ℕ) → ¬ isEvenT n × isOddT n ¬evenAndOdd zero (p , ()) ¬evenAndOdd (suc zero) () ¬evenAndOdd (suc (suc n)) = ¬evenAndOdd n -isPropIsEvenT : (n : ℕ) → isProp (isEvenT n) +isPropIsEvenT : (n : ℕ) → isProp (isEvenT n) isPropIsEvenT zero x y = refl isPropIsEvenT (suc zero) = isProp⊥ isPropIsEvenT (suc (suc n)) = isPropIsEvenT n -isPropIsOddT : (n : ℕ) → isProp (isOddT n) +isPropIsOddT : (n : ℕ) → isProp (isOddT n) isPropIsOddT n = isPropIsEvenT (suc n) -isPropEvenOrOdd : (n : ℕ) → isProp (isEvenT n ⊎ isOddT n) +isPropEvenOrOdd : (n : ℕ) → isProp (isEvenT n ⊎ isOddT n) isPropEvenOrOdd n (inl x) (inl x₁) = cong inl (isPropIsEvenT n x x₁) isPropEvenOrOdd n (inl x) (inr x₁) = ⊥.rec (¬evenAndOdd n (x , x₁)) isPropEvenOrOdd n (inr x) (inl x₁) = ⊥.rec (¬evenAndOdd (suc n) (x , x₁)) diff --git a/docs/Cubical.Data.Sigma.Base.html b/docs/Cubical.Data.Sigma.Base.html index 2c7ca4d..e29f596 100644 --- a/docs/Cubical.Data.Sigma.Base.html +++ b/docs/Cubical.Data.Sigma.Base.html @@ -43,7 +43,7 @@ -- Unique existence ∃! : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') -∃! A B = isContr (Σ A B) +∃! A B = isContr (Σ A B) infix 2 ∃!-syntax diff --git a/docs/Cubical.Data.Sigma.Properties.html b/docs/Cubical.Data.Sigma.Properties.html index 1ace07e..18e494a 100644 --- a/docs/Cubical.Data.Sigma.Properties.html +++ b/docs/Cubical.Data.Sigma.Properties.html @@ -89,13 +89,13 @@ ≡ (PathP (λ i → Σ (A i) (B i)) x y) ΣPath≡PathΣ = ua ΣPath≃PathΣ -×≡Prop : isProp A' → {u v : A × A'} → u .fst ≡ v .fst → u ≡ v +×≡Prop : isProp A' → {u v : A × A'} → u .fst ≡ v .fst → u ≡ v ×≡Prop pB {u} {v} p i = (p i) , (pB (u .snd) (v .snd) i) -- Useful lemma to prove unique existence -uniqueExists : (a : A) (b : B a) (h : (a' : A) → isProp (B a')) (H : (a' : A) → B a' → a ≡ a') → ∃![ a ∈ A ] B a +uniqueExists : (a : A) (b : B a) (h : (a' : A) → isProp (B a')) (H : (a' : A) → B a' → a ≡ a') → ∃![ a ∈ A ] B a fst (uniqueExists a b h H) = (a , b) -snd (uniqueExists a b h H) (a' , b') = ΣPathP (H a' b' , isProp→PathP (λ i → h (H a' b' i)) b b') +snd (uniqueExists a b h H) (a' , b') = ΣPathP (H a' b' , isProp→PathP (λ i → h (H a' b' i)) b b') -- Characterization of dependent paths in Σ @@ -123,7 +123,7 @@ discreteΣ {B = B} Adis Bdis (a0 , b0) (a1 , b1) = discreteΣ' (Adis a0 a1) where discreteΣ' : Dec (a0 ≡ a1) → Dec ((a0 , b0) ≡ (a1 , b1)) - discreteΣ' (yes p) = J (λ a1 p → ∀ b1 → Dec ((a0 , b0) ≡ (a1 , b1))) (discreteΣ'') p b1 + discreteΣ' (yes p) = J (λ a1 p → ∀ b1 → Dec ((a0 , b0) ≡ (a1 , b1))) (discreteΣ'') p b1 where discreteΣ'' : (b1 : B a0) → Dec ((a0 , b0) ≡ (a0 , b1)) discreteΣ'' b1 with Bdis a0 b0 b1 @@ -195,14 +195,14 @@ inv (Σ-cong-iso-fst {B = B} isom) x = inv isom (x .fst) , subst B (sym (ε (x .fst))) (x .snd) where ε = isHAEquiv.rinv (snd (iso→HAEquiv isom)) -rightInv (Σ-cong-iso-fst {B = B} isom) (x , y) = ΣPathP (ε x , toPathP goal) +rightInv (Σ-cong-iso-fst {B = B} isom) (x , y) = ΣPathP (ε x , toPathP goal) where ε = isHAEquiv.rinv (snd (iso→HAEquiv isom)) goal : subst B (ε x) (subst B (sym (ε x)) y) ≡ y goal = sym (substComposite B (sym (ε x)) (ε x) y) ∙∙ cong (λ x → subst B x y) (lCancel (ε x)) ∙∙ substRefl {B = B} y -leftInv (Σ-cong-iso-fst {A = A} {B = B} isom) (x , y) = ΣPathP (leftInv isom x , toPathP goal) +leftInv (Σ-cong-iso-fst {A = A} {B = B} isom) (x , y) = ΣPathP (leftInv isom x , toPathP goal) where ε = isHAEquiv.rinv (snd (iso→HAEquiv isom)) γ = isHAEquiv.com (snd (iso→HAEquiv isom)) @@ -264,7 +264,7 @@ leftInv (Σ-cong-iso-snd isom) (x , y') = ΣPathP (refl , leftInv (isom x) y') Σ-cong-equiv-snd : (∀ a → B a ≃ B' a) → Σ A B ≃ Σ A B' -Σ-cong-equiv-snd h = isoToEquiv (Σ-cong-iso-snd (equivToIso ∘ h)) +Σ-cong-equiv-snd h = isoToEquiv (Σ-cong-iso-snd (equivToIso ∘ h)) Σ-cong-snd : ((x : A) → B x ≡ B' x) → Σ A B ≡ Σ A B' Σ-cong-snd {A = A} p i = Σ[ x ∈ A ] (p x i) @@ -277,20 +277,20 @@ Σ-cong-equiv : (e : A ≃ A') → ((x : A) → B x ≃ B' (equivFun e x)) → Σ A B ≃ Σ A' B' -Σ-cong-equiv e e' = isoToEquiv (Σ-cong-iso (equivToIso e) (equivToIso ∘ e')) +Σ-cong-equiv e e' = isoToEquiv (Σ-cong-iso (equivToIso e) (equivToIso ∘ e')) Σ-cong' : (p : A ≡ A') → PathP (λ i → p i → Type ℓ') B B' → Σ A B ≡ Σ A' B' Σ-cong' p p' = cong₂ (λ (A : Type _) (B : A → Type _) → Σ A B) p p' Σ-cong-equiv-prop : (e : A ≃ A') - → ((x : A ) → isProp (B x)) - → ((x : A') → isProp (B' x)) + → ((x : A ) → isProp (B x)) + → ((x : A') → isProp (B' x)) → ((x : A) → B x → B' (equivFun e x)) → ((x : A) → B' (equivFun e x) → B x) → Σ A B ≃ Σ A' B' Σ-cong-equiv-prop e prop prop' prop→ prop← = - Σ-cong-equiv e (λ x → propBiimpl→Equiv (prop x) (prop' (equivFun e x)) (prop→ x) (prop← x)) + Σ-cong-equiv e (λ x → propBiimpl→Equiv (prop x) (prop' (equivFun e x)) (prop→ x) (prop← x)) -- Alternative version for path in Σ-types, as in the HoTT book @@ -314,16 +314,16 @@ ΣPathTransport≡PathΣ : (a b : Σ A B) → ΣPathTransport a b ≡ (a ≡ b) ΣPathTransport≡PathΣ a b = ua (ΣPathTransport≃PathΣ a b) -Σ-contractFstIso : (c : isContr A) → Iso (Σ A B) (B (c .fst)) +Σ-contractFstIso : (c : isContr A) → Iso (Σ A B) (B (c .fst)) fun (Σ-contractFstIso {B = B} c) p = subst B (sym (c .snd (fst p))) (snd p) inv (Σ-contractFstIso {B = B} c) b = _ , b rightInv (Σ-contractFstIso {B = B} c) b = - cong (λ p → subst B p b) (isProp→isSet (isContr→isProp c) _ _ _ _) ∙ transportRefl _ + cong (λ p → subst B p b) (isProp→isSet (isContr→isProp c) _ _ _ _) ∙ transportRefl _ fst (leftInv (Σ-contractFstIso {B = B} c) p j) = c .snd (fst p) j snd (leftInv (Σ-contractFstIso {B = B} c) p j) = transp (λ i → B (c .snd (fst p) (~ i ∨ j))) j (snd p) -Σ-contractFst : (c : isContr A) → Σ A B ≃ B (c .fst) +Σ-contractFst : (c : isContr A) → Σ A B ≃ B (c .fst) Σ-contractFst {B = B} c = isoToEquiv (Σ-contractFstIso c) -- a special case of the above @@ -331,7 +331,7 @@ ΣUnit : Σ Unit A ≃ A tt unquoteDef ΣUnit = defStrictEquiv ΣUnit snd (λ { x → (tt , x) }) -Σ-contractSnd : ((a : A) → isContr (B a)) → Σ A B ≃ A +Σ-contractSnd : ((a : A) → isContr (B a)) → Σ A B ≃ A Σ-contractSnd c = isoToEquiv isom where isom : Iso _ _ @@ -340,44 +340,44 @@ isom .rightInv _ = refl isom .leftInv (a , b) = cong (a ,_) (c a .snd b) -isEmbeddingFstΣProp : ((x : A) → isProp (B x)) +isEmbeddingFstΣProp : ((x : A) → isProp (B x)) → {u v : Σ A B} → isEquiv (λ (p : u ≡ v) → cong fst p) isEmbeddingFstΣProp {B = B} pB {u = u} {v = v} .equiv-proof x = ctr , isCtr where ctrP : u ≡ v - ctrP = ΣPathP (x , isProp→PathP (λ _ → pB _) _ _) + ctrP = ΣPathP (x , isProp→PathP (λ _ → pB _) _ _) ctr : fiber (λ (p : u ≡ v) → cong fst p) x ctr = ctrP , refl isCtr : ∀ z → ctr ≡ z isCtr (z , p) = ΣPathP (ctrP≡ , cong (sym ∘ snd) fzsingl) where - fzsingl : Path (singl x) (x , refl) (cong fst z , sym p) - fzsingl = isContrSingl x .snd (cong fst z , sym p) - ctrSnd : SquareP (λ i j → B (fzsingl i .fst j)) (cong snd ctrP) (cong snd z) _ _ + fzsingl : Path (singl x) (x , refl) (cong fst z , sym p) + fzsingl = isContrSingl x .snd (cong fst z , sym p) + ctrSnd : SquareP (λ i j → B (fzsingl i .fst j)) (cong snd ctrP) (cong snd z) _ _ ctrSnd = isProp→SquareP (λ _ _ → pB _) _ _ _ _ ctrP≡ : ctrP ≡ z ctrP≡ i = ΣPathP (fzsingl i .fst , ctrSnd i) -Σ≡PropEquiv : ((x : A) → isProp (B x)) → {u v : Σ A B} +Σ≡PropEquiv : ((x : A) → isProp (B x)) → {u v : Σ A B} → (u .fst ≡ v .fst) ≃ (u ≡ v) -Σ≡PropEquiv pB = invEquiv (_ , isEmbeddingFstΣProp pB) +Σ≡PropEquiv pB = invEquiv (_ , isEmbeddingFstΣProp pB) -Σ≡Prop : ((x : A) → isProp (B x)) → {u v : Σ A B} +Σ≡Prop : ((x : A) → isProp (B x)) → {u v : Σ A B} → (p : u .fst ≡ v .fst) → u ≡ v Σ≡Prop pB p = equivFun (Σ≡PropEquiv pB) p -- dependent version ΣPathPProp : ∀ {ℓ ℓ'} {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ'} → {u : Σ (A i0) (B i0)} {v : Σ (A i1) (B i1)} - → ((a : A (i1)) → isProp (B i1 a)) + → ((a : A (i1)) → isProp (B i1 a)) → PathP (λ i → A i) (fst u) (fst v) → PathP (λ i → Σ (A i) (B i)) u v fst (ΣPathPProp {u = u} {v = v} pB p i) = p i snd (ΣPathPProp {B = B} {u = u} {v = v} pB p i) = lem i where lem : PathP (λ i → B i (p i)) (snd u) (snd v) - lem = toPathP (pB _ _ _) + lem = toPathP (pB _ _ _) ≃-× : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} → A ≃ C → B ≃ D → A × B ≃ C × D ≃-× eq1 eq2 = @@ -409,11 +409,11 @@ prodEquivToIso : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} → (e : A ≃ C)(e' : B ≃ D) - → prodIso (equivToIso e) (equivToIso e') ≡ equivToIso (≃-× e e') -Iso.fun (prodEquivToIso e e' i) = Iso.fun (equivToIso (≃-× e e')) -Iso.inv (prodEquivToIso e e' i) = Iso.inv (equivToIso (≃-× e e')) -Iso.rightInv (prodEquivToIso e e' i) = Iso.rightInv (equivToIso (≃-× e e')) -Iso.leftInv (prodEquivToIso e e' i) = Iso.leftInv (equivToIso (≃-× e e')) + → prodIso (equivToIso e) (equivToIso e') ≡ equivToIso (≃-× e e') +Iso.fun (prodEquivToIso e e' i) = Iso.fun (equivToIso (≃-× e e')) +Iso.inv (prodEquivToIso e e' i) = Iso.inv (equivToIso (≃-× e e')) +Iso.rightInv (prodEquivToIso e e' i) = Iso.rightInv (equivToIso (≃-× e e')) +Iso.leftInv (prodEquivToIso e e' i) = Iso.leftInv (equivToIso (≃-× e e')) toProdIso : {B C : A → Type ℓ} → Iso ((a : A) → B a × C a) (((a : A) → B a) × ((a : A) → C a)) diff --git a/docs/Cubical.Data.Sum.Properties.html b/docs/Cubical.Data.Sum.Properties.html index ff43422..93e0e40 100644 --- a/docs/Cubical.Data.Sum.Properties.html +++ b/docs/Cubical.Data.Sum.Properties.html @@ -33,26 +33,26 @@ module ⊎Path {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where Cover : A ⊎ B → A ⊎ B → Type (ℓ-max ℓ ℓ') - Cover (inl a) (inl a') = Lift {j = ℓ-max ℓ ℓ'} (a ≡ a') - Cover (inl _) (inr _) = Lift ⊥ - Cover (inr _) (inl _) = Lift ⊥ - Cover (inr b) (inr b') = Lift {j = ℓ-max ℓ ℓ'} (b ≡ b') + Cover (inl a) (inl a') = Lift {j = ℓ-max ℓ ℓ'} (a ≡ a') + Cover (inl _) (inr _) = Lift ⊥ + Cover (inr _) (inl _) = Lift ⊥ + Cover (inr b) (inr b') = Lift {j = ℓ-max ℓ ℓ'} (b ≡ b') reflCode : (c : A ⊎ B) → Cover c c - reflCode (inl a) = lift refl - reflCode (inr b) = lift refl + reflCode (inl a) = lift refl + reflCode (inr b) = lift refl encode : ∀ c c' → c ≡ c' → Cover c c' - encode c _ = J (λ c' _ → Cover c c') (reflCode c) + encode c _ = J (λ c' _ → Cover c c') (reflCode c) encodeRefl : ∀ c → encode c c refl ≡ reflCode c - encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c) + encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c) decode : ∀ c c' → Cover c c' → c ≡ c' - decode (inl a) (inl a') (lift p) = cong inl p + decode (inl a) (inl a') (lift p) = cong inl p decode (inl a) (inr b') () decode (inr b) (inl a') () - decode (inr b) (inr b') (lift q) = cong inr q + decode (inr b) (inr b') (lift q) = cong inr q decodeRefl : ∀ c → decode c c (reflCode c) ≡ refl decodeRefl (inl a) = refl @@ -60,14 +60,14 @@ decodeEncode : ∀ c c' → (p : c ≡ c') → decode c c' (encode c c' p) ≡ p decodeEncode c _ = - J (λ c' p → decode c c' (encode c c' p) ≡ p) + J (λ c' p → decode c c' (encode c c' p) ≡ p) (cong (decode c c) (encodeRefl c) ∙ decodeRefl c) encodeDecode : ∀ c c' → (d : Cover c c') → encode c c' (decode c c' d) ≡ d - encodeDecode (inl a) (inl _) (lift d) = - J (λ a' p → encode (inl a) (inl a') (cong inl p) ≡ lift p) (encodeRefl (inl a)) d - encodeDecode (inr a) (inr _) (lift d) = - J (λ a' p → encode (inr a) (inr a') (cong inr p) ≡ lift p) (encodeRefl (inr a)) d + encodeDecode (inl a) (inl _) (lift d) = + J (λ a' p → encode (inl a) (inl a') (cong inl p) ≡ lift p) (encodeRefl (inl a)) d + encodeDecode (inr a) (inr _) (lift d) = + J (λ a' p → encode (inr a) (inr a') (cong inr p) ≡ lift p) (encodeRefl (inr a)) d Cover≃Path : ∀ c c' → Cover c c' ≃ (c ≡ c') Cover≃Path c c' = @@ -77,18 +77,18 @@ → isOfHLevel (suc (suc n)) A → isOfHLevel (suc (suc n)) B → ∀ c c' → isOfHLevel (suc n) (Cover c c') - isOfHLevelCover n p q (inl a) (inl a') = isOfHLevelLift (suc n) (p a a') + isOfHLevelCover n p q (inl a) (inl a') = isOfHLevelLift (suc n) (p a a') isOfHLevelCover n p q (inl a) (inr b') = - isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) isOfHLevelCover n p q (inr b) (inl a') = - isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) - isOfHLevelCover n p q (inr b) (inr b') = isOfHLevelLift (suc n) (q b b') + isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥) + isOfHLevelCover n p q (inr b) (inr b') = isOfHLevelLift (suc n) (q b b') isEmbedding-inl : isEmbedding (inl {A = A} {B = B}) -isEmbedding-inl w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inl w) (inl z))) +isEmbedding-inl w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inl w) (inl z))) isEmbedding-inr : isEmbedding (inr {A = A} {B = B}) -isEmbedding-inr w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inr w) (inr z))) +isEmbedding-inr w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inr w) (inr z))) isOfHLevel⊎ : (n : HLevel) → isOfHLevel (suc (suc n)) A @@ -101,26 +101,26 @@ (⊎Path.decodeEncode c c') (⊎Path.isOfHLevelCover n lA lB c c') -isProp⊎ : isProp A → isProp B → (A → B → ⊥) → isProp (A ⊎ B) +isProp⊎ : isProp A → isProp B → (A → B → ⊥) → isProp (A ⊎ B) isProp⊎ propA _ _ (inl x) (inl y) i = inl (propA x y i) isProp⊎ _ _ AB⊥ (inl x) (inr y) = ⊥.rec (AB⊥ x y) isProp⊎ _ _ AB⊥ (inr x) (inl y) = ⊥.rec (AB⊥ y x) isProp⊎ _ propB _ (inr x) (inr y) i = inr (propB x y i) -isSet⊎ : isSet A → isSet B → isSet (A ⊎ B) +isSet⊎ : isSet A → isSet B → isSet (A ⊎ B) isSet⊎ = isOfHLevel⊎ 0 -isGroupoid⊎ : isGroupoid A → isGroupoid B → isGroupoid (A ⊎ B) +isGroupoid⊎ : isGroupoid A → isGroupoid B → isGroupoid (A ⊎ B) isGroupoid⊎ = isOfHLevel⊎ 1 -is2Groupoid⊎ : is2Groupoid A → is2Groupoid B → is2Groupoid (A ⊎ B) +is2Groupoid⊎ : is2Groupoid A → is2Groupoid B → is2Groupoid (A ⊎ B) is2Groupoid⊎ = isOfHLevel⊎ 2 discrete⊎ : Discrete A → Discrete B → Discrete (A ⊎ B) discrete⊎ decA decB (inl a) (inl a') = mapDec (cong inl) (λ p q → p (isEmbedding→Inj isEmbedding-inl _ _ q)) (decA a a') -discrete⊎ decA decB (inl a) (inr b') = no (λ p → lower (⊎Path.encode (inl a) (inr b') p)) -discrete⊎ decA decB (inr b) (inl a') = no ((λ p → lower (⊎Path.encode (inr b) (inl a') p))) +discrete⊎ decA decB (inl a) (inr b') = no (λ p → lower (⊎Path.encode (inl a) (inr b') p)) +discrete⊎ decA decB (inr b) (inl a') = no ((λ p → lower (⊎Path.encode (inr b) (inl a') p))) discrete⊎ decA decB (inr b) (inr b') = mapDec (cong inr) (λ p q → p (isEmbedding→Inj isEmbedding-inr _ _ q)) (decB b b') @@ -135,7 +135,7 @@ leftInv (⊎Iso iac ibd) (inr x) = cong inr (ibd .leftInv x) ⊎-equiv : A ≃ C → B ≃ D → (A ⊎ B) ≃ (C ⊎ D) -⊎-equiv p q = isoToEquiv (⊎Iso (equivToIso p) (equivToIso q)) +⊎-equiv p q = isoToEquiv (⊎Iso (equivToIso p) (equivToIso q)) ⊎-swap-Iso : Iso (A ⊎ B) (B ⊎ A) fun ⊎-swap-Iso (inl x) = inr x @@ -223,15 +223,15 @@ leftInv Σ⊎Iso (inl a , ea) = refl leftInv Σ⊎Iso (inr b , eb) = refl -×DistL⊎Iso : Iso (A × (B ⊎ C)) ((A × B) ⊎ (A × C)) -fun ×DistL⊎Iso (a , inl b) = inl (a , b) -fun ×DistL⊎Iso (a , inr c) = inr (a , c) -inv ×DistL⊎Iso (inl (a , b)) = a , inl b -inv ×DistL⊎Iso (inr (a , c)) = a , inr c -rightInv ×DistL⊎Iso (inl (a , b)) = refl -rightInv ×DistL⊎Iso (inr (a , c)) = refl -leftInv ×DistL⊎Iso (a , inl b) = refl -leftInv ×DistL⊎Iso (a , inr c) = refl +×DistR⊎Iso : Iso (A × (B ⊎ C)) ((A × B) ⊎ (A × C)) +fun ×DistR⊎Iso (a , inl b) = inl (a , b) +fun ×DistR⊎Iso (a , inr c) = inr (a , c) +inv ×DistR⊎Iso (inl (a , b)) = a , inl b +inv ×DistR⊎Iso (inr (a , c)) = a , inr c +rightInv ×DistR⊎Iso (inl (a , b)) = refl +rightInv ×DistR⊎Iso (inr (a , c)) = refl +leftInv ×DistR⊎Iso (a , inl b) = refl +leftInv ×DistR⊎Iso (a , inr c) = refl Π⊎≃ : ((x : A ⊎ B) → E x) ≃ ((a : A) → E (inl a)) × ((b : B) → E (inr b)) Π⊎≃ = isoToEquiv Π⊎Iso @@ -243,20 +243,20 @@ ⊎Monotone↪ (f , embf) (g , embg) = (map f g) , emb where coverToMap : ∀ x y → ⊎Path.Cover x y → ⊎Path.Cover (map f g x) (map f g y) - coverToMap (inl _) (inl _) cover = lift (cong f (lower cover)) - coverToMap (inr _) (inr _) cover = lift (cong g (lower cover)) + coverToMap (inl _) (inl _) cover = lift (cong f (lower cover)) + coverToMap (inr _) (inr _) cover = lift (cong g (lower cover)) equiv : ∀ x y → isEquiv (coverToMap x y) equiv (inl a₀) (inl a₁) - = ((invEquiv LiftEquiv) - ∙ₑ ((cong f) , (embf a₀ a₁)) - ∙ₑ LiftEquiv) .snd + = ((invEquiv LiftEquiv) + ∙ₑ ((cong f) , (embf a₀ a₁)) + ∙ₑ LiftEquiv) .snd equiv (inl a₀) (inr b₁) .equiv-proof () equiv (inr b₀) (inl a₁) .equiv-proof () equiv (inr b₀) (inr b₁) - = ((invEquiv LiftEquiv) - ∙ₑ ((cong g) , (embg b₀ b₁)) - ∙ₑ LiftEquiv) .snd + = ((invEquiv LiftEquiv) + ∙ₑ ((cong g) , (embg b₀ b₁)) + ∙ₑ LiftEquiv) .snd lemma : ∀ x y → ∀ (p : x ≡ y) @@ -266,7 +266,7 @@ (map f g y) (coverToMap x y (⊎Path.encode x y p)) lemma (inl a₀) _ - = J (λ y p + = J (λ y p → cong (map f g) p ≡ ⊎Path.decode (map f g (inl a₀)) (map f g y) @@ -274,7 +274,7 @@ (⊎Path.encode (inl a₀) y p))) (sym $ cong (cong inl) (cong (cong f) (transportRefl _))) lemma (inr b₀) _ - = J (λ y p + = J (λ y p → cong (map f g) p ≡ ⊎Path.decode (map f g (inr b₀)) @@ -285,12 +285,12 @@ emb : isEmbedding (map f g) emb x y = subst (λ eq → isEquiv eq) (sym (funExt (lemma x y))) - ((x ≡ y ≃⟨ invEquiv (⊎Path.Cover≃Path x y) ⟩ - ⊎Path.Cover x y ≃⟨ (coverToMap x y) , (equiv x y) ⟩ + ((x ≡ y ≃⟨ invEquiv (⊎Path.Cover≃Path x y) ⟩ + ⊎Path.Cover x y ≃⟨ (coverToMap x y) , (equiv x y) ⟩ ⊎Path.Cover (map f g x) - (map f g y) ≃⟨ ⊎Path.Cover≃Path + (map f g y) ≃⟨ ⊎Path.Cover≃Path (map f g x) - (map f g y) ⟩ - map f g x ≡ map f g y ■) .snd) + (map f g y) ⟩ + map f g x ≡ map f g y ■) .snd) \ No newline at end of file diff --git a/docs/Cubical.Data.Unit.Base.html b/docs/Cubical.Data.Unit.Base.html index a883e44..cc667c4 100644 --- a/docs/Cubical.Data.Unit.Base.html +++ b/docs/Cubical.Data.Unit.Base.html @@ -10,9 +10,9 @@ -- Universe polymorphic version Unit* : {ℓ : Level} → Type ℓ -Unit* = Lift Unit +Unit* = Lift Unit -pattern tt* = lift tt +pattern tt* = lift tt -- Pointed version Unit*∙ : ∀ {ℓ} → Σ[ X ∈ Type ℓ ] X diff --git a/docs/Cubical.Data.Unit.Properties.html b/docs/Cubical.Data.Unit.Properties.html index 624a6f6..5d4fe6c 100644 --- a/docs/Cubical.Data.Unit.Properties.html +++ b/docs/Cubical.Data.Unit.Properties.html @@ -26,14 +26,14 @@ variable ℓ ℓ' : Level -isContrUnit : isContr Unit +isContrUnit : isContr Unit isContrUnit = tt , λ {tt → refl} -isPropUnit : isProp Unit +isPropUnit : isProp Unit isPropUnit _ _ i = tt -- definitionally equal to: isContr→isProp isContrUnit -isSetUnit : isSet Unit -isSetUnit = isProp→isSet isPropUnit +isSetUnit : isSet Unit +isSetUnit = isProp→isSet isPropUnit isOfHLevelUnit : (n : HLevel) → isOfHLevel n Unit isOfHLevelUnit n = isContr→isOfHLevel n isContrUnit @@ -77,7 +77,7 @@ rightInv fiberUnitIso _ = refl leftInv fiberUnitIso _ = refl -isContr→Iso2 : {A : Type ℓ} {B : Type ℓ'} → isContr A → Iso (A → B) B +isContr→Iso2 : {A : Type ℓ} {B : Type ℓ'} → isContr A → Iso (A → B) B fun (isContr→Iso2 iscontr) f = f (fst iscontr) inv (isContr→Iso2 iscontr) b _ = b rightInv (isContr→Iso2 iscontr) _ = refl @@ -91,19 +91,19 @@ where unquoteDecl e = declStrictEquiv e fst (λ a → a , refl) -isContr→≃Unit : {A : Type ℓ} → isContr A → A ≃ Unit +isContr→≃Unit : {A : Type ℓ} → isContr A → A ≃ Unit isContr→≃Unit contr = isoToEquiv (iso (λ _ → tt) (λ _ → fst contr) (λ _ → refl) λ _ → snd contr _) -isContr→≡Unit : {A : Type₀} → isContr A → A ≡ Unit +isContr→≡Unit : {A : Type₀} → isContr A → A ≡ Unit isContr→≡Unit contr = ua (isContr→≃Unit contr) -isContrUnit* : ∀ {ℓ} → isContr (Unit* {ℓ}) +isContrUnit* : ∀ {ℓ} → isContr (Unit* {ℓ}) isContrUnit* = tt* , λ _ → refl -isPropUnit* : ∀ {ℓ} → isProp (Unit* {ℓ}) +isPropUnit* : ∀ {ℓ} → isProp (Unit* {ℓ}) isPropUnit* _ _ = refl -isSetUnit* : ∀ {ℓ} → isSet (Unit* {ℓ}) +isSetUnit* : ∀ {ℓ} → isSet (Unit* {ℓ}) isSetUnit* _ _ _ _ = refl isOfHLevelUnit* : ∀ {ℓ} (n : HLevel) → isOfHLevel n (Unit* {ℓ}) @@ -113,11 +113,11 @@ isOfHLevelUnit* (suc (suc (suc n))) = isOfHLevelPlus 3 (isOfHLevelUnit* n) Unit≃Unit* : ∀ {ℓ} → Unit ≃ Unit* {ℓ} -Unit≃Unit* = invEquiv (isContr→≃Unit isContrUnit*) +Unit≃Unit* = invEquiv (isContr→≃Unit isContrUnit*) -isContr→≃Unit* : {A : Type ℓ} → isContr A → A ≃ Unit* {ℓ} -isContr→≃Unit* contr = compEquiv (isContr→≃Unit contr) Unit≃Unit* +isContr→≃Unit* : {A : Type ℓ} → isContr A → A ≃ Unit* {ℓ} +isContr→≃Unit* contr = compEquiv (isContr→≃Unit contr) Unit≃Unit* -isContr→≡Unit* : {A : Type ℓ} → isContr A → A ≡ Unit* +isContr→≡Unit* : {A : Type ℓ} → isContr A → A ≡ Unit* isContr→≡Unit* contr = ua (isContr→≃Unit* contr) \ No newline at end of file diff --git a/docs/Cubical.Data.Vec.Properties.html b/docs/Cubical.Data.Vec.Properties.html index 3bb2ebd..6f5baa4 100644 --- a/docs/Cubical.Data.Vec.Properties.html +++ b/docs/Cubical.Data.Vec.Properties.html @@ -63,7 +63,7 @@ FinVec≡Vec : (n : ℕ) → FinVec A n ≡ Vec A n FinVec≡Vec n = ua (FinVec≃Vec n) -isContrVec0 : isContr (Vec A 0) +isContrVec0 : isContr (Vec A 0) isContrVec0 = [] , λ { [] → refl } -- encode - decode Vec @@ -80,10 +80,10 @@ reflEncode (a ∷ v) = refl , refl encode : {n : ℕ} → (v v' : Vec A n) → (v ≡ v') → code v v' - encode v v' p = J (λ v' _ → code v v') (reflEncode v) p + encode v v' p = J (λ v' _ → code v v') (reflEncode v) p encodeRefl : {n : ℕ} → (v : Vec A n) → encode v v refl ≡ reflEncode v - encodeRefl v = JRefl (λ v' _ → code v v') (reflEncode v) + encodeRefl v = JRefl (λ v' _ → code v v') (reflEncode v) -- decode decode : {n : ℕ} → (v v' : Vec A n) → (r : code v v') → (v ≡ v') @@ -106,32 +106,32 @@ sect : {n : ℕ} → (v v' : Vec A n) → (r : code v v') → encode v v' (decode v v' r) ≡ r sect [] [] tt* = encodeRefl [] - sect (a ∷ v) (a' ∷ v') (p , q) = J (λ a' p → encode (a ∷ v) (a' ∷ v') (decode (a ∷ v) (a' ∷ v') (p , q)) ≡ (p , q)) - (J (λ v' q → encode (a ∷ v) (a ∷ v') (decode (a ∷ v) (a ∷ v') (refl , q)) ≡ (refl , q)) + sect (a ∷ v) (a' ∷ v') (p , q) = J (λ a' p → encode (a ∷ v) (a' ∷ v') (decode (a ∷ v) (a' ∷ v') (p , q)) ≡ (p , q)) + (J (λ v' q → encode (a ∷ v) (a ∷ v') (decode (a ∷ v) (a ∷ v') (refl , q)) ≡ (refl , q)) (encodeRefl (a ∷ v)) q) p leftInv is = retr v v' where retr : {n : ℕ} → (v v' : Vec A n) → (p : v ≡ v') → decode v v' (encode v v' p) ≡ p - retr v v' p = J (λ v' p → decode v v' (encode v v' p) ≡ p) + retr v v' p = J (λ v' p → decode v v' (encode v v' p) ≡ p) (cong (decode v v) (encodeRefl v) ∙ decodeRefl v) p isOfHLevelVec : (h : HLevel) (n : ℕ) → isOfHLevel (suc (suc h)) A → isOfHLevel (suc (suc h)) (Vec A n) - isOfHLevelVec h zero ofLevelA [] [] = isOfHLevelRespectEquiv (suc h) (invEquiv (≡Vec≃codeVec [] [])) + isOfHLevelVec h zero ofLevelA [] [] = isOfHLevelRespectEquiv (suc h) (invEquiv (≡Vec≃codeVec [] [])) (isOfHLevelUnit* (suc h)) - isOfHLevelVec h (suc n) ofLevelA (x ∷ v) (x' ∷ v') = isOfHLevelRespectEquiv (suc h) (invEquiv (≡Vec≃codeVec _ _)) + isOfHLevelVec h (suc n) ofLevelA (x ∷ v) (x' ∷ v') = isOfHLevelRespectEquiv (suc h) (invEquiv (≡Vec≃codeVec _ _)) (isOfHLevelΣ (suc h) (ofLevelA x x') (λ _ → isOfHLevelVec h n ofLevelA v v')) discreteA→discreteVecA : Discrete A → (n : ℕ) → Discrete (Vec A n) discreteA→discreteVecA DA zero [] [] = yes refl discreteA→discreteVecA DA (suc n) (a ∷ v) (a' ∷ v') with (DA a a') | (discreteA→discreteVecA DA n v v') - ... | yes p | yes q = yes (invIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) (p , q)) - ... | yes p | no ¬q = no (λ r → ¬q (snd (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) - ... | no ¬p | yes q = no (λ r → ¬p (fst (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) - ... | no ¬p | no ¬q = no (λ r → ¬q (snd (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) + ... | yes p | yes q = yes (invIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) (p , q)) + ... | yes p | no ¬q = no (λ r → ¬q (snd (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) + ... | no ¬p | yes q = no (λ r → ¬p (fst (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) + ... | no ¬p | no ¬q = no (λ r → ¬q (snd (funIsEq (snd (≡Vec≃codeVec (a ∷ v) (a' ∷ v'))) r))) ≢-∷ : {m : ℕ} → (Discrete A) → (a : A) → (v : Vec A m) → (a' : A) → (v' : Vec A m) → (a ∷ v ≡ a' ∷ v' → ⊥.⊥) → (a ≡ a' → ⊥.⊥) ⊎ (v ≡ v' → ⊥.⊥) diff --git a/docs/Cubical.Displayed.Base.html b/docs/Cubical.Displayed.Base.html index 403e9ba..db0daec 100644 --- a/docs/Cubical.Displayed.Base.html +++ b/docs/Cubical.Displayed.Base.html @@ -28,7 +28,7 @@ ua : (a a' : A) → (a ≅ a') ≃ (a ≡ a') uaIso : (a a' : A) → Iso (a ≅ a') (a ≡ a') - uaIso a a' = equivToIso (ua a a') + uaIso a a' = equivToIso (ua a a') ≅→≡ : {a a' : A} (p : a ≅ a') → a ≡ a' ≅→≡ {a} {a'} = Iso.fun (uaIso a a') @@ -38,13 +38,13 @@ ρ : (a : A) → a ≅ a ρ a = ≡→≅ refl -open BinaryRelation +open BinaryRelation -- another constructor for UARel using contractibility of relational singletons make-𝒮 : {A : Type ℓA} {_≅_ : A → A → Type ℓ≅A} - (ρ : isRefl _≅_) (contrTotal : contrRelSingl _≅_) → UARel A ℓ≅A + (ρ : isRefl _≅_) (contrTotal : contrRelSingl _≅_) → UARel A ℓ≅A UARel._≅_ (make-𝒮 {_≅_ = _≅_} _ _) = _≅_ -UARel.ua (make-𝒮 {_≅_ = _≅_} ρ c) = contrRelSingl→isUnivalent _≅_ ρ c +UARel.ua (make-𝒮 {_≅_ = _≅_} ρ c) = contrRelSingl→isUnivalent _≅_ ρ c record DUARel {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) (ℓ≅B : Level) : Type (ℓ-max (ℓ-max ℓA ℓB) (ℓ-max ℓ≅A (ℓ-suc ℓ≅B))) where @@ -56,17 +56,17 @@ _≅ᴰ⟨_⟩_ : {a a' : A} → B a → a ≅ a' → B a' → Type ℓ≅B uaᴰ : {a a' : A} (b : B a) (p : a ≅ a') (b' : B a') → (b ≅ᴰ⟨ p ⟩ b') ≃ PathP (λ i → B (≅→≡ p i)) b b' - fiberRel : (a : A) → Rel (B a) (B a) ℓ≅B + fiberRel : (a : A) → Rel (B a) (B a) ℓ≅B fiberRel a = _≅ᴰ⟨ ρ a ⟩_ uaᴰρ : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b') uaᴰρ {a} b b' = - compEquiv + compEquiv (uaᴰ b (ρ _) b') - (substEquiv (λ q → PathP (λ i → B (q i)) b b') (secEq (ua a a) refl)) + (substEquiv (λ q → PathP (λ i → B (q i)) b b') (secEq (ua a a) refl)) ρᴰ : {a : A} → (b : B a) → b ≅ᴰ⟨ ρ a ⟩ b - ρᴰ {a} b = invEq (uaᴰρ b b) refl + ρᴰ {a} b = invEq (uaᴰρ b b) refl -- total UARel induced by a DUARel @@ -82,7 +82,7 @@ ∫ : UARel (Σ A B) (ℓ-max ℓ≅A ℓ≅B) UARel._≅_ ∫ (a , b) (a' , b') = Σ[ p ∈ a ≅ a' ] (b ≅ᴰ⟨ p ⟩ b') UARel.ua ∫ (a , b) (a' , b') = - compEquiv + compEquiv (Σ-cong-equiv (ua a a') (λ p → uaᴰ b p b')) ΣPath≃PathΣ diff --git a/docs/Cubical.Displayed.Function.html b/docs/Cubical.Displayed.Function.html index bde1c04..2018770 100644 --- a/docs/Cubical.Displayed.Function.html +++ b/docs/Cubical.Displayed.Function.html @@ -37,8 +37,8 @@ 𝒮-Π : UARel ((a : A) → B a) (ℓ-max ℓA ℓ≅B) UARel._≅_ 𝒮-Π f f' = ∀ a → f a ≅ᴰ⟨ ρ a ⟩ f' a UARel.ua 𝒮-Π f f' = - compEquiv - (equivΠCod λ a → uaᴰρ (f a) (f' a)) + compEquiv + (equivΠCod λ a → uaᴰρ (f a) (f' a)) funExtEquiv -- Parameterize UARel by type @@ -46,8 +46,8 @@ _→𝒮_ : (A : Type ℓA) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) → UARel (A → B) (ℓ-max ℓA ℓ≅B) (A →𝒮 𝒮-B) .UARel._≅_ f f' = ∀ a → 𝒮-B .UARel._≅_ (f a) (f' a) (A →𝒮 𝒮-B) .UARel.ua f f' = - compEquiv - (equivΠCod λ a → 𝒮-B .UARel.ua (f a) (f' a)) + compEquiv + (equivΠCod λ a → 𝒮-B .UARel.ua (f a) (f' a)) funExtEquiv 𝒮-app : {A : Type ℓA} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} @@ -73,10 +73,10 @@ DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Π f p f' = ∀ {b b'} (q : b B.≅ᴰ⟨ p ⟩ b') → f b C.≅ᴰ⟨ p , q ⟩ f' b' DUARel.uaᴰ 𝒮ᴰ-Π f p f' = - compEquiv - (equivImplicitΠCod λ {b} → - (equivImplicitΠCod λ {b'} → - (equivΠ (B.uaᴰ b p b') (λ q → C.uaᴰ (f b) (p , q) (f' b'))))) + compEquiv + (equivImplicitΠCod λ {b} → + (equivImplicitΠCod λ {b'} → + (equivΠ (B.uaᴰ b p b') (λ q → C.uaᴰ (f b) (p , q) (f' b'))))) funExtDepEquiv _→𝒮ᴰ_ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} @@ -102,10 +102,10 @@ DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Πˢ f p f' = (b : B _) → f b ≅ᴰ⟨ p , refl ⟩ f' (act p .fst b) DUARel.uaᴰ 𝒮ᴰ-Πˢ f p f' = - compEquiv - (compEquiv - (equivΠCod λ b → Jequiv (λ b' q → f b ≅ᴰ⟨ p , q ⟩ f' b')) - (invEquiv implicit≃Explicit)) + compEquiv + (compEquiv + (equivΠCod λ b → Jequiv (λ b' q → f b ≅ᴰ⟨ p , q ⟩ f' b')) + (invEquiv implicit≃Explicit)) (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) 𝒮ᴰ-C) f p f') -- SubstRel on a dependent function type @@ -123,15 +123,15 @@ module C = SubstRel 𝒮ˢ-C 𝒮ˢ-Π : SubstRel 𝒮-A (λ a → (b : B a) → C (a , b)) - 𝒮ˢ-Π .act p = equivΠ' (B.act p) (λ q → C.act (p , q)) + 𝒮ˢ-Π .act p = equivΠ' (B.act p) (λ q → C.act (p , q)) 𝒮ˢ-Π .uaˢ p f = - fromPathP + fromPathP (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) f p (equivFun (𝒮ˢ-Π .act p) f) .fst (λ {b} → - J (λ b' q → + J (λ b' q → equivFun (C.act (p , q)) (f b) - ≡ equivFun (equivΠ' (𝒮ˢ-B .act p) (λ q → C.act (p , q))) f b') + ≡ equivFun (equivΠ' (𝒮ˢ-B .act p) (λ q → C.act (p , q))) f b') (λ i → - C.act (p , λ j → commSqIsEq (𝒮ˢ-B .act p .snd) b (~ i) j) .fst - (f (retEq (𝒮ˢ-B .act p) b (~ i)))))) + C.act (p , λ j → commSqIsEq (𝒮ˢ-B .act p .snd) b (~ i) j) .fst + (f (retEq (𝒮ˢ-B .act p) b (~ i)))))) \ No newline at end of file diff --git a/docs/Cubical.Displayed.Morphism.html b/docs/Cubical.Displayed.Morphism.html index e6a8453..5114c9c 100644 --- a/docs/Cubical.Displayed.Morphism.html +++ b/docs/Cubical.Displayed.Morphism.html @@ -54,7 +54,7 @@ → DUARel 𝒮-A (C ∘ fun f) ℓ≅C 𝒮ᴰ-reindex f 𝒮ᴰ-C .DUARel._≅ᴰ⟨_⟩_ c p c' = 𝒮ᴰ-C .DUARel._≅ᴰ⟨_⟩_ c (f .rel p) c' 𝒮ᴰ-reindex {C = C} f 𝒮ᴰ-C .DUARel.uaᴰ c p c' = - compEquiv + compEquiv (𝒮ᴰ-C .DUARel.uaᴰ c (f .rel p) c') (substEquiv (λ q → PathP (λ i → C (q i)) c c') (sym (f .ua p))) diff --git a/docs/Cubical.Displayed.Prop.html b/docs/Cubical.Displayed.Prop.html index 4240431..2be0919 100644 --- a/docs/Cubical.Displayed.Prop.html +++ b/docs/Cubical.Displayed.Prop.html @@ -24,31 +24,31 @@ 𝒮-prop : (P : hProp ℓP) → UARel (P .fst) ℓ-zero 𝒮-prop P .UARel._≅_ _ _ = Unit 𝒮-prop P .UARel.ua _ _ = - invEquiv (isContr→≃Unit (isOfHLevelPath' 0 (P .snd) _ _)) + invEquiv (isContr→≃Unit (isOfHLevelPath' 0 (P .snd) _ _)) 𝒮ᴰ-prop : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (P : A → hProp ℓP) → DUARel 𝒮-A (λ a → P a .fst) ℓ-zero 𝒮ᴰ-prop 𝒮-A P .DUARel._≅ᴰ⟨_⟩_ _ _ _ = Unit 𝒮ᴰ-prop 𝒮-A P .DUARel.uaᴰ _ _ _ = - invEquiv (isContr→≃Unit (isOfHLevelPathP' 0 (P _ .snd) _ _)) + invEquiv (isContr→≃Unit (isOfHLevelPathP' 0 (P _ .snd) _ _)) 𝒮-subtype : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {P : A → Type ℓP} - → (∀ a → isProp (P a)) + → (∀ a → isProp (P a)) → UARel (Σ A P) ℓ≅A 𝒮-subtype 𝒮-A propP .UARel._≅_ (a , _) (a' , _) = 𝒮-A .UARel._≅_ a a' 𝒮-subtype 𝒮-A propP .UARel.ua (a , _) (a' , _) = - compEquiv (𝒮-A .UARel.ua a a') (Σ≡PropEquiv propP) + compEquiv (𝒮-A .UARel.ua a a') (Σ≡PropEquiv propP) 𝒮ᴰ-subtype : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) {P : (a : A) → B a → Type ℓP} - → (∀ a b → isProp (P a b)) + → (∀ a b → isProp (P a b)) → DUARel 𝒮-A (λ a → Σ[ b ∈ B a ] (P a b)) ℓ≅B 𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel._≅ᴰ⟨_⟩_ (b , _) p (b' , _) = 𝒮ᴰ-B .DUARel._≅ᴰ⟨_⟩_ b p b' 𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel.uaᴰ (b , _) p (b' , _) = - compEquiv + compEquiv (𝒮ᴰ-B .DUARel.uaᴰ b p b') - (compEquiv - (invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (propP _ b') _ _)) + (compEquiv + (invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (propP _ b') _ _)) ΣPath≃PathΣ) \ No newline at end of file diff --git a/docs/Cubical.Displayed.Properties.html b/docs/Cubical.Displayed.Properties.html index e1059bf..ed52540 100644 --- a/docs/Cubical.Displayed.Properties.html +++ b/docs/Cubical.Displayed.Properties.html @@ -12,7 +12,7 @@ open import Cubical.Data.Sigma open import Cubical.Relation.Binary -open BinaryRelation +open BinaryRelation open import Cubical.Displayed.Base @@ -31,7 +31,7 @@ (p : a ≅ a') → P a' (≅→≡ p) 𝒮-J {a} P d {a'} p - = J (λ y q → P y q) + = J (λ y q → P y q) d (≅→≡ p) @@ -72,7 +72,7 @@ (sym (Iso.rightInv (uaIso a a) refl)) refl uni' : (b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ PathP (λ i → B (≅→≡ (ρ a) i)) b b' - uni' b' = compEquiv (uni b b') (pathToEquiv (g b')) + uni' b' = compEquiv (uni b b') (pathToEquiv (g b')) 𝒮ᴰ-make-1 : (uni : {a : A} (b b' : B a) → b ≅ᴰ⟨ ρ a ⟩ b' ≃ (b ≡ b')) → DUARel 𝒮-A B ℓ≅B @@ -81,19 +81,19 @@ -- constructor that reduces univalence further to contractibility of relational singletons - 𝒮ᴰ-make-2 : (ρᴰ : {a : A} → isRefl _≅ᴰ⟨ ρ a ⟩_) - (contrTotal : (a : A) → contrRelSingl _≅ᴰ⟨ ρ a ⟩_) + 𝒮ᴰ-make-2 : (ρᴰ : {a : A} → isRefl _≅ᴰ⟨ ρ a ⟩_) + (contrTotal : (a : A) → contrRelSingl _≅ᴰ⟨ ρ a ⟩_) → DUARel 𝒮-A B ℓ≅B - 𝒮ᴰ-make-2 ρᴰ contrTotal = 𝒮ᴰ-make-1 (contrRelSingl→isUnivalent _ ρᴰ (contrTotal _)) + 𝒮ᴰ-make-2 ρᴰ contrTotal = 𝒮ᴰ-make-1 (contrRelSingl→isUnivalent _ ρᴰ (contrTotal _)) -- relational isomorphisms 𝒮-iso→iso : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) - (F : RelIso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B)) + (F : RelIso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B)) → Iso A B 𝒮-iso→iso 𝒮-A 𝒮-B F - = RelIso→Iso (UARel._≅_ 𝒮-A) + = RelIso→Iso (UARel._≅_ 𝒮-A) (UARel._≅_ 𝒮-B) (UARel.≅→≡ 𝒮-A) (UARel.≅→≡ 𝒮-B) @@ -123,14 +123,14 @@ -- the following can of course be done slightly more generally -- for fiberwise binary relations - F*fiberRelB' : (a : A) → Rel (B' (f a)) (B' (f a)) ℓ≅B' + F*fiberRelB' : (a : A) → Rel (B' (f a)) (B' (f a)) ℓ≅B' F*fiberRelB' a = fiberRelB' (f a) - module _ (G : (a : A) → RelIso (fiberRelB a) (F*fiberRelB' a)) where + module _ (G : (a : A) → RelIso (fiberRelB a) (F*fiberRelB' a)) where private fiberIsoOver : (a : A) → Iso (B a) (B' (f a)) fiberIsoOver a - = RelIso→Iso (fiberRelB a) + = RelIso→Iso (fiberRelB a) (F*fiberRelB' a) (equivFun (uaᴰρB _ _)) (equivFun (uaᴰρB' _ _)) diff --git a/docs/Cubical.Displayed.Record.html b/docs/Cubical.Displayed.Record.html index 60d6a1b..292938b 100644 --- a/docs/Cubical.Displayed.Record.html +++ b/docs/Cubical.Displayed.Record.html @@ -91,7 +91,7 @@ → DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅ → ∀ {ℓF} {F : (a : A) → S a → Type ℓF} (πF : ∀ {a} → (r : R a) → F a (πS r)) - (propF : ∀ a s → isProp (F a s)) + (propF : ∀ a s → isProp (F a s)) → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-subtype 𝒮ᴰ-S propF) (λ p → πS≅ p) module _ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} @@ -115,7 +115,7 @@ (compIso (e≅ _ _ r p r') (compIso - (equivToIso (uaᴰ (e _ .Iso.fun r) p (e _ .Iso.fun r'))) + (equivToIso (uaᴰ (e _ .Iso.fun r) p (e _ .Iso.fun r'))) (invIso (congPathIso λ i → isoToEquiv (e _))))) module DisplayedRecordMacro where diff --git a/docs/Cubical.Displayed.Sigma.html b/docs/Cubical.Displayed.Sigma.html index 285a520..4fc99e5 100644 --- a/docs/Cubical.Displayed.Sigma.html +++ b/docs/Cubical.Displayed.Sigma.html @@ -68,7 +68,7 @@ DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Σ (b , c) p (b' , c') = Σ[ q ∈ b B.≅ᴰ⟨ p ⟩ b' ] (c C.≅ᴰ⟨ p , q ⟩ c') DUARel.uaᴰ 𝒮ᴰ-Σ (b , c) p (b' , c') = - compEquiv + compEquiv (Σ-cong-equiv (B.uaᴰ b p b') (λ q → C.uaᴰ c (p , q) c')) ΣPath≃PathΣ @@ -98,7 +98,7 @@ 𝒮ˢ-Σ : SubstRel 𝒮-A (λ a → Σ[ b ∈ B a ] C (a , b)) 𝒮ˢ-Σ .act p = Σ-cong-equiv (B.act p) (λ b → C.act (p , refl)) 𝒮ˢ-Σ .uaˢ p _ = - fromPathP + fromPathP (DUARel.uaᴰ (𝒮ᴰ-Σ (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) _ p _ .fst (refl , refl)) -- SubstRel on a non-dependent product diff --git a/docs/Cubical.Displayed.Subst.html b/docs/Cubical.Displayed.Subst.html index 3792aa8..467c7ae 100644 --- a/docs/Cubical.Displayed.Subst.html +++ b/docs/Cubical.Displayed.Subst.html @@ -35,15 +35,15 @@ act : {a a' : A} → a ≅ a' → B a ≃ B a' uaˢ : {a a' : A} (p : a ≅ a') (b : B a) → subst B (≅→≡ p) b ≡ equivFun (act p) b - uaˢ⁻ : {a a' : A} (p : a ≅ a') (b : B a') → subst B (sym (≅→≡ p)) b ≡ invEq (act p) b + uaˢ⁻ : {a a' : A} (p : a ≅ a') (b : B a') → subst B (sym (≅→≡ p)) b ≡ invEq (act p) b uaˢ⁻ p b = subst B (sym (≅→≡ p)) b - ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (secEq (act p) b)) ⟩ - subst B (sym (≅→≡ p)) (equivFun (act p) (invEq (act p) b)) - ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (uaˢ p (invEq (act p) b))) ⟩ - subst B (sym (≅→≡ p)) (subst B (≅→≡ p) (invEq (act p) b)) - ≡⟨ pathToIso (cong B (≅→≡ p)) .Iso.leftInv (invEq (act p) b) ⟩ - invEq (act p) b + ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (secEq (act p) b)) ⟩ + subst B (sym (≅→≡ p)) (equivFun (act p) (invEq (act p) b)) + ≡⟨ cong (subst B (sym (≅→≡ p))) (sym (uaˢ p (invEq (act p) b))) ⟩ + subst B (sym (≅→≡ p)) (subst B (≅→≡ p) (invEq (act p) b)) + ≡⟨ pathToIso (cong B (≅→≡ p)) .Iso.leftInv (invEq (act p) b) ⟩ + invEq (act p) b ∎ Subst→DUA : {A : Type ℓA} {ℓ≅A : Level} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} @@ -52,11 +52,11 @@ equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' DUARel.uaᴰ (Subst→DUA {𝒮-A = 𝒮-A} {B = B} 𝒮ˢ-B) b p b' = equivFun (SubstRel.act 𝒮ˢ-B p) b ≡ b' - ≃⟨ invEquiv (compPathlEquiv (sym (SubstRel.uaˢ 𝒮ˢ-B p b))) ⟩ + ≃⟨ invEquiv (compPathlEquiv (sym (SubstRel.uaˢ 𝒮ˢ-B p b))) ⟩ subst B (≅→≡ p) b ≡ b' - ≃⟨ invEquiv (PathP≃Path (λ i → B (≅→≡ p i)) b b') ⟩ + ≃⟨ invEquiv (PathP≃Path (λ i → B (≅→≡ p i)) b b') ⟩ PathP (λ i → B (≅→≡ p i)) b b' - ■ + ■ where open UARel 𝒮-A \ No newline at end of file diff --git a/docs/Cubical.Displayed.Unit.html b/docs/Cubical.Displayed.Unit.html index 7b7e7a0..c9e3dc3 100644 --- a/docs/Cubical.Displayed.Unit.html +++ b/docs/Cubical.Displayed.Unit.html @@ -22,7 +22,7 @@ 𝒮-Unit : UARel Unit ℓ-zero 𝒮-Unit .UARel._≅_ _ _ = Unit -𝒮-Unit .UARel.ua _ _ = invEquiv (isContr→≃Unit (isProp→isContrPath isPropUnit _ _)) +𝒮-Unit .UARel.ua _ _ = invEquiv (isContr→≃Unit (isProp→isContrPath isPropUnit _ _)) 𝒮ᴰ-Unit : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → DUARel 𝒮-A (λ _ → Unit) ℓ-zero 𝒮ᴰ-Unit 𝒮-A = 𝒮ᴰ-const 𝒮-A 𝒮-Unit diff --git a/docs/Cubical.Displayed.Universe.html b/docs/Cubical.Displayed.Universe.html index 6823ab9..5f9eaf6 100644 --- a/docs/Cubical.Displayed.Universe.html +++ b/docs/Cubical.Displayed.Universe.html @@ -30,5 +30,5 @@ 𝒮ᴰ-El : ∀ ℓ → DUARel (𝒮-Univ ℓ) (λ X → X) ℓ 𝒮ᴰ-El ℓ .DUARel._≅ᴰ⟨_⟩_ a e a' = e .fst a ≡ a' -𝒮ᴰ-El ℓ .DUARel.uaᴰ a e a' = invEquiv (ua-ungluePath-Equiv e) +𝒮ᴰ-El ℓ .DUARel.uaᴰ a e a' = invEquiv (ua-ungluePath-Equiv e) \ No newline at end of file diff --git a/docs/Cubical.Foundations.Equiv.Base.html b/docs/Cubical.Foundations.Equiv.Base.html index 24b1497..61fbdb3 100644 --- a/docs/Cubical.Foundations.Equiv.Base.html +++ b/docs/Cubical.Foundations.Equiv.Base.html @@ -29,7 +29,7 @@ -- the definition using Π-type isEquiv' : ∀ {ℓ}{ℓ'}{A : Type ℓ}{B : Type ℓ'} → (A → B) → Type (ℓ-max ℓ ℓ') -isEquiv' {B = B} f = (y : B) → isContr (fiber f y) +isEquiv' {B = B} f = (y : B) → isContr (fiber f y) -- Transport along a line of types A, constant on some extent φ, is an equivalence. isEquivTransp : ∀ {ℓ : I → Level} (A : (i : I) → Type (ℓ i)) → ∀ (φ : I) → isEquiv (transp (λ j → A (φ ∨ j)) φ) diff --git a/docs/Cubical.Foundations.Equiv.Dependent.html b/docs/Cubical.Foundations.Equiv.Dependent.html new file mode 100644 index 0000000..c2a35e0 --- /dev/null +++ b/docs/Cubical.Foundations.Equiv.Dependent.html @@ -0,0 +1,378 @@ + +Cubical.Foundations.Equiv.Dependent
{-
+
+Dependent version of isomorphisms and equivalences
+
+Extremely useful if one wants to construct explicit isomorphisms between record types
+with fields dependent on each other.
+
+This can be generalize in inumerable ways.
+Maybe one day someone will find a common scheme and then computer could automatically generate them.
+
+-}
+{-# OPTIONS --safe #-}
+module Cubical.Foundations.Equiv.Dependent where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Equiv.HalfAdjoint
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Transport
+
+private
+  variable
+    ℓ ℓ' ℓ'' ℓ''' : Level
+    A : Type ℓ
+    B : Type ℓ'
+    P : A → Type ℓ''
+    Q : B → Type ℓ'''
+
+
+-- Relative version of maps and their composition
+
+mapOver :
+  (f : A → B)
+  (P : A → Type ℓ'')(Q : B → Type ℓ''')
+  → Type _
+mapOver {A = A} f P Q = (a : A) → P a → Q (f a)
+
+compMapOver :
+  {ℓA ℓB ℓC ℓP ℓQ ℓR : Level}
+  {A : Type ℓA}{B : Type ℓB}{C : Type ℓC}
+  {P : A → Type ℓP}{Q : B → Type ℓQ}{R : C → Type ℓR}
+  {f : A → B}{g : B → C}
+  → mapOver f P Q → mapOver g Q R
+  → mapOver (g ∘ f) P R
+compMapOver f g _ p = g _ (f _ p)
+
+
+-- Fiberwise equivalence
+
+isEquivOver :
+  {f : A → B}
+  (F : mapOver f P Q)
+  → Type _
+isEquivOver {A = A} F = (a : A) → isEquiv (F a)
+
+isPropIsEquivOver :
+  {f : A → B}
+  (F : mapOver f P Q)
+  → isProp (isEquivOver {Q = Q} F)
+isPropIsEquivOver F = isPropΠ (λ a → isPropIsEquiv (F a))
+
+-- Relative version of section and retract
+
+sectionOver :
+  {f : A → B}{g : B → A}
+  (sec : section f g)
+  (F : mapOver f P Q)(G : mapOver g Q P)
+  → Type _
+sectionOver {B = B} {Q = Q} sec F G =
+  (b : B)(q : Q b) → PathP (λ i → Q (sec b i)) (F _ (G _ q)) q
+
+retractOver :
+  {f : A → B}{g : B → A}
+  (ret : retract f g)
+  (F : mapOver f P Q)(G : mapOver g Q P)
+  → Type _
+retractOver {A = A} {P = P} ret F G =
+  (a : A)(p : P a) → PathP (λ i → P (ret a i)) (G _ (F _ p)) p
+
+
+-- Relative version of isomorphism
+
+open Iso
+
+record IsoOver {ℓ ℓ'} {A : Type ℓ}{B : Type ℓ'}
+  (isom : Iso A B)(P : A → Type ℓ'')(Q : B → Type ℓ''')
+  : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓ'' ℓ''')) where
+  no-eta-equality
+  constructor isoover
+  field
+    fun : mapOver (isom .fun) P Q
+    inv : mapOver (isom .inv) Q P
+    rightInv : sectionOver (isom .rightInv) fun inv
+    leftInv  : retractOver (isom .leftInv ) fun inv
+
+record isIsoOver {ℓ ℓ'} {A : Type ℓ}{B : Type ℓ'}
+  (isom : Iso A B)(P : A → Type ℓ'')(Q : B → Type ℓ''')
+  (fun : mapOver (isom .fun) P Q)
+  : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓ'' ℓ''')) where
+  no-eta-equality
+  constructor isisoover
+  field
+    inv : mapOver (isom .inv) Q P
+    rightInv : sectionOver (isom .rightInv) fun inv
+    leftInv  : retractOver (isom .leftInv ) fun inv
+
+open IsoOver
+open isIsoOver
+
+
+isIsoOver→IsoOver :
+  {isom : Iso A B}
+  {fun : mapOver (isom .fun) P Q}
+  → isIsoOver isom P Q fun
+  → IsoOver isom P Q
+isIsoOver→IsoOver {fun = fun} isom .fun = fun
+isIsoOver→IsoOver {fun = fun} isom .inv = isom .inv
+isIsoOver→IsoOver {fun = fun} isom .rightInv = isom .rightInv
+isIsoOver→IsoOver {fun = fun} isom .leftInv  = isom .leftInv
+
+IsoOver→isIsoOver :
+  {isom : Iso A B}
+  → (isom' : IsoOver isom P Q)
+  → isIsoOver isom P Q (isom' .fun)
+IsoOver→isIsoOver isom .inv = isom .inv
+IsoOver→isIsoOver isom .rightInv = isom .rightInv
+IsoOver→isIsoOver isom .leftInv  = isom .leftInv
+
+invIsoOver : {isom : Iso A B} → IsoOver isom P Q → IsoOver (invIso isom) Q P
+invIsoOver {isom = isom} isom' .fun = isom' .inv
+invIsoOver {isom = isom} isom' .inv = isom' .fun
+invIsoOver {isom = isom} isom' .rightInv = isom' .leftInv
+invIsoOver {isom = isom} isom' .leftInv = isom' .rightInv
+
+compIsoOver :
+  {ℓA ℓB ℓC ℓP ℓQ ℓR : Level}
+  {A : Type ℓA}{B : Type ℓB}{C : Type ℓC}
+  {P : A → Type ℓP}{Q : B → Type ℓQ}{R : C → Type ℓR}
+  {isom₁ : Iso A B}{isom₂ : Iso B C}
+  → IsoOver isom₁ P Q → IsoOver isom₂ Q R
+  → IsoOver (compIso isom₁ isom₂) P R
+compIsoOver {A = A} {B} {C} {P} {Q} {R} {isom₁} {isom₂} isoover₁ isoover₂ = w
+  where
+  w : IsoOver _ _ _
+  w .fun _ = isoover₂ .fun _ ∘ isoover₁ .fun _
+  w .inv _ = isoover₁ .inv _ ∘ isoover₂ .inv _
+  w .rightInv b q i =
+    comp
+    (λ j → R (compPath-filler (cong (isom₂ .fun) (isom₁ .rightInv _)) (isom₂ .rightInv b) j i))
+    (λ j → λ
+      { (i = i0) → w .fun _ (w .inv _ q)
+      ; (i = i1) → isoover₂ .rightInv _ q j })
+    (isoover₂ .fun _ (isoover₁ .rightInv _ (isoover₂ .inv _ q) i))
+  w .leftInv a p i =
+    comp
+    (λ j → P (compPath-filler (cong (isom₁ .inv) (isom₂ .leftInv _)) (isom₁ .leftInv a) j i))
+    (λ j → λ
+      { (i = i0) → w .inv _ (w .fun _ p)
+      ; (i = i1) → isoover₁ .leftInv _ p j })
+    (isoover₁ .inv _ (isoover₂ .leftInv _ (isoover₁ .fun _ p) i))
+
+
+-- Special cases
+
+fiberIso→IsoOver :
+  {ℓA ℓP ℓQ : Level}
+  {A : Type ℓA}
+  {P : A → Type ℓP}{Q : A → Type ℓQ}
+  → ((a : A) → Iso (P a) (Q a))
+  → IsoOver idIso P Q
+fiberIso→IsoOver isom .fun a = isom a .fun
+fiberIso→IsoOver isom .inv b = isom b .inv
+fiberIso→IsoOver isom .rightInv b = isom b .rightInv
+fiberIso→IsoOver isom .leftInv  a = isom a .leftInv
+
+-- Only half-adjoint equivalence can be lifted.
+-- This is another clue that HAE is more natural than isomorphism.
+
+open isHAEquiv renaming (g to inv)
+
+pullbackIsoOver :
+  {ℓA ℓB ℓP : Level}
+  {A : Type ℓA}{B : Type ℓB}
+  {P : B → Type ℓP}
+  (f : A → B)
+  (hae : isHAEquiv f)
+  → IsoOver (isHAEquiv→Iso hae) (P ∘ f) P
+pullbackIsoOver {A = A} {B} {P} f hae = w
+  where
+  isom = isHAEquiv→Iso hae
+
+  w : IsoOver _ _ _
+  w .fun a = idfun _
+  w .inv b = subst P (sym (isom .rightInv b))
+  w .rightInv b p i = subst-filler P (sym (isom .rightInv b)) p (~ i)
+  w .leftInv  a p i =
+    comp
+    (λ j → P (hae .com a (~ j) i))
+    (λ j → λ
+      { (i = i0) → w .inv _ (w .fun _ p)
+      ; (i = i1) → p })
+    (w .rightInv _ p i)
+
+
+-- Lifting isomorphism of bases to isomorphism of families
+
+-- Since there is no regularity for transport (also no-eta-equality),
+-- we have to fix one field manually to make it invariant under transportation.
+liftHAEToIsoOver :
+  (f : A → B)
+  (hae : isHAEquiv f)
+  → ((a : A) → Iso (P a) (Q (f a)))
+  → IsoOver (isHAEquiv→Iso hae) P Q
+liftHAEToIsoOver {P = P} {Q = Q} f hae isom =
+  isIsoOver→IsoOver
+    (transport (λ i → isIsoOver (compIsoIdL (isHAEquiv→Iso hae) i) P Q (λ a x → isom a .fun x))
+      (IsoOver→isIsoOver (compIsoOver (fiberIso→IsoOver isom) (pullbackIsoOver f hae))))
+
+equivOver→IsoOver :
+  (e : A ≃ B)
+  (f : mapOver (e .fst) P Q)
+  → isEquivOver {P = P} {Q = Q} f
+  → IsoOver (equivToIso e) P Q
+equivOver→IsoOver {P = P} {Q = Q} e f equiv = w
+  where
+  isom = liftHAEToIsoOver _ (equiv→HAEquiv e .snd) (λ a → equivToIso (_ , equiv a))
+
+  -- no-eta-equality for Iso, so we have to fill in fields manually
+  w : IsoOver (equivToIso e) P Q
+  w .fun = isom .fun
+  w .inv = isom .inv
+  w .rightInv = isom .rightInv
+  w .leftInv  = isom .leftInv
+
+
+-- Turn isomorphism over HAE into relative equivalence,
+-- i.e. the inverse of the previous precedure.
+
+isoToEquivOver :
+  {A : Type ℓ } {P : A → Type ℓ'' }
+  {B : Type ℓ'} {Q : B → Type ℓ'''}
+  (f : A → B) (hae : isHAEquiv f)
+  (isom' : IsoOver (isHAEquiv→Iso hae) P Q)
+  → isEquivOver {Q = Q} (isom' .fun)
+isoToEquivOver {A = A} {P} {Q = Q} f hae isom' a = isoToEquiv (fibiso a) .snd
+  where
+  isom = isHAEquiv→Iso hae
+  finv = isom .inv
+
+  fibiso : (a : A) → Iso (P a) (Q (f a))
+  fibiso a .fun = isom' .fun a
+  fibiso a .inv x = transport (λ i → P (isom .leftInv a i)) (isom' .inv (f a) x)
+  fibiso a .leftInv  x = fromPathP (isom' .leftInv _ _)
+  fibiso a .rightInv x =
+    sym (substCommSlice _ _ (isom' .fun) _ _)
+    ∙ cong (λ p → subst Q p (isom' .fun _ (isom' .inv _ x))) (hae .com a)
+    ∙ fromPathP (isom' .rightInv _ _)
+
+
+-- Half-adjoint equivalence over half-adjoint equivalence
+
+record isHAEquivOver {ℓ ℓ'} {A : Type ℓ}{B : Type ℓ'}
+  (hae : HAEquiv A B)(P : A → Type ℓ'')(Q : B → Type ℓ''')
+  (fun : mapOver (hae .fst) P Q)
+  : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓ'' ℓ''')) where
+  field
+    inv  : mapOver (hae .snd .inv) Q P
+    rinv : sectionOver (hae .snd .rinv) fun inv
+    linv : retractOver (hae .snd .linv) fun inv
+    com  : ∀ {a} b → SquareP (λ i j → Q (hae .snd .com a i j))
+      (λ i → fun _ (linv _ b i)) (rinv _ (fun _ b))
+      (refl {x = fun _ (inv _ (fun a b))}) (refl {x = fun a b})
+
+open isHAEquivOver
+
+HAEquivOver : (P : A → Type ℓ'')(Q : B → Type ℓ''')(hae : HAEquiv A B) → Type _
+HAEquivOver P Q hae = Σ[ f ∈ mapOver (hae .fst) P Q ] isHAEquivOver hae P Q f
+
+
+-- forget the coherence square to get an dependent isomorphism
+
+isHAEquivOver→isIsoOver :
+  {hae : HAEquiv A B} (hae' : HAEquivOver P Q hae)
+  → IsoOver (isHAEquiv→Iso (hae .snd)) P Q
+isHAEquivOver→isIsoOver hae' .fun = hae' .fst
+isHAEquivOver→isIsoOver hae' .inv = hae' .snd .inv
+isHAEquivOver→isIsoOver hae' .leftInv  = hae' .snd .linv
+isHAEquivOver→isIsoOver hae' .rightInv = hae' .snd .rinv
+
+
+-- A dependent version of `isoToHAEquiv`
+
+IsoOver→HAEquivOver :
+  {isom : Iso A B}
+  → (isom' : IsoOver isom P Q)
+  → isHAEquivOver (iso→HAEquiv isom) P Q (isom' .fun)
+IsoOver→HAEquivOver {A = A} {P = P} {Q = Q} {isom = isom} isom' = w
+  where
+  f = isom .fun
+  g = isom .inv
+  ε = isom .rightInv
+  η = isom .leftInv
+
+  f' = isom' .fun
+  g' = isom' .inv
+  ε' = isom' .rightInv
+  η' = isom' .leftInv
+
+  sq : _ → I → I → _
+  sq b i j =
+    hfill (λ j → λ
+      { (i = i0) → ε (f (g b)) j
+      ; (i = i1) → ε b j })
+    (inS (f (η (g b) i))) j
+
+  Hfa≡fHa : (f : A → A) (H : ∀ a → f a ≡ a) → ∀ a → H (f a) ≡ cong f (H a)
+  Hfa≡fHa f H =
+    J (λ f p → ∀ a → funExt⁻ (sym p) (f a) ≡ cong f (funExt⁻ (sym p) a))
+      (λ a → refl) (sym (funExt H))
+
+  Hfa≡fHaRefl : Hfa≡fHa (idfun _) (λ _ → refl) ≡ λ _ → refl
+  Hfa≡fHaRefl =
+    JRefl {x = idfun _}
+      (λ f p → ∀ a → funExt⁻ (sym p) (f a) ≡ cong f (funExt⁻ (sym p) a))
+      (λ a → refl)
+
+  Hfa≡fHaOver : (f : A → A) (H : ∀ a → f a ≡ a)
+    (f' : mapOver f P P) (H' : ∀ a b → PathP (λ i → P (H a i)) (f' _ b) b)
+    → ∀ a b → SquareP (λ i j →
+      P (Hfa≡fHa f H a i j)) (H' _ (f' _ b)) (λ i → f' _ (H' _ b i)) refl refl
+  Hfa≡fHaOver f H f' H' =
+   JDep {B = λ f → mapOver f P P}
+    (λ f p f' p' → ∀ a b
+      → SquareP (λ i j → P (Hfa≡fHa f (funExt⁻ (sym p)) a i j))
+          (λ i → p' (~ i) _ (f' _ b)) (λ i → f' _ (p' (~ i) _ b))
+          (refl {x = f' _ (f' _ b)}) (refl {x = f' _ b}))
+    (λ a b →
+      transport (λ t → SquareP (λ i j → P (Hfa≡fHaRefl (~ t) a i j))
+        (refl {x = b}) refl refl refl) refl)
+    (sym (funExt H)) (λ i a b → H' a b (~ i))
+
+  cube : _ → I → I → I → _
+  cube a i j k =
+    hfill (λ k → λ
+      { (i = i0) → ε (f (η a j)) k
+      ; (j = i0) → ε (f (g (f a))) k
+      ; (j = i1) → ε (f a) k})
+    (inS (f (Hfa≡fHa (λ x → g (f x)) η a (~ i) j))) k
+
+  w : isHAEquivOver _ _ _ _
+  w .inv  = isom' .inv
+  w .linv = isom' .leftInv
+  w .rinv b x i =
+    comp (λ j → Q (sq b i j))
+    (λ j → λ
+      { (i = i0) → ε' _ (f' _ (g' _ x)) j
+      ; (i = i1) → ε' _ x j })
+    (f' _ (η' _ (g' _ x) i))
+  w. com {a} b i j =
+    comp (λ k → Q (cube a i j k))
+    (λ k → λ
+      { (i = i0) → ε' _ (f' _ (η' _ b j)) k
+      ; (j = i0) → ε' _ (f' _ (g' _ (f' _ b))) k
+      ; (j = i1) → ε' _ (f' _ b) k})
+    (f' _ (Hfa≡fHaOver _ η _ η' a b (~ i) j))
+
+
+-- transform an isomorphism over some isomorphism to an isomorphism over its half-adjoint-ization
+
+IsoOverIso→IsoOverHAEquiv :
+  {isom : Iso A B} (isom' : IsoOver isom P Q)
+  → IsoOver (isHAEquiv→Iso (iso→HAEquiv isom .snd)) P Q
+IsoOverIso→IsoOverHAEquiv isom' =
+  isHAEquivOver→isIsoOver (_ , IsoOver→HAEquivOver isom')
+
\ No newline at end of file diff --git a/docs/Cubical.Foundations.Equiv.Fiberwise.html b/docs/Cubical.Foundations.Equiv.Fiberwise.html index 77b11da..a11baca 100644 --- a/docs/Cubical.Foundations.Equiv.Fiberwise.html +++ b/docs/Cubical.Foundations.Equiv.Fiberwise.html @@ -27,14 +27,14 @@ fibers-total {xv} = iso h g h-g g-h where h : ∀ {xv} → fiber total xv → fiber (f (xv .fst)) (xv .snd) - h {xv} (p , eq) = J (\ xv eq → fiber (f (xv .fst)) (xv .snd)) ((p .snd) , refl) eq + h {xv} (p , eq) = J (\ xv eq → fiber (f (xv .fst)) (xv .snd)) ((p .snd) , refl) eq g : ∀ {xv} → fiber (f (xv .fst)) (xv .snd) → fiber total xv g {xv} (p , eq) = (xv .fst , p) , (\ i → _ , eq i) h-g : ∀ {xv} y → h {xv} (g {xv} y) ≡ y - h-g {x , v} (p , eq) = J (λ _ eq₁ → h (g (p , eq₁)) ≡ (p , eq₁)) (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) ((p , refl))) (eq) + h-g {x , v} (p , eq) = J (λ _ eq₁ → h (g (p , eq₁)) ≡ (p , eq₁)) (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) ((p , refl))) (eq) g-h : ∀ {xv} y → g {xv} (h {xv} y) ≡ y - g-h {xv} ((a , p) , eq) = J (λ _ eq₁ → g (h ((a , p) , eq₁)) ≡ ((a , p) , eq₁)) - (cong g (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) (p , refl))) + g-h {xv} ((a , p) , eq) = J (λ _ eq₁ → g (h ((a , p) , eq₁)) ≡ ((a , p) , eq₁)) + (cong g (JRefl (λ xv₁ eq₁ → fiber (f (xv₁ .fst)) (xv₁ .snd)) (p , refl))) eq -- Thm 4.7.7 (fiberwise equivalences) fiberEquiv : ([tf] : isEquiv total) @@ -57,7 +57,7 @@ isContrToUniv {A} {B} = fiberEquiv (λ z → A ≡ z) (λ z → A ~ z) (\ B → idTo~ {A} {B}) (λ { .equiv-proof y - → isContrΣ (isContrSingl _) + → isContrΣ (isContrSingl _) \ a → isContr→isContrPath (c A) _ _ }) B @@ -69,33 +69,33 @@ -} recognizeId : {A : Type ℓ} {a : A} (Eq : A → Type ℓ') → Eq a - → isContr (Σ _ Eq) + → isContr (Σ _ Eq) → (x : A) → (a ≡ x) ≃ (Eq x) recognizeId {A = A} {a = a} Eq eqRefl eqContr x = (fiberMap x) , (isEquivFiberMap x) where fiberMap : (x : A) → a ≡ x → Eq x - fiberMap x = J (λ x p → Eq x) eqRefl + fiberMap x = J (λ x p → Eq x) eqRefl mapOnSigma : Σ[ x ∈ A ] a ≡ x → Σ _ Eq mapOnSigma pair = fst pair , fiberMap (fst pair) (snd pair) equivOnSigma : (x : A) → isEquiv mapOnSigma - equivOnSigma x = isEquivFromIsContr mapOnSigma (isContrSingl a) eqContr + equivOnSigma x = isEquivFromIsContr mapOnSigma (isContrSingl a) eqContr isEquivFiberMap : (x : A) → isEquiv (fiberMap x) isEquivFiberMap = fiberEquiv (λ x → a ≡ x) Eq fiberMap (equivOnSigma x) fundamentalTheoremOfId : {A : Type ℓ} (Eq : A → A → Type ℓ') → ((x : A) → Eq x x) - → ((x : A) → isContr (Σ[ y ∈ A ] Eq x y)) + → ((x : A) → isContr (Σ[ y ∈ A ] Eq x y)) → (x y : A) → (x ≡ y) ≃ (Eq x y) fundamentalTheoremOfId Eq eqRefl eqContr x = recognizeId (Eq x) (eqRefl x) (eqContr x) fundamentalTheoremOfIdβ : {A : Type ℓ} (Eq : A → A → Type ℓ') → (eqRefl : (x : A) → Eq x x) - → (eqContr : (x : A) → isContr (Σ[ y ∈ A ] Eq x y)) + → (eqContr : (x : A) → isContr (Σ[ y ∈ A ] Eq x y)) → (x : A) → fst (fundamentalTheoremOfId Eq eqRefl eqContr x x) refl ≡ eqRefl x -fundamentalTheoremOfIdβ Eq eqRefl eqContr x = JRefl (λ y p → Eq x y) (eqRefl x) +fundamentalTheoremOfIdβ Eq eqRefl eqContr x = JRefl (λ y p → Eq x y) (eqRefl x) \ No newline at end of file diff --git a/docs/Cubical.Foundations.Equiv.HalfAdjoint.html b/docs/Cubical.Foundations.Equiv.HalfAdjoint.html index 42585ec..34279a4 100644 --- a/docs/Cubical.Foundations.Equiv.HalfAdjoint.html +++ b/docs/Cubical.Foundations.Equiv.HalfAdjoint.html @@ -52,10 +52,10 @@ gy≡x : g y ≡ x gy≡x = sym (cong g p) ∙∙ refl ∙∙ linv x - lem0 : Square (cong f (linv x)) p (cong f (linv x)) p + lem0 : Square (cong f (linv x)) p (cong f (linv x)) p lem0 i j = invSides-filler p (sym (cong f (linv x))) (~ i) j - ry≡p : Square (rinv y) p (cong f gy≡x) refl + ry≡p : Square (rinv y) p (cong f gy≡x) refl ry≡p i j = hcomp (λ k → λ { (i = i0) → cong rinv p k j ; (i = i1) → lem0 k j ; (j = i0) → f (doubleCompPath-filler (sym (cong g p)) refl (linv x) k i) @@ -77,7 +77,7 @@ η = Iso.leftInv e Hfa≡fHa : (f : A → A) → (H : ∀ a → f a ≡ a) → ∀ a → H (f a) ≡ cong f (H a) - Hfa≡fHa f H = J (λ f p → ∀ a → funExt⁻ (sym p) (f a) ≡ cong f (funExt⁻ (sym p) a)) + Hfa≡fHa f H = J (λ f p → ∀ a → funExt⁻ (sym p) (f a) ≡ cong f (funExt⁻ (sym p) a)) (λ a → refl) (sym (funExt H)) @@ -96,10 +96,10 @@ equiv→HAEquiv : A ≃ B → HAEquiv A B equiv→HAEquiv e = e .fst , λ where - .isHAEquiv.g → invIsEq (snd e) - .isHAEquiv.linv → retIsEq (snd e) - .isHAEquiv.rinv → secIsEq (snd e) - .isHAEquiv.com a → sym (commPathIsEq (snd e) a) + .isHAEquiv.g → invIsEq (snd e) + .isHAEquiv.linv → retIsEq (snd e) + .isHAEquiv.rinv → secIsEq (snd e) + .isHAEquiv.com a → sym (commPathIsEq (snd e) a) congIso : {x y : A} (e : Iso A B) → Iso (x ≡ y) (Iso.fun e x ≡ Iso.fun e y) congIso {x = x} {y} e = goal @@ -130,7 +130,7 @@ helper : {x : A} {y : B} (f : A → B) (r : f x ≡ y) (p q : x ≡ x) → (sym r ∙∙ cong f (p ∙ q) ∙∙ r) ≡ (sym r ∙∙ cong f p ∙∙ r) ∙ (sym r ∙∙ cong f q ∙∙ r) helper {x = x} f = - J (λ y r → (p q : x ≡ x) + J (λ y r → (p q : x ≡ x) → (sym r ∙∙ cong f (p ∙ q) ∙∙ r) ≡ (sym r ∙∙ cong f p ∙∙ r) ∙ (sym r ∙∙ cong f q ∙∙ r)) λ p q → (λ i → rUnit (congFunct f p q i) (~ i)) ∙ λ i → rUnit (cong f p) i ∙ rUnit (cong f q) i diff --git a/docs/Cubical.Foundations.Equiv.Properties.html b/docs/Cubical.Foundations.Equiv.Properties.html index 8225c96..cd3e02e 100644 --- a/docs/Cubical.Foundations.Equiv.Properties.html +++ b/docs/Cubical.Foundations.Equiv.Properties.html @@ -33,38 +33,38 @@ ℓ ℓ' ℓ'' : Level A B C : Type ℓ -isEquivInvEquiv : isEquiv (λ (e : A ≃ B) → invEquiv e) +isEquivInvEquiv : isEquiv (λ (e : A ≃ B) → invEquiv e) isEquivInvEquiv = isoToIsEquiv goal where open Iso goal : Iso (A ≃ B) (B ≃ A) - goal .fun = invEquiv - goal .inv = invEquiv - goal .rightInv g = equivEq refl - goal .leftInv f = equivEq refl + goal .fun = invEquiv + goal .inv = invEquiv + goal .rightInv g = equivEq refl + goal .leftInv f = equivEq refl invEquivEquiv : (A ≃ B) ≃ (B ≃ A) invEquivEquiv = _ , isEquivInvEquiv isEquivCong : {x y : A} (e : A ≃ B) → isEquiv (λ (p : x ≡ y) → cong (equivFun e) p) -isEquivCong e = isoToIsEquiv (congIso (equivToIso e)) +isEquivCong e = isoToIsEquiv (congIso (equivToIso e)) congEquiv : {x y : A} (e : A ≃ B) → (x ≡ y) ≃ (equivFun e x ≡ equivFun e y) -congEquiv e = isoToEquiv (congIso (equivToIso e)) +congEquiv e = isoToEquiv (congIso (equivToIso e)) -equivAdjointEquiv : (e : A ≃ B) → ∀ {a b} → (a ≡ invEq e b) ≃ (equivFun e a ≡ b) -equivAdjointEquiv e = compEquiv (congEquiv e) (compPathrEquiv (secEq e _)) +equivAdjointEquiv : (e : A ≃ B) → ∀ {a b} → (a ≡ invEq e b) ≃ (equivFun e a ≡ b) +equivAdjointEquiv e = compEquiv (congEquiv e) (compPathrEquiv (secEq e _)) -invEq≡→equivFun≡ : (e : A ≃ B) → ∀ {a b} → invEq e b ≡ a → equivFun e a ≡ b +invEq≡→equivFun≡ : (e : A ≃ B) → ∀ {a b} → invEq e b ≡ a → equivFun e a ≡ b invEq≡→equivFun≡ e = equivFun (equivAdjointEquiv e) ∘ sym isEquivPreComp : (e : A ≃ B) → isEquiv (λ (φ : B → C) → φ ∘ equivFun e) -isEquivPreComp e = snd (equiv→ (invEquiv e) (idEquiv _)) +isEquivPreComp e = snd (equiv→ (invEquiv e) (idEquiv _)) preCompEquiv : (e : A ≃ B) → (B → C) ≃ (A → C) preCompEquiv e = (λ φ → φ ∘ fst e) , isEquivPreComp e isEquivPostComp : (e : A ≃ B) → isEquiv (λ (φ : C → A) → e .fst ∘ φ) -isEquivPostComp e = snd (equivΠCod (λ _ → e)) +isEquivPostComp e = snd (equivΠCod (λ _ → e)) postCompEquiv : (e : A ≃ B) → (C → A) ≃ (C → B) postCompEquiv e = _ , isEquivPostComp e @@ -77,43 +77,43 @@ hasRetract : (A → B) → Type _ hasRetract {A = A} {B = B} f = Σ[ g ∈ (B → A) ] retract f g -isEquiv→isContrHasSection : {f : A → B} → isEquiv f → isContr (hasSection f) -fst (isEquiv→isContrHasSection isEq) = invIsEq isEq , secIsEq isEq +isEquiv→isContrHasSection : {f : A → B} → isEquiv f → isContr (hasSection f) +fst (isEquiv→isContrHasSection isEq) = invIsEq isEq , secIsEq isEq snd (isEquiv→isContrHasSection isEq) (f , ε) i = (λ b → fst (p b i)) , (λ b → snd (p b i)) - where p : ∀ b → (invIsEq isEq b , secIsEq isEq b) ≡ (f b , ε b) + where p : ∀ b → (invIsEq isEq b , secIsEq isEq b) ≡ (f b , ε b) p b = isEq .equiv-proof b .snd (f b , ε b) isEquiv→hasSection : {f : A → B} → isEquiv f → hasSection f isEquiv→hasSection = fst ∘ isEquiv→isContrHasSection -isContr-hasSection : (e : A ≃ B) → isContr (hasSection (fst e)) +isContr-hasSection : (e : A ≃ B) → isContr (hasSection (fst e)) isContr-hasSection e = isEquiv→isContrHasSection (snd e) -isEquiv→isContrHasRetract : {f : A → B} → isEquiv f → isContr (hasRetract f) -fst (isEquiv→isContrHasRetract isEq) = invIsEq isEq , retIsEq isEq +isEquiv→isContrHasRetract : {f : A → B} → isEquiv f → isContr (hasRetract f) +fst (isEquiv→isContrHasRetract isEq) = invIsEq isEq , retIsEq isEq snd (isEquiv→isContrHasRetract {f = f} isEq) (g , η) = λ i → (λ b → p b i) , (λ a → q a i) - where p : ∀ b → invIsEq isEq b ≡ g b - p b = sym (η (invIsEq isEq b)) ∙' cong g (secIsEq isEq b) + where p : ∀ b → invIsEq isEq b ≡ g b + p b = sym (η (invIsEq isEq b)) ∙' cong g (secIsEq isEq b) -- one square from the definition of invIsEq - ieSq : ∀ a → Square (cong g (secIsEq isEq (f a))) + ieSq : ∀ a → Square (cong g (secIsEq isEq (f a))) refl - (cong (g ∘ f) (retIsEq isEq a)) + (cong (g ∘ f) (retIsEq isEq a)) refl - ieSq a k j = g (commSqIsEq isEq a k j) + ieSq a k j = g (commSqIsEq isEq a k j) -- one square from η - ηSq : ∀ a → Square (η (invIsEq isEq (f a))) + ηSq : ∀ a → Square (η (invIsEq isEq (f a))) (η a) - (cong (g ∘ f) (retIsEq isEq a)) - (retIsEq isEq a) - ηSq a i j = η (retIsEq isEq a i) j + (cong (g ∘ f) (retIsEq isEq a)) + (retIsEq isEq a) + ηSq a i j = η (retIsEq isEq a i) j -- and one last square from the definition of p - pSq : ∀ b → Square (η (invIsEq isEq b)) + pSq : ∀ b → Square (η (invIsEq isEq b)) refl - (cong g (secIsEq isEq b)) + (cong g (secIsEq isEq b)) (p b) - pSq b i j = compPath'-filler (sym (η (invIsEq isEq b))) (cong g (secIsEq isEq b)) j i - q : ∀ a → Square (retIsEq isEq a) (η a) (p (f a)) refl + pSq b i j = compPath'-filler (sym (η (invIsEq isEq b))) (cong g (secIsEq isEq b)) j i + q : ∀ a → Square (retIsEq isEq a) (η a) (p (f a)) refl q a i j = hcomp (λ k → λ { (i = i0) → ηSq a j k ; (i = i1) → η a (j ∧ k) ; (j = i0) → pSq (f a) i k @@ -124,12 +124,12 @@ isEquiv→hasRetract : {f : A → B} → isEquiv f → hasRetract f isEquiv→hasRetract = fst ∘ isEquiv→isContrHasRetract -isContr-hasRetract : (e : A ≃ B) → isContr (hasRetract (fst e)) +isContr-hasRetract : (e : A ≃ B) → isContr (hasRetract (fst e)) isContr-hasRetract e = isEquiv→isContrHasRetract (snd e) isEquiv→retractIsEquiv : {f : A → B} {g : B → A} → isEquiv f → retract f g → isEquiv g isEquiv→retractIsEquiv {f = f} {g = g} isEquiv-f retract-g = subst isEquiv f⁻¹≡g (snd f⁻¹) - where f⁻¹ = invEquiv (f , isEquiv-f) + where f⁻¹ = invEquiv (f , isEquiv-f) retract-f⁻¹ : retract f (fst f⁻¹) retract-f⁻¹ = snd (isEquiv→hasRetract isEquiv-f) @@ -137,14 +137,14 @@ f⁻¹≡g : fst f⁻¹ ≡ g f⁻¹≡g = cong fst - (isContr→isProp (isEquiv→isContrHasRetract isEquiv-f) + (isContr→isProp (isEquiv→isContrHasRetract isEquiv-f) (fst f⁻¹ , retract-f⁻¹) (g , retract-g)) isEquiv→sectionIsEquiv : {f : A → B} {g : B → A} → isEquiv f → section f g → isEquiv g isEquiv→sectionIsEquiv {f = f} {g = g} isEquiv-f section-g = subst isEquiv f⁻¹≡g (snd f⁻¹) - where f⁻¹ = invEquiv (f , isEquiv-f) + where f⁻¹ = invEquiv (f , isEquiv-f) section-f⁻¹ : section f (fst f⁻¹) section-f⁻¹ = snd (isEquiv→hasSection isEquiv-f) @@ -152,7 +152,7 @@ f⁻¹≡g : fst f⁻¹ ≡ g f⁻¹≡g = cong fst - (isContr→isProp (isEquiv→isContrHasSection isEquiv-f) + (isContr→isProp (isEquiv→isContrHasSection isEquiv-f) (fst f⁻¹ , section-f⁻¹) (g , section-g)) @@ -167,7 +167,7 @@ pathToEquiv refl ≡⟨ pathToEquivRefl ⟩ idEquiv (F A) ∎ -isPropIsHAEquiv : {f : A → B} → isProp (isHAEquiv f) +isPropIsHAEquiv : {f : A → B} → isProp (isHAEquiv f) isPropIsHAEquiv {f = f} ishaef = goal ishaef where equivF : isEquiv f equivF = isHAEquiv→isEquiv ishaef @@ -176,10 +176,10 @@ rCoh1 (g , ε) = Σ[ η ∈ retract f g ] ∀ x → cong f (η x) ≡ ε (f x) rCoh2 : (sec : hasSection f) → Type _ - rCoh2 (g , ε) = Σ[ η ∈ retract f g ] ∀ x → Square (ε (f x)) refl (cong f (η x)) refl + rCoh2 (g , ε) = Σ[ η ∈ retract f g ] ∀ x → Square (ε (f x)) refl (cong f (η x)) refl rCoh3 : (sec : hasSection f) → Type _ - rCoh3 (g , ε) = ∀ x → Σ[ ηx ∈ g (f x) ≡ x ] Square (ε (f x)) refl (cong f ηx) refl + rCoh3 (g , ε) = ∀ x → Σ[ ηx ∈ g (f x) ≡ x ] Square (ε (f x)) refl (cong f ηx) refl rCoh4 : (sec : hasSection f) → Type _ rCoh4 (g , ε) = ∀ x → Path (fiber f (f x)) (g (f x) , ε (f x)) (x , refl) @@ -188,31 +188,31 @@ characterization = isHAEquiv f -- first convert between Σ and record - ≃⟨ isoToEquiv (iso (λ e → (e .g , e .rinv) , (e .linv , e .com)) + ≃⟨ isoToEquiv (iso (λ e → (e .g , e .rinv) , (e .linv , e .com)) (λ e → record { g = e .fst .fst ; rinv = e .fst .snd ; linv = e .snd .fst ; com = e .snd .snd }) - (λ _ → refl) λ _ → refl) ⟩ + (λ _ → refl) λ _ → refl) ⟩ Σ _ rCoh1 -- secondly, convert the path into a dependent path for later convenience - ≃⟨ Σ-cong-equiv-snd (λ s → Σ-cong-equiv-snd - λ η → equivΠCod - λ x → compEquiv (flipSquareEquiv {a₀₀ = f x}) (invEquiv slideSquareEquiv)) ⟩ + ≃⟨ Σ-cong-equiv-snd (λ s → Σ-cong-equiv-snd + λ η → equivΠCod + λ x → compEquiv (flipSquareEquiv {a₀₀ = f x}) (invEquiv slideSquareEquiv)) ⟩ Σ _ rCoh2 - ≃⟨ Σ-cong-equiv-snd (λ s → invEquiv Σ-Π-≃) ⟩ + ≃⟨ Σ-cong-equiv-snd (λ s → invEquiv Σ-Π-≃) ⟩ Σ _ rCoh3 - ≃⟨ Σ-cong-equiv-snd (λ s → equivΠCod λ x → ΣPath≃PathΣ) ⟩ + ≃⟨ Σ-cong-equiv-snd (λ s → equivΠCod λ x → ΣPath≃PathΣ) ⟩ Σ _ rCoh4 - ■ + ■ where open isHAEquiv - goal : isProp (isHAEquiv f) - goal = subst isProp (sym (ua characterization)) - (isPropΣ (isContr→isProp (isEquiv→isContrHasSection equivF)) - λ s → isPropΠ λ x → isProp→isSet (isContr→isProp (equivF .equiv-proof (f x))) _ _) + goal : isProp (isHAEquiv f) + goal = subst isProp (sym (ua characterization)) + (isPropΣ (isContr→isProp (isEquiv→isContrHasSection equivF)) + λ s → isPropΠ λ x → isProp→isSet (isContr→isProp (equivF .equiv-proof (f x))) _ _) -- loop spaces connected by a path are equivalent conjugatePathEquiv : {A : Type ℓ} {a b : A} (p : a ≡ b) → (a ≡ a) ≃ (b ≡ b) -conjugatePathEquiv p = compEquiv (compPathrEquiv p) (compPathlEquiv (sym p)) +conjugatePathEquiv p = compEquiv (compPathrEquiv p) (compPathlEquiv (sym p)) -- composition on the right induces an equivalence of path types compr≡Equiv : {A : Type ℓ} {a b c : A} (p q : a ≡ b) (r : b ≡ c) → (p ≡ q) ≃ (p ∙ r ≡ q ∙ r) @@ -223,37 +223,37 @@ compl≡Equiv p q r = congEquiv ((λ s → p ∙ s) , (compPathl-isEquiv p)) isEquivFromIsContr : {A : Type ℓ} {B : Type ℓ'} - → (f : A → B) → isContr A → isContr B + → (f : A → B) → isContr A → isContr B → isEquiv f isEquivFromIsContr f isContrA isContrB = - subst isEquiv (λ i x → isContr→isProp isContrB (fst B≃A x) (f x) i) (snd B≃A) - where B≃A = isContr→Equiv isContrA isContrB + subst isEquiv (λ i x → isContr→isProp isContrB (fst B≃A x) (f x) i) (snd B≃A) + where B≃A = isContr→Equiv isContrA isContrB isEquiv[f∘equivFunA≃B]→isEquiv[f] : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} → (f : B → C) (A≃B : A ≃ B) → isEquiv (f ∘ equivFun A≃B) → isEquiv f isEquiv[f∘equivFunA≃B]→isEquiv[f] f (g , gIsEquiv) f∘gIsEquiv = - precomposesToId→Equiv f _ w w' + precomposesToId→Equiv f _ w w' where - w : f ∘ g ∘ equivFun (invEquiv (_ , f∘gIsEquiv)) ≡ idfun _ - w = (cong fst (invEquiv-is-linv (_ , f∘gIsEquiv))) + w : f ∘ g ∘ equivFun (invEquiv (_ , f∘gIsEquiv)) ≡ idfun _ + w = (cong fst (invEquiv-is-linv (_ , f∘gIsEquiv))) - w' : isEquiv (g ∘ equivFun (invEquiv (_ , f∘gIsEquiv))) - w' = (snd (compEquiv (invEquiv (_ , f∘gIsEquiv) ) (_ , gIsEquiv))) + w' : isEquiv (g ∘ equivFun (invEquiv (_ , f∘gIsEquiv))) + w' = (snd (compEquiv (invEquiv (_ , f∘gIsEquiv) ) (_ , gIsEquiv))) isEquiv[equivFunA≃B∘f]→isEquiv[f] : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} → (f : C → A) (A≃B : A ≃ B) → isEquiv (equivFun A≃B ∘ f) → isEquiv f isEquiv[equivFunA≃B∘f]→isEquiv[f] f (g , gIsEquiv) g∘fIsEquiv = - composesToId→Equiv _ f w w' + composesToId→Equiv _ f w w' where - w : equivFun (invEquiv (_ , g∘fIsEquiv)) ∘ g ∘ f ≡ idfun _ - w = (cong fst (invEquiv-is-rinv (_ , g∘fIsEquiv))) + w : equivFun (invEquiv (_ , g∘fIsEquiv)) ∘ g ∘ f ≡ idfun _ + w = (cong fst (invEquiv-is-rinv (_ , g∘fIsEquiv))) - w' : isEquiv (equivFun (invEquiv (_ , g∘fIsEquiv)) ∘ g) - w' = snd (compEquiv (_ , gIsEquiv) (invEquiv (_ , g∘fIsEquiv))) + w' : isEquiv (equivFun (invEquiv (_ , g∘fIsEquiv)) ∘ g) + w' = snd (compEquiv (_ , gIsEquiv) (invEquiv (_ , g∘fIsEquiv))) isPointedTarget→isEquiv→isEquiv : {A B : Type ℓ} (f : A → B) → (B → isEquiv f) → isEquiv f diff --git a/docs/Cubical.Foundations.Equiv.html b/docs/Cubical.Foundations.Equiv.html index 37a371d..482462e 100644 --- a/docs/Cubical.Foundations.Equiv.html +++ b/docs/Cubical.Foundations.Equiv.html @@ -30,7 +30,7 @@ ℓ ℓ' ℓ'' : Level A B C D : Type ℓ -infixr 30 _∙ₑ_ +infixr 30 _∙ₑ_ equivIsEquiv : (e : A ≃ B) → isEquiv (equivFun e) equivIsEquiv e = snd e @@ -45,15 +45,15 @@ -- Proof using isPropIsContr. This is slow and the direct proof below is better -isPropIsEquiv' : (f : A → B) → isProp (isEquiv f) +isPropIsEquiv' : (f : A → B) → isProp (isEquiv f) equiv-proof (isPropIsEquiv' f u0 u1 i) y = - isPropIsContr (u0 .equiv-proof y) (u1 .equiv-proof y) i + isPropIsContr (u0 .equiv-proof y) (u1 .equiv-proof y) i -- Direct proof that computes quite ok (can be optimized further if -- necessary, see: -- https://github.com/mortberg/cubicaltt/blob/pi4s3_dimclosures/examples/brunerie2.ctt#L562 -isPropIsEquiv : (f : A → B) → isProp (isEquiv f) +isPropIsEquiv : (f : A → B) → isProp (isEquiv f) equiv-proof (isPropIsEquiv f p q i) y = let p2 = p .equiv-proof y .snd q2 = q .equiv-proof y .snd @@ -64,260 +64,265 @@ ; (j = i1) → w }) (p2 w (i ∨ j)) -equivEq : {e f : A ≃ B} → (h : e .fst ≡ f .fst) → e ≡ f -equivEq {e = e} {f = f} h = λ i → (h i) , isProp→PathP (λ i → isPropIsEquiv (h i)) (e .snd) (f .snd) i - -module _ {f : A → B} (equivF : isEquiv f) where - funIsEq : A → B - funIsEq = f - - invIsEq : B → A - invIsEq y = equivF .equiv-proof y .fst .fst - - secIsEq : section f invIsEq - secIsEq y = equivF .equiv-proof y .fst .snd - - retIsEq : retract f invIsEq - retIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .fst - - commSqIsEq : ∀ a → Square (secIsEq (f a)) refl (cong f (retIsEq a)) refl - commSqIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .snd - - commPathIsEq : ∀ a → secIsEq (f a) ≡ cong f (retIsEq a) - commPathIsEq a i j = - hcomp - (λ k → λ - { (i = i0) → secIsEq (f a) j - ; (i = i1) → f (retIsEq a (j ∨ ~ k)) - ; (j = i0) → f (retIsEq a (i ∧ ~ k)) - ; (j = i1) → f a - }) - (commSqIsEq a i j) - -module _ (w : A ≃ B) where - invEq : B → A - invEq = invIsEq (snd w) - - retEq : retract (w .fst) invEq - retEq = retIsEq (snd w) - - secEq : section (w .fst) invEq - secEq = secIsEq (snd w) - -open Iso - -equivToIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → A ≃ B → Iso A B -fun (equivToIso e) = e .fst -inv (equivToIso e) = invEq e -rightInv (equivToIso e) = secEq e -leftInv (equivToIso e) = retEq e - --- TODO: there should be a direct proof of this that doesn't use equivToIso -invEquiv : A ≃ B → B ≃ A -invEquiv e = isoToEquiv (invIso (equivToIso e)) - -invEquivIdEquiv : (A : Type ℓ) → invEquiv (idEquiv A) ≡ idEquiv A -invEquivIdEquiv _ = equivEq refl - -compEquiv : A ≃ B → B ≃ C → A ≃ C -compEquiv f g .fst = g .fst ∘ f .fst -compEquiv {A = A} {C = C} f g .snd .equiv-proof c = contr - where - contractG = g .snd .equiv-proof c .snd - - secFiller : (a : A) (p : g .fst (f .fst a) ≡ c) → _ {- square in A -} - secFiller a p = compPath-filler (cong (invEq f ∘ fst) (contractG (_ , p))) (retEq f a) - - contr : isContr (fiber (g .fst ∘ f .fst) c) - contr .fst .fst = invEq f (invEq g c) - contr .fst .snd = cong (g .fst) (secEq f (invEq g c)) ∙ secEq g c - contr .snd (a , p) i .fst = secFiller a p i1 i - contr .snd (a , p) i .snd j = - hcomp - (λ k → λ - { (i = i1) → fSquare k - ; (j = i0) → g .fst (f .fst (secFiller a p k i)) - ; (j = i1) → contractG (_ , p) i .snd k - }) - (g .fst (secEq f (contractG (_ , p) i .fst) j)) - where - fSquare : I → C - fSquare k = - hcomp - (λ l → λ - { (j = i0) → g .fst (f .fst (retEq f a k)) - ; (j = i1) → p (k ∧ l) - ; (k = i0) → g .fst (secEq f (f .fst a) j) - ; (k = i1) → p (j ∧ l) - }) - (g .fst (f .snd .equiv-proof (f .fst a) .snd (a , refl) k .snd j)) - -_∙ₑ_ = compEquiv - -compEquivIdEquiv : (e : A ≃ B) → compEquiv (idEquiv A) e ≡ e -compEquivIdEquiv e = equivEq refl - -compEquivEquivId : (e : A ≃ B) → compEquiv e (idEquiv B) ≡ e -compEquivEquivId e = equivEq refl - -invEquiv-is-rinv : (e : A ≃ B) → compEquiv e (invEquiv e) ≡ idEquiv A -invEquiv-is-rinv e = equivEq (funExt (retEq e)) - -invEquiv-is-linv : (e : A ≃ B) → compEquiv (invEquiv e) e ≡ idEquiv B -invEquiv-is-linv e = equivEq (funExt (secEq e)) - -compEquiv-assoc : (f : A ≃ B) (g : B ≃ C) (h : C ≃ D) - → compEquiv f (compEquiv g h) ≡ compEquiv (compEquiv f g) h -compEquiv-assoc f g h = equivEq refl - -LiftEquiv : A ≃ Lift {i = ℓ} {j = ℓ'} A -LiftEquiv .fst a .lower = a -LiftEquiv .snd .equiv-proof = strictContrFibers lower - -Lift≃Lift : (e : A ≃ B) → Lift {j = ℓ'} A ≃ Lift {j = ℓ''} B -Lift≃Lift e .fst a .lower = e .fst (a .lower) -Lift≃Lift e .snd .equiv-proof b .fst .fst .lower = invEq e (b .lower) -Lift≃Lift e .snd .equiv-proof b .fst .snd i .lower = - e .snd .equiv-proof (b .lower) .fst .snd i -Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .fst .lower = - e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .fst -Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .snd j .lower = - e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .snd j - -isContr→Equiv : isContr A → isContr B → A ≃ B -isContr→Equiv Actr Bctr = isoToEquiv (isContr→Iso Actr Bctr) - -propBiimpl→Equiv : (Aprop : isProp A) (Bprop : isProp B) (f : A → B) (g : B → A) → A ≃ B -propBiimpl→Equiv Aprop Bprop f g = f , hf - where - hf : isEquiv f - hf .equiv-proof y .fst = (g y , Bprop (f (g y)) y) - hf .equiv-proof y .snd h i .fst = Aprop (g y) (h .fst) i - hf .equiv-proof y .snd h i .snd = isProp→isSet' Bprop (Bprop (f (g y)) y) (h .snd) - (cong f (Aprop (g y) (h .fst))) refl i - -isEquivPropBiimpl→Equiv : isProp A → isProp B - → ((A → B) × (B → A)) ≃ (A ≃ B) -isEquivPropBiimpl→Equiv {A = A} {B = B} Aprop Bprop = isoToEquiv isom where - isom : Iso (Σ (A → B) (λ _ → B → A)) (A ≃ B) - isom .fun (f , g) = propBiimpl→Equiv Aprop Bprop f g - isom .inv e = equivFun e , invEq e - isom .rightInv e = equivEq refl - isom .leftInv _ = refl - -equivΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'} - → ((x : A) → F x ≃ G x) → ((x : A) → F x) ≃ ((x : A) → G x) -equivΠCod k .fst f x = k x .fst (f x) -equivΠCod k .snd .equiv-proof f .fst .fst x = equivCtr (k x) (f x) .fst -equivΠCod k .snd .equiv-proof f .fst .snd i x = equivCtr (k x) (f x) .snd i -equivΠCod k .snd .equiv-proof f .snd (g , p) i .fst x = - equivCtrPath (k x) (f x) (g x , λ j → p j x) i .fst -equivΠCod k .snd .equiv-proof f .snd (g , p) i .snd j x = - equivCtrPath (k x) (f x) (g x , λ k → p k x) i .snd j - -equivImplicitΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'} - → ({x : A} → F x ≃ G x) → ({x : A} → F x) ≃ ({x : A} → G x) -equivImplicitΠCod k .fst f {x} = k {x} .fst (f {x}) -equivImplicitΠCod k .snd .equiv-proof f .fst .fst {x} = equivCtr (k {x}) (f {x}) .fst -equivImplicitΠCod k .snd .equiv-proof f .fst .snd i {x} = equivCtr (k {x}) (f {x}) .snd i -equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .fst {x} = - equivCtrPath (k {x}) (f {x}) (g {x} , λ j → p j {x}) i .fst -equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .snd j {x} = - equivCtrPath (k {x}) (f {x}) (g {x} , λ k → p k {x}) i .snd j - -equiv→Iso : (A ≃ B) → (C ≃ D) → Iso (A → C) (B → D) -equiv→Iso h k .Iso.fun f b = equivFun k (f (invEq h b)) -equiv→Iso h k .Iso.inv g a = invEq k (g (equivFun h a)) -equiv→Iso h k .Iso.rightInv g = funExt λ b → secEq k _ ∙ cong g (secEq h b) -equiv→Iso h k .Iso.leftInv f = funExt λ a → retEq k _ ∙ cong f (retEq h a) - -equiv→ : (A ≃ B) → (C ≃ D) → (A → C) ≃ (B → D) -equiv→ h k = isoToEquiv (equiv→Iso h k) - - -equivΠ' : ∀ {ℓA ℓA' ℓB ℓB'} {A : Type ℓA} {A' : Type ℓA'} - {B : A → Type ℓB} {B' : A' → Type ℓB'} - (eA : A ≃ A') - (eB : {a : A} {a' : A'} → eA .fst a ≡ a' → B a ≃ B' a') - → ((a : A) → B a) ≃ ((a' : A') → B' a') -equivΠ' {B' = B'} eA eB = isoToEquiv isom - where - open Iso - - isom : Iso _ _ - isom .fun f a' = - eB (secEq eA a') .fst (f (invEq eA a')) - isom .inv f' a = - invEq (eB refl) (f' (eA .fst a)) - isom .rightInv f' = - funExt λ a' → - J (λ a'' p → eB p .fst (invEq (eB refl) (f' (p i0))) ≡ f' a'') - (secEq (eB refl) (f' (eA .fst (invEq eA a')))) - (secEq eA a') - isom .leftInv f = - funExt λ a → - subst - (λ p → invEq (eB refl) (eB p .fst (f (invEq eA (eA .fst a)))) ≡ f a) - (sym (commPathIsEq (eA .snd) a)) - (J (λ a'' p → invEq (eB refl) (eB (cong (eA .fst) p) .fst (f (invEq eA (eA .fst a)))) ≡ f a'') - (retEq (eB refl) (f (invEq eA (eA .fst a)))) - (retEq eA a)) - -equivΠ : ∀ {ℓA ℓA' ℓB ℓB'} {A : Type ℓA} {A' : Type ℓA'} - {B : A → Type ℓB} {B' : A' → Type ℓB'} - (eA : A ≃ A') - (eB : (a : A) → B a ≃ B' (eA .fst a)) - → ((a : A) → B a) ≃ ((a' : A') → B' a') -equivΠ {B = B} {B' = B'} eA eB = equivΠ' eA (λ {a = a} p → J (λ a' p → B a ≃ B' a') (eB a) p) - - -equivCompIso : (A ≃ B) → (C ≃ D) → Iso (A ≃ C) (B ≃ D) -equivCompIso h k .Iso.fun f = compEquiv (compEquiv (invEquiv h) f) k -equivCompIso h k .Iso.inv g = compEquiv (compEquiv h g) (invEquiv k) -equivCompIso h k .Iso.rightInv g = equivEq (equiv→Iso h k .Iso.rightInv (equivFun g)) -equivCompIso h k .Iso.leftInv f = equivEq (equiv→Iso h k .Iso.leftInv (equivFun f)) - -equivComp : (A ≃ B) → (C ≃ D) → (A ≃ C) ≃ (B ≃ D) -equivComp h k = isoToEquiv (equivCompIso h k) - --- Some helpful notation: -_≃⟨_⟩_ : (X : Type ℓ) → (X ≃ B) → (B ≃ C) → (X ≃ C) -_ ≃⟨ f ⟩ g = compEquiv f g - -_■ : (X : Type ℓ) → (X ≃ X) -_■ = idEquiv - -infixr 0 _≃⟨_⟩_ -infix 1 _■ - -composesToId→Equiv : (f : A → B) (g : B → A) → f ∘ g ≡ idfun B → isEquiv f → isEquiv g -composesToId→Equiv f g id iseqf = - isoToIsEquiv - (iso g f - (λ b → (λ i → equiv-proof iseqf (f b) .snd (g (f b) , cong (λ h → h (f b)) id) (~ i) .fst) - ∙∙ cong (λ x → equiv-proof iseqf (f b) .fst .fst) id - ∙∙ λ i → equiv-proof iseqf (f b) .snd (b , refl) i .fst) - λ a i → id i a) - -precomposesToId→Equiv : (f : A → B) (g : B → A) → f ∘ g ≡ idfun B → isEquiv g → isEquiv f -precomposesToId→Equiv f g id iseqg = subst isEquiv (sym f-≡-g⁻) (snd (invEquiv (_ , iseqg))) - where - g⁻ = invEq (g , iseqg) - - f-≡-g⁻ : _ - f-≡-g⁻ = cong (f ∘_ ) (cong fst (sym (invEquiv-is-linv (g , iseqg)))) ∙ cong (_∘ g⁻) id - --- equivalence between isEquiv and isEquiv' - -isEquiv-isEquiv'-Iso : (f : A → B) → Iso (isEquiv f) (isEquiv' f) -isEquiv-isEquiv'-Iso f .fun p = p .equiv-proof -isEquiv-isEquiv'-Iso f .inv q .equiv-proof = q -isEquiv-isEquiv'-Iso f .rightInv q = refl -isEquiv-isEquiv'-Iso f .leftInv p i .equiv-proof = p .equiv-proof - -isEquiv≃isEquiv' : (f : A → B) → isEquiv f ≃ isEquiv' f -isEquiv≃isEquiv' f = isoToEquiv (isEquiv-isEquiv'-Iso f) - --- The fact that funExt is an equivalence can be found in Cubical.Functions.FunExtEquiv +equivPathP : {A : I → Type ℓ} {B : I → Type ℓ'} {e : A i0 ≃ B i0} {f : A i1 ≃ B i1} + → (h : PathP (λ i → A i → B i) (e .fst) (f .fst)) → PathP (λ i → A i ≃ B i) e f +equivPathP {e = e} {f = f} h = + λ i → (h i) , isProp→PathP (λ i → isPropIsEquiv (h i)) (e .snd) (f .snd) i + +equivEq : {e f : A ≃ B} → (h : e .fst ≡ f .fst) → e ≡ f +equivEq = equivPathP + +module _ {f : A → B} (equivF : isEquiv f) where + funIsEq : A → B + funIsEq = f + + invIsEq : B → A + invIsEq y = equivF .equiv-proof y .fst .fst + + secIsEq : section f invIsEq + secIsEq y = equivF .equiv-proof y .fst .snd + + retIsEq : retract f invIsEq + retIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .fst + + commSqIsEq : ∀ a → Square (secIsEq (f a)) refl (cong f (retIsEq a)) refl + commSqIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .snd + + commPathIsEq : ∀ a → secIsEq (f a) ≡ cong f (retIsEq a) + commPathIsEq a i j = + hcomp + (λ k → λ + { (i = i0) → secIsEq (f a) j + ; (i = i1) → f (retIsEq a (j ∨ ~ k)) + ; (j = i0) → f (retIsEq a (i ∧ ~ k)) + ; (j = i1) → f a + }) + (commSqIsEq a i j) + +module _ (w : A ≃ B) where + invEq : B → A + invEq = invIsEq (snd w) + + retEq : retract (w .fst) invEq + retEq = retIsEq (snd w) + + secEq : section (w .fst) invEq + secEq = secIsEq (snd w) + +open Iso + +equivToIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → A ≃ B → Iso A B +fun (equivToIso e) = e .fst +inv (equivToIso e) = invEq e +rightInv (equivToIso e) = secEq e +leftInv (equivToIso e) = retEq e + +-- TODO: there should be a direct proof of this that doesn't use equivToIso +invEquiv : A ≃ B → B ≃ A +invEquiv e = isoToEquiv (invIso (equivToIso e)) + +invEquivIdEquiv : (A : Type ℓ) → invEquiv (idEquiv A) ≡ idEquiv A +invEquivIdEquiv _ = equivEq refl + +compEquiv : A ≃ B → B ≃ C → A ≃ C +compEquiv f g .fst = g .fst ∘ f .fst +compEquiv {A = A} {C = C} f g .snd .equiv-proof c = contr + where + contractG = g .snd .equiv-proof c .snd + + secFiller : (a : A) (p : g .fst (f .fst a) ≡ c) → _ {- square in A -} + secFiller a p = compPath-filler (cong (invEq f ∘ fst) (contractG (_ , p))) (retEq f a) + + contr : isContr (fiber (g .fst ∘ f .fst) c) + contr .fst .fst = invEq f (invEq g c) + contr .fst .snd = cong (g .fst) (secEq f (invEq g c)) ∙ secEq g c + contr .snd (a , p) i .fst = secFiller a p i1 i + contr .snd (a , p) i .snd j = + hcomp + (λ k → λ + { (i = i1) → fSquare k + ; (j = i0) → g .fst (f .fst (secFiller a p k i)) + ; (j = i1) → contractG (_ , p) i .snd k + }) + (g .fst (secEq f (contractG (_ , p) i .fst) j)) + where + fSquare : I → C + fSquare k = + hcomp + (λ l → λ + { (j = i0) → g .fst (f .fst (retEq f a k)) + ; (j = i1) → p (k ∧ l) + ; (k = i0) → g .fst (secEq f (f .fst a) j) + ; (k = i1) → p (j ∧ l) + }) + (g .fst (f .snd .equiv-proof (f .fst a) .snd (a , refl) k .snd j)) + +_∙ₑ_ = compEquiv + +compEquivIdEquiv : (e : A ≃ B) → compEquiv (idEquiv A) e ≡ e +compEquivIdEquiv e = equivEq refl + +compEquivEquivId : (e : A ≃ B) → compEquiv e (idEquiv B) ≡ e +compEquivEquivId e = equivEq refl + +invEquiv-is-rinv : (e : A ≃ B) → compEquiv e (invEquiv e) ≡ idEquiv A +invEquiv-is-rinv e = equivEq (funExt (retEq e)) + +invEquiv-is-linv : (e : A ≃ B) → compEquiv (invEquiv e) e ≡ idEquiv B +invEquiv-is-linv e = equivEq (funExt (secEq e)) + +compEquiv-assoc : (f : A ≃ B) (g : B ≃ C) (h : C ≃ D) + → compEquiv f (compEquiv g h) ≡ compEquiv (compEquiv f g) h +compEquiv-assoc f g h = equivEq refl + +LiftEquiv : A ≃ Lift {i = ℓ} {j = ℓ'} A +LiftEquiv .fst a .lower = a +LiftEquiv .snd .equiv-proof = strictContrFibers lower + +Lift≃Lift : (e : A ≃ B) → Lift {j = ℓ'} A ≃ Lift {j = ℓ''} B +Lift≃Lift e .fst a .lower = e .fst (a .lower) +Lift≃Lift e .snd .equiv-proof b .fst .fst .lower = invEq e (b .lower) +Lift≃Lift e .snd .equiv-proof b .fst .snd i .lower = + e .snd .equiv-proof (b .lower) .fst .snd i +Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .fst .lower = + e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .fst +Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .snd j .lower = + e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .snd j + +isContr→Equiv : isContr A → isContr B → A ≃ B +isContr→Equiv Actr Bctr = isoToEquiv (isContr→Iso Actr Bctr) + +propBiimpl→Equiv : (Aprop : isProp A) (Bprop : isProp B) (f : A → B) (g : B → A) → A ≃ B +propBiimpl→Equiv Aprop Bprop f g = f , hf + where + hf : isEquiv f + hf .equiv-proof y .fst = (g y , Bprop (f (g y)) y) + hf .equiv-proof y .snd h i .fst = Aprop (g y) (h .fst) i + hf .equiv-proof y .snd h i .snd = isProp→isSet' Bprop (Bprop (f (g y)) y) (h .snd) + (cong f (Aprop (g y) (h .fst))) refl i + +isEquivPropBiimpl→Equiv : isProp A → isProp B + → ((A → B) × (B → A)) ≃ (A ≃ B) +isEquivPropBiimpl→Equiv {A = A} {B = B} Aprop Bprop = isoToEquiv isom where + isom : Iso (Σ (A → B) (λ _ → B → A)) (A ≃ B) + isom .fun (f , g) = propBiimpl→Equiv Aprop Bprop f g + isom .inv e = equivFun e , invEq e + isom .rightInv e = equivEq refl + isom .leftInv _ = refl + +equivΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'} + → ((x : A) → F x ≃ G x) → ((x : A) → F x) ≃ ((x : A) → G x) +equivΠCod k .fst f x = k x .fst (f x) +equivΠCod k .snd .equiv-proof f .fst .fst x = equivCtr (k x) (f x) .fst +equivΠCod k .snd .equiv-proof f .fst .snd i x = equivCtr (k x) (f x) .snd i +equivΠCod k .snd .equiv-proof f .snd (g , p) i .fst x = + equivCtrPath (k x) (f x) (g x , λ j → p j x) i .fst +equivΠCod k .snd .equiv-proof f .snd (g , p) i .snd j x = + equivCtrPath (k x) (f x) (g x , λ k → p k x) i .snd j + +equivImplicitΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'} + → ({x : A} → F x ≃ G x) → ({x : A} → F x) ≃ ({x : A} → G x) +equivImplicitΠCod k .fst f {x} = k {x} .fst (f {x}) +equivImplicitΠCod k .snd .equiv-proof f .fst .fst {x} = equivCtr (k {x}) (f {x}) .fst +equivImplicitΠCod k .snd .equiv-proof f .fst .snd i {x} = equivCtr (k {x}) (f {x}) .snd i +equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .fst {x} = + equivCtrPath (k {x}) (f {x}) (g {x} , λ j → p j {x}) i .fst +equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .snd j {x} = + equivCtrPath (k {x}) (f {x}) (g {x} , λ k → p k {x}) i .snd j + +equiv→Iso : (A ≃ B) → (C ≃ D) → Iso (A → C) (B → D) +equiv→Iso h k .Iso.fun f b = equivFun k (f (invEq h b)) +equiv→Iso h k .Iso.inv g a = invEq k (g (equivFun h a)) +equiv→Iso h k .Iso.rightInv g = funExt λ b → secEq k _ ∙ cong g (secEq h b) +equiv→Iso h k .Iso.leftInv f = funExt λ a → retEq k _ ∙ cong f (retEq h a) + +equiv→ : (A ≃ B) → (C ≃ D) → (A → C) ≃ (B → D) +equiv→ h k = isoToEquiv (equiv→Iso h k) + + +equivΠ' : ∀ {ℓA ℓA' ℓB ℓB'} {A : Type ℓA} {A' : Type ℓA'} + {B : A → Type ℓB} {B' : A' → Type ℓB'} + (eA : A ≃ A') + (eB : {a : A} {a' : A'} → eA .fst a ≡ a' → B a ≃ B' a') + → ((a : A) → B a) ≃ ((a' : A') → B' a') +equivΠ' {B' = B'} eA eB = isoToEquiv isom + where + open Iso + + isom : Iso _ _ + isom .fun f a' = + eB (secEq eA a') .fst (f (invEq eA a')) + isom .inv f' a = + invEq (eB refl) (f' (eA .fst a)) + isom .rightInv f' = + funExt λ a' → + J (λ a'' p → eB p .fst (invEq (eB refl) (f' (p i0))) ≡ f' a'') + (secEq (eB refl) (f' (eA .fst (invEq eA a')))) + (secEq eA a') + isom .leftInv f = + funExt λ a → + subst + (λ p → invEq (eB refl) (eB p .fst (f (invEq eA (eA .fst a)))) ≡ f a) + (sym (commPathIsEq (eA .snd) a)) + (J (λ a'' p → invEq (eB refl) (eB (cong (eA .fst) p) .fst (f (invEq eA (eA .fst a)))) ≡ f a'') + (retEq (eB refl) (f (invEq eA (eA .fst a)))) + (retEq eA a)) + +equivΠ : ∀ {ℓA ℓA' ℓB ℓB'} {A : Type ℓA} {A' : Type ℓA'} + {B : A → Type ℓB} {B' : A' → Type ℓB'} + (eA : A ≃ A') + (eB : (a : A) → B a ≃ B' (eA .fst a)) + → ((a : A) → B a) ≃ ((a' : A') → B' a') +equivΠ {B = B} {B' = B'} eA eB = equivΠ' eA (λ {a = a} p → J (λ a' p → B a ≃ B' a') (eB a) p) + + +equivCompIso : (A ≃ B) → (C ≃ D) → Iso (A ≃ C) (B ≃ D) +equivCompIso h k .Iso.fun f = compEquiv (compEquiv (invEquiv h) f) k +equivCompIso h k .Iso.inv g = compEquiv (compEquiv h g) (invEquiv k) +equivCompIso h k .Iso.rightInv g = equivEq (equiv→Iso h k .Iso.rightInv (equivFun g)) +equivCompIso h k .Iso.leftInv f = equivEq (equiv→Iso h k .Iso.leftInv (equivFun f)) + +equivComp : (A ≃ B) → (C ≃ D) → (A ≃ C) ≃ (B ≃ D) +equivComp h k = isoToEquiv (equivCompIso h k) + +-- Some helpful notation: +_≃⟨_⟩_ : (X : Type ℓ) → (X ≃ B) → (B ≃ C) → (X ≃ C) +_ ≃⟨ f ⟩ g = compEquiv f g + +_■ : (X : Type ℓ) → (X ≃ X) +_■ = idEquiv + +infixr 0 _≃⟨_⟩_ +infix 1 _■ + +composesToId→Equiv : (f : A → B) (g : B → A) → f ∘ g ≡ idfun B → isEquiv f → isEquiv g +composesToId→Equiv f g id iseqf = + isoToIsEquiv + (iso g f + (λ b → (λ i → equiv-proof iseqf (f b) .snd (g (f b) , cong (λ h → h (f b)) id) (~ i) .fst) + ∙∙ cong (λ x → equiv-proof iseqf (f b) .fst .fst) id + ∙∙ λ i → equiv-proof iseqf (f b) .snd (b , refl) i .fst) + λ a i → id i a) + +precomposesToId→Equiv : (f : A → B) (g : B → A) → f ∘ g ≡ idfun B → isEquiv g → isEquiv f +precomposesToId→Equiv f g id iseqg = subst isEquiv (sym f-≡-g⁻) (snd (invEquiv (_ , iseqg))) + where + g⁻ = invEq (g , iseqg) + + f-≡-g⁻ : _ + f-≡-g⁻ = cong (f ∘_ ) (cong fst (sym (invEquiv-is-linv (g , iseqg)))) ∙ cong (_∘ g⁻) id + +-- equivalence between isEquiv and isEquiv' + +isEquiv-isEquiv'-Iso : (f : A → B) → Iso (isEquiv f) (isEquiv' f) +isEquiv-isEquiv'-Iso f .fun p = p .equiv-proof +isEquiv-isEquiv'-Iso f .inv q .equiv-proof = q +isEquiv-isEquiv'-Iso f .rightInv q = refl +isEquiv-isEquiv'-Iso f .leftInv p i .equiv-proof = p .equiv-proof + +isEquiv≃isEquiv' : (f : A → B) → isEquiv f ≃ isEquiv' f +isEquiv≃isEquiv' f = isoToEquiv (isEquiv-isEquiv'-Iso f) + +-- The fact that funExt is an equivalence can be found in Cubical.Functions.FunExtEquiv \ No newline at end of file diff --git a/docs/Cubical.Foundations.Function.html b/docs/Cubical.Foundations.Function.html index a40ec2f..b9a3c60 100644 --- a/docs/Cubical.Foundations.Function.html +++ b/docs/Cubical.Foundations.Function.html @@ -83,80 +83,83 @@ curry : ((p : Σ A B) → C (fst p) (snd p)) → (x : A) → (y : B x) → C x y curry f x y = f (x , y) -module _ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where - -- Notions of 'coherently constant' functions for low dimensions. - -- These are the properties of functions necessary to e.g. eliminate - -- from the propositional truncation. - - -- 2-Constant functions are coherently constant if B is a set. - 2-Constant : (A → B) → Type _ - 2-Constant f = ∀ x y → f x ≡ f y - - 2-Constant-isProp : isSet B → (f : A → B) → isProp (2-Constant f) - 2-Constant-isProp Bset f link1 link2 i x y j - = Bset (f x) (f y) (link1 x y) (link2 x y) i j - - -- 3-Constant functions are coherently constant if B is a groupoid. - record 3-Constant (f : A → B) : Type (ℓ-max ℓ ℓ') where - field - link : 2-Constant f - coh₁ : ∀ x y z → Square (link x y) (link x z) refl (link y z) - - coh₂ : ∀ x y z → Square (link x z) (link y z) (link x y) refl - coh₂ x y z i j - = hcomp (λ k → λ - { (j = i0) → link x y i - ; (i = i0) → link x z (j ∧ k) - ; (j = i1) → link x z (i ∨ k) - ; (i = i1) → link y z j - }) - (coh₁ x y z j i) - - link≡refl : ∀ x → refl ≡ link x x - link≡refl x i j - = hcomp (λ k → λ - { (i = i0) → link x x (j ∧ ~ k) - ; (i = i1) → link x x j - ; (j = i0) → f x - ; (j = i1) → link x x (~ i ∧ ~ k) - }) - (coh₁ x x x (~ i) j) - - downleft : ∀ x y → Square (link x y) refl refl (link y x) - downleft x y i j - = hcomp (λ k → λ - { (i = i0) → link x y j - ; (i = i1) → link≡refl x (~ k) j - ; (j = i0) → f x - ; (j = i1) → link y x i - }) - (coh₁ x y x i j) - - link≡symlink : ∀ x y → link x y ≡ sym (link y x) - link≡symlink x y i j - = hcomp (λ k → λ - { (i = i0) → link x y j - ; (i = i1) → link y x (~ j ∨ ~ k) - ; (j = i0) → f x - ; (j = i1) → link y x (i ∧ ~ k) - }) - (downleft x y i j) - -homotopyNatural : {B : Type ℓ'} {f g : A → B} (H : ∀ a → f a ≡ g a) {x y : A} (p : x ≡ y) → - H x ∙ cong g p ≡ cong f p ∙ H y -homotopyNatural {f = f} {g = g} H {x} {y} p i j = - hcomp (λ k → λ { (i = i0) → compPath-filler (H x) (cong g p) k j - ; (i = i1) → compPath-filler' (cong f p) (H y) k j - ; (j = i0) → cong f p (i ∧ ~ k) - ; (j = i1) → cong g p (i ∨ k) }) - (H (p i) j) - -homotopySymInv : {f : A → A} (H : ∀ a → f a ≡ a) (a : A) - → Path (f a ≡ f a) (λ i → H (H a (~ i)) i) refl -homotopySymInv {f = f} H a j i = - hcomp (λ k → λ { (i = i0) → f a - ; (i = i1) → H a (j ∧ ~ k) - ; (j = i0) → H (H a (~ i)) i - ; (j = i1) → H a (i ∧ ~ k)}) - (H (H a (~ i ∨ j)) i) +∘diag : {B : (x y : A) → Type ℓ} → (∀ x y → B x y) → ∀ x → B x x +∘diag f x = f x x + +module _ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where + -- Notions of 'coherently constant' functions for low dimensions. + -- These are the properties of functions necessary to e.g. eliminate + -- from the propositional truncation. + + -- 2-Constant functions are coherently constant if B is a set. + 2-Constant : (A → B) → Type _ + 2-Constant f = ∀ x y → f x ≡ f y + + 2-Constant-isProp : isSet B → (f : A → B) → isProp (2-Constant f) + 2-Constant-isProp Bset f link1 link2 i x y j + = Bset (f x) (f y) (link1 x y) (link2 x y) i j + + -- 3-Constant functions are coherently constant if B is a groupoid. + record 3-Constant (f : A → B) : Type (ℓ-max ℓ ℓ') where + field + link : 2-Constant f + coh₁ : ∀ x y z → Square (link x y) (link x z) refl (link y z) + + coh₂ : ∀ x y z → Square (link x z) (link y z) (link x y) refl + coh₂ x y z i j + = hcomp (λ k → λ + { (j = i0) → link x y i + ; (i = i0) → link x z (j ∧ k) + ; (j = i1) → link x z (i ∨ k) + ; (i = i1) → link y z j + }) + (coh₁ x y z j i) + + link≡refl : ∀ x → refl ≡ link x x + link≡refl x i j + = hcomp (λ k → λ + { (i = i0) → link x x (j ∧ ~ k) + ; (i = i1) → link x x j + ; (j = i0) → f x + ; (j = i1) → link x x (~ i ∧ ~ k) + }) + (coh₁ x x x (~ i) j) + + downleft : ∀ x y → Square (link x y) refl refl (link y x) + downleft x y i j + = hcomp (λ k → λ + { (i = i0) → link x y j + ; (i = i1) → link≡refl x (~ k) j + ; (j = i0) → f x + ; (j = i1) → link y x i + }) + (coh₁ x y x i j) + + link≡symlink : ∀ x y → link x y ≡ sym (link y x) + link≡symlink x y i j + = hcomp (λ k → λ + { (i = i0) → link x y j + ; (i = i1) → link y x (~ j ∨ ~ k) + ; (j = i0) → f x + ; (j = i1) → link y x (i ∧ ~ k) + }) + (downleft x y i j) + +homotopyNatural : {B : Type ℓ'} {f g : A → B} (H : ∀ a → f a ≡ g a) {x y : A} (p : x ≡ y) → + H x ∙ cong g p ≡ cong f p ∙ H y +homotopyNatural {f = f} {g = g} H {x} {y} p i j = + hcomp (λ k → λ { (i = i0) → compPath-filler (H x) (cong g p) k j + ; (i = i1) → compPath-filler' (cong f p) (H y) k j + ; (j = i0) → cong f p (i ∧ ~ k) + ; (j = i1) → cong g p (i ∨ k) }) + (H (p i) j) + +homotopySymInv : {f : A → A} (H : ∀ a → f a ≡ a) (a : A) + → Path (f a ≡ f a) (λ i → H (H a (~ i)) i) refl +homotopySymInv {f = f} H a j i = + hcomp (λ k → λ { (i = i0) → f a + ; (i = i1) → H a (j ∧ ~ k) + ; (j = i0) → H (H a (~ i)) i + ; (j = i1) → H a (i ∧ ~ k)}) + (H (H a (~ i ∨ j)) i) \ No newline at end of file diff --git a/docs/Cubical.Foundations.GroupoidLaws.html b/docs/Cubical.Foundations.GroupoidLaws.html index 1e09c8a..33b8fa6 100644 --- a/docs/Cubical.Foundations.GroupoidLaws.html +++ b/docs/Cubical.Foundations.GroupoidLaws.html @@ -169,7 +169,7 @@ -- some exchange law for doubleCompPath and refl -invSides-filler : {x y z : A} (p : x ≡ y) (q : x ≡ z) → Square p (sym q) q (sym p) +invSides-filler : {x y z : A} (p : x ≡ y) (q : x ≡ z) → Square p (sym q) q (sym p) invSides-filler {x = x} p q i j = hcomp (λ k → λ { (i = i0) → p (k ∧ j) ; (i = i1) → q (~ j ∧ k) @@ -438,7 +438,7 @@ compPath-filler-in-filler : (p : _ ≡ y) → (q : _ ≡ _ ) - → _≡_ {A = Square (p ∙ q) (p ∙ q) (λ _ → x) (λ _ → z)} + → _≡_ {A = Square (p ∙ q) (p ∙ q) (λ _ → x) (λ _ → z)} (λ i j → hcomp (λ i₂ → λ { (j = i0) → x @@ -473,7 +473,7 @@ cube-comp₋₀₋ : (c : I → I → I → A) - → {a' : Square _ _ _ _} + → {a' : Square _ _ _ _} → (λ i i₁ → c i i0 i₁) ≡ a' → (I → I → I → A) cube-comp₋₀₋ c p i j k = @@ -490,7 +490,7 @@ cube-comp₀₋₋ : (c : I → I → I → A) - → {a' : Square _ _ _ _} + → {a' : Square _ _ _ _} → (λ i i₁ → c i0 i i₁) ≡ a' → (I → I → I → A) cube-comp₀₋₋ c p i j k = diff --git a/docs/Cubical.Foundations.HLevels.html b/docs/Cubical.Foundations.HLevels.html index 411eb21..ff42a1e 100644 --- a/docs/Cubical.Foundations.HLevels.html +++ b/docs/Cubical.Foundations.HLevels.html @@ -43,8 +43,8 @@ n : HLevel isOfHLevel : HLevel → Type ℓ → Type ℓ -isOfHLevel 0 A = isContr A -isOfHLevel 1 A = isProp A +isOfHLevel 0 A = isContr A +isOfHLevel 1 A = isProp A isOfHLevel (suc (suc n)) A = (x y : A) → isOfHLevel (suc n) (x ≡ y) isOfHLevelFun : (n : HLevel) {A : Type ℓ} {B : Type ℓ'} (f : A → B) → Type (ℓ-max ℓ ℓ') @@ -54,9 +54,9 @@ ∀ {ℓ} {A : Type ℓ} (n : ℕ) → ((x : A) → isOfHLevel (suc n) (x ≡ x)) → isOfHLevel (2 + n) A isOfHLevelΩ→isOfHLevel zero hΩ x y = - J (λ y p → (q : x ≡ y) → p ≡ q) (hΩ x refl) + J (λ y p → (q : x ≡ y) → p ≡ q) (hΩ x refl) isOfHLevelΩ→isOfHLevel (suc n) hΩ x y = - J (λ y p → (q : x ≡ y) → isOfHLevel (suc n) (p ≡ q)) (hΩ x refl) + J (λ y p → (q : x ≡ y) → isOfHLevel (suc n) (p ≡ q)) (hΩ x refl) TypeOfHLevel : ∀ ℓ → HLevel → Type (ℓ-suc ℓ) TypeOfHLevel ℓ n = TypeWithStr ℓ (isOfHLevel n) @@ -70,25 +70,25 @@ -- lower h-levels imply higher h-levels isOfHLevelSuc : (n : HLevel) → isOfHLevel n A → isOfHLevel (suc n) A -isOfHLevelSuc 0 = isContr→isProp -isOfHLevelSuc 1 = isProp→isSet +isOfHLevelSuc 0 = isContr→isProp +isOfHLevelSuc 1 = isProp→isSet isOfHLevelSuc (suc (suc n)) h a b = isOfHLevelSuc (suc n) (h a b) -isSet→isGroupoid : isSet A → isGroupoid A +isSet→isGroupoid : isSet A → isGroupoid A isSet→isGroupoid = isOfHLevelSuc 2 -isGroupoid→is2Groupoid : isGroupoid A → is2Groupoid A +isGroupoid→is2Groupoid : isGroupoid A → is2Groupoid A isGroupoid→is2Groupoid = isOfHLevelSuc 3 isOfHLevelPlus : (m : HLevel) → isOfHLevel n A → isOfHLevel (m + n) A isOfHLevelPlus zero hA = hA isOfHLevelPlus (suc m) hA = isOfHLevelSuc _ (isOfHLevelPlus m hA) -isContr→isOfHLevel : (n : HLevel) → isContr A → isOfHLevel n A +isContr→isOfHLevel : (n : HLevel) → isContr A → isOfHLevel n A isContr→isOfHLevel zero cA = cA isContr→isOfHLevel (suc n) cA = isOfHLevelSuc _ (isContr→isOfHLevel n cA) -isProp→isOfHLevelSuc : (n : HLevel) → isProp A → isOfHLevel (suc n) A +isProp→isOfHLevelSuc : (n : HLevel) → isProp A → isOfHLevel (suc n) A isProp→isOfHLevelSuc zero pA = pA isProp→isOfHLevelSuc (suc n) pA = isOfHLevelSuc _ (isProp→isOfHLevelSuc n pA) @@ -99,11 +99,11 @@ -- hlevel of path types -isProp→isContrPath : isProp A → (x y : A) → isContr (x ≡ y) -isProp→isContrPath h x y = h x y , isProp→isSet h x y _ +isProp→isContrPath : isProp A → (x y : A) → isContr (x ≡ y) +isProp→isContrPath h x y = h x y , isProp→isSet h x y _ -isContr→isContrPath : isContr A → (x y : A) → isContr (x ≡ y) -isContr→isContrPath cA = isProp→isContrPath (isContr→isProp cA) +isContr→isContrPath : isContr A → (x y : A) → isContr (x ≡ y) +isContr→isContrPath cA = isProp→isContrPath (isContr→isProp cA) isOfHLevelPath' : (n : HLevel) → isOfHLevel (suc n) A → (x y : A) → isOfHLevel n (x ≡ y) isOfHLevelPath' 0 = isProp→isContrPath @@ -119,19 +119,19 @@ -- h-level of isOfHLevel -isPropIsOfHLevel : (n : HLevel) → isProp (isOfHLevel n A) -isPropIsOfHLevel 0 = isPropIsContr -isPropIsOfHLevel 1 = isPropIsProp +isPropIsOfHLevel : (n : HLevel) → isProp (isOfHLevel n A) +isPropIsOfHLevel 0 = isPropIsContr +isPropIsOfHLevel 1 = isPropIsProp isPropIsOfHLevel (suc (suc n)) f g i a b = isPropIsOfHLevel (suc n) (f a b) (g a b) i -isPropIsSet : isProp (isSet A) +isPropIsSet : isProp (isSet A) isPropIsSet = isPropIsOfHLevel 2 -isPropIsGroupoid : isProp (isGroupoid A) +isPropIsGroupoid : isProp (isGroupoid A) isPropIsGroupoid = isPropIsOfHLevel 3 -isPropIs2Groupoid : isProp (is2Groupoid A) +isPropIs2Groupoid : isProp (is2Groupoid A) isPropIs2Groupoid = isPropIsOfHLevel 4 TypeOfHLevel≡ : (n : HLevel) {X Y : TypeOfHLevel ℓ n} → ⟨ X ⟩ ≡ ⟨ Y ⟩ → X ≡ Y @@ -143,7 +143,7 @@ : ∀ {B : Type ℓ} → (f : A → B) (g : B → A) → (h : retract f g) - → (v : isContr B) → isContr A + → (v : isContr B) → isContr A fst (isContrRetract f g h (b , p)) = g b snd (isContrRetract f g h (b , p)) x = (cong g (p (f x))) ∙ (h x) @@ -151,7 +151,7 @@ : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) - → isProp B → isProp A + → isProp B → isProp A isPropRetract f g h p x y i = hcomp (λ j → λ @@ -163,7 +163,7 @@ : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) - → isSet B → isSet A + → isSet B → isSet A isSetRetract f g h set x y p q i j = hcomp (λ k → λ { (i = i0) → h (p j) k ; (i = i1) → h (q j) k @@ -176,7 +176,7 @@ : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) - → isGroupoid B → isGroupoid A + → isGroupoid B → isGroupoid A isGroupoidRetract f g h grp x y p q P Q i j k = hcomp ((λ l → λ { (i = i0) → h (P j k) l ; (i = i1) → h (Q j k) l @@ -191,7 +191,7 @@ : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) - → is2Groupoid B → is2Groupoid A + → is2Groupoid B → is2Groupoid A is2GroupoidRetract f g h grp x y p q P Q R S i j k l = hcomp (λ r → λ { (i = i0) → h (R j k l) r ; (i = i1) → h (S j k l) r @@ -247,11 +247,11 @@ isOfHLevelRetractFromIso n e hlev = isOfHLevelRetract n (Iso.fun e) (Iso.inv e) (Iso.leftInv e) hlev isOfHLevelRespectEquiv : {A : Type ℓ} {B : Type ℓ'} → (n : HLevel) → A ≃ B → isOfHLevel n A → isOfHLevel n B -isOfHLevelRespectEquiv n eq = isOfHLevelRetract n (invEq eq) (eq .fst) (secEq eq) +isOfHLevelRespectEquiv n eq = isOfHLevelRetract n (invEq eq) (eq .fst) (secEq eq) isContrRetractOfConstFun : {A : Type ℓ} {B : Type ℓ'} (b₀ : B) → Σ[ f ∈ (B → A) ] ((x : A) → (f ∘ (λ _ → b₀)) x ≡ x) - → isContr A + → isContr A fst (isContrRetractOfConstFun b₀ ret) = ret .fst b₀ snd (isContrRetractOfConstFun b₀ ret) y = ret .snd y @@ -273,35 +273,35 @@ isSet→SquareP : {A : I → I → Type ℓ} - (isSet : (i j : I) → isSet (A i j)) + (isSet : (i j : I) → isSet (A i j)) {a₀₀ : A i0 i0} {a₀₁ : A i0 i1} (a₀₋ : PathP (λ j → A i0 j) a₀₀ a₀₁) {a₁₀ : A i1 i0} {a₁₁ : A i1 i1} (a₁₋ : PathP (λ j → A i1 j) a₁₀ a₁₁) (a₋₀ : PathP (λ i → A i i0) a₀₀ a₁₀) (a₋₁ : PathP (λ i → A i i1) a₀₁ a₁₁) - → SquareP A a₀₋ a₁₋ a₋₀ a₋₁ + → SquareP A a₀₋ a₁₋ a₋₀ a₋₁ isSet→SquareP isset a₀₋ a₁₋ a₋₀ a₋₁ = PathPIsoPath _ _ _ .Iso.inv (isOfHLevelPathP' 1 (isset _ _) _ _ _ _ ) -isGroupoid→isGroupoid' : isGroupoid A → isGroupoid' A +isGroupoid→isGroupoid' : isGroupoid A → isGroupoid' A isGroupoid→isGroupoid' {A = A} Agpd a₀₋₋ a₁₋₋ a₋₀₋ a₋₁₋ a₋₋₀ a₋₋₁ = - PathPIsoPath (λ i → Square (a₋₀₋ i) (a₋₁₋ i) (a₋₋₀ i) (a₋₋₁ i)) a₀₋₋ a₁₋₋ .Iso.inv + PathPIsoPath (λ i → Square (a₋₀₋ i) (a₋₁₋ i) (a₋₋₀ i) (a₋₋₁ i)) a₀₋₋ a₁₋₋ .Iso.inv (isGroupoid→isPropSquare _ _ _ _ _ _) where isGroupoid→isPropSquare : {a₀₀ a₀₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) {a₁₀ a₁₁ : A} (a₁₋ : a₁₀ ≡ a₁₁) (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) - → isProp (Square a₀₋ a₁₋ a₋₀ a₋₁) + → isProp (Square a₀₋ a₁₋ a₋₀ a₋₁) isGroupoid→isPropSquare a₀₋ a₁₋ a₋₀ a₋₁ = isOfHLevelRetractFromIso 1 (PathPIsoPath (λ i → a₋₀ i ≡ a₋₁ i) a₀₋ a₁₋) (Agpd _ _ _ _) -isGroupoid'→isGroupoid : isGroupoid' A → isGroupoid A +isGroupoid'→isGroupoid : isGroupoid' A → isGroupoid A isGroupoid'→isGroupoid Agpd' x y p q r s = Agpd' r s refl refl refl refl -- h-level of Σ-types -isProp∃! : isProp (∃! A B) -isProp∃! = isPropIsContr +isProp∃! : isProp (∃! A B) +isProp∃! = isPropIsContr -isContrΣ : isContr A → ((x : A) → isContr (B x)) → isContr (Σ A B) +isContrΣ : isContr A → ((x : A) → isContr (B x)) → isContr (Σ A B) isContrΣ {A = A} {B = B} (a , p) q = let h : (x : A) (y : B x) → (q x) .fst ≡ y h x y = (q x) .snd y @@ -309,24 +309,24 @@ , ( λ x i → p (x .fst) i , h (p (x .fst) i) (transp (λ j → B (p (x .fst) (i ∨ ~ j))) i (x .snd)) i)) -isContrΣ' : (ca : isContr A) → isContr (B (fst ca)) → isContr (Σ A B) +isContrΣ' : (ca : isContr A) → isContr (B (fst ca)) → isContr (Σ A B) isContrΣ' ca cb = isContrΣ ca (λ x → subst _ (snd ca x) cb) section-Σ≡Prop - : (pB : (x : A) → isProp (B x)) {u v : Σ A B} + : (pB : (x : A) → isProp (B x)) {u v : Σ A B} → section (Σ≡Prop pB {u} {v}) (cong fst) section-Σ≡Prop {A = A} pB {u} {v} p j i = - (p i .fst) , isProp→PathP (λ i → isOfHLevelPath 1 (pB (fst (p i))) + (p i .fst) , isProp→PathP (λ i → isOfHLevelPath 1 (pB (fst (p i))) (Σ≡Prop pB {u} {v} (cong fst p) i .snd) (p i .snd) ) refl refl i j isEquiv-Σ≡Prop - : (pB : (x : A) → isProp (B x)) {u v : Σ A B} + : (pB : (x : A) → isProp (B x)) {u v : Σ A B} → isEquiv (Σ≡Prop pB {u} {v}) isEquiv-Σ≡Prop {A = A} pB {u} {v} = isoToIsEquiv (iso (Σ≡Prop pB) (cong fst) (section-Σ≡Prop pB) (λ _ → refl)) -isPropΣ : isProp A → ((x : A) → isProp (B x)) → isProp (Σ A B) +isPropΣ : isProp A → ((x : A) → isProp (B x)) → isProp (Σ A B) isPropΣ pA pB t u = Σ≡Prop pB (pA (t .fst) (u .fst)) isOfHLevelΣ : ∀ n → isOfHLevel n A → ((x : A) → isOfHLevel n (B x)) @@ -338,39 +338,39 @@ (invIso (IsoΣPathTransportPathΣ _ _)) (isOfHLevelΣ (suc n) (h1 (fst x) (fst y)) λ x → h2 _ _ _) -isSetΣ : isSet A → ((x : A) → isSet (B x)) → isSet (Σ A B) +isSetΣ : isSet A → ((x : A) → isSet (B x)) → isSet (Σ A B) isSetΣ = isOfHLevelΣ 2 -- Useful consequence -isSetΣSndProp : isSet A → ((x : A) → isProp (B x)) → isSet (Σ A B) -isSetΣSndProp h p = isSetΣ h (λ x → isProp→isSet (p x)) +isSetΣSndProp : isSet A → ((x : A) → isProp (B x)) → isSet (Σ A B) +isSetΣSndProp h p = isSetΣ h (λ x → isProp→isSet (p x)) -isGroupoidΣ : isGroupoid A → ((x : A) → isGroupoid (B x)) → isGroupoid (Σ A B) +isGroupoidΣ : isGroupoid A → ((x : A) → isGroupoid (B x)) → isGroupoid (Σ A B) isGroupoidΣ = isOfHLevelΣ 3 -is2GroupoidΣ : is2Groupoid A → ((x : A) → is2Groupoid (B x)) → is2Groupoid (Σ A B) +is2GroupoidΣ : is2Groupoid A → ((x : A) → is2Groupoid (B x)) → is2Groupoid (Σ A B) is2GroupoidΣ = isOfHLevelΣ 4 -- h-level of × -isProp× : {A : Type ℓ} {B : Type ℓ'} → isProp A → isProp B → isProp (A × B) +isProp× : {A : Type ℓ} {B : Type ℓ'} → isProp A → isProp B → isProp (A × B) isProp× pA pB = isPropΣ pA (λ _ → pB) isProp×2 : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - → isProp A → isProp B → isProp C → isProp (A × B × C) + → isProp A → isProp B → isProp C → isProp (A × B × C) isProp×2 pA pB pC = isProp× pA (isProp× pB pC) isProp×3 : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} - → isProp A → isProp B → isProp C → isProp D → isProp (A × B × C × D) + → isProp A → isProp B → isProp C → isProp D → isProp (A × B × C × D) isProp×3 pA pB pC pD = isProp×2 pA pB (isProp× pC pD) isProp×4 : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} {E : Type ℓ''''} - → isProp A → isProp B → isProp C → isProp D → isProp E → isProp (A × B × C × D × E) + → isProp A → isProp B → isProp C → isProp D → isProp E → isProp (A × B × C × D × E) isProp×4 pA pB pC pD pE = isProp×3 pA pB pC (isProp× pD pE) isProp×5 : {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} {E : Type ℓ''''} {F : Type ℓ'''''} - → isProp A → isProp B → isProp C → isProp D → isProp E → isProp F - → isProp (A × B × C × D × E × F) + → isProp A → isProp B → isProp C → isProp D → isProp E → isProp F + → isProp (A × B × C × D × E × F) isProp×5 pA pB pC pD pE pF = isProp×4 pA pB pC pD (isProp× pE pF) @@ -378,15 +378,15 @@ → isOfHLevel n (A × B) isOfHLevel× n hA hB = isOfHLevelΣ n hA (λ _ → hB) -isSet× : ∀ {A : Type ℓ} {B : Type ℓ'} → isSet A → isSet B → isSet (A × B) +isSet× : ∀ {A : Type ℓ} {B : Type ℓ'} → isSet A → isSet B → isSet (A × B) isSet× = isOfHLevel× 2 -isGroupoid× : ∀ {A : Type ℓ} {B : Type ℓ'} → isGroupoid A → isGroupoid B - → isGroupoid (A × B) +isGroupoid× : ∀ {A : Type ℓ} {B : Type ℓ'} → isGroupoid A → isGroupoid B + → isGroupoid (A × B) isGroupoid× = isOfHLevel× 3 -is2Groupoid× : ∀ {A : Type ℓ} {B : Type ℓ'} → is2Groupoid A → is2Groupoid B - → is2Groupoid (A × B) +is2Groupoid× : ∀ {A : Type ℓ} {B : Type ℓ'} → is2Groupoid A → is2Groupoid B + → is2Groupoid (A × B) is2Groupoid× = isOfHLevel× 4 -- h-level of Π-types @@ -417,386 +417,427 @@ → isOfHLevel n ((x : A) → (y : B x) → C x y) isOfHLevelΠ2 n f = isOfHLevelΠ n (λ x → isOfHLevelΠ n (f x)) -isContrΠ : (h : (x : A) → isContr (B x)) → isContr ((x : A) → B x) +isContrΠ : (h : (x : A) → isContr (B x)) → isContr ((x : A) → B x) isContrΠ = isOfHLevelΠ 0 -isPropΠ : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x) +isPropΠ : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x) isPropΠ = isOfHLevelΠ 1 -isPropΠ2 : (h : (x : A) (y : B x) → isProp (C x y)) - → isProp ((x : A) (y : B x) → C x y) +isPropΠ2 : (h : (x : A) (y : B x) → isProp (C x y)) + → isProp ((x : A) (y : B x) → C x y) isPropΠ2 h = isPropΠ λ x → isPropΠ λ y → h x y -isPropΠ3 : (h : (x : A) (y : B x) (z : C x y) → isProp (D x y z)) - → isProp ((x : A) (y : B x) (z : C x y) → D x y z) +isPropΠ3 : (h : (x : A) (y : B x) (z : C x y) → isProp (D x y z)) + → isProp ((x : A) (y : B x) (z : C x y) → D x y z) isPropΠ3 h = isPropΠ λ x → isPropΠ λ y → isPropΠ λ z → h x y z -isPropΠ4 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) → isProp (E x y z w)) - → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) → E x y z w) +isPropΠ4 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) → isProp (E x y z w)) + → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) → E x y z w) isPropΠ4 h = isPropΠ λ _ → isPropΠ3 (h _) -isPropΠ5 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) → isProp (F x y z w v)) - → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) → F x y z w v) +isPropΠ5 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) → isProp (F x y z w v)) + → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) → F x y z w v) isPropΠ5 h = isPropΠ λ _ → isPropΠ4 (h _) -isPropΠ6 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) (u : F x y z w v) → isProp (G x y z w v u)) - → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) (u : F x y z w v) → G x y z w v u) +isPropΠ6 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) (u : F x y z w v) → isProp (G x y z w v u)) + → isProp ((x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) (u : F x y z w v) → G x y z w v u) isPropΠ6 h = isPropΠ λ _ → isPropΠ5 (h _) -isPropImplicitΠ : (h : (x : A) → isProp (B x)) → isProp ({x : A} → B x) +isPropImplicitΠ : (h : (x : A) → isProp (B x)) → isProp ({x : A} → B x) isPropImplicitΠ h f g i {x} = h x (f {x}) (g {x}) i -isPropImplicitΠ2 : (h : (x : A) (y : B x) → isProp (C x y)) → isProp ({x : A} {y : B x} → C x y) +isPropImplicitΠ2 : (h : (x : A) (y : B x) → isProp (C x y)) → isProp ({x : A} {y : B x} → C x y) isPropImplicitΠ2 h = isPropImplicitΠ (λ x → isPropImplicitΠ (λ y → h x y)) -isProp→ : {A : Type ℓ} {B : Type ℓ'} → isProp B → isProp (A → B) -isProp→ pB = isPropΠ λ _ → pB - -isSetΠ : ((x : A) → isSet (B x)) → isSet ((x : A) → B x) -isSetΠ = isOfHLevelΠ 2 - -isSetImplicitΠ : (h : (x : A) → isSet (B x)) → isSet ({x : A} → B x) -isSetImplicitΠ h f g F G i j {x} = h x (f {x}) (g {x}) (λ i → F i {x}) (λ i → G i {x}) i j - -isSet→ : isSet A' → isSet (A → A') -isSet→ isSet-A' = isOfHLevelΠ 2 (λ _ → isSet-A') - -isSetΠ2 : (h : (x : A) (y : B x) → isSet (C x y)) - → isSet ((x : A) (y : B x) → C x y) -isSetΠ2 h = isSetΠ λ x → isSetΠ λ y → h x y - -isSetΠ3 : (h : (x : A) (y : B x) (z : C x y) → isSet (D x y z)) - → isSet ((x : A) (y : B x) (z : C x y) → D x y z) -isSetΠ3 h = isSetΠ λ x → isSetΠ λ y → isSetΠ λ z → h x y z - -isGroupoidΠ : ((x : A) → isGroupoid (B x)) → isGroupoid ((x : A) → B x) -isGroupoidΠ = isOfHLevelΠ 3 - -isGroupoidΠ2 : (h : (x : A) (y : B x) → isGroupoid (C x y)) → isGroupoid ((x : A) (y : B x) → C x y) -isGroupoidΠ2 h = isGroupoidΠ λ _ → isGroupoidΠ λ _ → h _ _ - -isGroupoidΠ3 : (h : (x : A) (y : B x) (z : C x y) → isGroupoid (D x y z)) - → isGroupoid ((x : A) (y : B x) (z : C x y) → D x y z) -isGroupoidΠ3 h = isGroupoidΠ λ _ → isGroupoidΠ2 λ _ → h _ _ - -isGroupoidΠ4 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) → isGroupoid (E x y z w)) - → isGroupoid ((x : A) (y : B x) (z : C x y) (w : D x y z) → E x y z w) -isGroupoidΠ4 h = isGroupoidΠ λ _ → isGroupoidΠ3 λ _ → h _ _ - -is2GroupoidΠ : ((x : A) → is2Groupoid (B x)) → is2Groupoid ((x : A) → B x) -is2GroupoidΠ = isOfHLevelΠ 4 - -isOfHLevelΠ⁻ : ∀ {A : Type ℓ} {B : Type ℓ'} n - → isOfHLevel n (A → B) → (A → isOfHLevel n B) -isOfHLevelΠ⁻ 0 h x = fst h x , λ y → funExt⁻ (snd h (const y)) x -isOfHLevelΠ⁻ 1 h x y z = funExt⁻ (h (const y) (const z)) x -isOfHLevelΠ⁻ (suc (suc n)) h x y z = - isOfHLevelΠ⁻ (suc n) (isOfHLevelRetractFromIso (suc n) funExtIso (h _ _)) x - -isOfHLevel→∙ : {A : Pointed ℓ} {B : Pointed ℓ'} (n : ℕ) - → isOfHLevel n (fst B) → isOfHLevel n (A →∙ B) -isOfHLevel→∙ n hlev = - isOfHLevelΣ n (isOfHLevelΠ n (λ _ → hlev)) - λ _ → isOfHLevelPath n hlev _ _ - --- h-level of A ≃ B and A ≡ B - -isOfHLevel≃ - : ∀ n {A : Type ℓ} {B : Type ℓ'} - → (hA : isOfHLevel n A) (hB : isOfHLevel n B) → isOfHLevel n (A ≃ B) -isOfHLevel≃ zero {A = A} {B = B} hA hB = isContr→Equiv hA hB , contr - where - contr : (y : A ≃ B) → isContr→Equiv hA hB ≡ y - contr y = Σ≡Prop isPropIsEquiv (funExt (λ a → snd hB (fst y a))) - -isOfHLevel≃ (suc n) {A = A} {B = B} hA hB = - isOfHLevelΣ (suc n) (isOfHLevelΠ _ λ _ → hB) - (λ f → isProp→isOfHLevelSuc n (isPropIsEquiv f)) - -isOfHLevel≡ : ∀ n → {A B : Type ℓ} (hA : isOfHLevel n A) (hB : isOfHLevel n B) → - isOfHLevel n (A ≡ B) -isOfHLevel≡ n hA hB = isOfHLevelRetractFromIso n univalenceIso (isOfHLevel≃ n hA hB) - -isOfHLevel⁺≃ₗ - : ∀ n {A : Type ℓ} {B : Type ℓ'} - → isOfHLevel (suc n) A → isOfHLevel (suc n) (A ≃ B) -isOfHLevel⁺≃ₗ zero pA e = isOfHLevel≃ 1 pA (isOfHLevelRespectEquiv 1 e pA) e -isOfHLevel⁺≃ₗ (suc n) hA e = isOfHLevel≃ m hA (isOfHLevelRespectEquiv m e hA) e - where - m = suc (suc n) - -isOfHLevel⁺≃ᵣ - : ∀ n {A : Type ℓ} {B : Type ℓ'} - → isOfHLevel (suc n) B → isOfHLevel (suc n) (A ≃ B) -isOfHLevel⁺≃ᵣ zero pB e - = isOfHLevel≃ 1 (isPropRetract (e .fst) (invEq e) (retEq e) pB) pB e -isOfHLevel⁺≃ᵣ (suc n) hB e - = isOfHLevel≃ m (isOfHLevelRetract m (e .fst) (invEq e) (retEq e) hB) hB e - where - m = suc (suc n) - -isOfHLevel⁺≡ₗ - : ∀ n → {A B : Type ℓ} - → isOfHLevel (suc n) A → isOfHLevel (suc n) (A ≡ B) -isOfHLevel⁺≡ₗ zero pA P = isOfHLevel≡ 1 pA (subst isProp P pA) P -isOfHLevel⁺≡ₗ (suc n) hA P - = isOfHLevel≡ m hA (subst (isOfHLevel m) P hA) P - where - m = suc (suc n) - -isOfHLevel⁺≡ᵣ - : ∀ n → {A B : Type ℓ} - → isOfHLevel (suc n) B → isOfHLevel (suc n) (A ≡ B) -isOfHLevel⁺≡ᵣ zero pB P = isOfHLevel≡ 1 (subst⁻ isProp P pB) pB P -isOfHLevel⁺≡ᵣ (suc n) hB P - = isOfHLevel≡ m (subst⁻ (isOfHLevel m) P hB) hB P - where - m = suc (suc n) - --- h-level of TypeOfHLevel - -isPropHContr : isProp (TypeOfHLevel ℓ 0) -isPropHContr x y = Σ≡Prop (λ _ → isPropIsContr) (isOfHLevel≡ 0 (x .snd) (y .snd) .fst) - -isOfHLevelTypeOfHLevel : ∀ n → isOfHLevel (suc n) (TypeOfHLevel ℓ n) -isOfHLevelTypeOfHLevel zero = isPropHContr -isOfHLevelTypeOfHLevel (suc n) (X , a) (Y , b) = - isOfHLevelRetract (suc n) (cong fst) (Σ≡Prop λ _ → isPropIsOfHLevel (suc n)) - (section-Σ≡Prop λ _ → isPropIsOfHLevel (suc n)) - (isOfHLevel≡ (suc n) a b) - -isSetHProp : isSet (hProp ℓ) -isSetHProp = isOfHLevelTypeOfHLevel 1 - -isGroupoidHSet : isGroupoid (hSet ℓ) -isGroupoidHSet = isOfHLevelTypeOfHLevel 2 - - --- h-level of lifted type - -isOfHLevelLift : ∀ {ℓ ℓ'} (n : HLevel) {A : Type ℓ} → isOfHLevel n A → isOfHLevel n (Lift {j = ℓ'} A) -isOfHLevelLift n = isOfHLevelRetract n lower lift λ _ → refl - -isOfHLevelLower : ∀ {ℓ ℓ'} (n : HLevel) {A : Type ℓ} → isOfHLevel n (Lift {j = ℓ'} A) → isOfHLevel n A -isOfHLevelLower n = isOfHLevelRetract n lift lower λ _ → refl - ----------------------------- - --- More consequences of isProp and isContr - -inhProp→isContr : A → isProp A → isContr A -inhProp→isContr x h = x , h x - -extend : isContr A → (∀ φ → (u : Partial φ A) → Sub A φ u) -extend (x , p) φ u = inS (hcomp (λ { j (φ = i1) → p (u 1=1) j }) x) - -isContrPartial→isContr : ∀ {ℓ} {A : Type ℓ} - → (extend : ∀ φ → Partial φ A → A) - → (∀ u → u ≡ (extend i1 λ { _ → u})) - → isContr A -isContrPartial→isContr {A = A} extend law - = ex , λ y → law ex ∙ (λ i → Aux.v y i) ∙ sym (law y) - where ex = extend i0 empty - module Aux (y : A) (i : I) where - φ = ~ i ∨ i - u : Partial φ A - u = λ { (i = i0) → ex ; (i = i1) → y } - v = extend φ u - --- Dependent h-level over a type - -isOfHLevelDep : HLevel → {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') -isOfHLevelDep 0 {A = A} B = {a : A} → Σ[ b ∈ B a ] ({a' : A} (b' : B a') (p : a ≡ a') → PathP (λ i → B (p i)) b b') -isOfHLevelDep 1 {A = A} B = {a0 a1 : A} (b0 : B a0) (b1 : B a1) (p : a0 ≡ a1) → PathP (λ i → B (p i)) b0 b1 -isOfHLevelDep (suc (suc n)) {A = A} B = {a0 a1 : A} (b0 : B a0) (b1 : B a1) → isOfHLevelDep (suc n) {A = a0 ≡ a1} (λ p → PathP (λ i → B (p i)) b0 b1) - -isContrDep : {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') -isContrDep = isOfHLevelDep 0 - -isPropDep : {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') -isPropDep = isOfHLevelDep 1 - -isContrDep∘ - : {A' : Type ℓ} (f : A' → A) → isContrDep B → isContrDep (B ∘ f) -isContrDep∘ f cB {a} = λ where - .fst → cB .fst - .snd b' p → cB .snd b' (cong f p) - -isPropDep∘ : {A' : Type ℓ} (f : A' → A) → isPropDep B → isPropDep (B ∘ f) -isPropDep∘ f pB b0 b1 = pB b0 b1 ∘ cong f - -isOfHLevelDep→isOfHLevel : (n : HLevel) - → {A : Type ℓ} {B : A → Type ℓ'} → isOfHLevelDep n {A = A} B → (a : A) → isOfHLevel n (B a) -isOfHLevelDep→isOfHLevel 0 h a = h .fst , λ b → h .snd b refl -isOfHLevelDep→isOfHLevel 1 h a x y = h x y refl -isOfHLevelDep→isOfHLevel (suc (suc n)) h a x y = isOfHLevelDep→isOfHLevel (suc n) (h x y) refl - -isOfHLevel→isOfHLevelDep : (n : HLevel) - → {A : Type ℓ} {B : A → Type ℓ'} (h : (a : A) → isOfHLevel n (B a)) → isOfHLevelDep n {A = A} B -isOfHLevel→isOfHLevelDep 0 h {a} = - (h a .fst , λ b' p → isProp→PathP (λ i → isContr→isProp (h (p i))) (h a .fst) b') -isOfHLevel→isOfHLevelDep 1 h = λ b0 b1 p → isProp→PathP (λ i → h (p i)) b0 b1 -isOfHLevel→isOfHLevelDep (suc (suc n)) {A = A} {B} h {a0} {a1} b0 b1 = - isOfHLevel→isOfHLevelDep (suc n) (λ p → helper p) - where - helper : (p : a0 ≡ a1) → - isOfHLevel (suc n) (PathP (λ i → B (p i)) b0 b1) - helper p = J (λ a1 p → ∀ b1 → isOfHLevel (suc n) (PathP (λ i → B (p i)) b0 b1)) - (λ _ → h _ _ _) p b1 - -isContrDep→isPropDep : isOfHLevelDep 0 B → isOfHLevelDep 1 B -isContrDep→isPropDep {B = B} Bctr {a0 = a0} b0 b1 p i - = comp (λ k → B (p (i ∧ k))) (λ k → λ where - (i = i0) → Bctr .snd b0 refl k - (i = i1) → Bctr .snd b1 p k) - (c0 .fst) - where - c0 = Bctr {a0} - -isPropDep→isSetDep : isOfHLevelDep 1 B → isOfHLevelDep 2 B -isPropDep→isSetDep {B = B} Bprp b0 b1 b2 b3 p i j - = comp (λ k → B (p (i ∧ k) (j ∧ k))) (λ k → λ where - (j = i0) → Bprp b0 b0 refl k - (i = i0) → Bprp b0 (b2 j) (λ k → p i0 (j ∧ k)) k - (i = i1) → Bprp b0 (b3 j) (λ k → p k (j ∧ k)) k - (j = i1) → Bprp b0 b1 (λ k → p (i ∧ k) (j ∧ k)) k) - b0 - -isOfHLevelDepSuc : (n : HLevel) → isOfHLevelDep n B → isOfHLevelDep (suc n) B -isOfHLevelDepSuc 0 = isContrDep→isPropDep -isOfHLevelDepSuc 1 = isPropDep→isSetDep -isOfHLevelDepSuc (suc (suc n)) Blvl b0 b1 = isOfHLevelDepSuc (suc n) (Blvl b0 b1) - -isPropDep→isSetDep' - : isOfHLevelDep 1 B - → {p : w ≡ x} {q : y ≡ z} {r : w ≡ y} {s : x ≡ z} - → {tw : B w} {tx : B x} {ty : B y} {tz : B z} - → (sq : Square p q r s) - → (tp : PathP (λ i → B (p i)) tw tx) - → (tq : PathP (λ i → B (q i)) ty tz) - → (tr : PathP (λ i → B (r i)) tw ty) - → (ts : PathP (λ i → B (s i)) tx tz) - → SquareP (λ i j → B (sq i j)) tp tq tr ts -isPropDep→isSetDep' {B = B} Bprp {p} {q} {r} {s} {tw} sq tp tq tr ts i j - = comp (λ k → B (sq (i ∧ k) (j ∧ k))) (λ k → λ where - (i = i0) → Bprp tw (tp j) (λ k → p (k ∧ j)) k - (i = i1) → Bprp tw (tq j) (λ k → sq (i ∧ k) (j ∧ k)) k - (j = i0) → Bprp tw (tr i) (λ k → r (k ∧ i)) k - (j = i1) → Bprp tw (ts i) (λ k → sq (k ∧ i) (j ∧ k)) k) - tw - -isOfHLevelΣ' : ∀ n → isOfHLevel n A → isOfHLevelDep n B → isOfHLevel n (Σ A B) -isOfHLevelΣ' 0 Actr Bctr .fst = (Actr .fst , Bctr .fst) -isOfHLevelΣ' 0 Actr Bctr .snd (x , y) i - = Actr .snd x i , Bctr .snd y (Actr .snd x) i -isOfHLevelΣ' 1 Alvl Blvl (w , y) (x , z) i .fst = Alvl w x i -isOfHLevelΣ' 1 Alvl Blvl (w , y) (x , z) i .snd = Blvl y z (Alvl w x) i -isOfHLevelΣ' {A = A} {B = B} (suc (suc n)) Alvl Blvl (w , y) (x , z) - = isOfHLevelRetract (suc n) - (λ p → (λ i → p i .fst) , λ i → p i .snd) - ΣPathP - (λ x → refl) - (isOfHLevelΣ' (suc n) (Alvl w x) (Blvl y z)) - -ΣSquareSet : ((x : A) → isSet (B x)) → {u v w x : Σ A B} - → {p : u ≡ v} {q : v ≡ w} {r : x ≡ w} {s : u ≡ x} - → Square (cong fst p) (cong fst r) - (cong fst s) (cong fst q) - → Square p r s q -fst (ΣSquareSet pB sq i j) = sq i j -snd (ΣSquareSet {B = B} pB {p = p} {q = q} {r = r} {s = s} sq i j) = lem i j - where - lem : SquareP (λ i j → B (sq i j)) - (cong snd p) (cong snd r) (cong snd s) (cong snd q) - lem = toPathP (isOfHLevelPathP' 1 (pB _) _ _ _ _) - -module _ (isSet-A : isSet A) (isSet-A' : isSet A') where - - - isSet-SetsIso : isSet (Iso A A') - isSet-SetsIso x y p₀ p₁ = h - where - - module X = Iso x - module Y = Iso y - - f-p : ∀ i₁ → (Iso.fun (p₀ i₁) , Iso.inv (p₀ i₁)) ≡ - (Iso.fun (p₁ i₁) , Iso.inv (p₁ i₁)) - fst (f-p i₁ i) a = isSet-A' (X.fun a ) (Y.fun a ) (cong _ p₀) (cong _ p₁) i i₁ - snd (f-p i₁ i) a' = isSet-A (X.inv a') (Y.inv a') (cong _ p₀) (cong _ p₁) i i₁ - - s-p : ∀ b → _ - s-p b = - isSet→SquareP (λ i j → isProp→isSet (isSet-A' _ _)) - refl refl (λ i₁ → (Iso.rightInv (p₀ i₁) b)) (λ i₁ → (Iso.rightInv (p₁ i₁) b)) - - r-p : ∀ a → _ - r-p a = - isSet→SquareP (λ i j → isProp→isSet (isSet-A _ _)) - refl refl (λ i₁ → (Iso.leftInv (p₀ i₁) a)) (λ i₁ → (Iso.leftInv (p₁ i₁) a)) - - - h : p₀ ≡ p₁ - Iso.fun (h i i₁) = fst (f-p i₁ i) - Iso.inv (h i i₁) = snd (f-p i₁ i) - Iso.rightInv (h i i₁) b = s-p b i₁ i - Iso.leftInv (h i i₁) a = r-p a i₁ i - - - SetsIso≡-ext : ∀ {a b : Iso A A'} - → (∀ x → Iso.fun a x ≡ Iso.fun b x) - → (∀ x → Iso.inv a x ≡ Iso.inv b x) - → a ≡ b - Iso.fun (SetsIso≡-ext {a} {b} fun≡ inv≡ i) x = fun≡ x i - Iso.inv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) x = inv≡ x i - Iso.rightInv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) b₁ = - isSet→SquareP (λ _ _ → isSet-A') - (Iso.rightInv a b₁) - (Iso.rightInv b b₁) - (λ i → fun≡ (inv≡ b₁ i) i) - refl i - Iso.leftInv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) a₁ = - isSet→SquareP (λ _ _ → isSet-A) - (Iso.leftInv a a₁) - (Iso.leftInv b a₁) - (λ i → inv≡ (fun≡ a₁ i) i ) - refl i - - SetsIso≡ : ∀ {a b : Iso A A'} - → (Iso.fun a ≡ Iso.fun b) - → (Iso.inv a ≡ Iso.inv b) - → a ≡ b - SetsIso≡ p q = - SetsIso≡-ext (funExt⁻ p) (funExt⁻ q) - - isSet→Iso-Iso-≃ : Iso (Iso A A') (A ≃ A') - isSet→Iso-Iso-≃ = ww - where - open Iso - - ww : Iso _ _ - fun ww = isoToEquiv - inv ww = equivToIso - rightInv ww b = equivEq refl - leftInv ww a = SetsIso≡ refl refl - - - isSet→isEquiv-isoToPath : isEquiv isoToEquiv - isSet→isEquiv-isoToPath = isoToIsEquiv isSet→Iso-Iso-≃ - - - -isSet→Iso-Iso-≡ : (isSet-A : isSet A) → (isSet-A' : isSet A') → Iso (Iso A A') (A ≡ A') -isSet→Iso-Iso-≡ isSet-A isSet-A' = ww - where - open Iso - - ww : Iso _ _ - fun ww = isoToPath - inv ww = pathToIso - rightInv ww b = isInjectiveTransport (funExt λ _ → transportRefl _) - leftInv ww a = SetsIso≡-ext isSet-A isSet-A' (λ _ → transportRefl (fun a _)) λ _ → cong (inv a) (transportRefl _) - -hSet-Iso-Iso-≡ : (A : hSet ℓ) → (A' : hSet ℓ) → Iso (Iso (fst A) (fst A')) (A ≡ A') -hSet-Iso-Iso-≡ A A' = compIso (isSet→Iso-Iso-≡ (snd A) (snd A')) (equivToIso (_ , isEquiv-Σ≡Prop λ _ → isPropIsSet)) +isPropImplicitΠ3 : (h : (x : A) (y : B x) (z : C x y) → isProp (D x y z)) → + isProp ({x : A} {y : B x} {z : C x y} → D x y z) +isPropImplicitΠ3 h = isPropImplicitΠ (λ x → isPropImplicitΠ2 (λ y → h x y)) + +isPropImplicitΠ4 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) → isProp (E x y z w)) → + isProp ({x : A} {y : B x} {z : C x y} {w : D x y z} → E x y z w) +isPropImplicitΠ4 h = isPropImplicitΠ (λ x → isPropImplicitΠ3 (λ y → h x y)) + +isProp→ : {A : Type ℓ} {B : Type ℓ'} → isProp B → isProp (A → B) +isProp→ pB = isPropΠ λ _ → pB + +isSetΠ : ((x : A) → isSet (B x)) → isSet ((x : A) → B x) +isSetΠ = isOfHLevelΠ 2 + +isSetImplicitΠ : (h : (x : A) → isSet (B x)) → isSet ({x : A} → B x) +isSetImplicitΠ h f g F G i j {x} = h x (f {x}) (g {x}) (λ i → F i {x}) (λ i → G i {x}) i j + +isSetImplicitΠ2 : (h : (x : A) → (y : B x) → isSet (C x y)) → isSet ({x : A} → {y : B x} → C x y) +isSetImplicitΠ2 h = isSetImplicitΠ (λ x → isSetImplicitΠ (λ y → h x y)) + +isSetImplicitΠ3 : (h : (x : A) → (y : B x) → (z : C x y) → isSet (D x y z)) → + isSet ({x : A} → {y : B x} → {z : C x y} → D x y z) +isSetImplicitΠ3 h = isSetImplicitΠ (λ x → isSetImplicitΠ2 (λ y → λ z → h x y z)) + +isSet→ : isSet A' → isSet (A → A') +isSet→ isSet-A' = isOfHLevelΠ 2 (λ _ → isSet-A') + +isSetΠ2 : (h : (x : A) (y : B x) → isSet (C x y)) + → isSet ((x : A) (y : B x) → C x y) +isSetΠ2 h = isSetΠ λ x → isSetΠ λ y → h x y + +isSetΠ3 : (h : (x : A) (y : B x) (z : C x y) → isSet (D x y z)) + → isSet ((x : A) (y : B x) (z : C x y) → D x y z) +isSetΠ3 h = isSetΠ λ x → isSetΠ λ y → isSetΠ λ z → h x y z + +isGroupoidΠ : ((x : A) → isGroupoid (B x)) → isGroupoid ((x : A) → B x) +isGroupoidΠ = isOfHLevelΠ 3 + +isGroupoidΠ2 : (h : (x : A) (y : B x) → isGroupoid (C x y)) → isGroupoid ((x : A) (y : B x) → C x y) +isGroupoidΠ2 h = isGroupoidΠ λ _ → isGroupoidΠ λ _ → h _ _ + +isGroupoidΠ3 : (h : (x : A) (y : B x) (z : C x y) → isGroupoid (D x y z)) + → isGroupoid ((x : A) (y : B x) (z : C x y) → D x y z) +isGroupoidΠ3 h = isGroupoidΠ λ _ → isGroupoidΠ2 λ _ → h _ _ + +isGroupoidΠ4 : (h : (x : A) (y : B x) (z : C x y) (w : D x y z) → isGroupoid (E x y z w)) + → isGroupoid ((x : A) (y : B x) (z : C x y) (w : D x y z) → E x y z w) +isGroupoidΠ4 h = isGroupoidΠ λ _ → isGroupoidΠ3 λ _ → h _ _ + +is2GroupoidΠ : ((x : A) → is2Groupoid (B x)) → is2Groupoid ((x : A) → B x) +is2GroupoidΠ = isOfHLevelΠ 4 + +isOfHLevelΠ⁻ : ∀ {A : Type ℓ} {B : Type ℓ'} n + → isOfHLevel n (A → B) → (A → isOfHLevel n B) +isOfHLevelΠ⁻ 0 h x = fst h x , λ y → funExt⁻ (snd h (const y)) x +isOfHLevelΠ⁻ 1 h x y z = funExt⁻ (h (const y) (const z)) x +isOfHLevelΠ⁻ (suc (suc n)) h x y z = + isOfHLevelΠ⁻ (suc n) (isOfHLevelRetractFromIso (suc n) funExtIso (h _ _)) x + +isOfHLevel→∙ : {A : Pointed ℓ} {B : Pointed ℓ'} (n : ℕ) + → isOfHLevel n (fst B) → isOfHLevel n (A →∙ B) +isOfHLevel→∙ n hlev = + isOfHLevelΣ n (isOfHLevelΠ n (λ _ → hlev)) + λ _ → isOfHLevelPath n hlev _ _ + +-- h-level of A ≃ B and A ≡ B + +isOfHLevel≃ + : ∀ n {A : Type ℓ} {B : Type ℓ'} + → (hA : isOfHLevel n A) (hB : isOfHLevel n B) → isOfHLevel n (A ≃ B) +isOfHLevel≃ zero {A = A} {B = B} hA hB = isContr→Equiv hA hB , contr + where + contr : (y : A ≃ B) → isContr→Equiv hA hB ≡ y + contr y = Σ≡Prop isPropIsEquiv (funExt (λ a → snd hB (fst y a))) + +isOfHLevel≃ (suc n) {A = A} {B = B} hA hB = + isOfHLevelΣ (suc n) (isOfHLevelΠ _ λ _ → hB) + (λ f → isProp→isOfHLevelSuc n (isPropIsEquiv f)) + +isOfHLevel≡ : ∀ n → {A B : Type ℓ} (hA : isOfHLevel n A) (hB : isOfHLevel n B) → + isOfHLevel n (A ≡ B) +isOfHLevel≡ n hA hB = isOfHLevelRetractFromIso n univalenceIso (isOfHLevel≃ n hA hB) + +isOfHLevel⁺≃ₗ + : ∀ n {A : Type ℓ} {B : Type ℓ'} + → isOfHLevel (suc n) A → isOfHLevel (suc n) (A ≃ B) +isOfHLevel⁺≃ₗ zero pA e = isOfHLevel≃ 1 pA (isOfHLevelRespectEquiv 1 e pA) e +isOfHLevel⁺≃ₗ (suc n) hA e = isOfHLevel≃ m hA (isOfHLevelRespectEquiv m e hA) e + where + m = suc (suc n) + +isOfHLevel⁺≃ᵣ + : ∀ n {A : Type ℓ} {B : Type ℓ'} + → isOfHLevel (suc n) B → isOfHLevel (suc n) (A ≃ B) +isOfHLevel⁺≃ᵣ zero pB e + = isOfHLevel≃ 1 (isPropRetract (e .fst) (invEq e) (retEq e) pB) pB e +isOfHLevel⁺≃ᵣ (suc n) hB e + = isOfHLevel≃ m (isOfHLevelRetract m (e .fst) (invEq e) (retEq e) hB) hB e + where + m = suc (suc n) + +isOfHLevel⁺≡ₗ + : ∀ n → {A B : Type ℓ} + → isOfHLevel (suc n) A → isOfHLevel (suc n) (A ≡ B) +isOfHLevel⁺≡ₗ zero pA P = isOfHLevel≡ 1 pA (subst isProp P pA) P +isOfHLevel⁺≡ₗ (suc n) hA P + = isOfHLevel≡ m hA (subst (isOfHLevel m) P hA) P + where + m = suc (suc n) + +isOfHLevel⁺≡ᵣ + : ∀ n → {A B : Type ℓ} + → isOfHLevel (suc n) B → isOfHLevel (suc n) (A ≡ B) +isOfHLevel⁺≡ᵣ zero pB P = isOfHLevel≡ 1 (subst⁻ isProp P pB) pB P +isOfHLevel⁺≡ᵣ (suc n) hB P + = isOfHLevel≡ m (subst⁻ (isOfHLevel m) P hB) hB P + where + m = suc (suc n) + +-- h-level of TypeOfHLevel + +isPropHContr : isProp (TypeOfHLevel ℓ 0) +isPropHContr x y = Σ≡Prop (λ _ → isPropIsContr) (isOfHLevel≡ 0 (x .snd) (y .snd) .fst) + +isOfHLevelTypeOfHLevel : ∀ n → isOfHLevel (suc n) (TypeOfHLevel ℓ n) +isOfHLevelTypeOfHLevel zero = isPropHContr +isOfHLevelTypeOfHLevel (suc n) (X , a) (Y , b) = + isOfHLevelRetract (suc n) (cong fst) (Σ≡Prop λ _ → isPropIsOfHLevel (suc n)) + (section-Σ≡Prop λ _ → isPropIsOfHLevel (suc n)) + (isOfHLevel≡ (suc n) a b) + +isSetHProp : isSet (hProp ℓ) +isSetHProp = isOfHLevelTypeOfHLevel 1 + +isGroupoidHSet : isGroupoid (hSet ℓ) +isGroupoidHSet = isOfHLevelTypeOfHLevel 2 + + +-- h-level of lifted type + +isOfHLevelLift : ∀ {ℓ ℓ'} (n : HLevel) {A : Type ℓ} → isOfHLevel n A → isOfHLevel n (Lift {j = ℓ'} A) +isOfHLevelLift n = isOfHLevelRetract n lower lift λ _ → refl + +isOfHLevelLower : ∀ {ℓ ℓ'} (n : HLevel) {A : Type ℓ} → isOfHLevel n (Lift {j = ℓ'} A) → isOfHLevel n A +isOfHLevelLower n = isOfHLevelRetract n lift lower λ _ → refl + +---------------------------- + +-- More consequences of isProp and isContr + +inhProp→isContr : A → isProp A → isContr A +inhProp→isContr x h = x , h x + +extend : isContr A → (∀ φ → (u : Partial φ A) → Sub A φ u) +extend (x , p) φ u = inS (hcomp (λ { j (φ = i1) → p (u 1=1) j }) x) + +isContrPartial→isContr : ∀ {ℓ} {A : Type ℓ} + → (extend : ∀ φ → Partial φ A → A) + → (∀ u → u ≡ (extend i1 λ { _ → u})) + → isContr A +isContrPartial→isContr {A = A} extend law + = ex , λ y → law ex ∙ (λ i → Aux.v y i) ∙ sym (law y) + where ex = extend i0 empty + module Aux (y : A) (i : I) where + φ = ~ i ∨ i + u : Partial φ A + u = λ { (i = i0) → ex ; (i = i1) → y } + v = extend φ u + +-- Dependent h-level over a type + +isOfHLevelDep : HLevel → {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') +isOfHLevelDep 0 {A = A} B = {a : A} → Σ[ b ∈ B a ] ({a' : A} (b' : B a') (p : a ≡ a') → PathP (λ i → B (p i)) b b') +isOfHLevelDep 1 {A = A} B = {a0 a1 : A} (b0 : B a0) (b1 : B a1) (p : a0 ≡ a1) → PathP (λ i → B (p i)) b0 b1 +isOfHLevelDep (suc (suc n)) {A = A} B = {a0 a1 : A} (b0 : B a0) (b1 : B a1) → isOfHLevelDep (suc n) {A = a0 ≡ a1} (λ p → PathP (λ i → B (p i)) b0 b1) + +isContrDep : {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') +isContrDep = isOfHLevelDep 0 + +isPropDep : {A : Type ℓ} (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ') +isPropDep = isOfHLevelDep 1 + +isContrDep∘ + : {A' : Type ℓ} (f : A' → A) → isContrDep B → isContrDep (B ∘ f) +isContrDep∘ f cB {a} = λ where + .fst → cB .fst + .snd b' p → cB .snd b' (cong f p) + +isPropDep∘ : {A' : Type ℓ} (f : A' → A) → isPropDep B → isPropDep (B ∘ f) +isPropDep∘ f pB b0 b1 = pB b0 b1 ∘ cong f + +isOfHLevelDep→isOfHLevel : (n : HLevel) + → {A : Type ℓ} {B : A → Type ℓ'} → isOfHLevelDep n {A = A} B → (a : A) → isOfHLevel n (B a) +isOfHLevelDep→isOfHLevel 0 h a = h .fst , λ b → h .snd b refl +isOfHLevelDep→isOfHLevel 1 h a x y = h x y refl +isOfHLevelDep→isOfHLevel (suc (suc n)) h a x y = isOfHLevelDep→isOfHLevel (suc n) (h x y) refl + +isOfHLevel→isOfHLevelDep : (n : HLevel) + → {A : Type ℓ} {B : A → Type ℓ'} (h : (a : A) → isOfHLevel n (B a)) → isOfHLevelDep n {A = A} B +isOfHLevel→isOfHLevelDep 0 h {a} = + (h a .fst , λ b' p → isProp→PathP (λ i → isContr→isProp (h (p i))) (h a .fst) b') +isOfHLevel→isOfHLevelDep 1 h = λ b0 b1 p → isProp→PathP (λ i → h (p i)) b0 b1 +isOfHLevel→isOfHLevelDep (suc (suc n)) {A = A} {B} h {a0} {a1} b0 b1 = + isOfHLevel→isOfHLevelDep (suc n) (λ p → helper p) + where + helper : (p : a0 ≡ a1) → + isOfHLevel (suc n) (PathP (λ i → B (p i)) b0 b1) + helper p = J (λ a1 p → ∀ b1 → isOfHLevel (suc n) (PathP (λ i → B (p i)) b0 b1)) + (λ _ → h _ _ _) p b1 + +isContrDep→isPropDep : isOfHLevelDep 0 B → isOfHLevelDep 1 B +isContrDep→isPropDep {B = B} Bctr {a0 = a0} b0 b1 p i + = comp (λ k → B (p (i ∧ k))) (λ k → λ where + (i = i0) → Bctr .snd b0 refl k + (i = i1) → Bctr .snd b1 p k) + (c0 .fst) + where + c0 = Bctr {a0} + +isPropDep→isSetDep : isOfHLevelDep 1 B → isOfHLevelDep 2 B +isPropDep→isSetDep {B = B} Bprp b0 b1 b2 b3 p i j + = comp (λ k → B (p (i ∧ k) (j ∧ k))) (λ k → λ where + (j = i0) → Bprp b0 b0 refl k + (i = i0) → Bprp b0 (b2 j) (λ k → p i0 (j ∧ k)) k + (i = i1) → Bprp b0 (b3 j) (λ k → p k (j ∧ k)) k + (j = i1) → Bprp b0 b1 (λ k → p (i ∧ k) (j ∧ k)) k) + b0 + +isOfHLevelDepSuc : (n : HLevel) → isOfHLevelDep n B → isOfHLevelDep (suc n) B +isOfHLevelDepSuc 0 = isContrDep→isPropDep +isOfHLevelDepSuc 1 = isPropDep→isSetDep +isOfHLevelDepSuc (suc (suc n)) Blvl b0 b1 = isOfHLevelDepSuc (suc n) (Blvl b0 b1) + +isPropDep→isSetDep' + : isOfHLevelDep 1 B + → {p : w ≡ x} {q : y ≡ z} {r : w ≡ y} {s : x ≡ z} + → {tw : B w} {tx : B x} {ty : B y} {tz : B z} + → (sq : Square p q r s) + → (tp : PathP (λ i → B (p i)) tw tx) + → (tq : PathP (λ i → B (q i)) ty tz) + → (tr : PathP (λ i → B (r i)) tw ty) + → (ts : PathP (λ i → B (s i)) tx tz) + → SquareP (λ i j → B (sq i j)) tp tq tr ts +isPropDep→isSetDep' {B = B} Bprp {p} {q} {r} {s} {tw} sq tp tq tr ts i j + = comp (λ k → B (sq (i ∧ k) (j ∧ k))) (λ k → λ where + (i = i0) → Bprp tw (tp j) (λ k → p (k ∧ j)) k + (i = i1) → Bprp tw (tq j) (λ k → sq (i ∧ k) (j ∧ k)) k + (j = i0) → Bprp tw (tr i) (λ k → r (k ∧ i)) k + (j = i1) → Bprp tw (ts i) (λ k → sq (k ∧ i) (j ∧ k)) k) + tw + +isOfHLevelΣ' : ∀ n → isOfHLevel n A → isOfHLevelDep n B → isOfHLevel n (Σ A B) +isOfHLevelΣ' 0 Actr Bctr .fst = (Actr .fst , Bctr .fst) +isOfHLevelΣ' 0 Actr Bctr .snd (x , y) i + = Actr .snd x i , Bctr .snd y (Actr .snd x) i +isOfHLevelΣ' 1 Alvl Blvl (w , y) (x , z) i .fst = Alvl w x i +isOfHLevelΣ' 1 Alvl Blvl (w , y) (x , z) i .snd = Blvl y z (Alvl w x) i +isOfHLevelΣ' {A = A} {B = B} (suc (suc n)) Alvl Blvl (w , y) (x , z) + = isOfHLevelRetract (suc n) + (λ p → (λ i → p i .fst) , λ i → p i .snd) + ΣPathP + (λ x → refl) + (isOfHLevelΣ' (suc n) (Alvl w x) (Blvl y z)) + +ΣSquareSet : ((x : A) → isSet (B x)) → {u v w x : Σ A B} + → {p : u ≡ v} {q : v ≡ w} {r : x ≡ w} {s : u ≡ x} + → Square (cong fst p) (cong fst r) + (cong fst s) (cong fst q) + → Square p r s q +fst (ΣSquareSet pB sq i j) = sq i j +snd (ΣSquareSet {B = B} pB {p = p} {q = q} {r = r} {s = s} sq i j) = lem i j + where + lem : SquareP (λ i j → B (sq i j)) + (cong snd p) (cong snd r) (cong snd s) (cong snd q) + lem = toPathP (isOfHLevelPathP' 1 (pB _) _ _ _ _) + +module _ (isSet-A : isSet A) (isSet-A' : isSet A') where + + + isSet-SetsIso : isSet (Iso A A') + isSet-SetsIso x y p₀ p₁ = h + where + + module X = Iso x + module Y = Iso y + + f-p : ∀ i₁ → (Iso.fun (p₀ i₁) , Iso.inv (p₀ i₁)) ≡ + (Iso.fun (p₁ i₁) , Iso.inv (p₁ i₁)) + fst (f-p i₁ i) a = isSet-A' (X.fun a ) (Y.fun a ) (cong _ p₀) (cong _ p₁) i i₁ + snd (f-p i₁ i) a' = isSet-A (X.inv a') (Y.inv a') (cong _ p₀) (cong _ p₁) i i₁ + + s-p : ∀ b → _ + s-p b = + isSet→SquareP (λ i j → isProp→isSet (isSet-A' _ _)) + refl refl (λ i₁ → (Iso.rightInv (p₀ i₁) b)) (λ i₁ → (Iso.rightInv (p₁ i₁) b)) + + r-p : ∀ a → _ + r-p a = + isSet→SquareP (λ i j → isProp→isSet (isSet-A _ _)) + refl refl (λ i₁ → (Iso.leftInv (p₀ i₁) a)) (λ i₁ → (Iso.leftInv (p₁ i₁) a)) + + + h : p₀ ≡ p₁ + Iso.fun (h i i₁) = fst (f-p i₁ i) + Iso.inv (h i i₁) = snd (f-p i₁ i) + Iso.rightInv (h i i₁) b = s-p b i₁ i + Iso.leftInv (h i i₁) a = r-p a i₁ i + + + SetsIso≡-ext : ∀ {a b : Iso A A'} + → (∀ x → Iso.fun a x ≡ Iso.fun b x) + → (∀ x → Iso.inv a x ≡ Iso.inv b x) + → a ≡ b + Iso.fun (SetsIso≡-ext {a} {b} fun≡ inv≡ i) x = fun≡ x i + Iso.inv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) x = inv≡ x i + Iso.rightInv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) b₁ = + isSet→SquareP (λ _ _ → isSet-A') + (Iso.rightInv a b₁) + (Iso.rightInv b b₁) + (λ i → fun≡ (inv≡ b₁ i) i) + refl i + Iso.leftInv (SetsIso≡-ext {a} {b} fun≡ inv≡ i) a₁ = + isSet→SquareP (λ _ _ → isSet-A) + (Iso.leftInv a a₁) + (Iso.leftInv b a₁) + (λ i → inv≡ (fun≡ a₁ i) i ) + refl i + + SetsIso≡ : ∀ {a b : Iso A A'} + → (Iso.fun a ≡ Iso.fun b) + → (Iso.inv a ≡ Iso.inv b) + → a ≡ b + SetsIso≡ p q = + SetsIso≡-ext (funExt⁻ p) (funExt⁻ q) + + isSet→Iso-Iso-≃ : Iso (Iso A A') (A ≃ A') + isSet→Iso-Iso-≃ = ww + where + open Iso + + ww : Iso _ _ + fun ww = isoToEquiv + inv ww = equivToIso + rightInv ww b = equivEq refl + leftInv ww a = SetsIso≡ refl refl + + + isSet→isEquiv-isoToPath : isEquiv isoToEquiv + isSet→isEquiv-isoToPath = isoToIsEquiv isSet→Iso-Iso-≃ + + + +isSet→Iso-Iso-≡ : (isSet-A : isSet A) → (isSet-A' : isSet A') → Iso (Iso A A') (A ≡ A') +isSet→Iso-Iso-≡ isSet-A isSet-A' = ww + where + open Iso + + ww : Iso _ _ + fun ww = isoToPath + inv ww = pathToIso + rightInv ww b = isInjectiveTransport (funExt λ _ → transportRefl _) + leftInv ww a = SetsIso≡-ext isSet-A isSet-A' (λ _ → transportRefl (fun a _)) λ _ → cong (inv a) (transportRefl _) + +hSet-Iso-Iso-≡ : (A : hSet ℓ) → (A' : hSet ℓ) → Iso (Iso (fst A) (fst A')) (A ≡ A') +hSet-Iso-Iso-≡ A A' = compIso (isSet→Iso-Iso-≡ (snd A) (snd A')) (equivToIso (_ , isEquiv-Σ≡Prop λ _ → isPropIsSet)) + +module _ (B : (i j k : I) → Type ℓ) + {c₀₀₀ : B i0 i0 i0} {c₀₀₁ : B i0 i0 i1} {c₀₁₀ : B i0 i1 i0} {c₀₁₁ : B i0 i1 i1} + {c₁₀₀ : B i1 i0 i0} {c₁₀₁ : B i1 i0 i1} {c₁₁₀ : B i1 i1 i0} {c₁₁₁ : B i1 i1 i1} + {c₀₀₋ : PathP (λ k → B i0 i0 k) c₀₀₀ c₀₀₁} {c₀₁₋ : PathP (λ k → B i0 i1 k) c₀₁₀ c₀₁₁} + {c₀₋₀ : PathP (λ i → B i0 i i0) c₀₀₀ c₀₁₀} {c₀₋₁ : PathP (λ i → B i0 i i1) c₀₀₁ c₀₁₁} + {c₁₀₋ : PathP (λ k → B i1 i0 k) c₁₀₀ c₁₀₁} {c₁₁₋ : PathP (λ k → B i1 i1 k) c₁₁₀ c₁₁₁} + {c₁₋₀ : PathP (λ i → B i1 i i0) c₁₀₀ c₁₁₀} {c₁₋₁ : PathP (λ i → B i1 i i1) c₁₀₁ c₁₁₁} + {c₋₀₀ : PathP (λ i → B i i0 i0) c₀₀₀ c₁₀₀} {c₋₀₁ : PathP (λ i → B i i0 i1) c₀₀₁ c₁₀₁} + {c₋₁₀ : PathP (λ i → B i i1 i0) c₀₁₀ c₁₁₀} {c₋₁₁ : PathP (λ i → B i i1 i1) c₀₁₁ c₁₁₁} + (c₀₋₋ : SquareP (λ j k → B i0 j k) c₀₀₋ c₀₁₋ c₀₋₀ c₀₋₁) + (c₁₋₋ : SquareP (λ j k → B i1 j k) c₁₀₋ c₁₁₋ c₁₋₀ c₁₋₁) + (c₋₀₋ : SquareP (λ i k → B i i0 k) c₀₀₋ c₁₀₋ c₋₀₀ c₋₀₁) + (c₋₁₋ : SquareP (λ i k → B i i1 k) c₀₁₋ c₁₁₋ c₋₁₀ c₋₁₁) + (c₋₋₀ : SquareP (λ i j → B i j i0) c₀₋₀ c₁₋₀ c₋₀₀ c₋₁₀) + (c₋₋₁ : SquareP (λ i j → B i j i1) c₀₋₁ c₁₋₁ c₋₀₁ c₋₁₁) where + + CubeP : Type ℓ + CubeP = PathP (λ i → SquareP (λ j k → B i j k) + (c₋₀₋ i) (c₋₁₋ i) + (c₋₋₀ i) (c₋₋₁ i)) + c₀₋₋ c₁₋₋ + + isGroupoid→CubeP : isGroupoid (B i1 i1 i1) → CubeP + isGroupoid→CubeP grpd = + isOfHLevelPathP' 0 (isOfHLevelPathP' 1 (isOfHLevelPathP' 2 grpd _ _) _ _) _ _ .fst \ No newline at end of file diff --git a/docs/Cubical.Foundations.Isomorphism.html b/docs/Cubical.Foundations.Isomorphism.html index b9bd2d5..14f72f6 100644 --- a/docs/Cubical.Foundations.Isomorphism.html +++ b/docs/Cubical.Foundations.Isomorphism.html @@ -149,25 +149,25 @@ rightInv (compIsoIdR isom i) b = rUnit (isom .rightInv b) (~ i) leftInv (compIsoIdR isom i) a = lUnit (isom .leftInv a) (~ i) -LiftIso : Iso A (Lift {i = ℓ} {j = ℓ'} A) -fun LiftIso = lift -inv LiftIso = lower +LiftIso : Iso A (Lift {i = ℓ} {j = ℓ'} A) +fun LiftIso = lift +inv LiftIso = lower rightInv LiftIso _ = refl leftInv LiftIso _ = refl -isContr→Iso : isContr A → isContr B → Iso A B +isContr→Iso : isContr A → isContr B → Iso A B fun (isContr→Iso _ Bctr) _ = Bctr .fst inv (isContr→Iso Actr _) _ = Actr .fst rightInv (isContr→Iso _ Bctr) = Bctr .snd leftInv (isContr→Iso Actr _) = Actr .snd -isContr→Iso' : isContr A → isContr B → (A → B) → Iso A B +isContr→Iso' : isContr A → isContr B → (A → B) → Iso A B fun (isContr→Iso' _ Bctr f) = f inv (isContr→Iso' Actr _ _) _ = Actr .fst -rightInv (isContr→Iso' _ Bctr f) = isContr→isProp Bctr _ +rightInv (isContr→Iso' _ Bctr f) = isContr→isProp Bctr _ leftInv (isContr→Iso' Actr _ _) = Actr .snd -isProp→Iso : (Aprop : isProp A) (Bprop : isProp B) (f : A → B) (g : B → A) → Iso A B +isProp→Iso : (Aprop : isProp A) (Bprop : isProp B) (f : A → B) (g : B → A) → Iso A B fun (isProp→Iso _ _ f _) = f inv (isProp→Iso _ _ _ g) = g rightInv (isProp→Iso _ Bprop f g) b = Bprop (f (g b)) b @@ -208,14 +208,20 @@ binaryOpIso : Iso A B → Iso (A → A → A) (B → B → B) binaryOpIso is = compIso (domIso is) (codomainIso (endoIso is)) -Iso≡Set : isSet A → isSet B → (f g : Iso A B) +Iso≡Set : isSet A → isSet B → (f g : Iso A B) → ((x : A) → f .fun x ≡ g .fun x) → ((x : B) → f .inv x ≡ g .inv x) → f ≡ g fun (Iso≡Set hA hB f g hfun hinv i) x = hfun x i inv (Iso≡Set hA hB f g hfun hinv i) x = hinv x i rightInv (Iso≡Set hA hB f g hfun hinv i) x j = - isSet→isSet' hB (rightInv f x) (rightInv g x) (λ i → hfun (hinv x i) i) refl i j + isSet→isSet' hB (rightInv f x) (rightInv g x) (λ i → hfun (hinv x i) i) refl i j leftInv (Iso≡Set hA hB f g hfun hinv i) x j = - isSet→isSet' hA (leftInv f x) (leftInv g x) (λ i → hinv (hfun x i) i) refl i j + isSet→isSet' hA (leftInv f x) (leftInv g x) (λ i → hinv (hfun x i) i) refl i j + +transportIsoToPath : (f : Iso A B) (x : A) → transport (isoToPath f) x ≡ f .fun x +transportIsoToPath f x = transportRefl _ + +transportIsoToPath⁻ : (f : Iso A B) (x : B) → transport (sym (isoToPath f)) x ≡ f .inv x +transportIsoToPath⁻ f x = cong (f .inv) (transportRefl _) \ No newline at end of file diff --git a/docs/Cubical.Foundations.Path.html b/docs/Cubical.Foundations.Path.html index 87ee14d..30857c1 100644 --- a/docs/Cubical.Foundations.Path.html +++ b/docs/Cubical.Foundations.Path.html @@ -19,10 +19,10 @@ module _ {A : I → Type ℓ} {x : A i0} {y : A i1} where toPathP⁻ : x ≡ transport⁻ (λ i → A i) y → PathP A x y - toPathP⁻ p = symP (toPathP (sym p)) + toPathP⁻ p = symP (toPathP (sym p)) fromPathP⁻ : PathP A x y → x ≡ transport⁻ (λ i → A i) y - fromPathP⁻ p = sym (fromPathP {A = λ i → A (~ i)} (symP p)) + fromPathP⁻ p = sym (fromPathP {A = λ i → A (~ i)} (symP p)) PathP≡Path : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) → PathP P p q ≡ Path (P i1) (transport (λ i → P i) p) q @@ -33,8 +33,8 @@ PathP≡Path⁻ P p q i = PathP (λ j → P (~ i ∧ j)) p (transport⁻-filler (λ j → P j) q i) PathPIsoPath : ∀ (A : I → Type ℓ) (x : A i0) (y : A i1) → Iso (PathP A x y) (transport (λ i → A i) x ≡ y) -PathPIsoPath A x y .Iso.fun = fromPathP -PathPIsoPath A x y .Iso.inv = toPathP +PathPIsoPath A x y .Iso.fun = fromPathP +PathPIsoPath A x y .Iso.inv = toPathP PathPIsoPath A x y .Iso.rightInv q k i = hcomp (λ j → λ @@ -89,11 +89,11 @@ PathP≡compPath p q r k = PathP (λ i → p i0 ≡ q (i ∨ k)) (λ j → compPath-filler p q k j) r -- a quick corollary for 3-constant functions -3-ConstantCompChar : {A : Type ℓ} {B : Type ℓ'} (f : A → B) (link : 2-Constant f) +3-ConstantCompChar : {A : Type ℓ} {B : Type ℓ'} (f : A → B) (link : 2-Constant f) → (∀ x y z → link x y ∙ link y z ≡ link x z) - → 3-Constant f -3-Constant.link (3-ConstantCompChar f link coh₂) = link -3-Constant.coh₁ (3-ConstantCompChar f link coh₂) _ _ _ = + → 3-Constant f +3-Constant.link (3-ConstantCompChar f link coh₂) = link +3-Constant.coh₁ (3-ConstantCompChar f link coh₂) _ _ _ = transport⁻ (PathP≡compPath _ _ _) (coh₂ _ _ _) PathP≡doubleCompPathˡ : ∀ {A : Type ℓ} {w x y z : A} (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z) @@ -129,11 +129,11 @@ compPathrEquiv p = (_∙ p) , compPathr-isEquiv p -- Variations of isProp→isSet for PathP -isProp→SquareP : ∀ {B : I → I → Type ℓ} → ((i j : I) → isProp (B i j)) +isProp→SquareP : ∀ {B : I → I → Type ℓ} → ((i j : I) → isProp (B i j)) → {a : B i0 i0} {b : B i0 i1} {c : B i1 i0} {d : B i1 i1} → (r : PathP (λ j → B j i0) a c) (s : PathP (λ j → B j i1) b d) → (t : PathP (λ j → B i0 j) a b) (u : PathP (λ j → B i1 j) c d) - → SquareP B t u r s + → SquareP B t u r s isProp→SquareP {B = B} isPropB {a = a} r s t u i j = hcomp (λ { k (i = i0) → isPropB i0 j (base i0 j) (t j) k ; k (i = i1) → isPropB i1 j (base i1 j) (u j) k @@ -143,32 +143,32 @@ base : (i j : I) → B i j base i j = transport (λ k → B (i ∧ k) (j ∧ k)) a -isProp→isPropPathP : ∀ {ℓ} {B : I → Type ℓ} → ((i : I) → isProp (B i)) +isProp→isPropPathP : ∀ {ℓ} {B : I → Type ℓ} → ((i : I) → isProp (B i)) → (b0 : B i0) (b1 : B i1) - → isProp (PathP (λ i → B i) b0 b1) + → isProp (PathP (λ i → B i) b0 b1) isProp→isPropPathP {B = B} hB b0 b1 = isProp→SquareP (λ _ → hB) refl refl -isProp→isContrPathP : {A : I → Type ℓ} → (∀ i → isProp (A i)) +isProp→isContrPathP : {A : I → Type ℓ} → (∀ i → isProp (A i)) → (x : A i0) (y : A i1) - → isContr (PathP A x y) -isProp→isContrPathP h x y = isProp→PathP h x y , isProp→isPropPathP h x y _ + → isContr (PathP A x y) +isProp→isContrPathP h x y = isProp→PathP h x y , isProp→isPropPathP h x y _ -- Flipping a square along its diagonal flipSquare : {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁} {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁} {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁} - → Square a₀₋ a₁₋ a₋₀ a₋₁ → Square a₋₀ a₋₁ a₀₋ a₁₋ + → Square a₀₋ a₁₋ a₋₀ a₋₁ → Square a₋₀ a₋₁ a₀₋ a₁₋ flipSquare sq i j = sq j i module _ {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁} {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁} {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁} where - flipSquareEquiv : Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ Square a₋₀ a₋₁ a₀₋ a₁₋ + flipSquareEquiv : Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ Square a₋₀ a₋₁ a₀₋ a₁₋ unquoteDef flipSquareEquiv = defStrictEquiv flipSquareEquiv flipSquare flipSquare - flipSquarePath : Square a₀₋ a₁₋ a₋₀ a₋₁ ≡ Square a₋₀ a₋₁ a₀₋ a₁₋ + flipSquarePath : Square a₀₋ a₁₋ a₋₀ a₋₁ ≡ Square a₋₀ a₋₁ a₀₋ a₁₋ flipSquarePath = ua flipSquareEquiv module _ {a₀₀ a₁₁ : A} {a₋ : a₀₀ ≡ a₁₁} @@ -180,12 +180,12 @@ slideSquareFaces i j k (j = i0) = a₋₀ i slideSquareFaces i j k (j = i1) = a₋ (i ∨ ~ k) - slideSquare : Square a₋ a₁₋ a₋₀ refl → Square refl a₁₋ a₋₀ a₋ + slideSquare : Square a₋ a₁₋ a₋₀ refl → Square refl a₁₋ a₋₀ a₋ slideSquare sq i j = hcomp (slideSquareFaces i j) (sq i j) - slideSquareEquiv : (Square a₋ a₁₋ a₋₀ refl) ≃ (Square refl a₁₋ a₋₀ a₋) + slideSquareEquiv : (Square a₋ a₁₋ a₋₀ refl) ≃ (Square refl a₁₋ a₋₀ a₋) slideSquareEquiv = isoToEquiv (iso slideSquare slideSquareInv fillerTo fillerFrom) where - slideSquareInv : Square refl a₁₋ a₋₀ a₋ → Square a₋ a₁₋ a₋₀ refl + slideSquareInv : Square refl a₁₋ a₋₀ a₋ → Square a₋ a₁₋ a₋₀ refl slideSquareInv sq i j = hcomp (λ k → slideSquareFaces i j (~ k)) (sq i j) fillerTo : ∀ p → slideSquare (slideSquareInv p) ≡ p fillerTo p k i j = hcomp-equivFiller (λ k → slideSquareFaces i j (~ k)) (inS (p i j)) (~ k) @@ -196,11 +196,11 @@ Square≃doubleComp : {a₀₀ a₀₁ a₁₀ a₁₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) (a₁₋ : a₁₀ ≡ a₁₁) (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) - → Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ (a₋₀ ⁻¹ ∙∙ a₀₋ ∙∙ a₋₁ ≡ a₁₋) + → Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ (a₋₀ ⁻¹ ∙∙ a₀₋ ∙∙ a₋₁ ≡ a₁₋) Square≃doubleComp a₀₋ a₁₋ a₋₀ a₋₁ = pathToEquiv (PathP≡doubleCompPathˡ a₋₀ a₀₋ a₁₋ a₋₁) -- Flipping a square in Ω²A is the same as inverting it -sym≡flipSquare : {x : A} (P : Square (refl {x = x}) refl refl refl) +sym≡flipSquare : {x : A} (P : Square (refl {x = x}) refl refl refl) → sym P ≡ flipSquare P sym≡flipSquare {x = x} P = sym (main refl P) where @@ -208,10 +208,10 @@ B q i = PathP (λ j → x ≡ q (i ∨ j)) (λ k → q (i ∧ k)) refl main : (q : x ≡ x) (p : refl ≡ q) → PathP (λ i → B q i) (λ i j → p j i) (sym p) - main q = J (λ q p → PathP (λ i → B q i) (λ i j → p j i) (sym p)) refl + main q = J (λ q p → PathP (λ i → B q i) (λ i j → p j i) (sym p)) refl -- Inverting both interval arguments of a square in Ω²A is the same as doing nothing -sym-cong-sym≡id : {x : A} (P : Square (refl {x = x}) refl refl refl) +sym-cong-sym≡id : {x : A} (P : Square (refl {x = x}) refl refl refl) → P ≡ λ i j → P (~ i) (~ j) sym-cong-sym≡id {x = x} P = sym (main refl P) where @@ -219,15 +219,15 @@ B q i = Path (x ≡ q i) (λ j → q (i ∨ ~ j)) λ j → q (i ∧ j) main : (q : x ≡ x) (p : refl ≡ q) → PathP (λ i → B q i) (λ i j → p (~ i) (~ j)) p - main q = J (λ q p → PathP (λ i → B q i) (λ i j → p (~ i) (~ j)) p) refl + main q = J (λ q p → PathP (λ i → B q i) (λ i j → p (~ i) (~ j)) p) refl -- Applying cong sym is the same as flipping a square in Ω²A -flipSquare≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl) +flipSquare≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl) → flipSquare P ≡ λ i j → P i (~ j) flipSquare≡cong-sym P = sym (sym≡flipSquare P) ∙ sym (sym-cong-sym≡id (cong sym P)) -- Applying cong sym is the same as inverting a square in Ω²A -sym≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl) +sym≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl) → sym P ≡ cong sym P sym≡cong-sym P = sym-cong-sym≡id (sym P) @@ -247,13 +247,13 @@ where -- "Pointwise" composition - _∙v_ : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) - → Square a₀₋ a₂₋ (a₋₀ ∙ b₋₀) (a₋₁ ∙ b₋₁) + _∙v_ : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) + → Square a₀₋ a₂₋ (a₋₀ ∙ b₋₀) (a₋₁ ∙ b₋₁) (p ∙v q) i j = ((λ i → p i j) ∙ (λ i → q i j)) i -- "Direct" composition - _∙v'_ : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) - → Square a₀₋ a₂₋ (a₋₀ ∙ b₋₀) (a₋₁ ∙ b₋₁) + _∙v'_ : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) + → Square a₀₋ a₂₋ (a₋₀ ∙ b₋₀) (a₋₁ ∙ b₋₁) (p ∙v' q) i = comp (λ k → compPath-filler a₋₀ b₋₀ k i ≡ compPath-filler a₋₁ b₋₁ k i) (λ where k (i = i0) → a₀₋ @@ -262,7 +262,7 @@ -- The two ways of composing squares are equal, because they are -- correct "lids" for the same box - ∙v≡∙v' : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) + ∙v≡∙v' : (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square a₁₋ a₂₋ b₋₀ b₋₁) → p ∙v q ≡ p ∙v' q ∙v≡∙v' p q l i = outS (comp-unique {A = λ k → compPath-filler a₋₀ b₋₀ k i ≡ compPath-filler a₋₁ b₋₁ k i} @@ -288,13 +288,13 @@ Jequiv P = isoToEquiv isom where isom : Iso _ _ - Iso.fun isom = J P + Iso.fun isom = J P Iso.inv isom f = f refl Iso.rightInv isom f = implicitFunExt λ {_} → funExt λ t → - J (λ _ t → J P (f refl) t ≡ f t) (JRefl P (f refl)) t - Iso.leftInv isom = JRefl P + J (λ _ t → J P (f refl) t ≡ f t) (JRefl P (f refl)) t + Iso.leftInv isom = JRefl P -- Action of PathP on equivalences (without relying on univalence) @@ -305,36 +305,36 @@ congPathIso {A = A} {B} e {a₀} {a₁} .Iso.inv q i = hcomp (λ j → λ - { (i = i0) → retEq (e i0) a₀ j - ; (i = i1) → retEq (e i1) a₁ j + { (i = i0) → retEq (e i0) a₀ j + ; (i = i1) → retEq (e i1) a₁ j }) - (invEq (e i) (q i)) + (invEq (e i) (q i)) congPathIso {A = A} {B} e {a₀} {a₁} .Iso.rightInv q k i = hcomp (λ j → λ - { (i = i0) → commSqIsEq (e i0 .snd) a₀ j k - ; (i = i1) → commSqIsEq (e i1 .snd) a₁ j k + { (i = i0) → commSqIsEq (e i0 .snd) a₀ j k + ; (i = i1) → commSqIsEq (e i1 .snd) a₁ j k ; (k = i0) → e i .fst (hfill (λ j → λ - { (i = i0) → retEq (e i0) a₀ j - ; (i = i1) → retEq (e i1) a₁ j + { (i = i0) → retEq (e i0) a₀ j + ; (i = i1) → retEq (e i1) a₁ j }) - (inS (invEq (e i) (q i))) + (inS (invEq (e i) (q i))) j) ; (k = i1) → q i }) - (secEq (e i) (q i) k) - where b = commSqIsEq + (secEq (e i) (q i) k) + where b = commSqIsEq congPathIso {A = A} {B} e {a₀} {a₁} .Iso.leftInv p k i = hcomp (λ j → λ - { (i = i0) → retEq (e i0) a₀ (j ∨ k) - ; (i = i1) → retEq (e i1) a₁ (j ∨ k) + { (i = i0) → retEq (e i0) a₀ (j ∨ k) + ; (i = i1) → retEq (e i1) a₁ (j ∨ k) ; (k = i1) → p i }) - (retEq (e i) (p i) k) + (retEq (e i) (p i) k) congPathEquiv : ∀ {ℓ ℓ'} {A : I → Type ℓ} {B : I → Type ℓ'} (e : ∀ i → A i ≃ B i) {a₀ : A i0} {a₁ : A i1} @@ -420,16 +420,16 @@ (j = i1) → compPath-filler' r q (~ k) i compPath→Square : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d} - → p ∙ s ≡ r ∙ q → Square r s p q + → p ∙ s ≡ r ∙ q → Square r s p q compPath→Square {p = p} {q = q} {r = r} {s = s} P i j = hcomp (compPath→Square-faces p q r s i j) (P j i) Square→compPath : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d} - → Square r s p q → p ∙ s ≡ r ∙ q + → Square r s p q → p ∙ s ≡ r ∙ q Square→compPath {p = p} {q = q} {r = r} {s = s} sq i j = hcomp (λ k → compPath→Square-faces p q r s j i (~ k)) (sq j i) -Square→compPathΩ² : {a : A} (sq : Square (λ _ → a) refl refl refl) +Square→compPathΩ² : {a : A} (sq : Square (λ _ → a) refl refl refl) → Square→compPath sq ≡ cong (_∙ refl) (flipSquare sq) Square→compPathΩ² {a = a} sq k i j = hcomp (λ r → λ {(i = i0) → rUnit (λ _ → a) r j diff --git a/docs/Cubical.Foundations.Pointed.Base.html b/docs/Cubical.Foundations.Pointed.Base.html index bbdb4dd..3d1120d 100644 --- a/docs/Cubical.Foundations.Pointed.Base.html +++ b/docs/Cubical.Foundations.Pointed.Base.html @@ -48,13 +48,13 @@ snd (≃∙map e) = snd e invEquiv∙ : {A : Pointed ℓ} {B : Pointed ℓ'} → A ≃∙ B → B ≃∙ A -fst (invEquiv∙ x) = invEquiv (fst x) +fst (invEquiv∙ x) = invEquiv (fst x) snd (invEquiv∙ {A = A} x) = - sym (cong (fst (invEquiv (fst x))) (snd x)) ∙ retEq (fst x) (pt A) + sym (cong (fst (invEquiv (fst x))) (snd x)) ∙ retEq (fst x) (pt A) compEquiv∙ : ∀ {ℓ ℓ' ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''} → A ≃∙ B → B ≃∙ C → A ≃∙ C -fst (compEquiv∙ e1 e2) = compEquiv (fst e1) (fst e2) +fst (compEquiv∙ e1 e2) = compEquiv (fst e1) (fst e2) snd (compEquiv∙ e1 e2) = cong (fst (fst e2)) (snd e1) ∙ snd e2 Equiv∙J : {B : Pointed ℓ} (C : (A : Pointed ℓ) → A ≃∙ B → Type ℓ') @@ -73,7 +73,7 @@ → (C : (A : Pointed ℓ) → A ≃∙ (fst B , b) → Type ℓ') → C (fst B , b) (idEquiv (fst B) , refl) → C (A , a) (e , p)) - λ a b → J (λ b p + λ a b → J (λ b p → (C : (A : Pointed ℓ) → A ≃∙ (fst B , b) → Type ℓ') → C (fst B , b) (idEquiv (fst B) , refl) → @@ -91,7 +91,7 @@ → ((f : fst A → B) → P (f (pt A)) (f , refl)) → {b₀ : B} (f : A →∙ (B , b₀)) → P b₀ f →∙J {A = A} P ind = - uncurry λ f → J (λ b₀ y → P b₀ (f , y)) (ind f) + uncurry λ f → J (λ b₀ y → P b₀ (f , y)) (ind f) {- HIT allowing for pattern matching on pointed types -} data Pointer {ℓ} (A : Pointed ℓ) : Type ℓ where diff --git a/docs/Cubical.Foundations.Pointed.FunExt.html b/docs/Cubical.Foundations.Pointed.FunExt.html index e47bfe5..ca86d57 100644 --- a/docs/Cubical.Foundations.Pointed.FunExt.html +++ b/docs/Cubical.Foundations.Pointed.FunExt.html @@ -39,12 +39,12 @@ -- funExt∙≃ using the other kind of pointed homotopy funExt∙≃ : (f g : Π∙ A B ptB) → (f ∙∼ g) ≃ (f ≡ g) - funExt∙≃ f g = compEquiv (∙∼≃∙∼P f g) (funExt∙P≃ f g) + funExt∙≃ f g = compEquiv (∙∼≃∙∼P f g) (funExt∙P≃ f g) -- standard pointed function extensionality and its inverse funExt∙ : {f g : Π∙ A B ptB} → f ∙∼ g → f ≡ g funExt∙ {f = f} {g = g} = equivFun (funExt∙≃ f g) funExt∙⁻ : {f g : Π∙ A B ptB} → f ≡ g → f ∙∼ g - funExt∙⁻ {f = f} {g = g} = equivFun (invEquiv (funExt∙≃ f g)) + funExt∙⁻ {f = f} {g = g} = equivFun (invEquiv (funExt∙≃ f g)) \ No newline at end of file diff --git a/docs/Cubical.Foundations.Pointed.Homogeneous.html b/docs/Cubical.Foundations.Pointed.Homogeneous.html index 96d4fef..4aefe52 100644 --- a/docs/Cubical.Foundations.Pointed.Homogeneous.html +++ b/docs/Cubical.Foundations.Pointed.Homogeneous.html @@ -58,153 +58,161 @@ }) (sym (h (pt B∙)) ∙ h ((sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀) i)) -→∙Homogeneous≡Path : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} {f∙ g∙ : A∙ →∙ B∙} - (h : isHomogeneous B∙) → (p q : f∙ ≡ g∙) → cong fst p ≡ cong fst q → p ≡ q -→∙Homogeneous≡Path {A∙ = A∙@(A , a₀)} {B∙@(B , b)} {f∙@(f , f₀)} {g∙@(g , g₀)} h p q r = - transport (λ k - → PathP (λ i - → PathP (λ j → (A , a₀) →∙ newPath-refl p q r i j (~ k)) - (f , f₀) (g , g₀)) p q) - (badPath p q r) - where - newPath : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) - → Square (refl {x = b}) refl refl refl - newPath p q r i j = - hcomp (λ k → λ {(i = i0) → cong snd p j k - ; (i = i1) → cong snd q j k - ; (j = i0) → f₀ k - ; (j = i1) → g₀ k}) - (r i j a₀) - - newPath-refl : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) - → PathP (λ i → (PathP (λ j → B∙ ≡ (B , newPath p q r i j))) refl refl) refl refl - newPath-refl p q r i j k = - hcomp (λ w → λ { (i = i0) → lCancel (h b) w k - ; (i = i1) → lCancel (h b) w k - ; (j = i0) → lCancel (h b) w k - ; (j = i1) → lCancel (h b) w k - ; (k = i0) → lCancel (h b) w k - ; (k = i1) → B , newPath p q r i j}) - ((sym (h b) ∙ h (newPath p q r i j)) k) - - badPath : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) - → PathP (λ i → - PathP (λ j → A∙ →∙ (B , newPath p q r i j)) - (f , f₀) (g , g₀)) - p q - fst (badPath p q r i j) = r i j - snd (badPath p q s i j) k = - hcomp (λ r → λ { (i = i0) → snd (p j) (r ∧ k) - ; (i = i1) → snd (q j) (r ∧ k) - ; (j = i0) → f₀ (k ∧ r) - ; (j = i1) → g₀ (k ∧ r) - ; (k = i0) → s i j a₀}) - (s i j a₀) - -→∙HomogeneousSquare : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} {f∙ g∙ h∙ l∙ : A∙ →∙ B∙} - (h : isHomogeneous B∙) → (s : f∙ ≡ h∙) (t : g∙ ≡ l∙) (p : f∙ ≡ g∙) (q : h∙ ≡ l∙) - → Square (cong fst p) (cong fst q) (cong fst s) (cong fst t) - → Square p q s t -→∙HomogeneousSquare {f∙ = f∙} {g∙ = g∙} {h∙ = h∙} {l∙ = l∙} h = - J (λ h∙ s → (t : g∙ ≡ l∙) (p : f∙ ≡ g∙) (q : h∙ ≡ l∙) → - Square (cong fst p) (cong fst q) (cong fst s) (cong fst t) → - Square p q s t) - (J (λ l∙ t → (p : f∙ ≡ g∙) (q : f∙ ≡ l∙) - → Square (cong fst p) (cong fst q) refl (cong fst t) - → Square p q refl t) - (→∙Homogeneous≡Path {f∙ = f∙} {g∙ = g∙} h)) - -isHomogeneousPi : ∀ {ℓ ℓ'} {A : Type ℓ} {B∙ : A → Pointed ℓ'} - → (∀ a → isHomogeneous (B∙ a)) → isHomogeneous (Πᵘ∙ A B∙) -isHomogeneousPi h f i .fst = ∀ a → typ (h a (f a) i) -isHomogeneousPi h f i .snd a = pt (h a (f a) i) - -isHomogeneousΠ∙ : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : typ A → Type ℓ') - → (b₀ : B (pt A)) - → ((a : typ A) (x : B a) → isHomogeneous (B a , x)) - → (f : Π∙ A B b₀) - → isHomogeneous (Π∙ A B b₀ , f) -fst (isHomogeneousΠ∙ A B b₀ h f g i) = - Σ[ r ∈ ((a : typ A) → fst ((h a (fst f a) (fst g a)) i)) ] - r (pt A) ≡ hcomp (λ k → λ {(i = i0) → snd f k - ; (i = i1) → snd g k}) - (snd (h (pt A) (fst f (pt A)) (fst g (pt A)) i)) -snd (isHomogeneousΠ∙ A B b₀ h f g i) = - (λ a → snd (h a (fst f a) (fst g a) i)) - , λ j → hcomp (λ k → λ { (i = i0) → snd f (k ∧ j) - ; (i = i1) → snd g (k ∧ j) - ; (j = i0) → snd (h (pt A) (fst f (pt A)) - (fst g (pt A)) i)}) - (snd (h (pt A) (fst f (pt A)) (fst g (pt A)) i)) - -isHomogeneous→∙ : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} - → isHomogeneous B∙ → isHomogeneous (A∙ →∙ B∙ ∙) -isHomogeneous→∙ {A∙ = A∙} {B∙} h f∙ = - ΣPathP - ( (λ i → Π∙ A∙ (λ a → T a i) (t₀ i)) - , PathPIsoPath _ _ _ .Iso.inv - (→∙Homogeneous≡ h - (PathPIsoPath (λ i → (a : typ A∙) → T a i) (λ _ → pt B∙) _ .Iso.fun - (λ i a → pt (h (f∙ .fst a) i)))) - ) - where - T : ∀ a → typ B∙ ≡ typ B∙ - T a i = typ (h (f∙ .fst a) i) - - t₀ : PathP (λ i → T (pt A∙) i) (pt B∙) (pt B∙) - t₀ = cong pt (h (f∙ .fst (pt A∙))) ▷ f∙ .snd - -isHomogeneousProd : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} - → isHomogeneous A∙ → isHomogeneous B∙ → isHomogeneous (A∙ ×∙ B∙) -isHomogeneousProd hA hB (a , b) i .fst = typ (hA a i) × typ (hB b i) -isHomogeneousProd hA hB (a , b) i .snd .fst = pt (hA a i) -isHomogeneousProd hA hB (a , b) i .snd .snd = pt (hB b i) - -isHomogeneousPath : ∀ {ℓ} (A : Type ℓ) {x y : A} (p : x ≡ y) → isHomogeneous ((x ≡ y) , p) -isHomogeneousPath A {x} {y} p q - = pointed-sip ((x ≡ y) , p) ((x ≡ y) , q) (eqv , compPathr-cancel p q) - where eqv : (x ≡ y) ≃ (x ≡ y) - eqv = compPathlEquiv (q ∙ sym p) - -module HomogeneousDiscrete {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) (y : typ A∙) where - - -- switches pt A∙ with y - switch : typ A∙ → typ A∙ - switch x with dA x (pt A∙) - ... | yes _ = y - ... | no _ with dA x y - ... | yes _ = pt A∙ - ... | no _ = x - - switch-ptA∙ : switch (pt A∙) ≡ y - switch-ptA∙ with dA (pt A∙) (pt A∙) - ... | yes _ = refl - ... | no ¬p = ⊥.rec (¬p refl) - - switch-idp : ∀ x → switch (switch x) ≡ x - switch-idp x with dA x (pt A∙) - switch-idp x | yes p with dA y (pt A∙) - switch-idp x | yes p | yes q = q ∙ sym p - switch-idp x | yes p | no _ with dA y y - switch-idp x | yes p | no _ | yes _ = sym p - switch-idp x | yes p | no _ | no ¬p = ⊥.rec (¬p refl) - switch-idp x | no ¬p with dA x y - switch-idp x | no ¬p | yes p with dA y (pt A∙) - switch-idp x | no ¬p | yes p | yes q = ⊥.rec (¬p (p ∙ q)) - switch-idp x | no ¬p | yes p | no _ with dA (pt A∙) (pt A∙) - switch-idp x | no ¬p | yes p | no _ | yes _ = sym p - switch-idp x | no ¬p | yes p | no _ | no ¬q = ⊥.rec (¬q refl) - switch-idp x | no ¬p | no ¬q with dA x (pt A∙) - switch-idp x | no ¬p | no ¬q | yes p = ⊥.rec (¬p p) - switch-idp x | no ¬p | no ¬q | no _ with dA x y - switch-idp x | no ¬p | no ¬q | no _ | yes q = ⊥.rec (¬q q) - switch-idp x | no ¬p | no ¬q | no _ | no _ = refl - - switch-eqv : typ A∙ ≃ typ A∙ - switch-eqv = isoToEquiv (iso switch switch switch-idp switch-idp) - -isHomogeneousDiscrete : ∀ {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) → isHomogeneous A∙ -isHomogeneousDiscrete {ℓ} {A∙} dA y - = pointed-sip (typ A∙ , pt A∙) (typ A∙ , y) (switch-eqv , switch-ptA∙) - where open HomogeneousDiscrete {ℓ} {A∙} dA y +→∙HomogeneousPathP : + ∀ {ℓ ℓ'} {A∙ A∙' : Pointed ℓ} {B∙ B∙' : Pointed ℓ'} + {f∙ : A∙ →∙ B∙} {g∙ : A∙' →∙ B∙'} (p : A∙ ≡ A∙') (q : B∙ ≡ B∙') + (h : isHomogeneous B∙') + → PathP (λ i → fst (p i) → fst (q i)) (f∙ .fst) (g∙ .fst) + → PathP (λ i → p i →∙ q i) f∙ g∙ +→∙HomogeneousPathP p q h r = toPathP (→∙Homogeneous≡ h (fromPathP r)) + +→∙Homogeneous≡Path : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} {f∙ g∙ : A∙ →∙ B∙} + (h : isHomogeneous B∙) → (p q : f∙ ≡ g∙) → cong fst p ≡ cong fst q → p ≡ q +→∙Homogeneous≡Path {A∙ = A∙@(A , a₀)} {B∙@(B , b)} {f∙@(f , f₀)} {g∙@(g , g₀)} h p q r = + transport (λ k + → PathP (λ i + → PathP (λ j → (A , a₀) →∙ newPath-refl p q r i j (~ k)) + (f , f₀) (g , g₀)) p q) + (badPath p q r) + where + newPath : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) + → Square (refl {x = b}) refl refl refl + newPath p q r i j = + hcomp (λ k → λ {(i = i0) → cong snd p j k + ; (i = i1) → cong snd q j k + ; (j = i0) → f₀ k + ; (j = i1) → g₀ k}) + (r i j a₀) + + newPath-refl : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) + → PathP (λ i → (PathP (λ j → B∙ ≡ (B , newPath p q r i j))) refl refl) refl refl + newPath-refl p q r i j k = + hcomp (λ w → λ { (i = i0) → lCancel (h b) w k + ; (i = i1) → lCancel (h b) w k + ; (j = i0) → lCancel (h b) w k + ; (j = i1) → lCancel (h b) w k + ; (k = i0) → lCancel (h b) w k + ; (k = i1) → B , newPath p q r i j}) + ((sym (h b) ∙ h (newPath p q r i j)) k) + + badPath : (p q : f∙ ≡ g∙) (r : cong fst p ≡ cong fst q) + → PathP (λ i → + PathP (λ j → A∙ →∙ (B , newPath p q r i j)) + (f , f₀) (g , g₀)) + p q + fst (badPath p q r i j) = r i j + snd (badPath p q s i j) k = + hcomp (λ r → λ { (i = i0) → snd (p j) (r ∧ k) + ; (i = i1) → snd (q j) (r ∧ k) + ; (j = i0) → f₀ (k ∧ r) + ; (j = i1) → g₀ (k ∧ r) + ; (k = i0) → s i j a₀}) + (s i j a₀) + +→∙HomogeneousSquare : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} {f∙ g∙ h∙ l∙ : A∙ →∙ B∙} + (h : isHomogeneous B∙) → (s : f∙ ≡ h∙) (t : g∙ ≡ l∙) (p : f∙ ≡ g∙) (q : h∙ ≡ l∙) + → Square (cong fst p) (cong fst q) (cong fst s) (cong fst t) + → Square p q s t +→∙HomogeneousSquare {f∙ = f∙} {g∙ = g∙} {h∙ = h∙} {l∙ = l∙} h = + J (λ h∙ s → (t : g∙ ≡ l∙) (p : f∙ ≡ g∙) (q : h∙ ≡ l∙) → + Square (cong fst p) (cong fst q) (cong fst s) (cong fst t) → + Square p q s t) + (J (λ l∙ t → (p : f∙ ≡ g∙) (q : f∙ ≡ l∙) + → Square (cong fst p) (cong fst q) refl (cong fst t) + → Square p q refl t) + (→∙Homogeneous≡Path {f∙ = f∙} {g∙ = g∙} h)) + +isHomogeneousPi : ∀ {ℓ ℓ'} {A : Type ℓ} {B∙ : A → Pointed ℓ'} + → (∀ a → isHomogeneous (B∙ a)) → isHomogeneous (Πᵘ∙ A B∙) +isHomogeneousPi h f i .fst = ∀ a → typ (h a (f a) i) +isHomogeneousPi h f i .snd a = pt (h a (f a) i) + +isHomogeneousΠ∙ : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : typ A → Type ℓ') + → (b₀ : B (pt A)) + → ((a : typ A) (x : B a) → isHomogeneous (B a , x)) + → (f : Π∙ A B b₀) + → isHomogeneous (Π∙ A B b₀ , f) +fst (isHomogeneousΠ∙ A B b₀ h f g i) = + Σ[ r ∈ ((a : typ A) → fst ((h a (fst f a) (fst g a)) i)) ] + r (pt A) ≡ hcomp (λ k → λ {(i = i0) → snd f k + ; (i = i1) → snd g k}) + (snd (h (pt A) (fst f (pt A)) (fst g (pt A)) i)) +snd (isHomogeneousΠ∙ A B b₀ h f g i) = + (λ a → snd (h a (fst f a) (fst g a) i)) + , λ j → hcomp (λ k → λ { (i = i0) → snd f (k ∧ j) + ; (i = i1) → snd g (k ∧ j) + ; (j = i0) → snd (h (pt A) (fst f (pt A)) + (fst g (pt A)) i)}) + (snd (h (pt A) (fst f (pt A)) (fst g (pt A)) i)) + +isHomogeneous→∙ : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} + → isHomogeneous B∙ → isHomogeneous (A∙ →∙ B∙ ∙) +isHomogeneous→∙ {A∙ = A∙} {B∙} h f∙ = + ΣPathP + ( (λ i → Π∙ A∙ (λ a → T a i) (t₀ i)) + , PathPIsoPath _ _ _ .Iso.inv + (→∙Homogeneous≡ h + (PathPIsoPath (λ i → (a : typ A∙) → T a i) (λ _ → pt B∙) _ .Iso.fun + (λ i a → pt (h (f∙ .fst a) i)))) + ) + where + T : ∀ a → typ B∙ ≡ typ B∙ + T a i = typ (h (f∙ .fst a) i) + + t₀ : PathP (λ i → T (pt A∙) i) (pt B∙) (pt B∙) + t₀ = cong pt (h (f∙ .fst (pt A∙))) ▷ f∙ .snd + +isHomogeneousProd : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} + → isHomogeneous A∙ → isHomogeneous B∙ → isHomogeneous (A∙ ×∙ B∙) +isHomogeneousProd hA hB (a , b) i .fst = typ (hA a i) × typ (hB b i) +isHomogeneousProd hA hB (a , b) i .snd .fst = pt (hA a i) +isHomogeneousProd hA hB (a , b) i .snd .snd = pt (hB b i) + +isHomogeneousPath : ∀ {ℓ} (A : Type ℓ) {x y : A} (p : x ≡ y) → isHomogeneous ((x ≡ y) , p) +isHomogeneousPath A {x} {y} p q + = pointed-sip ((x ≡ y) , p) ((x ≡ y) , q) (eqv , compPathr-cancel p q) + where eqv : (x ≡ y) ≃ (x ≡ y) + eqv = compPathlEquiv (q ∙ sym p) + +module HomogeneousDiscrete {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) (y : typ A∙) where + + -- switches pt A∙ with y + switch : typ A∙ → typ A∙ + switch x with dA x (pt A∙) + ... | yes _ = y + ... | no _ with dA x y + ... | yes _ = pt A∙ + ... | no _ = x + + switch-ptA∙ : switch (pt A∙) ≡ y + switch-ptA∙ with dA (pt A∙) (pt A∙) + ... | yes _ = refl + ... | no ¬p = ⊥.rec (¬p refl) + + switch-idp : ∀ x → switch (switch x) ≡ x + switch-idp x with dA x (pt A∙) + switch-idp x | yes p with dA y (pt A∙) + switch-idp x | yes p | yes q = q ∙ sym p + switch-idp x | yes p | no _ with dA y y + switch-idp x | yes p | no _ | yes _ = sym p + switch-idp x | yes p | no _ | no ¬p = ⊥.rec (¬p refl) + switch-idp x | no ¬p with dA x y + switch-idp x | no ¬p | yes p with dA y (pt A∙) + switch-idp x | no ¬p | yes p | yes q = ⊥.rec (¬p (p ∙ q)) + switch-idp x | no ¬p | yes p | no _ with dA (pt A∙) (pt A∙) + switch-idp x | no ¬p | yes p | no _ | yes _ = sym p + switch-idp x | no ¬p | yes p | no _ | no ¬q = ⊥.rec (¬q refl) + switch-idp x | no ¬p | no ¬q with dA x (pt A∙) + switch-idp x | no ¬p | no ¬q | yes p = ⊥.rec (¬p p) + switch-idp x | no ¬p | no ¬q | no _ with dA x y + switch-idp x | no ¬p | no ¬q | no _ | yes q = ⊥.rec (¬q q) + switch-idp x | no ¬p | no ¬q | no _ | no _ = refl + + switch-eqv : typ A∙ ≃ typ A∙ + switch-eqv = isoToEquiv (iso switch switch switch-idp switch-idp) + +isHomogeneousDiscrete : ∀ {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) → isHomogeneous A∙ +isHomogeneousDiscrete {ℓ} {A∙} dA y + = pointed-sip (typ A∙ , pt A∙) (typ A∙ , y) (switch-eqv , switch-ptA∙) + where open HomogeneousDiscrete {ℓ} {A∙} dA y \ No newline at end of file diff --git a/docs/Cubical.Foundations.Pointed.Homotopy.html b/docs/Cubical.Foundations.Pointed.Homotopy.html index 5fd82f5..b634f57 100644 --- a/docs/Cubical.Foundations.Pointed.Homotopy.html +++ b/docs/Cubical.Foundations.Pointed.Homotopy.html @@ -99,7 +99,7 @@ -- inverse of ∙∼→∙∼P extracted from the equivalence ∙∼P→∙∼ : {f g : Π∙ A B ptB} → f ∙∼P g → f ∙∼ g - ∙∼P→∙∼ {f = f} {g = g} = invEq (∙∼≃∙∼P f g) + ∙∼P→∙∼ {f = f} {g = g} = invEq (∙∼≃∙∼P f g) -- ∙∼≃∙∼P transformed to a path ∙∼≡∙∼P : (f g : Π∙ A B ptB) → (f ∙∼ g) ≡ (f ∙∼P g) diff --git a/docs/Cubical.Foundations.Pointed.Properties.html b/docs/Cubical.Foundations.Pointed.Properties.html index 87b015b..14ba990 100644 --- a/docs/Cubical.Foundations.Pointed.Properties.html +++ b/docs/Cubical.Foundations.Pointed.Properties.html @@ -61,7 +61,7 @@ post∘∙ X f .snd = ΣPathP ( (funExt λ _ → f .snd) - , (sym (lUnit (f .snd)) ◁ λ i j → f .snd (i ∨ j))) + , (sym (lUnit (f .snd)) ◁ λ i j → f .snd (i ∨ j))) -- pointed identity id∙ : (A : Pointed ℓA) → (A →∙ A) @@ -121,21 +121,21 @@ Iso.fun (pre∘∙equiv {A = A} {B = B} {C = C} e) = toEq' B C A e Iso.inv (pre∘∙equiv {A = A} {B = B} {C = C} e) = fromEq' B C A e Iso.rightInv (pre∘∙equiv {A = A} {B = B} {C = C} e) = - J (λ ptC p → section (toEq' B (fst C , ptC) A (fst e , p)) + J (λ ptC p → section (toEq' B (fst C , ptC) A (fst e , p)) (fromEq' B (fst C , ptC) A (fst e , p))) (uncurry (λ f p → ΣPathP (funExt (λ x → isHAEquiv.rinv (HAe .snd) (f x)) , ((sym (rUnit _) ∙ cong (cong (fst (fst e))) - λ i → cong (invEq (fst e)) p - ∙ (lUnit (retEq (fst e) (pt B)) (~ i))) + λ i → cong (invEq (fst e)) p + ∙ (lUnit (retEq (fst e) (pt B)) (~ i))) ∙ cong-∙ (fst (fst e)) - (cong (invEq (fst e)) p) - (retEq (fst e) (pt B)) + (cong (invEq (fst e)) p) + (retEq (fst e) (pt B)) ∙ refl - ◁ flipSquare (((λ _ → isHAEquiv.rinv (HAe .snd) (f (pt A))) + ◁ flipSquare (((λ _ → isHAEquiv.rinv (HAe .snd) (f (pt A))) ∙ refl) - ◁ lem _ _ _ _ (cong (isHAEquiv.rinv (HAe .snd)) p - ▷ sym (isHAEquiv.com (HAe .snd) (pt B)))))))) + ◁ lem _ _ _ _ (cong (isHAEquiv.rinv (HAe .snd)) p + ▷ sym (isHAEquiv.com (HAe .snd) (pt B)))))))) (snd e) where HAe = equiv→HAEquiv (fst e) @@ -149,21 +149,21 @@ ; (j = i1) → l i}) (P i j) Iso.leftInv (pre∘∙equiv {A = A} {B = B} {C = C} e) = - J (λ pt p → retract (toEq' B (fst C , pt) A (fst e , p)) + J (λ pt p → retract (toEq' B (fst C , pt) A (fst e , p)) (fromEq' B (fst C , pt) A (fst e , p))) (uncurry (λ f → - J (λ ptB p + J (λ ptB p → fromEq' (fst B , ptB) (fst C , fst (fst e) ptB) A (fst e , refl) (toEq' (fst B , ptB) (fst C , fst (fst e) ptB) A (fst e , refl) (f , p)) ≡ (f , p)) (ΣPathP - (funExt (λ x → retEq (fst e) (f x)) - , ((cong₂ _∙_ ((λ i → cong (invEq (fst e)) (lUnit refl (~ i)))) - (sym (lUnit _) ∙ λ _ → retEq (fst e) (f (pt A))) + (funExt (λ x → retEq (fst e) (f x)) + , ((cong₂ _∙_ ((λ i → cong (invEq (fst e)) (lUnit refl (~ i)))) + (sym (lUnit _) ∙ λ _ → retEq (fst e) (f (pt A))) ∙ sym (lUnit _)) - ◁ λ i j → retEq (fst e) (f (pt A)) (i ∨ j)))))) + ◁ λ i j → retEq (fst e) (f (pt A)) (i ∨ j)))))) (snd e) post∘∙equiv : ∀ {ℓA ℓB ℓC} {A : Pointed ℓA} {B : Pointed ℓB} {C : Pointed ℓC} @@ -171,37 +171,37 @@ Iso.fun (post∘∙equiv {A = A} {B = B} {C = C} e) = toEq A B C e Iso.inv (post∘∙equiv {A = A} {B = B} {C = C} e) = fromEq A B C e Iso.rightInv (post∘∙equiv {A = A}{B = B , ptB} {C = C} e) = - J (λ pt p → section (toEq A (B , pt) C (fst e , p)) + J (λ pt p → section (toEq A (B , pt) C (fst e , p)) (fromEq A (B , pt) C (fst e , p))) (uncurry (λ f → - J (λ ptC p → toEq A (B , fst (fst e) (pt A)) (fst C , ptC) (fst e , refl) + J (λ ptC p → toEq A (B , fst (fst e) (pt A)) (fst C , ptC) (fst e , refl) (fromEq A (B , fst (fst e) (pt A)) (fst C , ptC) (fst e , refl) (f , p)) ≡ (f , p)) (ΣPathP (funExt (λ x → cong f (isHAEquiv.rinv (snd HAe) x)) , (cong₂ _∙_ - (λ i → cong f (cong (fst (fst e)) (lUnit (retEq (fst e) (pt A)) (~ i)))) + (λ i → cong f (cong (fst (fst e)) (lUnit (retEq (fst e) (pt A)) (~ i)))) (sym (rUnit refl)) ∙ sym (rUnit _) ∙ cong (cong f) (isHAEquiv.com (snd HAe) (pt A))) - ◁ λ i j → f (isHAEquiv.rinv (snd HAe) (fst HAe (pt A)) (i ∨ j)))))) + ◁ λ i j → f (isHAEquiv.rinv (snd HAe) (fst HAe (pt A)) (i ∨ j)))))) (snd e) where HAe = equiv→HAEquiv (fst e) Iso.leftInv (post∘∙equiv {A = A} {B = B , ptB} {C = C} e) = - J (λ pt p → retract (toEq A (B , pt) C (fst e , p)) + J (λ pt p → retract (toEq A (B , pt) C (fst e , p)) (fromEq A (B , pt) C (fst e , p))) - (uncurry (λ f → J (λ ptC y → + (uncurry (λ f → J (λ ptC y → fromEq A (B , fst (fst e) (pt A)) (fst C , ptC) (fst e , refl) (toEq A (B , fst (fst e) (pt A)) (fst C , ptC) (fst e , refl) (f , y)) ≡ (f , y)) - (ΣPathP (funExt (λ x → cong f (retEq (fst e) x)) + (ΣPathP (funExt (λ x → cong f (retEq (fst e) x)) , (sym (lUnit _) ∙ sym (rUnit _) ∙ cong (cong f) (sym (lUnit _)) - ∙ (λ _ → cong f (retEq (fst e) (pt A))) - ◁ λ i j → f (retEq (fst e) (pt A) (i ∨ j))))))) + ∙ (λ _ → cong f (retEq (fst e) (pt A))) + ◁ λ i j → f (retEq (fst e) (pt A) (i ∨ j))))))) (snd e) flip→∙∙ : {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓA} diff --git a/docs/Cubical.Foundations.Powerset.html b/docs/Cubical.Foundations.Powerset.html index d07a814..1e5bac6 100644 --- a/docs/Cubical.Foundations.Powerset.html +++ b/docs/Cubical.Foundations.Powerset.html @@ -28,8 +28,8 @@ ℙ : Type ℓ → Type (ℓ-suc ℓ) ℙ X = X → hProp _ -isSetℙ : isSet (ℙ X) -isSetℙ = isSetΠ λ x → isSetHProp +isSetℙ : isSet (ℙ X) +isSetℙ = isSetΠ λ x → isSetHProp infix 5 _∈_ @@ -39,10 +39,10 @@ _⊆_ : {X : Type ℓ} → ℙ X → ℙ X → Type ℓ A ⊆ B = ∀ x → x ∈ A → x ∈ B -∈-isProp : (A : ℙ X) (x : X) → isProp (x ∈ A) +∈-isProp : (A : ℙ X) (x : X) → isProp (x ∈ A) ∈-isProp A = snd ∘ A -⊆-isProp : (A B : ℙ X) → isProp (A ⊆ B) +⊆-isProp : (A B : ℙ X) → isProp (A ⊆ B) ⊆-isProp A B = isPropΠ2 (λ x _ → ∈-isProp B x) ⊆-refl : (A : ℙ X) → A ⊆ A @@ -64,15 +64,4 @@ (⊆-refl-consequence A B) (λ _ → isSetℙ A B _ _) (λ _ → isPropΣ (⊆-isProp A B) (λ _ → ⊆-isProp B A) _ _)) - -module _ where - open import Cubical.Data.Unit - open import Cubical.Data.Empty - - full : ℙ X - full = λ _ → Unit* , isPropUnit* - - ∅ : ℙ X - ∅ = λ _ → ⊥* , isProp⊥* - \ No newline at end of file diff --git a/docs/Cubical.Foundations.Prelude.html b/docs/Cubical.Foundations.Prelude.html index 21f2444..9192fbb 100644 --- a/docs/Cubical.Foundations.Prelude.html +++ b/docs/Cubical.Foundations.Prelude.html @@ -27,11 +27,11 @@ open import Cubical.Core.Primitives public infixr 30 _∙_ -infixr 30 _∙₂_ +infixr 30 _∙₂_ infix 3 _∎ infixr 2 step-≡ _≡⟨⟩_ infixr 2.5 _≡⟨_⟩≡⟨_⟩_ -infixl 4 _≡$_ _≡$S_ +infixl 4 _≡$_ _≡$S_ -- Basic theory about paths. These proofs should typically be -- inlined. This module also makes equational reasoning work with @@ -328,283 +328,291 @@ → ((x : A) → PathP (B x) (f x) (g x)) funExt⁻ eq x i = eq i x -implicitFunExt⁻ : {B : A → I → Type ℓ'} - {f : {x : A} → B x i0} {g : {x : A} → B x i1} - → PathP (λ i → {x : A} → B x i) f g - → ({x : A} → PathP (B x) (f {x}) (g {x})) -implicitFunExt⁻ eq {x} i = eq i {x} +congP₂$ : {A : I → Type ℓ} {B : ∀ i → A i → Type ℓ'} + {f : ∀ x → B i0 x} {g : ∀ y → B i1 y} + → (p : PathP (λ i → ∀ x → B i x) f g) + → ∀ {x y} (p : PathP A x y) → PathP (λ i → B i (p i)) (f x) (g y) +congP₂$ eq x i = eq i (x i) -_≡$_ = funExt⁻ +implicitFunExt⁻ : {B : A → I → Type ℓ'} + {f : {x : A} → B x i0} {g : {x : A} → B x i1} + → PathP (λ i → {x : A} → B x i) f g + → ({x : A} → PathP (B x) (f {x}) (g {x})) +implicitFunExt⁻ eq {x} i = eq i {x} -{- `S` stands for simply typed. Using `funExtS⁻` instead of `funExt⁻` +_≡$_ = funExt⁻ + +{- `S` stands for simply typed. Using `funExtS⁻` instead of `funExt⁻` can help Agda to solve metavariables that may otherwise remain unsolved. -} -funExtS⁻ : {B : I → Type ℓ'} - {f : (x : A) → B i0} {g : (x : A) → B i1} - → PathP (λ i → (x : A) → B i) f g - → ((x : A) → PathP (λ i → B i) (f x) (g x)) -funExtS⁻ eq x i = eq i x +funExtS⁻ : {B : I → Type ℓ'} + {f : (x : A) → B i0} {g : (x : A) → B i1} + → PathP (λ i → (x : A) → B i) f g + → ((x : A) → PathP (λ i → B i) (f x) (g x)) +funExtS⁻ eq x i = eq i x -_≡$S_ = funExtS⁻ +_≡$S_ = funExtS⁻ --- J for paths and its computation rule +-- J for paths and its computation rule -module _ (P : ∀ y → x ≡ y → Type ℓ') (d : P x refl) where +module _ (P : ∀ y → x ≡ y → Type ℓ') (d : P x refl) where - J : (p : x ≡ y) → P y p - J p = transport (λ i → P (p i) (λ j → p (i ∧ j))) d + J : (p : x ≡ y) → P y p + J p = transport (λ i → P (p i) (λ j → p (i ∧ j))) d - JRefl : J refl ≡ d - JRefl = transportRefl d + JRefl : J refl ≡ d + JRefl = transportRefl d - J-∙ : (p : x ≡ y) (q : y ≡ z) - → J (p ∙ q) ≡ transport (λ i → P (q i) (λ j → compPath-filler p q i j)) (J p) - J-∙ p q k = - transp - (λ i → P (q (i ∨ ~ k)) - (λ j → compPath-filler p q (i ∨ ~ k) j)) (~ k) - (J (λ j → compPath-filler p q (~ k) j)) + J-∙ : (p : x ≡ y) (q : y ≡ z) + → J (p ∙ q) ≡ transport (λ i → P (q i) (λ j → compPath-filler p q i j)) (J p) + J-∙ p q k = + transp + (λ i → P (q (i ∨ ~ k)) + (λ j → compPath-filler p q (i ∨ ~ k) j)) (~ k) + (J (λ j → compPath-filler p q (~ k) j)) --- Multi-variable versions of J +-- Multi-variable versions of J -module _ {b : B x} - (P : (y : A) (p : x ≡ y) (z : B y) (q : PathP (λ i → B (p i)) b z) → Type ℓ'') - (d : P _ refl _ refl) where +module _ {b : B x} + (P : (y : A) (p : x ≡ y) (z : B y) (q : PathP (λ i → B (p i)) b z) → Type ℓ'') + (d : P _ refl _ refl) where - JDep : {y : A} (p : x ≡ y) {z : B y} (q : PathP (λ i → B (p i)) b z) → P _ p _ q - JDep _ q = transport (λ i → P _ _ _ (λ j → q (i ∧ j))) d + JDep : {y : A} (p : x ≡ y) {z : B y} (q : PathP (λ i → B (p i)) b z) → P _ p _ q + JDep _ q = transport (λ i → P _ _ _ (λ j → q (i ∧ j))) d - JDepRefl : JDep refl refl ≡ d - JDepRefl = transportRefl d + JDepRefl : JDep refl refl ≡ d + JDepRefl = transportRefl d -module _ {x : A} - {P : (y : A) → x ≡ y → Type ℓ'} {d : (y : A) (p : x ≡ y) → P y p} - (Q : (y : A) (p : x ≡ y) (z : P y p) → d y p ≡ z → Type ℓ'') - (r : Q _ refl _ refl) where +module _ {x : A} + {P : (y : A) → x ≡ y → Type ℓ'} {d : (y : A) (p : x ≡ y) → P y p} + (Q : (y : A) (p : x ≡ y) (z : P y p) → d y p ≡ z → Type ℓ'') + (r : Q _ refl _ refl) where - private - ΠQ : (y : A) → x ≡ y → _ - ΠQ y p = ∀ z q → Q y p z q + private + ΠQ : (y : A) → x ≡ y → _ + ΠQ y p = ∀ z q → Q y p z q - J2 : {y : A} (p : x ≡ y) {z : P y p} (q : d y p ≡ z) → Q _ p _ q - J2 p = J ΠQ (λ _ → J (Q x refl) r) p _ + J2 : {y : A} (p : x ≡ y) {z : P y p} (q : d y p ≡ z) → Q _ p _ q + J2 p = J ΠQ (λ _ → J (Q x refl) r) p _ - J2Refl : J2 refl refl ≡ r - J2Refl = (λ i → JRefl ΠQ (λ _ → J (Q x refl) r) i _ refl) ∙ JRefl (Q x refl) _ + J2Refl : J2 refl refl ≡ r + J2Refl = (λ i → JRefl ΠQ (λ _ → J (Q x refl) r) i _ refl) ∙ JRefl (Q x refl) _ --- A prefix operator version of J that is more suitable to be nested +-- A prefix operator version of J that is more suitable to be nested -module _ {P : ∀ y → x ≡ y → Type ℓ'} (d : P x refl) where +module _ {P : ∀ y → x ≡ y → Type ℓ'} (d : P x refl) where - J>_ : ∀ y → (p : x ≡ y) → P y p - J>_ _ p = transport (λ i → P (p i) (λ j → p (i ∧ j))) d + J>_ : ∀ y → (p : x ≡ y) → P y p + J>_ _ p = transport (λ i → P (p i) (λ j → p (i ∧ j))) d - infix 10 J>_ + infix 10 J>_ --- Converting to and from a PathP - -module _ {A : I → Type ℓ} {x : A i0} {y : A i1} where - toPathP : transport (λ i → A i) x ≡ y → PathP A x y - toPathP p i = hcomp (λ j → λ { (i = i0) → x - ; (i = i1) → p j }) - (transp (λ j → A (i ∧ j)) (~ i) x) - - fromPathP : PathP A x y → transport (λ i → A i) x ≡ y - fromPathP p i = transp (λ j → A (i ∨ j)) i (p i) - --- Whiskering a dependent path by a path --- Double whiskering -_◁_▷_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ a₁' : A i1} - → a₀ ≡ a₀' → PathP A a₀' a₁ → a₁ ≡ a₁' - → PathP A a₀ a₁' -(p ◁ P ▷ q) i = - hcomp (λ j → λ {(i = i0) → p (~ j) ; (i = i1) → q j}) (P i) - -doubleWhiskFiller : - ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ a₁' : A i1} - → (p : a₀ ≡ a₀') (pq : PathP A a₀' a₁) (q : a₁ ≡ a₁') - → PathP (λ i → PathP A (p (~ i)) (q i)) - pq - (p ◁ pq ▷ q) -doubleWhiskFiller p pq q k i = - hfill (λ j → λ {(i = i0) → p (~ j) ; (i = i1) → q j}) - (inS (pq i)) - k - -_◁_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ : A i1} - → a₀ ≡ a₀' → PathP A a₀' a₁ → PathP A a₀ a₁ -(p ◁ q) = p ◁ q ▷ refl - -_▷_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ : A i0} {a₁ a₁' : A i1} - → PathP A a₀ a₁ → a₁ ≡ a₁' → PathP A a₀ a₁' -p ▷ q = refl ◁ p ▷ q - --- Direct definitions of lower h-levels - -isContr : Type ℓ → Type ℓ -isContr A = Σ[ x ∈ A ] (∀ y → x ≡ y) - -isProp : Type ℓ → Type ℓ -isProp A = (x y : A) → x ≡ y - -isSet : Type ℓ → Type ℓ -isSet A = (x y : A) → isProp (x ≡ y) - -isGroupoid : Type ℓ → Type ℓ -isGroupoid A = ∀ a b → isSet (Path A a b) - -is2Groupoid : Type ℓ → Type ℓ -is2Groupoid A = ∀ a b → isGroupoid (Path A a b) - --- Contractibility of singletons - -singlP : (A : I → Type ℓ) (a : A i0) → Type _ -singlP A a = Σ[ x ∈ A i1 ] PathP A a x - -singl : (a : A) → Type _ -singl {A = A} a = singlP (λ _ → A) a - -isContrSingl : (a : A) → isContr (singl a) -isContrSingl a .fst = (a , refl) -isContrSingl a .snd p i .fst = p .snd i -isContrSingl a .snd p i .snd j = p .snd (i ∧ j) - -isContrSinglP : (A : I → Type ℓ) (a : A i0) → isContr (singlP A a) -isContrSinglP A a .fst = _ , transport-filler (λ i → A i) a -isContrSinglP A a .snd (x , p) i = - _ , λ j → fill A (λ j → λ {(i = i0) → transport-filler (λ i → A i) a j; (i = i1) → p j}) (inS a) j - --- Higher cube types - -SquareP : - (A : I → I → Type ℓ) - {a₀₀ : A i0 i0} {a₀₁ : A i0 i1} (a₀₋ : PathP (λ j → A i0 j) a₀₀ a₀₁) - {a₁₀ : A i1 i0} {a₁₁ : A i1 i1} (a₁₋ : PathP (λ j → A i1 j) a₁₀ a₁₁) - (a₋₀ : PathP (λ i → A i i0) a₀₀ a₁₀) (a₋₁ : PathP (λ i → A i i1) a₀₁ a₁₁) - → Type ℓ -SquareP A a₀₋ a₁₋ a₋₀ a₋₁ = PathP (λ i → PathP (λ j → A i j) (a₋₀ i) (a₋₁ i)) a₀₋ a₁₋ - -Square : - {a₀₀ a₀₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) - {a₁₀ a₁₁ : A} (a₁₋ : a₁₀ ≡ a₁₁) - (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) - → Type _ -Square a₀₋ a₁₋ a₋₀ a₋₁ = PathP (λ i → a₋₀ i ≡ a₋₁ i) a₀₋ a₁₋ - -Cube : - {a₀₀₀ a₀₀₁ : A} {a₀₀₋ : a₀₀₀ ≡ a₀₀₁} - {a₀₁₀ a₀₁₁ : A} {a₀₁₋ : a₀₁₀ ≡ a₀₁₁} - {a₀₋₀ : a₀₀₀ ≡ a₀₁₀} {a₀₋₁ : a₀₀₁ ≡ a₀₁₁} - (a₀₋₋ : Square a₀₀₋ a₀₁₋ a₀₋₀ a₀₋₁) - {a₁₀₀ a₁₀₁ : A} {a₁₀₋ : a₁₀₀ ≡ a₁₀₁} - {a₁₁₀ a₁₁₁ : A} {a₁₁₋ : a₁₁₀ ≡ a₁₁₁} - {a₁₋₀ : a₁₀₀ ≡ a₁₁₀} {a₁₋₁ : a₁₀₁ ≡ a₁₁₁} - (a₁₋₋ : Square a₁₀₋ a₁₁₋ a₁₋₀ a₁₋₁) - {a₋₀₀ : a₀₀₀ ≡ a₁₀₀} {a₋₀₁ : a₀₀₁ ≡ a₁₀₁} - (a₋₀₋ : Square a₀₀₋ a₁₀₋ a₋₀₀ a₋₀₁) - {a₋₁₀ : a₀₁₀ ≡ a₁₁₀} {a₋₁₁ : a₀₁₁ ≡ a₁₁₁} - (a₋₁₋ : Square a₀₁₋ a₁₁₋ a₋₁₀ a₋₁₁) - (a₋₋₀ : Square a₀₋₀ a₁₋₀ a₋₀₀ a₋₁₀) - (a₋₋₁ : Square a₀₋₁ a₁₋₁ a₋₀₁ a₋₁₁) - → Type _ -Cube a₀₋₋ a₁₋₋ a₋₀₋ a₋₁₋ a₋₋₀ a₋₋₁ = - PathP (λ i → Square (a₋₀₋ i) (a₋₁₋ i) (a₋₋₀ i) (a₋₋₁ i)) a₀₋₋ a₁₋₋ - --- Horizontal composition of squares (along their second dimension) --- See Cubical.Foundations.Path for vertical composition - -_∙₂_ : - {a₀₀ a₀₁ a₀₂ : A} {a₀₋ : a₀₀ ≡ a₀₁} {b₀₋ : a₀₁ ≡ a₀₂} - {a₁₀ a₁₁ a₁₂ : A} {a₁₋ : a₁₀ ≡ a₁₁} {b₁₋ : a₁₁ ≡ a₁₂} - {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁} {a₋₂ : a₀₂ ≡ a₁₂} - (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square b₀₋ b₁₋ a₋₁ a₋₂) - → Square (a₀₋ ∙ b₀₋) (a₁₋ ∙ b₁₋) a₋₀ a₋₂ -_∙₂_ = congP₂ (λ _ → _∙_) - --- Alternative (equivalent) definitions of hlevel n that give fillers for n-cubes instead of n-globes - -isSet' : Type ℓ → Type ℓ -isSet' A = - {a₀₀ a₀₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) - {a₁₀ a₁₁ : A} (a₁₋ : a₁₀ ≡ a₁₁) - (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) - → Square a₀₋ a₁₋ a₋₀ a₋₁ - -isSet→isSet' : isSet A → isSet' A -isSet→isSet' Aset _ _ _ _ = toPathP (Aset _ _ _ _) - -isSet'→isSet : isSet' A → isSet A -isSet'→isSet Aset' x y p q = Aset' p q refl refl - -isGroupoid' : Type ℓ → Type ℓ -isGroupoid' A = - {a₀₀₀ a₀₀₁ : A} {a₀₀₋ : a₀₀₀ ≡ a₀₀₁} - {a₀₁₀ a₀₁₁ : A} {a₀₁₋ : a₀₁₀ ≡ a₀₁₁} - {a₀₋₀ : a₀₀₀ ≡ a₀₁₀} {a₀₋₁ : a₀₀₁ ≡ a₀₁₁} - (a₀₋₋ : Square a₀₀₋ a₀₁₋ a₀₋₀ a₀₋₁) - {a₁₀₀ a₁₀₁ : A} {a₁₀₋ : a₁₀₀ ≡ a₁₀₁} - {a₁₁₀ a₁₁₁ : A} {a₁₁₋ : a₁₁₀ ≡ a₁₁₁} - {a₁₋₀ : a₁₀₀ ≡ a₁₁₀} {a₁₋₁ : a₁₀₁ ≡ a₁₁₁} - (a₁₋₋ : Square a₁₀₋ a₁₁₋ a₁₋₀ a₁₋₁) - {a₋₀₀ : a₀₀₀ ≡ a₁₀₀} {a₋₀₁ : a₀₀₁ ≡ a₁₀₁} - (a₋₀₋ : Square a₀₀₋ a₁₀₋ a₋₀₀ a₋₀₁) - {a₋₁₀ : a₀₁₀ ≡ a₁₁₀} {a₋₁₁ : a₀₁₁ ≡ a₁₁₁} - (a₋₁₋ : Square a₀₁₋ a₁₁₋ a₋₁₀ a₋₁₁) - (a₋₋₀ : Square a₀₋₀ a₁₋₀ a₋₀₀ a₋₁₀) - (a₋₋₁ : Square a₀₋₁ a₁₋₁ a₋₀₁ a₋₁₁) - → Cube a₀₋₋ a₁₋₋ a₋₀₋ a₋₁₋ a₋₋₀ a₋₋₁ - --- Essential properties of isProp and isContr - -isProp→PathP : ∀ {B : I → Type ℓ} → ((i : I) → isProp (B i)) - → (b0 : B i0) (b1 : B i1) - → PathP B b0 b1 -isProp→PathP hB b0 b1 = toPathP (hB _ _ _) - -isPropIsContr : isProp (isContr A) -isPropIsContr (c0 , h0) (c1 , h1) j .fst = h0 c1 j -isPropIsContr (c0 , h0) (c1 , h1) j .snd y i = - hcomp (λ k → λ { (i = i0) → h0 (h0 c1 j) k; - (i = i1) → h0 y k; - (j = i0) → h0 (h0 y i) k; - (j = i1) → h0 (h1 y i) k}) - c0 - -isContr→isProp : isContr A → isProp A -isContr→isProp (x , p) a b = sym (p a) ∙ p b - -isProp→isSet : isProp A → isSet A -isProp→isSet h a b p q j i = - hcomp (λ k → λ { (i = i0) → h a a k - ; (i = i1) → h a b k - ; (j = i0) → h a (p i) k - ; (j = i1) → h a (q i) k }) a - -isProp→isSet' : isProp A → isSet' A -isProp→isSet' h {a} p q r s i j = - hcomp (λ k → λ { (i = i0) → h a (p j) k - ; (i = i1) → h a (q j) k - ; (j = i0) → h a (r i) k - ; (j = i1) → h a (s i) k}) a - -isPropIsProp : isProp (isProp A) -isPropIsProp f g i a b = isProp→isSet f a b (f a b) (g a b) i - -isPropSingl : {a : A} → isProp (singl a) -isPropSingl = isContr→isProp (isContrSingl _) - -isPropSinglP : {A : I → Type ℓ} {a : A i0} → isProp (singlP A a) -isPropSinglP = isContr→isProp (isContrSinglP _ _) - --- Universe lifting - -record Lift {i j} (A : Type i) : Type (ℓ-max i j) where - constructor lift - field - lower : A - -open Lift public - -liftExt : ∀ {A : Type ℓ} {a b : Lift {ℓ} {ℓ'} A} → (lower a ≡ lower b) → a ≡ b -liftExt x i = lift (x i) +-- Converting to and from a PathP + +module _ {A : I → Type ℓ} {x : A i0} {y : A i1} where + toPathP : transport (λ i → A i) x ≡ y → PathP A x y + toPathP p i = hcomp (λ j → λ { (i = i0) → x + ; (i = i1) → p j }) + (transp (λ j → A (i ∧ j)) (~ i) x) + + fromPathP : PathP A x y → transport (λ i → A i) x ≡ y + fromPathP p i = transp (λ j → A (i ∨ j)) i (p i) + +-- Whiskering a dependent path by a path +-- Double whiskering +_◁_▷_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ a₁' : A i1} + → a₀ ≡ a₀' → PathP A a₀' a₁ → a₁ ≡ a₁' + → PathP A a₀ a₁' +(p ◁ P ▷ q) i = + hcomp (λ j → λ {(i = i0) → p (~ j) ; (i = i1) → q j}) (P i) + +doubleWhiskFiller : + ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ a₁' : A i1} + → (p : a₀ ≡ a₀') (pq : PathP A a₀' a₁) (q : a₁ ≡ a₁') + → PathP (λ i → PathP A (p (~ i)) (q i)) + pq + (p ◁ pq ▷ q) +doubleWhiskFiller p pq q k i = + hfill (λ j → λ {(i = i0) → p (~ j) ; (i = i1) → q j}) + (inS (pq i)) + k + +_◁_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ a₀' : A i0} {a₁ : A i1} + → a₀ ≡ a₀' → PathP A a₀' a₁ → PathP A a₀ a₁ +(p ◁ q) = p ◁ q ▷ refl + +_▷_ : ∀ {ℓ} {A : I → Type ℓ} {a₀ : A i0} {a₁ a₁' : A i1} + → PathP A a₀ a₁ → a₁ ≡ a₁' → PathP A a₀ a₁' +p ▷ q = refl ◁ p ▷ q + +-- Direct definitions of lower h-levels + +isContr : Type ℓ → Type ℓ +isContr A = Σ[ x ∈ A ] (∀ y → x ≡ y) + +isProp : Type ℓ → Type ℓ +isProp A = (x y : A) → x ≡ y + +isSet : Type ℓ → Type ℓ +isSet A = (x y : A) → isProp (x ≡ y) + +isGroupoid : Type ℓ → Type ℓ +isGroupoid A = ∀ a b → isSet (Path A a b) + +is2Groupoid : Type ℓ → Type ℓ +is2Groupoid A = ∀ a b → isGroupoid (Path A a b) + +-- Contractibility of singletons + +singlP : (A : I → Type ℓ) (a : A i0) → Type _ +singlP A a = Σ[ x ∈ A i1 ] PathP A a x + +singl : (a : A) → Type _ +singl {A = A} a = singlP (λ _ → A) a + +isContrSingl : (a : A) → isContr (singl a) +isContrSingl a .fst = (a , refl) +isContrSingl a .snd p i .fst = p .snd i +isContrSingl a .snd p i .snd j = p .snd (i ∧ j) + +isContrSinglP : (A : I → Type ℓ) (a : A i0) → isContr (singlP A a) +isContrSinglP A a .fst = _ , transport-filler (λ i → A i) a +isContrSinglP A a .snd (x , p) i = + _ , λ j → fill A (λ j → λ {(i = i0) → transport-filler (λ i → A i) a j; (i = i1) → p j}) (inS a) j + +-- Higher cube types + +SquareP : + (A : I → I → Type ℓ) + {a₀₀ : A i0 i0} {a₀₁ : A i0 i1} (a₀₋ : PathP (λ j → A i0 j) a₀₀ a₀₁) + {a₁₀ : A i1 i0} {a₁₁ : A i1 i1} (a₁₋ : PathP (λ j → A i1 j) a₁₀ a₁₁) + (a₋₀ : PathP (λ i → A i i0) a₀₀ a₁₀) (a₋₁ : PathP (λ i → A i i1) a₀₁ a₁₁) + → Type ℓ +SquareP A a₀₋ a₁₋ a₋₀ a₋₁ = PathP (λ i → PathP (λ j → A i j) (a₋₀ i) (a₋₁ i)) a₀₋ a₁₋ + +Square : + {a₀₀ a₀₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) + {a₁₀ a₁₁ : A} (a₁₋ : a₁₀ ≡ a₁₁) + (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) + → Type _ +Square a₀₋ a₁₋ a₋₀ a₋₁ = PathP (λ i → a₋₀ i ≡ a₋₁ i) a₀₋ a₁₋ + +Cube : + {a₀₀₀ a₀₀₁ : A} {a₀₀₋ : a₀₀₀ ≡ a₀₀₁} + {a₀₁₀ a₀₁₁ : A} {a₀₁₋ : a₀₁₀ ≡ a₀₁₁} + {a₀₋₀ : a₀₀₀ ≡ a₀₁₀} {a₀₋₁ : a₀₀₁ ≡ a₀₁₁} + (a₀₋₋ : Square a₀₀₋ a₀₁₋ a₀₋₀ a₀₋₁) + {a₁₀₀ a₁₀₁ : A} {a₁₀₋ : a₁₀₀ ≡ a₁₀₁} + {a₁₁₀ a₁₁₁ : A} {a₁₁₋ : a₁₁₀ ≡ a₁₁₁} + {a₁₋₀ : a₁₀₀ ≡ a₁₁₀} {a₁₋₁ : a₁₀₁ ≡ a₁₁₁} + (a₁₋₋ : Square a₁₀₋ a₁₁₋ a₁₋₀ a₁₋₁) + {a₋₀₀ : a₀₀₀ ≡ a₁₀₀} {a₋₀₁ : a₀₀₁ ≡ a₁₀₁} + (a₋₀₋ : Square a₀₀₋ a₁₀₋ a₋₀₀ a₋₀₁) + {a₋₁₀ : a₀₁₀ ≡ a₁₁₀} {a₋₁₁ : a₀₁₁ ≡ a₁₁₁} + (a₋₁₋ : Square a₀₁₋ a₁₁₋ a₋₁₀ a₋₁₁) + (a₋₋₀ : Square a₀₋₀ a₁₋₀ a₋₀₀ a₋₁₀) + (a₋₋₁ : Square a₀₋₁ a₁₋₁ a₋₀₁ a₋₁₁) + → Type _ +Cube a₀₋₋ a₁₋₋ a₋₀₋ a₋₁₋ a₋₋₀ a₋₋₁ = + PathP (λ i → Square (a₋₀₋ i) (a₋₁₋ i) (a₋₋₀ i) (a₋₋₁ i)) a₀₋₋ a₁₋₋ + +-- See HLevels.agda for CubeP + +-- Horizontal composition of squares (along their second dimension) +-- See Cubical.Foundations.Path for vertical composition + +_∙₂_ : + {a₀₀ a₀₁ a₀₂ : A} {a₀₋ : a₀₀ ≡ a₀₁} {b₀₋ : a₀₁ ≡ a₀₂} + {a₁₀ a₁₁ a₁₂ : A} {a₁₋ : a₁₀ ≡ a₁₁} {b₁₋ : a₁₁ ≡ a₁₂} + {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁} {a₋₂ : a₀₂ ≡ a₁₂} + (p : Square a₀₋ a₁₋ a₋₀ a₋₁) (q : Square b₀₋ b₁₋ a₋₁ a₋₂) + → Square (a₀₋ ∙ b₀₋) (a₁₋ ∙ b₁₋) a₋₀ a₋₂ +_∙₂_ = congP₂ (λ _ → _∙_) + +-- Alternative (equivalent) definitions of hlevel n that give fillers for n-cubes instead of n-globes + +isSet' : Type ℓ → Type ℓ +isSet' A = + {a₀₀ a₀₁ : A} (a₀₋ : a₀₀ ≡ a₀₁) + {a₁₀ a₁₁ : A} (a₁₋ : a₁₀ ≡ a₁₁) + (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁) + → Square a₀₋ a₁₋ a₋₀ a₋₁ + +isSet→isSet' : isSet A → isSet' A +isSet→isSet' Aset _ _ _ _ = toPathP (Aset _ _ _ _) + +isSet'→isSet : isSet' A → isSet A +isSet'→isSet Aset' x y p q = Aset' p q refl refl + +isGroupoid' : Type ℓ → Type ℓ +isGroupoid' A = + {a₀₀₀ a₀₀₁ : A} {a₀₀₋ : a₀₀₀ ≡ a₀₀₁} + {a₀₁₀ a₀₁₁ : A} {a₀₁₋ : a₀₁₀ ≡ a₀₁₁} + {a₀₋₀ : a₀₀₀ ≡ a₀₁₀} {a₀₋₁ : a₀₀₁ ≡ a₀₁₁} + (a₀₋₋ : Square a₀₀₋ a₀₁₋ a₀₋₀ a₀₋₁) + {a₁₀₀ a₁₀₁ : A} {a₁₀₋ : a₁₀₀ ≡ a₁₀₁} + {a₁₁₀ a₁₁₁ : A} {a₁₁₋ : a₁₁₀ ≡ a₁₁₁} + {a₁₋₀ : a₁₀₀ ≡ a₁₁₀} {a₁₋₁ : a₁₀₁ ≡ a₁₁₁} + (a₁₋₋ : Square a₁₀₋ a₁₁₋ a₁₋₀ a₁₋₁) + {a₋₀₀ : a₀₀₀ ≡ a₁₀₀} {a₋₀₁ : a₀₀₁ ≡ a₁₀₁} + (a₋₀₋ : Square a₀₀₋ a₁₀₋ a₋₀₀ a₋₀₁) + {a₋₁₀ : a₀₁₀ ≡ a₁₁₀} {a₋₁₁ : a₀₁₁ ≡ a₁₁₁} + (a₋₁₋ : Square a₀₁₋ a₁₁₋ a₋₁₀ a₋₁₁) + (a₋₋₀ : Square a₀₋₀ a₁₋₀ a₋₀₀ a₋₁₀) + (a₋₋₁ : Square a₀₋₁ a₁₋₁ a₋₀₁ a₋₁₁) + → Cube a₀₋₋ a₁₋₋ a₋₀₋ a₋₁₋ a₋₋₀ a₋₋₁ + +-- Essential properties of isProp and isContr + +isProp→PathP : ∀ {B : I → Type ℓ} → ((i : I) → isProp (B i)) + → (b0 : B i0) (b1 : B i1) + → PathP B b0 b1 +isProp→PathP hB b0 b1 = toPathP (hB _ _ _) + +isPropIsContr : isProp (isContr A) +isPropIsContr (c0 , h0) (c1 , h1) j .fst = h0 c1 j +isPropIsContr (c0 , h0) (c1 , h1) j .snd y i = + hcomp (λ k → λ { (i = i0) → h0 (h0 c1 j) k; + (i = i1) → h0 y k; + (j = i0) → h0 (h0 y i) k; + (j = i1) → h0 (h1 y i) k}) + c0 + +isContr→isProp : isContr A → isProp A +isContr→isProp (x , p) a b = sym (p a) ∙ p b + +isProp→isSet : isProp A → isSet A +isProp→isSet h a b p q j i = + hcomp (λ k → λ { (i = i0) → h a a k + ; (i = i1) → h a b k + ; (j = i0) → h a (p i) k + ; (j = i1) → h a (q i) k }) a + +isProp→isSet' : isProp A → isSet' A +isProp→isSet' h {a} p q r s i j = + hcomp (λ k → λ { (i = i0) → h a (p j) k + ; (i = i1) → h a (q j) k + ; (j = i0) → h a (r i) k + ; (j = i1) → h a (s i) k}) a + +isPropIsProp : isProp (isProp A) +isPropIsProp f g i a b = isProp→isSet f a b (f a b) (g a b) i + +isPropSingl : {a : A} → isProp (singl a) +isPropSingl = isContr→isProp (isContrSingl _) + +isPropSinglP : {A : I → Type ℓ} {a : A i0} → isProp (singlP A a) +isPropSinglP = isContr→isProp (isContrSinglP _ _) + +-- Universe lifting + +record Lift {i j} (A : Type i) : Type (ℓ-max i j) where + constructor lift + field + lower : A + +open Lift public + +liftExt : ∀ {A : Type ℓ} {a b : Lift {ℓ} {ℓ'} A} → (lower a ≡ lower b) → a ≡ b +liftExt x i = lift (x i) \ No newline at end of file diff --git a/docs/Cubical.Foundations.SIP.html b/docs/Cubical.Foundations.SIP.html index 8b2d24a..9b1ed73 100644 --- a/docs/Cubical.Foundations.SIP.html +++ b/docs/Cubical.Foundations.SIP.html @@ -55,11 +55,11 @@ → UnivalentStr S ι → SNS S ι UnivalentStr→SNS S ι θ {X = X} s t = ι (X , s) (X , t) (idEquiv X) - ≃⟨ θ (idEquiv X) ⟩ + ≃⟨ θ (idEquiv X) ⟩ PathP (λ i → S (ua (idEquiv X) i)) s t - ≃⟨ pathToEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = X} j i)) s t) ⟩ + ≃⟨ pathToEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = X} j i)) s t) ⟩ s ≡ t - ■ + ■ SNS→UnivalentStr : (ι : StrEquiv S ℓ₃) → SNS S ι → UnivalentStr S ι @@ -73,11 +73,11 @@ C : (s t : S Y) → ι (Y , s) (Y , t) (idEquiv Y) ≃ PathP (λ i → S (ua (idEquiv Y) i)) s t C s t = ι (Y , s) (Y , t) (idEquiv Y) - ≃⟨ θ s t ⟩ + ≃⟨ θ s t ⟩ s ≡ t - ≃⟨ pathToEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = Y} (~ j) i)) s t) ⟩ + ≃⟨ pathToEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = Y} (~ j) i)) s t) ⟩ PathP (λ i → S (ua (idEquiv Y) i)) s t - ■ + ■ TransportStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S) → Type (ℓ-max (ℓ-suc ℓ) ℓ₁) TransportStr {ℓ} {S = S} α = @@ -87,23 +87,23 @@ → TransportStr α → UnivalentStr S (EquivAction→StrEquiv α) TransportStr→UnivalentStr {S = S} α τ {X , s} {Y , t} e = equivFun (α e) s ≡ t - ≃⟨ pathToEquiv (cong (_≡ t) (τ e s)) ⟩ + ≃⟨ pathToEquiv (cong (_≡ t) (τ e s)) ⟩ subst S (ua e) s ≡ t - ≃⟨ invEquiv (PathP≃Path _ _ _) ⟩ + ≃⟨ invEquiv (PathP≃Path _ _ _) ⟩ PathP (λ i → S (ua e i)) s t - ■ + ■ UnivalentStr→TransportStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S) → UnivalentStr S (EquivAction→StrEquiv α) → TransportStr α UnivalentStr→TransportStr {S = S} α θ e s = - invEq (θ e) (transport-filler (cong S (ua e)) s) + invEq (θ e) (transport-filler (cong S (ua e)) s) invTransportStr : {S : Type ℓ → Type ℓ₂} (α : EquivAction S) (τ : TransportStr α) - {X Y : Type ℓ} (e : X ≃ Y) (t : S Y) → invEq (α e) t ≡ subst⁻ S (ua e) t + {X Y : Type ℓ} (e : X ≃ Y) (t : S Y) → invEq (α e) t ≡ subst⁻ S (ua e) t invTransportStr {S = S} α τ e t = - sym (transport⁻Transport (cong S (ua e)) (invEq (α e) t)) - ∙∙ sym (cong (subst⁻ S (ua e)) (τ e (invEq (α e) t))) - ∙∙ cong (subst⁻ S (ua e)) (secEq (α e) t) + sym (transport⁻Transport (cong S (ua e)) (invEq (α e) t)) + ∙∙ sym (cong (subst⁻ S (ua e)) (τ e (invEq (α e) t))) + ∙∙ cong (subst⁻ S (ua e)) (secEq (α e) t) --- We can now define an invertible function @@ -119,8 +119,8 @@ SIP : A ≃[ ι ] B ≃ (A ≡ B) SIP = - sip , isoToIsEquiv (compIso (Σ-cong-iso (invIso univalenceIso) (equivToIso ∘ θ)) ΣPathIsoPathΣ) + sip , isoToIsEquiv (compIso (Σ-cong-iso (invIso univalenceIso) (equivToIso ∘ θ)) ΣPathIsoPathΣ) sip⁻ : A ≡ B → A ≃[ ι ] B - sip⁻ = invEq SIP + sip⁻ = invEq SIP \ No newline at end of file diff --git a/docs/Cubical.Foundations.Transport.html b/docs/Cubical.Foundations.Transport.html index 91db5c8..ceba929 100644 --- a/docs/Cubical.Foundations.Transport.html +++ b/docs/Cubical.Foundations.Transport.html @@ -104,22 +104,22 @@ isInjectiveTransport {p = p} {q} α i = hcomp (λ j → λ - { (i = i0) → retEq univalence p j - ; (i = i1) → retEq univalence q j + { (i = i0) → retEq univalence p j + ; (i = i1) → retEq univalence q j }) - (invEq univalence ((λ a → α i a) , t i)) + (invEq univalence ((λ a → α i a) , t i)) where t : PathP (λ i → isEquiv (λ a → α i a)) (pathToEquiv p .snd) (pathToEquiv q .snd) - t = isProp→PathP (λ i → isPropIsEquiv (λ a → α i a)) _ _ + t = isProp→PathP (λ i → isPropIsEquiv (λ a → α i a)) _ _ -transportUaInv : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → transport (ua (invEquiv e)) ≡ transport (sym (ua e)) +transportUaInv : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → transport (ua (invEquiv e)) ≡ transport (sym (ua e)) transportUaInv e = cong transport (uaInvEquiv e) -- notice that transport (ua e) would reduce, thus an alternative definition using EquivJ can give -- refl for the case of idEquiv: -- transportUaInv e = EquivJ (λ _ e → transport (ua (invEquiv e)) ≡ transport (sym (ua e))) refl e isSet-subst : ∀ {ℓ ℓ'} {A : Type ℓ} {B : A → Type ℓ'} - → (isSet-A : isSet A) + → (isSet-A : isSet A) → ∀ {a : A} → (p : a ≡ a) → (x : B a) → subst B p x ≡ x isSet-subst {B = B} isSet-A p x = subst (λ p′ → subst B p′ x ≡ x) (isSet-A _ _ refl p) (substRefl {B = B} x) @@ -165,7 +165,7 @@ → transport (λ i → P i ≡ P i) (p ∙ q) ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q overPathFunct p q = - J (λ y P → transport (λ i → P i ≡ P i) (p ∙ q) ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q) + J (λ y P → transport (λ i → P i ≡ P i) (p ∙ q) ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q) (transportRefl (p ∙ q) ∙ cong₂ _∙_ (sym (transportRefl p)) (sym (transportRefl q))) -- substition over families of paths @@ -174,7 +174,7 @@ → (f g : A → B) → (p : a ≡ a') (q : f a ≡ g a) → subst (λ x → f x ≡ g x) p q ≡ sym (cong f p) ∙ q ∙ cong g p substInPaths {a = a} f g p q = - J (λ x p' → (subst (λ y → f y ≡ g y) p' q) ≡ (sym (cong f p') ∙ q ∙ cong g p')) + J (λ x p' → (subst (λ y → f y ≡ g y) p' q) ≡ (sym (cong f p') ∙ q ∙ cong g p')) p=refl p where p=refl : subst (λ y → f y ≡ g y) refl q @@ -206,4 +206,18 @@ ≡⟨ assoc (sym p) q refl ⟩ (sym p ∙ q) ∙ refl ≡⟨ sym (rUnit (sym p ∙ q))⟩ sym p ∙ q ∎ + +transport-filler-ua : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) (a : A) + → SquareP (λ _ i → ua e i) + (transport-filler (ua e) a) + (ua-gluePath e refl) + refl + (transportRefl (fst e a)) +transport-filler-ua {A = A} {B = B} (e , _) a j i = + let b = e a + tr = transportRefl b + z = tr (j ∧ ~ i) + in glue (λ { (i = i0) → a ; (i = i1) → tr j }) + (hcomp (λ k → λ { (i = i0) → b ; (i = i1) → tr (j ∧ k) ; (j = i1) → tr (~ i ∨ k) }) + (hcomp (λ k → λ { (i = i0) → tr (j ∨ k) ; (i = i1) → z ; (j = i1) → z }) z)) \ No newline at end of file diff --git a/docs/Cubical.Foundations.Univalence.html b/docs/Cubical.Foundations.Univalence.html index 50e0aa3..5a8c73c 100644 --- a/docs/Cubical.Foundations.Univalence.html +++ b/docs/Cubical.Foundations.Univalence.html @@ -42,8 +42,8 @@ uaIdEquiv {A = A} i j = Glue A {φ = i ∨ ~ j ∨ j} (λ _ → A , idEquiv A) -- Propositional extensionality -hPropExt : {A B : Type ℓ} → isProp A → isProp B → (A → B) → (B → A) → A ≡ B -hPropExt Aprop Bprop f g = ua (propBiimpl→Equiv Aprop Bprop f g) +hPropExt : {A B : Type ℓ} → isProp A → isProp B → (A → B) → (B → A) → A ≡ B +hPropExt Aprop Bprop f g = ua (propBiimpl→Equiv Aprop Bprop f g) -- the unglue and glue primitives specialized to the case of ua @@ -164,7 +164,7 @@ contrSinglEquiv : {A B : Type ℓ} (e : A ≃ B) → (B , idEquiv B) ≡ (A , e) contrSinglEquiv {A = A} {B = B} e = - isContr→isProp (EquivContr B) (B , idEquiv B) (A , e) + isContr→isProp (EquivContr B) (B , idEquiv B) (A , e) -- Equivalence induction EquivJ : {A B : Type ℓ} (P : (A : Type ℓ) → (e : A ≃ B) → Type ℓ') @@ -187,7 +187,7 @@ pathToEquiv p .snd = isEquivTransport p pathToEquivRefl : {A : Type ℓ} → pathToEquiv refl ≡ idEquiv A -pathToEquivRefl {A = A} = equivEq (λ i x → transp (λ _ → A) i x) +pathToEquivRefl {A = A} = equivEq (λ i x → transp (λ _ → A) i x) -- The computation rule for ua. Because of "ghcomp" it is now very -- simple compared to cubicaltt: @@ -206,7 +206,7 @@ sides (j = i1) = B , idEquiv B pathToEquiv-ua : {A B : Type ℓ} (e : A ≃ B) → pathToEquiv (ua e) ≡ e -pathToEquiv-ua e = equivEq (funExt (uaβ e)) +pathToEquiv-ua e = equivEq (funExt (uaβ e)) ua-pathToEquiv : {A B : Type ℓ} (p : A ≡ B) → ua (pathToEquiv p) ≡ p ua-pathToEquiv = uaη @@ -230,7 +230,7 @@ (aurefl : ∀ {ℓ} {A : Type ℓ} → au refl ≡ idEquiv A) where ua-au : {A B : Type ℓ} (p : A ≡ B) → ua (au p) ≡ p - ua-au {B = B} = J (λ _ p → ua (au p) ≡ p) + ua-au {B = B} = J (λ _ p → ua (au p) ≡ p) (cong ua aurefl ∙ uaIdEquiv) au-ua : {A B : Type ℓ} (e : A ≃ B) → au (ua e) ≡ e @@ -248,10 +248,10 @@ -- The original map from UniMath/Foundations eqweqmap : {A B : Type ℓ} → A ≡ B → A ≃ B -eqweqmap {A = A} e = J (λ X _ → A ≃ X) (idEquiv A) e +eqweqmap {A = A} e = J (λ X _ → A ≃ X) (idEquiv A) e eqweqmapid : {A : Type ℓ} → eqweqmap refl ≡ idEquiv A -eqweqmapid {A = A} = JRefl (λ X _ → A ≃ X) (idEquiv A) +eqweqmapid {A = A} = JRefl (λ X _ → A ≃ X) (idEquiv A) univalenceStatement : {A B : Type ℓ} → isEquiv (eqweqmap {ℓ} {A} {B}) univalenceStatement = Univalence.thm eqweqmap eqweqmapid @@ -259,8 +259,8 @@ univalenceUAH : {A B : Type ℓ} → (A ≡ B) ≃ (A ≃ B) univalenceUAH = ( _ , univalenceStatement ) -univalencePath : {A B : Type ℓ} → (A ≡ B) ≡ Lift (A ≃ B) -univalencePath = ua (compEquiv univalence LiftEquiv) +univalencePath : {A B : Type ℓ} → (A ≡ B) ≡ Lift (A ≃ B) +univalencePath = ua (compEquiv univalence LiftEquiv) -- Lemmas for constructing and destructing dependent paths in a function type where the domain is ua. ua→ : ∀ {ℓ ℓ'} {A₀ A₁ : Type ℓ} {e : A₀ ≃ A₁} {B : (i : I) → Type ℓ'} @@ -276,7 +276,7 @@ (h (transp (λ j → ua e (~ j ∧ i)) (~ i) a) i) where lem : ∀ a₁ → e .fst (transport (sym (ua e)) a₁) ≡ a₁ - lem a₁ = secEq e _ ∙ transportRefl _ + lem a₁ = secEq e _ ∙ transportRefl _ ua→⁻ : ∀ {ℓ ℓ'} {A₀ A₁ : Type ℓ} {e : A₀ ≃ A₁} {B : (i : I) → Type ℓ'} {f₀ : A₀ → B i0} {f₁ : A₁ → B i1} @@ -301,16 +301,16 @@ -- Useful lemma for unfolding a transported function over ua -- If we would have regularity this would be refl transportUAop₁ : ∀ {A B : Type ℓ} → (e : A ≃ B) (f : A → A) (x : B) - → transport (λ i → ua e i → ua e i) f x ≡ equivFun e (f (invEq e x)) -transportUAop₁ e f x i = transportRefl (equivFun e (f (invEq e (transportRefl x i)))) i + → transport (λ i → ua e i → ua e i) f x ≡ equivFun e (f (invEq e x)) +transportUAop₁ e f x i = transportRefl (equivFun e (f (invEq e (transportRefl x i)))) i -- Binary version transportUAop₂ : ∀ {ℓ} {A B : Type ℓ} → (e : A ≃ B) (f : A → A → A) (x y : B) → transport (λ i → ua e i → ua e i → ua e i) f x y ≡ - equivFun e (f (invEq e x) (invEq e y)) + equivFun e (f (invEq e x) (invEq e y)) transportUAop₂ e f x y i = - transportRefl (equivFun e (f (invEq e (transportRefl x i)) - (invEq e (transportRefl y i)))) i + transportRefl (equivFun e (f (invEq e (transportRefl x i)) + (invEq e (transportRefl y i)))) i -- Alternative version of EquivJ that only requires a predicate on functions elimEquivFun : {A B : Type ℓ} (P : (A : Type ℓ) → (A → B) → Type ℓ') @@ -333,13 +333,13 @@ rem1 f g sfg rfg = elimEquivFun P rem (f , isoToIsEquiv (iso f g sfg rfg)) g sfg rfg -uaInvEquiv : ∀ {A B : Type ℓ} → (e : A ≃ B) → ua (invEquiv e) ≡ sym (ua e) -uaInvEquiv {B = B} = EquivJ (λ _ e → ua (invEquiv e) ≡ sym (ua e)) - (cong ua (invEquivIdEquiv B)) +uaInvEquiv : ∀ {A B : Type ℓ} → (e : A ≃ B) → ua (invEquiv e) ≡ sym (ua e) +uaInvEquiv {B = B} = EquivJ (λ _ e → ua (invEquiv e) ≡ sym (ua e)) + (cong ua (invEquivIdEquiv B)) -uaCompEquiv : ∀ {A B C : Type ℓ} → (e : A ≃ B) (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f -uaCompEquiv {B = B} {C} = EquivJ (λ _ e → (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f) - (λ f → cong ua (compEquivIdEquiv f) +uaCompEquiv : ∀ {A B C : Type ℓ} → (e : A ≃ B) (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f +uaCompEquiv {B = B} {C} = EquivJ (λ _ e → (f : B ≃ C) → ua (compEquiv e f) ≡ ua e ∙ ua f) + (λ f → cong ua (compEquivIdEquiv f) ∙ sym (cong (λ x → x ∙ ua f) uaIdEquiv ∙ sym (lUnit (ua f)))) \ No newline at end of file diff --git a/docs/Cubical.Functions.Embedding.html b/docs/Cubical.Functions.Embedding.html index e82e004..91346ed 100644 --- a/docs/Cubical.Functions.Embedding.html +++ b/docs/Cubical.Functions.Embedding.html @@ -45,7 +45,7 @@ isEmbedding : (A → B) → Type _ isEmbedding f = ∀ w x → isEquiv {A = w ≡ x} (cong f) -isPropIsEmbedding : isProp (isEmbedding f) +isPropIsEmbedding : isProp (isEmbedding f) isPropIsEmbedding {f = f} = isPropΠ2 λ _ _ → isPropIsEquiv (cong f) -- Embedding is injection in the aforementioned sense: @@ -62,24 +62,24 @@ -- If `f` is an embedding, we'd expect the fibers of `f` to be -- propositions, like an injective function. hasPropFibers : (A → B) → Type _ -hasPropFibers f = ∀ y → isProp (fiber f y) +hasPropFibers f = ∀ y → isProp (fiber f y) -- This can be relaxed to having all prop fibers over the image, see [hasPropFibersOfImage→isEmbedding] hasPropFibersOfImage : (A → B) → Type _ -hasPropFibersOfImage f = ∀ x → isProp (fiber f (f x)) +hasPropFibersOfImage f = ∀ x → isProp (fiber f (f x)) -- some notation _↪_ : Type ℓ' → Type ℓ'' → Type (ℓ-max ℓ' ℓ'') A ↪ B = Σ[ f ∈ (A → B) ] isEmbedding f -hasPropFibersIsProp : isProp (hasPropFibers f) -hasPropFibersIsProp = isPropΠ (λ _ → isPropIsProp) +hasPropFibersIsProp : isProp (hasPropFibers f) +hasPropFibersIsProp = isPropΠ (λ _ → isPropIsProp) private lemma₀ : (p : y ≡ z) → fiber f y ≡ fiber f z lemma₀ {f = f} p = λ i → fiber f (p i) - lemma₁ : isEmbedding f → ∀ x → isContr (fiber f (f x)) + lemma₁ : isEmbedding f → ∀ x → isContr (fiber f (f x)) lemma₁ {f = f} iE x = value , path where value : fiber f (f x) @@ -98,7 +98,7 @@ isEmbedding→hasPropFibers : isEmbedding f → hasPropFibers f isEmbedding→hasPropFibers iE y (x , p) - = subst (λ f → isProp f) (lemma₀ p) (isContr→isProp (lemma₁ iE x)) (x , p) + = subst (λ f → isProp f) (lemma₀ p) (isContr→isProp (lemma₁ iE x)) (x , p) private fibCong→PathP @@ -124,7 +124,7 @@ hasPropFibers→isEmbedding : hasPropFibers f → isEmbedding f hasPropFibers→isEmbedding {f = f} iP w x .equiv-proof p - = subst isContr (PathP≡fibCong p) (isProp→isContrPathP (λ i → iP (p i)) fw fx) + = subst isContr (PathP≡fibCong p) (isProp→isContrPathP (λ i → iP (p i)) fw fx) where fw : fiber f (f w) fw = (w , refl) @@ -134,7 +134,7 @@ hasPropFibersOfImage→hasPropFibers : hasPropFibersOfImage f → hasPropFibers f hasPropFibersOfImage→hasPropFibers {f = f} fibImg y a b = - subst (λ y → isProp (fiber f y)) (snd a) (fibImg (fst a)) a b + subst (λ y → isProp (fiber f y)) (snd a) (fibImg (fst a)) a b hasPropFibersOfImage→isEmbedding : hasPropFibersOfImage f → isEmbedding f hasPropFibersOfImage→isEmbedding = hasPropFibers→isEmbedding ∘ hasPropFibersOfImage→hasPropFibers @@ -151,7 +151,7 @@ -- implies isEmbedding as long as B is an h-set. module _ {f : A → B} - (isSetB : isSet B) + (isSetB : isSet B) where module _ @@ -174,7 +174,7 @@ inj {w = w} {x = x} p = sym (ret w) ∙∙ cong g p ∙∙ ret x isEquiv→hasPropFibers : isEquiv f → hasPropFibers f -isEquiv→hasPropFibers e b = isContr→isProp (equiv-proof e b) +isEquiv→hasPropFibers e b = isContr→isProp (equiv-proof e b) isEquiv→isEmbedding : isEquiv f → isEmbedding f isEquiv→isEmbedding e = λ _ _ → congEquiv (_ , e) .snd @@ -202,29 +202,29 @@ Embedding-into-Discrete→Discrete : A ↪ B → Discrete B → Discrete A Embedding-into-Discrete→Discrete (f , isEmbeddingF) _≟_ x y with f x ≟ f y -... | yes p = yes (invIsEq (isEmbeddingF x y) p) +... | yes p = yes (invIsEq (isEmbeddingF x y) p) ... | no ¬p = no (¬p ∘ cong f) -Embedding-into-isProp→isProp : A ↪ B → isProp B → isProp A +Embedding-into-isProp→isProp : A ↪ B → isProp B → isProp A Embedding-into-isProp→isProp (f , isEmbeddingF) isProp-B x y - = invIsEq (isEmbeddingF x y) (isProp-B (f x) (f y)) + = invIsEq (isEmbeddingF x y) (isProp-B (f x) (f y)) -Embedding-into-isSet→isSet : A ↪ B → isSet B → isSet A +Embedding-into-isSet→isSet : A ↪ B → isSet B → isSet A Embedding-into-isSet→isSet (f , isEmbeddingF) isSet-B x y p q = - p ≡⟨ sym (retIsEq isEquiv-cong-f p) ⟩ + p ≡⟨ sym (retIsEq isEquiv-cong-f p) ⟩ cong-f⁻¹ (cong f p) ≡⟨ cong cong-f⁻¹ cong-f-p≡cong-f-q ⟩ - cong-f⁻¹ (cong f q) ≡⟨ retIsEq isEquiv-cong-f q ⟩ + cong-f⁻¹ (cong f q) ≡⟨ retIsEq isEquiv-cong-f q ⟩ q ∎ where cong-f-p≡cong-f-q = isSet-B (f x) (f y) (cong f p) (cong f q) isEquiv-cong-f = isEmbeddingF x y - cong-f⁻¹ = invIsEq isEquiv-cong-f + cong-f⁻¹ = invIsEq isEquiv-cong-f Embedding-into-hLevel→hLevel : ∀ n → A ↪ B → isOfHLevel (suc n) B → isOfHLevel (suc n) A Embedding-into-hLevel→hLevel zero = Embedding-into-isProp→isProp Embedding-into-hLevel→hLevel (suc n) (f , isEmbeddingF) Blvl x y - = isOfHLevelRespectEquiv (suc n) (invEquiv equiv) subLvl + = isOfHLevelRespectEquiv (suc n) (invEquiv equiv) subLvl where equiv : (x ≡ y) ≃ (f x ≡ f y) equiv .fst = cong f @@ -246,11 +246,11 @@ Ψ w x = isEmbeddingFstΣProp (∈-isProp A) Subset→Embedding→Subset : {X : Type ℓ} → section (Embedding→Subset {ℓ} {X}) (Subset→Embedding {ℓ} {X}) -Subset→Embedding→Subset _ = funExt λ x → Σ≡Prop (λ _ → isPropIsProp) (ua (FiberIso.fiberEquiv _ x)) +Subset→Embedding→Subset _ = funExt λ x → Σ≡Prop (λ _ → isPropIsProp) (ua (FiberIso.fiberEquiv _ x)) Embedding→Subset→Embedding : {X : Type ℓ} → retract (Embedding→Subset {ℓ} {X}) (Subset→Embedding {ℓ} {X}) Embedding→Subset→Embedding {ℓ = ℓ} {X = X} (A , f , ψ) = - cong (equivFun Σ-assoc-≃) (Σ≡Prop (λ _ → isPropIsEmbedding) (retEq (fibrationEquiv X ℓ) (A , f))) + cong (equivFun Σ-assoc-≃) (Σ≡Prop (λ _ → isPropIsEmbedding) (retEq (fibrationEquiv X ℓ) (A , f))) Subset≃Embedding : {X : Type ℓ} → ℙ X ≃ (Σ[ A ∈ Type ℓ ] (A ↪ X)) Subset≃Embedding = isoToEquiv (iso Subset→Embedding Embedding→Subset @@ -261,7 +261,7 @@ isEmbedding-∘ : isEmbedding f → isEmbedding h → isEmbedding (f ∘ h) isEmbedding-∘ {f = f} {h = h} Embf Embh w x - = compEquiv (cong h , Embh w x) (cong f , Embf (h w) (h x)) .snd + = compEquiv (cong h , Embh w x) (cong f , Embf (h w) (h x)) .snd compEmbedding : (B ↪ C) → (A ↪ B) → (A ↪ C) (compEmbedding (g , _ ) (f , _ )).fst = g ∘ f @@ -269,9 +269,9 @@ isEmbedding→embedsFibersIntoSingl : isEmbedding f - → ∀ z → fiber f z ↪ singl z + → ∀ z → fiber f z ↪ singl z isEmbedding→embedsFibersIntoSingl {f = f} isE z = e , isEmbE where - e : fiber f z → singl z + e : fiber f z → singl z e x = f (fst x) , sym (snd x) isEmbE : isEmbedding e @@ -306,7 +306,7 @@ isEmbedding→hasPropFibers′ : isEmbedding f → hasPropFibers f isEmbedding→hasPropFibers′ {f = f} iE z = - Embedding-into-isProp→isProp (isEmbedding→embedsFibersIntoSingl iE z) isPropSingl + Embedding-into-isProp→isProp (isEmbedding→embedsFibersIntoSingl iE z) isPropSingl universeEmbedding : ∀ {ℓ ℓ' : Level} @@ -315,19 +315,19 @@ → isEmbedding F universeEmbedding F liftingEquiv = hasPropFibersOfImage→isEmbedding propFibersF where lemma : ∀ A B → (F A ≡ F B) ≃ (B ≡ A) - lemma A B = (F A ≡ F B) ≃⟨ univalence ⟩ - (F A ≃ F B) ≃⟨ equivComp (liftingEquiv A) (liftingEquiv B) ⟩ - (A ≃ B) ≃⟨ invEquivEquiv ⟩ - (B ≃ A) ≃⟨ invEquiv univalence ⟩ - (B ≡ A) ■ - fiberSingl : ∀ X → fiber F (F X) ≃ singl X + lemma A B = (F A ≡ F B) ≃⟨ univalence ⟩ + (F A ≃ F B) ≃⟨ equivComp (liftingEquiv A) (liftingEquiv B) ⟩ + (A ≃ B) ≃⟨ invEquivEquiv ⟩ + (B ≃ A) ≃⟨ invEquiv univalence ⟩ + (B ≡ A) ■ + fiberSingl : ∀ X → fiber F (F X) ≃ singl X fiberSingl X = Σ-cong-equiv-snd (λ _ → lemma _ _) propFibersF : hasPropFibersOfImage F - propFibersF X = Embedding-into-isProp→isProp (Equiv→Embedding (fiberSingl X)) isPropSingl + propFibersF X = Embedding-into-isProp→isProp (Equiv→Embedding (fiberSingl X)) isPropSingl liftEmbedding : (ℓ ℓ' : Level) - → isEmbedding (Lift {i = ℓ} {j = ℓ'}) -liftEmbedding ℓ ℓ' = universeEmbedding (Lift {j = ℓ'}) (λ _ → invEquiv LiftEquiv) + → isEmbedding (Lift {i = ℓ} {j = ℓ'}) +liftEmbedding ℓ ℓ' = universeEmbedding (Lift {j = ℓ'}) (λ _ → invEquiv LiftEquiv) module FibrationIdentityPrinciple {B : Type ℓ} {ℓ'} where -- note that fibrationEquiv (for good reason) uses ℓ' = ℓ-max ℓ ℓ', so we have to work @@ -343,38 +343,38 @@ Fibration′IP : f≃g′ ≃ (f ≡ g) Fibration′IP = f≃g′ - ≃⟨ equivΠCod (λ _ → invEquiv univalence) ⟩ + ≃⟨ equivΠCod (λ _ → invEquiv univalence) ⟩ (∀ b → fiber (f .snd) b ≡ fiber (g .snd) b) - ≃⟨ funExtEquiv ⟩ + ≃⟨ funExtEquiv ⟩ fiber (f .snd) ≡ fiber (g .snd) - ≃⟨ invEquiv (congEquiv (fibrationEquiv B ℓ')) ⟩ + ≃⟨ invEquiv (congEquiv (fibrationEquiv B ℓ')) ⟩ f ≡ g - ■ + ■ -- Then embed into the above case by lifting the type L : Type _ → Type _ -- local synonym fixing the levels of Lift - L = Lift {i = ℓ'} {j = ℓ} + L = Lift {i = ℓ'} {j = ℓ} liftFibration : Fibration B ℓ' → Fibration′ - liftFibration (A , f) = L A , f ∘ lower + liftFibration (A , f) = L A , f ∘ lower hasPropFibersLiftFibration : hasPropFibers liftFibration hasPropFibersLiftFibration (A , f) = Embedding-into-isProp→isProp (Equiv→Embedding fiberChar) (isPropΣ (isEmbedding→hasPropFibers (liftEmbedding _ _) A) - λ _ → isEquiv→hasPropFibers (snd (invEquiv (preCompEquiv LiftEquiv))) _) + λ _ → isEquiv→hasPropFibers (snd (invEquiv (preCompEquiv LiftEquiv))) _) where fiberChar : fiber liftFibration (A , f) - ≃ (Σ[ (E , eq) ∈ fiber L A ] fiber (_∘ lower) (transport⁻ (λ i → eq i → B) f)) + ≃ (Σ[ (E , eq) ∈ fiber L A ] fiber (_∘ lower) (transport⁻ (λ i → eq i → B) f)) fiberChar = fiber liftFibration (A , f) - ≃⟨ Σ-cong-equiv-snd (λ _ → invEquiv ΣPath≃PathΣ) ⟩ - (Σ[ (E , g) ∈ Fibration B ℓ' ] Σ[ eq ∈ (L E ≡ A) ] PathP (λ i → eq i → B) (g ∘ lower) f) - ≃⟨ boringSwap ⟩ - (Σ[ (E , eq) ∈ fiber L A ] Σ[ g ∈ (E → B) ] PathP (λ i → eq i → B) (g ∘ lower) f) - ≃⟨ Σ-cong-equiv-snd (λ _ → Σ-cong-equiv-snd λ _ → pathToEquiv (PathP≡Path⁻ _ _ _)) ⟩ - (Σ[ (E , eq) ∈ fiber L A ] fiber (_∘ lower) (transport⁻ (λ i → eq i → B) f)) - ■ where + ≃⟨ Σ-cong-equiv-snd (λ _ → invEquiv ΣPath≃PathΣ) ⟩ + (Σ[ (E , g) ∈ Fibration B ℓ' ] Σ[ eq ∈ (L E ≡ A) ] PathP (λ i → eq i → B) (g ∘ lower) f) + ≃⟨ boringSwap ⟩ + (Σ[ (E , eq) ∈ fiber L A ] Σ[ g ∈ (E → B) ] PathP (λ i → eq i → B) (g ∘ lower) f) + ≃⟨ Σ-cong-equiv-snd (λ _ → Σ-cong-equiv-snd λ _ → pathToEquiv (PathP≡Path⁻ _ _ _)) ⟩ + (Σ[ (E , eq) ∈ fiber L A ] fiber (_∘ lower) (transport⁻ (λ i → eq i → B) f)) + ■ where unquoteDecl boringSwap = declStrictEquiv boringSwap (λ ((E , g) , (eq , p)) → ((E , eq) , (g , p))) @@ -391,11 +391,11 @@ FibrationIP : f≃g ≃ (f ≡ g) FibrationIP = - f≃g ≃⟨ equivΠCod (λ b → equivComp (Σ-cong-equiv-fst LiftEquiv) - (Σ-cong-equiv-fst LiftEquiv)) ⟩ - f≃g′ ≃⟨ Fibration′IP ⟩ - (liftFibration f ≡ liftFibration g) ≃⟨ invEquiv (_ , isEmbeddingLiftFibration _ _) ⟩ - (f ≡ g) ■ + f≃g ≃⟨ equivΠCod (λ b → equivComp (Σ-cong-equiv-fst LiftEquiv) + (Σ-cong-equiv-fst LiftEquiv)) ⟩ + f≃g′ ≃⟨ Fibration′IP ⟩ + (liftFibration f ≡ liftFibration g) ≃⟨ invEquiv (_ , isEmbeddingLiftFibration _ _) ⟩ + (f ≡ g) ■ _≃Fib_ : {B : Type ℓ} (f g : Fibration B ℓ') → Type (ℓ-max ℓ ℓ') _≃Fib_ = FibrationIdentityPrinciple.f≃g @@ -421,21 +421,21 @@ isEmbeddingToFibr w x = fullEquiv .snd where -- carefully managed such that (cong toFibr) is the equivalence fullEquiv : (w ≡ x) ≃ (toFibr w ≡ toFibr x) - fullEquiv = compEquiv (congEquiv (invEquiv Σ-assoc-≃)) (invEquiv (Σ≡PropEquiv (λ _ → isPropIsEmbedding))) + fullEquiv = compEquiv (congEquiv (invEquiv Σ-assoc-≃)) (invEquiv (Σ≡PropEquiv (λ _ → isPropIsEmbedding))) EmbeddingIP : f≃g ≃ (f ≡ g) EmbeddingIP = f≃g - ≃⟨ strictIsoToEquiv (invIso toProdIso) ⟩ + ≃⟨ strictIsoToEquiv (invIso toProdIso) ⟩ (∀ b → (fiber ffun b → fiber gfun b) × (fiber gfun b → fiber ffun b)) - ≃⟨ equivΠCod (λ _ → isEquivPropBiimpl→Equiv (isEmbedding→hasPropFibers isEmbF _) - (isEmbedding→hasPropFibers isEmbG _)) ⟩ + ≃⟨ equivΠCod (λ _ → isEquivPropBiimpl→Equiv (isEmbedding→hasPropFibers isEmbF _) + (isEmbedding→hasPropFibers isEmbG _)) ⟩ (∀ b → (fiber (f .snd .fst) b) ≃ (fiber (g .snd .fst) b)) - ≃⟨ FibrationIP (toFibr f) (toFibr g) ⟩ + ≃⟨ FibrationIP (toFibr f) (toFibr g) ⟩ (toFibr f ≡ toFibr g) - ≃⟨ invEquiv (_ , isEmbeddingToFibr _ _) ⟩ + ≃⟨ invEquiv (_ , isEmbeddingToFibr _ _) ⟩ f ≡ g - ■ + ■ _≃Emb_ : {B : Type ℓ} (f g : Embedding B ℓ') → Type _ _≃Emb_ = EmbeddingIdentityPrinciple.f≃g @@ -444,7 +444,7 @@ EmbeddingIP = EmbeddingIdentityPrinciple.EmbeddingIP -- Cantor's theorem for sets -Set-Embedding-into-Powerset : {A : Type ℓ} → isSet A → A ↪ ℙ A +Set-Embedding-into-Powerset : {A : Type ℓ} → isSet A → A ↪ ℙ A Set-Embedding-into-Powerset {A = A} setA = fun , (injEmbedding isSetℙ (λ y → sym (H₃ (H₂ y)))) where fun : A → ℙ A @@ -465,14 +465,14 @@ apmap x y x≡y = ΣPathP (cong (f ∘ fst) x≡y , cong (g ∘ snd) x≡y) equiv : ∀ x y → isEquiv (apmap x y) - equiv x y = ((invEquiv ΣPathP≃PathPΣ) - ∙ₑ (≃-× ((cong f) , (embf (fst x) (fst y))) + equiv x y = ((invEquiv ΣPathP≃PathPΣ) + ∙ₑ (≃-× ((cong f) , (embf (fst x) (fst y))) ((cong g) , (embg (snd x) (snd y)))) - ∙ₑ ΣPathP≃PathPΣ) .snd + ∙ₑ ΣPathP≃PathPΣ) .snd emb : isEmbedding (map-× f g) emb x y = equiv x y -EmbeddingΣProp : {A : Type ℓ} → {B : A → Type ℓ'} → (∀ a → isProp (B a)) → Σ A B ↪ A +EmbeddingΣProp : {A : Type ℓ} → {B : A → Type ℓ'} → (∀ a → isProp (B a)) → Σ A B ↪ A EmbeddingΣProp f = fst , (λ _ _ → isEmbeddingFstΣProp f) \ No newline at end of file diff --git a/docs/Cubical.Functions.Fibration.html b/docs/Cubical.Functions.Fibration.html index 45af7e9..7edb58c 100644 --- a/docs/Cubical.Functions.Fibration.html +++ b/docs/Cubical.Functions.Fibration.html @@ -3,7 +3,7 @@ module Cubical.Functions.Fibration where open import Cubical.Foundations.Prelude -open import Cubical.Foundations.HLevels using (isOfHLevel→isOfHLevelDep) +open import Cubical.Foundations.HLevels using (isOfHLevel→isOfHLevelDep) open import Cubical.Foundations.Function open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Equiv @@ -35,13 +35,13 @@ bwd-fwd : ∀ x → bwd (fwd x) ≡ x bwd-fwd ((x' , y) , q) i = h (r i) - where h : Σ[ s ∈ singl x ] p⁻¹ (s .fst) → fiber p x + where h : Σ[ s ∈ singl x ] p⁻¹ (s .fst) → fiber p x h ((x , p) , y) = (x , y) , sym p - r : Path (Σ[ s ∈ singl x ] p⁻¹ (s .fst)) + r : Path (Σ[ s ∈ singl x ] p⁻¹ (s .fst)) ((x , refl ) , subst p⁻¹ q y) ((x' , sym q) , y ) - r = ΣPathP (isContrSingl x .snd (x' , sym q) - , toPathP (transport⁻Transport (λ i → p⁻¹ (q i)) y)) + r = ΣPathP (isContrSingl x .snd (x' , sym q) + , toPathP (transport⁻Transport (λ i → p⁻¹ (q i)) y)) -- HoTT Lemma 4.8.1 fiberEquiv : fiber p x ≃ p⁻¹ x @@ -75,13 +75,13 @@ where e = totalEquiv p -module ForSets {E : Type ℓ} {isSetB : isSet B} (f : E → B) where +module ForSets {E : Type ℓ} {isSetB : isSet B} (f : E → B) where module _ {x x'} {px : x ≡ x'} {a' : fiber f x} {b' : fiber f x'} where -- fibers are equal when their representatives are equal fibersEqIfRepsEq : fst a' ≡ fst b' → PathP (λ i → fiber f (px i)) a' b' fibersEqIfRepsEq p = ΣPathP (p , - (isOfHLevel→isOfHLevelDep 1 + (isOfHLevel→isOfHLevelDep 1 (λ (v , w) → isSetB (f v) w) (snd a') (snd b') (λ i → (p i , px i)))) diff --git a/docs/Cubical.Functions.Fixpoint.html b/docs/Cubical.Functions.Fixpoint.html index bd73a20..721831e 100644 --- a/docs/Cubical.Functions.Fixpoint.html +++ b/docs/Cubical.Functions.Fixpoint.html @@ -26,14 +26,14 @@ -- Kraus' lemma -- a version not using cubical features can be found at -- https://www.cs.bham.ac.uk/~mhe/GeneralizedHedberg/html/GeneralizedHedberg.html#21576 -2-Constant→isPropFixpoint : (f : A → A) → 2-Constant f → isProp (Fixpoint f) +2-Constant→isPropFixpoint : (f : A → A) → 2-Constant f → isProp (Fixpoint f) 2-Constant→isPropFixpoint f fconst (x , p) (y , q) i = s i , t i where noose : ∀ x y → f x ≡ f y noose x y = sym (fconst x x) ∙ fconst x y -- the main idea is that for any path p, cong f p does not depend on p -- but only on its endpoints and the structure of 2-Constant f KrausInsight : ∀ {x y} → (p : x ≡ y) → noose x y ≡ cong f p - KrausInsight {x} = J (λ y p → noose x y ≡ cong f p) (lCancel (fconst x x)) + KrausInsight {x} = J (λ y p → noose x y ≡ cong f p) (lCancel (fconst x x)) -- Need to solve for a path s : x ≡ y, such that: -- transport (λ i → cong f s i ≡ s i) p ≡ q s : x ≡ y diff --git a/docs/Cubical.Functions.FunExtEquiv.html b/docs/Cubical.Functions.FunExtEquiv.html index beb457b..4077317 100644 --- a/docs/Cubical.Functions.FunExtEquiv.html +++ b/docs/Cubical.Functions.FunExtEquiv.html @@ -168,7 +168,7 @@ lemi→i : PathP (λ m → lemi→j i m ≡ p i) (coei→i A i (p i)) refl lemi→i = sym (coei→i (λ k → coei→j A i k (p i) ≡ p k) i (coei→i A i (p i))) - ◁ λ m k → lemi→j i (m ∨ k) + ◁ λ m k → lemi→j i (m ∨ k) heteroHomotopy≃Homotopy : {A : I → Type ℓ} {B : (i : I) → Type ℓ₁} {f : A i0 → B i0} {g : A i1 → B i1} @@ -178,18 +178,18 @@ where open Iso isom : Iso _ _ - isom .fun h x₀ = h (isContrSinglP A x₀ .fst .snd) + isom .fun h x₀ = h (isContrSinglP A x₀ .fst .snd) isom .inv k {x₀} {x₁} p = - subst (λ fib → PathP B (f x₀) (g (fib .fst))) (isContrSinglP A x₀ .snd (x₁ , p)) (k x₀) + subst (λ fib → PathP B (f x₀) (g (fib .fst))) (isContrSinglP A x₀ .snd (x₁ , p)) (k x₀) isom .rightInv k = funExt λ x₀ → cong (λ α → subst (λ fib → PathP B (f x₀) (g (fib .fst))) α (k x₀)) - (isProp→isSet isPropSinglP (isContrSinglP A x₀ .fst) _ - (isContrSinglP A x₀ .snd (isContrSinglP A x₀ .fst)) + (isProp→isSet isPropSinglP (isContrSinglP A x₀ .fst) _ + (isContrSinglP A x₀ .snd (isContrSinglP A x₀ .fst)) refl) ∙ transportRefl (k x₀) isom .leftInv h j {x₀} {x₁} p = transp - (λ i → PathP B (f x₀) (g (isContrSinglP A x₀ .snd (x₁ , p) (i ∨ j) .fst))) + (λ i → PathP B (f x₀) (g (isContrSinglP A x₀ .snd (x₁ , p) (i ∨ j) .fst))) j - (h (isContrSinglP A x₀ .snd (x₁ , p) j .snd)) + (h (isContrSinglP A x₀ .snd (x₁ , p) j .snd)) \ No newline at end of file diff --git a/docs/Cubical.Functions.Involution.html b/docs/Cubical.Functions.Involution.html index 4a8cc37..4ca249d 100644 --- a/docs/Cubical.Functions.Involution.html +++ b/docs/Cubical.Functions.Involution.html @@ -29,16 +29,16 @@ involPath : A ≡ A involPath = ua involEquiv - involEquivComp : compEquiv involEquiv involEquiv ≡ idEquiv A + involEquivComp : compEquiv involEquiv involEquiv ≡ idEquiv A involEquivComp - = equivEq (λ i x → invol x i) + = equivEq (λ i x → invol x i) involPathComp : involPath ∙ involPath ≡ refl involPathComp = sym (uaCompEquiv involEquiv involEquiv) ∙∙ cong ua involEquivComp ∙∙ uaIdEquiv - involPath² : Square involPath refl refl involPath + involPath² : Square involPath refl refl involPath involPath² - = subst (λ s → Square involPath s refl involPath) + = subst (λ s → Square involPath s refl involPath) involPathComp (compPath-filler involPath involPath) \ No newline at end of file diff --git a/docs/Cubical.Functions.Logic.html b/docs/Cubical.Functions.Logic.html index 9b787e9..ff755ea 100644 --- a/docs/Cubical.Functions.Logic.html +++ b/docs/Cubical.Functions.Logic.html @@ -69,7 +69,7 @@ hProp≡ : ⟨ P ⟩ ≡ ⟨ Q ⟩ → P ≡ Q hProp≡ = TypeOfHLevel≡ 1 -isProp⟨⟩ : (A : hProp ℓ) → isProp ⟨ A ⟩ +isProp⟨⟩ : (A : hProp ℓ) → isProp ⟨ A ⟩ isProp⟨⟩ = snd -------------------------------------------------------------------------------- diff --git a/docs/Cubical.Functions.Surjection.html b/docs/Cubical.Functions.Surjection.html index 0baf98b..16e502f 100644 --- a/docs/Cubical.Functions.Surjection.html +++ b/docs/Cubical.Functions.Surjection.html @@ -33,7 +33,7 @@ section→isSurjection : {g : B → A} → section f g → isSurjection f section→isSurjection {g = g} s b = ∣ g b , s b ∣₁ -isPropIsSurjection : isProp (isSurjection f) +isPropIsSurjection : isProp (isSurjection f) isPropIsSurjection = isPropΠ λ _ → squash₁ isEquiv→isSurjection : isEquiv f → isSurjection f @@ -44,7 +44,7 @@ isEmbedding×isSurjection→isEquiv : isEmbedding f × isSurjection f → isEquiv f equiv-proof (isEmbedding×isSurjection→isEquiv {f = f} (emb , sur)) b = - inhProp→isContr (PT.rec fib' (λ x → x) fib) fib' + inhProp→isContr (PT.rec fib' (λ x → x) fib) fib' where hpf : hasPropFibers f hpf = isEmbedding→hasPropFibers emb @@ -52,7 +52,7 @@ fib : ∥ fiber f b ∥₁ fib = sur b - fib' : isProp (fiber f b) + fib' : isProp (fiber f b) fib' = hpf b isEquiv≃isEmbedding×isSurjection : isEquiv f ≃ isEmbedding f × isSurjection f diff --git a/docs/Cubical.HITs.PropositionalTruncation.MagicTrick.html b/docs/Cubical.HITs.PropositionalTruncation.MagicTrick.html index 62289a3..81647aa 100644 --- a/docs/Cubical.HITs.PropositionalTruncation.MagicTrick.html +++ b/docs/Cubical.HITs.PropositionalTruncation.MagicTrick.html @@ -31,7 +31,7 @@ a = pt A∙ toEquivPtd : ∥ A ∥₁ → Σ[ B∙ ∈ Pointed ℓ ] (A , a) ≡ B∙ - toEquivPtd = rec isPropSingl (λ x → (A , x) , h x) + toEquivPtd = rec isPropSingl (λ x → (A , x) , h x) private B∙ : ∥ A ∥₁ → Pointed ℓ B∙ tx = fst (toEquivPtd tx) @@ -68,7 +68,7 @@ private open import Cubical.Data.Nat - open Recover (ℕ , zero) (isHomogeneousDiscrete discreteℕ) + open Recover (ℕ , zero) (isHomogeneousDiscrete discreteℕ) -- only `∣hidden∣` is exported, `hidden` is no longer in scope module _ where diff --git a/docs/Cubical.HITs.PropositionalTruncation.Properties.html b/docs/Cubical.HITs.PropositionalTruncation.Properties.html index f10c3bf..01a6127 100644 --- a/docs/Cubical.HITs.PropositionalTruncation.Properties.html +++ b/docs/Cubical.HITs.PropositionalTruncation.Properties.html @@ -31,19 +31,19 @@ A B C : Type ℓ A′ : Type ℓ' -∥∥-isPropDep : (P : A → Type ℓ) → isOfHLevelDep 1 (λ x → ∥ P x ∥₁) -∥∥-isPropDep P = isOfHLevel→isOfHLevelDep 1 (λ _ → squash₁) +∥∥-isPropDep : (P : A → Type ℓ) → isOfHLevelDep 1 (λ x → ∥ P x ∥₁) +∥∥-isPropDep P = isOfHLevel→isOfHLevelDep 1 (λ _ → squash₁) -rec : {P : Type ℓ} → isProp P → (A → P) → ∥ A ∥₁ → P +rec : {P : Type ℓ} → isProp P → (A → P) → ∥ A ∥₁ → P rec Pprop f ∣ x ∣₁ = f x rec Pprop f (squash₁ x y i) = Pprop (rec Pprop f x) (rec Pprop f y) i -rec2 : {P : Type ℓ} → isProp P → (A → B → P) → ∥ A ∥₁ → ∥ B ∥₁ → P +rec2 : {P : Type ℓ} → isProp P → (A → B → P) → ∥ A ∥₁ → ∥ B ∥₁ → P rec2 Pprop f ∣ x ∣₁ ∣ y ∣₁ = f x y rec2 Pprop f ∣ x ∣₁ (squash₁ y z i) = Pprop (rec2 Pprop f ∣ x ∣₁ y) (rec2 Pprop f ∣ x ∣₁ z) i rec2 Pprop f (squash₁ x y i) z = Pprop (rec2 Pprop f x z) (rec2 Pprop f y z) i -rec3 : {P : Type ℓ} → isProp P → (A → B → C → P) → ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → P +rec3 : {P : Type ℓ} → isProp P → (A → B → C → P) → ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → P rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = f x y z rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ (squash₁ z w i) = Pprop (rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ z) (rec3 Pprop f ∣ x ∣₁ ∣ y ∣₁ w) i rec3 Pprop f ∣ x ∣₁ (squash₁ y z i) w = Pprop (rec3 Pprop f ∣ x ∣₁ y w) (rec3 Pprop f ∣ x ∣₁ z w) i @@ -55,7 +55,7 @@ -- n-ary recursor, stated using a dependent FinVec recFin : {m : ℕ} {P : Fin m → Type ℓ} - {B : Type ℓ'} (isPropB : isProp B) + {B : Type ℓ'} (isPropB : isProp B) → ((∀ i → P i) → B) --------------------- → ((∀ i → ∥ P i ∥₁) → B) @@ -68,10 +68,10 @@ (λ famSuc → untruncHyp (λ { zero → p₀ ; (suc i) → famSuc i })) curriedishTrunc : ∥ P zero ∥₁ → (∀ i → ∥ P (suc i) ∥₁) → B - curriedishTrunc = rec (isProp→ isPropB) curriedish + curriedishTrunc = rec (isProp→ isPropB) curriedish recFin2 : {m1 m2 : ℕ} {P : Fin m1 → Fin m2 → Type ℓ} - {B : Type ℓ'} (isPropB : isProp B) + {B : Type ℓ'} (isPropB : isProp B) → ((∀ i j → P i j) → B) -------------------------- → (∀ i j → ∥ P i j ∥₁) @@ -86,18 +86,18 @@ truncFamSuc curriedishTrunc : (∀ j → ∥ P zero j ∥₁) → (∀ i j → ∥ P (suc i) j ∥₁) → B - curriedishTrunc = recFin (isProp→ isPropB) curriedish + curriedishTrunc = recFin (isProp→ isPropB) curriedish -elim : {P : ∥ A ∥₁ → Type ℓ} → ((a : ∥ A ∥₁) → isProp (P a)) +elim : {P : ∥ A ∥₁ → Type ℓ} → ((a : ∥ A ∥₁) → isProp (P a)) → ((x : A) → P ∣ x ∣₁) → (a : ∥ A ∥₁) → P a elim Pprop f ∣ x ∣₁ = f x elim Pprop f (squash₁ x y i) = - isOfHLevel→isOfHLevelDep 1 Pprop + isOfHLevel→isOfHLevelDep 1 Pprop (elim Pprop f x) (elim Pprop f y) (squash₁ x y) i elim2 : {P : ∥ A ∥₁ → ∥ B ∥₁ → Type ℓ} - (Pprop : (x : ∥ A ∥₁) (y : ∥ B ∥₁) → isProp (P x y)) + (Pprop : (x : ∥ A ∥₁) (y : ∥ B ∥₁) → isProp (P x y)) (f : (a : A) (b : B) → P ∣ a ∣₁ ∣ b ∣₁) (x : ∥ A ∥₁) (y : ∥ B ∥₁) → P x y elim2 Pprop f = @@ -105,7 +105,7 @@ (λ a → elim (λ _ → Pprop _ _) (f a)) elim3 : {P : ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → Type ℓ} - (Pprop : ((x : ∥ A ∥₁) (y : ∥ B ∥₁) (z : ∥ C ∥₁) → isProp (P x y z))) + (Pprop : ((x : ∥ A ∥₁) (y : ∥ B ∥₁) (z : ∥ C ∥₁) → isProp (P x y z))) (g : (a : A) (b : B) (c : C) → P (∣ a ∣₁) ∣ b ∣₁ ∣ c ∣₁) (x : ∥ A ∥₁) (y : ∥ B ∥₁) (z : ∥ C ∥₁) → P x y z elim3 Pprop g = elim2 (λ _ _ → isPropΠ (λ _ → Pprop _ _ _)) @@ -114,7 +114,7 @@ -- n-ary eliminator, stated using a dependent FinVec elimFin : {m : ℕ} {P : Fin m → Type ℓ} {B : (∀ i → ∥ P i ∥₁) → Type ℓ'} - (isPropB : ∀ x → isProp (B x)) + (isPropB : ∀ x → isProp (B x)) → ((x : ∀ i → P i) → B (λ i → ∣ x i ∣₁)) ---------------------------------------- → ((x : ∀ i → ∥ P i ∥₁) → B x) @@ -136,30 +136,30 @@ λ x₀ xₛ → subst B (funExt (λ { zero → refl ; (suc i) → refl})) (curriedish x₀ xₛ) -isPropPropTrunc : isProp ∥ A ∥₁ +isPropPropTrunc : isProp ∥ A ∥₁ isPropPropTrunc x y = squash₁ x y propTrunc≃ : A ≃ B → ∥ A ∥₁ ≃ ∥ B ∥₁ propTrunc≃ e = - propBiimpl→Equiv + propBiimpl→Equiv isPropPropTrunc isPropPropTrunc (rec isPropPropTrunc (λ a → ∣ e .fst a ∣₁)) - (rec isPropPropTrunc (λ b → ∣ invEq e b ∣₁)) + (rec isPropPropTrunc (λ b → ∣ invEq e b ∣₁)) -propTruncIdempotent≃ : isProp A → ∥ A ∥₁ ≃ A +propTruncIdempotent≃ : isProp A → ∥ A ∥₁ ≃ A propTruncIdempotent≃ {A = A} hA = isoToEquiv f where f : Iso ∥ A ∥₁ A Iso.fun f = rec hA (idfun A) Iso.inv f x = ∣ x ∣₁ Iso.rightInv f _ = refl - Iso.leftInv f = elim (λ _ → isProp→isSet isPropPropTrunc _ _) (λ _ → refl) + Iso.leftInv f = elim (λ _ → isProp→isSet isPropPropTrunc _ _) (λ _ → refl) -propTruncIdempotent : isProp A → ∥ A ∥₁ ≡ A +propTruncIdempotent : isProp A → ∥ A ∥₁ ≡ A propTruncIdempotent hA = ua (propTruncIdempotent≃ hA) -- We could also define the eliminator using the recursor -elim' : {P : ∥ A ∥₁ → Type ℓ} → ((a : ∥ A ∥₁) → isProp (P a)) → +elim' : {P : ∥ A ∥₁ → Type ℓ} → ((a : ∥ A ∥₁) → isProp (P a)) → ((x : A) → P ∣ x ∣₁) → (a : ∥ A ∥₁) → P a elim' {P = P} Pprop f a = rec (Pprop a) (λ x → transp (λ i → P (squash₁ ∣ x ∣₁ a i)) i0 (f x)) a @@ -175,12 +175,12 @@ -- constant.' The details of this can be found in the following paper: -- -- https://arxiv.org/pdf/1411.2682.pdf -module SetElim (Bset : isSet B) where - Bset' : isSet' B - Bset' = isSet→isSet' Bset +module SetElim (Bset : isSet B) where + Bset' : isSet' B + Bset' = isSet→isSet' Bset - rec→Set : (f : A → B) (kf : 2-Constant f) → ∥ A ∥₁ → B - helper : (f : A → B) (kf : 2-Constant f) → (t u : ∥ A ∥₁) + rec→Set : (f : A → B) (kf : 2-Constant f) → ∥ A ∥₁ → B + helper : (f : A → B) (kf : 2-Constant f) → (t u : ∥ A ∥₁) → rec→Set f kf t ≡ rec→Set f kf u rec→Set f kf ∣ x ∣₁ = f x @@ -192,14 +192,14 @@ helper f kf t (squash₁ u v i) = Bset' (helper f kf t u) (helper f kf t v) refl (helper f kf u v) i - kcomp : (f : ∥ A ∥₁ → B) → 2-Constant (f ∘ ∣_∣₁) + kcomp : (f : ∥ A ∥₁ → B) → 2-Constant (f ∘ ∣_∣₁) kcomp f x y = cong f (squash₁ ∣ x ∣₁ ∣ y ∣₁) - Fset : isSet (A → B) - Fset = isSetΠ (const Bset) + Fset : isSet (A → B) + Fset = isSetΠ (const Bset) - Kset : (f : A → B) → isSet (2-Constant f) - Kset f = isSetΠ (λ _ → isSetΠ (λ _ → isProp→isSet (Bset _ _))) + Kset : (f : A → B) → isSet (2-Constant f) + Kset f = isSetΠ (λ _ → isSetΠ (λ _ → isProp→isSet (Bset _ _))) setRecLemma : (f : ∥ A ∥₁ → B) @@ -208,28 +208,28 @@ = elim {P = λ t → rec→Set (f ∘ ∣_∣₁) (kcomp f) t ≡ f t} (λ t → Bset _ _) (λ x → refl) t i - mkKmap : (∥ A ∥₁ → B) → Σ (A → B) 2-Constant + mkKmap : (∥ A ∥₁ → B) → Σ (A → B) 2-Constant mkKmap f = f ∘ ∣_∣₁ , kcomp f - fib : (g : Σ (A → B) 2-Constant) → fiber mkKmap g + fib : (g : Σ (A → B) 2-Constant) → fiber mkKmap g fib (g , kg) = rec→Set g kg , refl - eqv : (g : Σ (A → B) 2-Constant) → ∀ fi → fib g ≡ fi + eqv : (g : Σ (A → B) 2-Constant) → ∀ fi → fib g ≡ fi eqv g (f , p) = Σ≡Prop (λ f → isOfHLevelΣ 2 Fset Kset _ _) (cong (uncurry rec→Set) (sym p) ∙ setRecLemma f) - trunc→Set≃ : (∥ A ∥₁ → B) ≃ (Σ (A → B) 2-Constant) + trunc→Set≃ : (∥ A ∥₁ → B) ≃ (Σ (A → B) 2-Constant) trunc→Set≃ .fst = mkKmap trunc→Set≃ .snd .equiv-proof g = fib g , eqv g -- The strategy of this equivalence proof follows the paper more closely. -- It is used further down for the groupoid version, because the above -- strategy does not generalize so easily. - e : B → Σ (A → B) 2-Constant + e : B → Σ (A → B) 2-Constant e b = const b , λ _ _ → refl - eval : A → (γ : Σ (A → B) 2-Constant) → B + eval : A → (γ : Σ (A → B) 2-Constant) → B eval a₀ (g , _) = g a₀ e-eval : ∀ (a₀ : A) γ → e (eval a₀ γ) ≡ γ @@ -239,13 +239,13 @@ e-isEquiv : A → isEquiv (e {A = A}) e-isEquiv a₀ = isoToIsEquiv (iso e (eval a₀) (e-eval a₀) λ _ → refl) - preEquiv₁ : ∥ A ∥₁ → B ≃ Σ (A → B) 2-Constant + preEquiv₁ : ∥ A ∥₁ → B ≃ Σ (A → B) 2-Constant preEquiv₁ t = e , rec (isPropIsEquiv e) e-isEquiv t - preEquiv₂ : (∥ A ∥₁ → Σ (A → B) 2-Constant) ≃ Σ (A → B) 2-Constant + preEquiv₂ : (∥ A ∥₁ → Σ (A → B) 2-Constant) ≃ Σ (A → B) 2-Constant preEquiv₂ = isoToEquiv (iso to const (λ _ → refl) retr) where - to : (∥ A ∥₁ → Σ (A → B) 2-Constant) → Σ (A → B) 2-Constant + to : (∥ A ∥₁ → Σ (A → B) 2-Constant) → Σ (A → B) 2-Constant to f .fst x = f ∣ x ∣₁ .fst x to f .snd x y i = f (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) .snd x y i @@ -259,14 +259,14 @@ (λ j → f (squash₁ ∣ y ∣₁ t j) .fst y) i - trunc→Set≃₂ : (∥ A ∥₁ → B) ≃ Σ (A → B) 2-Constant - trunc→Set≃₂ = compEquiv (equivΠCod preEquiv₁) preEquiv₂ + trunc→Set≃₂ : (∥ A ∥₁ → B) ≃ Σ (A → B) 2-Constant + trunc→Set≃₂ = compEquiv (equivΠCod preEquiv₁) preEquiv₂ open SetElim public using (rec→Set; trunc→Set≃) elim→Set : {P : ∥ A ∥₁ → Type ℓ} - → (∀ t → isSet (P t)) + → (∀ t → isSet (P t)) → (f : (x : A) → P ∣ x ∣₁) → (kf : ∀ x y → PathP (λ i → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i)) (f x) (f y)) → (t : ∥ A ∥₁) → P t @@ -276,20 +276,20 @@ g : A → P t g x = transp (λ i → P (squash₁ ∣ x ∣₁ t i)) i0 (f x) - gk : 2-Constant g + gk : 2-Constant g gk x y i = transp (λ j → P (squash₁ (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) t j)) i0 (kf x y i) elim2→Set : {P : ∥ A ∥₁ → ∥ B ∥₁ → Type ℓ} - → (∀ t u → isSet (P t u)) + → (∀ t u → isSet (P t u)) → (f : (x : A) (y : B) → P ∣ x ∣₁ ∣ y ∣₁) → (kf₁ : ∀ x y v → PathP (λ i → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) ∣ v ∣₁) (f x v) (f y v)) → (kf₂ : ∀ x v w → PathP (λ i → P ∣ x ∣₁ (squash₁ ∣ v ∣₁ ∣ w ∣₁ i)) (f x v) (f x w)) - → (sf : ∀ x y v w → SquareP (λ i j → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) (squash₁ ∣ v ∣₁ ∣ w ∣₁ j)) + → (sf : ∀ x y v w → SquareP (λ i j → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) (squash₁ ∣ v ∣₁ ∣ w ∣₁ j)) (kf₂ x v w) (kf₂ y v w) (kf₁ x y v) (kf₁ x y w)) → (t : ∥ A ∥₁) → (u : ∥ B ∥₁) → P t u elim2→Set {A = A} {B = B} {P = P} Pset f kf₁ kf₂ sf = - elim→Set (λ _ → isSetΠ (λ _ → Pset _ _)) mapHelper squareHelper + elim→Set (λ _ → isSetΠ (λ _ → Pset _ _)) mapHelper squareHelper where mapHelper : (x : A) (u : ∥ B ∥₁) → P ∣ x ∣₁ u mapHelper x = elim→Set (λ _ → Pset _ _) (f x) (kf₂ x) @@ -299,272 +299,268 @@ squareHelper x y i = elim→Set (λ _ → Pset _ _) (λ v → kf₁ x y v i) λ v w → sf x y v w i RecHProp : (P : A → hProp ℓ) (kP : ∀ x y → P x ≡ P y) → ∥ A ∥₁ → hProp ℓ -RecHProp P kP = rec→Set isSetHProp P kP - -module GpdElim (Bgpd : isGroupoid B) where - Bgpd' : isGroupoid' B - Bgpd' = isGroupoid→isGroupoid' Bgpd - - module _ (f : A → B) (3kf : 3-Constant f) where - open 3-Constant 3kf - - rec→Gpd : ∥ A ∥₁ → B - pathHelper : (t u : ∥ A ∥₁) → rec→Gpd t ≡ rec→Gpd u - triHelper₁ - : (t u v : ∥ A ∥₁) - → Square (pathHelper t u) (pathHelper t v) refl (pathHelper u v) - triHelper₂ - : (t u v : ∥ A ∥₁) - → Square (pathHelper t v) (pathHelper u v) (pathHelper t u) refl - - rec→Gpd ∣ x ∣₁ = f x - rec→Gpd (squash₁ t u i) = pathHelper t u i - - pathHelper ∣ x ∣₁ ∣ y ∣₁ = link x y - pathHelper (squash₁ t u j) v = triHelper₂ t u v j - pathHelper ∣ x ∣₁ (squash₁ u v j) = triHelper₁ ∣ x ∣₁ u v j - - triHelper₁ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = coh₁ x y z - triHelper₁ (squash₁ s t i) u v - = Bgpd' - (triHelper₁ s u v) - (triHelper₁ t u v) - (triHelper₂ s t u) - (triHelper₂ s t v) - (λ i → refl) - (λ i → pathHelper u v) - i - triHelper₁ ∣ x ∣₁ (squash₁ t u i) v - = Bgpd' - (triHelper₁ ∣ x ∣₁ t v) - (triHelper₁ ∣ x ∣₁ u v) - (triHelper₁ ∣ x ∣₁ t u) - (λ i → pathHelper ∣ x ∣₁ v) - (λ i → refl) - (triHelper₂ t u v) - i - triHelper₁ ∣ x ∣₁ ∣ y ∣₁ (squash₁ u v i) - = Bgpd' - (triHelper₁ ∣ x ∣₁ ∣ y ∣₁ u) - (triHelper₁ ∣ x ∣₁ ∣ y ∣₁ v) - (λ i → link x y) - (triHelper₁ ∣ x ∣₁ u v) - (λ i → refl) - (triHelper₁ ∣ y ∣₁ u v) - i - - triHelper₂ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = coh₂ x y z - triHelper₂ (squash₁ s t i) u v - = Bgpd' - (triHelper₂ s u v) - (triHelper₂ t u v) - (triHelper₂ s t v) - (λ i → pathHelper u v) - (triHelper₂ s t u) - (λ i → refl) - i - triHelper₂ ∣ x ∣₁ (squash₁ t u i) v - = Bgpd' - (triHelper₂ ∣ x ∣₁ t v) - (triHelper₂ ∣ x ∣₁ u v) - (λ i → pathHelper ∣ x ∣₁ v) - (triHelper₂ t u v) - (triHelper₁ ∣ x ∣₁ t u) - (λ i → refl) - i - triHelper₂ ∣ x ∣₁ ∣ y ∣₁ (squash₁ u v i) - = Bgpd' - (triHelper₂ ∣ x ∣₁ ∣ y ∣₁ u) - (triHelper₂ ∣ x ∣₁ ∣ y ∣₁ v) - (triHelper₁ ∣ x ∣₁ u v) - (triHelper₁ ∣ y ∣₁ u v) - (λ i → link x y) - (λ i → refl) - i - - preEquiv₁ : (∥ A ∥₁ → Σ (A → B) 3-Constant) ≃ Σ (A → B) 3-Constant - preEquiv₁ = isoToEquiv (iso fn const (λ _ → refl) retr) - where - open 3-Constant - - fn : (∥ A ∥₁ → Σ (A → B) 3-Constant) → Σ (A → B) 3-Constant - fn f .fst x = f ∣ x ∣₁ .fst x - fn f .snd .link x y i = f (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) .snd .link x y i - fn f .snd .coh₁ x y z i j - = f (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) j) .snd .coh₁ x y z i j - - retr : retract fn const - retr f i t .fst x = f (squash₁ ∣ x ∣₁ t i) .fst x - retr f i t .snd .link x y j - = f (squash₁ (squash₁ ∣ x ∣₁ ∣ y ∣₁ j) t i) .snd .link x y j - retr f i t .snd .coh₁ x y z - = Bgpd' - (λ k j → f (cb k j i0) .snd .coh₁ x y z k j ) - (λ k j → f (cb k j i1) .snd .coh₁ x y z k j) - (λ k j → f (cb i0 j k) .snd .link x y j) - (λ k j → f (cb i1 j k) .snd .link x z j) - (λ _ → refl) - (λ k j → f (cb j i1 k) .snd .link y z j) - i - where - cb : I → I → I → ∥ _ ∥₁ - cb i j k = squash₁ (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) j) t k - - e : B → Σ (A → B) 3-Constant - e b .fst _ = b - e b .snd = record - { link = λ _ _ _ → b - ; coh₁ = λ _ _ _ _ _ → b - } - - eval : A → Σ (A → B) 3-Constant → B - eval a₀ (g , _) = g a₀ - - module _ where - open 3-Constant - e-eval : ∀(a₀ : A) γ → e (eval a₀ γ) ≡ γ - e-eval a₀ (g , 3kg) i .fst x = 3kg .link a₀ x i - e-eval a₀ (g , 3kg) i .snd .link x y = λ j → 3kg .coh₁ a₀ x y j i - e-eval a₀ (g , 3kg) i .snd .coh₁ x y z - = Bgpd' - (λ _ _ → g a₀) - (3kg .coh₁ x y z) - (λ k j → 3kg .coh₁ a₀ x y j k) - (λ k j → 3kg .coh₁ a₀ x z j k) - (λ _ → refl) - (λ k j → 3kg .coh₁ a₀ y z j k) - i - - e-isEquiv : A → isEquiv (e {A = A}) - e-isEquiv a₀ = isoToIsEquiv (iso e (eval a₀) (e-eval a₀) λ _ → refl) - - preEquiv₂ : ∥ A ∥₁ → B ≃ Σ (A → B) 3-Constant - preEquiv₂ t = e , rec (isPropIsEquiv e) e-isEquiv t - - trunc→Gpd≃ : (∥ A ∥₁ → B) ≃ Σ (A → B) 3-Constant - trunc→Gpd≃ = compEquiv (equivΠCod preEquiv₂) preEquiv₁ - -open GpdElim using (rec→Gpd; trunc→Gpd≃) public - -squash₁ᵗ - : ∀(x y z : A) - → Square (squash₁ ∣ x ∣₁ ∣ y ∣₁) (squash₁ ∣ x ∣₁ ∣ z ∣₁) refl (squash₁ ∣ y ∣₁ ∣ z ∣₁) -squash₁ᵗ x y z i = squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) - -elim→Gpd - : (P : ∥ A ∥₁ → Type ℓ) - → (∀ t → isGroupoid (P t)) - → (f : (x : A) → P ∣ x ∣₁) - → (kf : ∀ x y → PathP (λ i → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i)) (f x) (f y)) - → (3kf : ∀ x y z - → SquareP (λ i j → P (squash₁ᵗ x y z i j)) (kf x y) (kf x z) refl (kf y z)) - → (t : ∥ A ∥₁) → P t -elim→Gpd {A = A} P Pgpd f kf 3kf t = rec→Gpd (Pgpd t) g 3kg t - where - g : A → P t - g x = transp (λ i → P (squash₁ ∣ x ∣₁ t i)) i0 (f x) - - open 3-Constant - - 3kg : 3-Constant g - 3kg .link x y i - = transp (λ j → P (squash₁ (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) t j)) i0 (kf x y i) - 3kg .coh₁ x y z i j - = transp (λ k → P (squash₁ (squash₁ᵗ x y z i j) t k)) i0 (3kf x y z i j) - -RecHSet : (P : A → TypeOfHLevel ℓ 2) → 3-Constant P → ∥ A ∥₁ → TypeOfHLevel ℓ 2 -RecHSet P 3kP = rec→Gpd (isOfHLevelTypeOfHLevel 2) P 3kP - -∥∥-IdempotentL-⊎-≃ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≃ ∥ A ⊎ A′ ∥₁ -∥∥-IdempotentL-⊎-≃ = isoToEquiv ∥∥-IdempotentL-⊎-Iso - where ∥∥-IdempotentL-⊎-Iso : Iso (∥ ∥ A ∥₁ ⊎ A′ ∥₁) (∥ A ⊎ A′ ∥₁) - Iso.fun ∥∥-IdempotentL-⊎-Iso x = rec squash₁ lem x - where lem : ∥ A ∥₁ ⊎ A′ → ∥ A ⊎ A′ ∥₁ - lem (inl x) = map (λ a → inl a) x - lem (inr x) = ∣ inr x ∣₁ - Iso.inv ∥∥-IdempotentL-⊎-Iso x = map lem x - where lem : A ⊎ A′ → ∥ A ∥₁ ⊎ A′ - lem (inl x) = inl ∣ x ∣₁ - lem (inr x) = inr x - Iso.rightInv ∥∥-IdempotentL-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-⊎-Iso (Iso.inv ∥∥-IdempotentL-⊎-Iso x)) x - Iso.leftInv ∥∥-IdempotentL-⊎-Iso x = squash₁ (Iso.inv ∥∥-IdempotentL-⊎-Iso (Iso.fun ∥∥-IdempotentL-⊎-Iso x)) x - -∥∥-IdempotentL-⊎ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ -∥∥-IdempotentL-⊎ = ua ∥∥-IdempotentL-⊎-≃ - -∥∥-IdempotentR-⊎-≃ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≃ ∥ A ⊎ A′ ∥₁ -∥∥-IdempotentR-⊎-≃ = isoToEquiv ∥∥-IdempotentR-⊎-Iso - where ∥∥-IdempotentR-⊎-Iso : Iso (∥ A ⊎ ∥ A′ ∥₁ ∥₁) (∥ A ⊎ A′ ∥₁) - Iso.fun ∥∥-IdempotentR-⊎-Iso x = rec squash₁ lem x - where lem : A ⊎ ∥ A′ ∥₁ → ∥ A ⊎ A′ ∥₁ - lem (inl x) = ∣ inl x ∣₁ - lem (inr x) = map (λ a → inr a) x - Iso.inv ∥∥-IdempotentR-⊎-Iso x = map lem x - where lem : A ⊎ A′ → A ⊎ ∥ A′ ∥₁ - lem (inl x) = inl x - lem (inr x) = inr ∣ x ∣₁ - Iso.rightInv ∥∥-IdempotentR-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-⊎-Iso (Iso.inv ∥∥-IdempotentR-⊎-Iso x)) x - Iso.leftInv ∥∥-IdempotentR-⊎-Iso x = squash₁ (Iso.inv ∥∥-IdempotentR-⊎-Iso (Iso.fun ∥∥-IdempotentR-⊎-Iso x)) x - -∥∥-IdempotentR-⊎ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ -∥∥-IdempotentR-⊎ = ua ∥∥-IdempotentR-⊎-≃ - -∥∥-Idempotent-⊎ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ -∥∥-Idempotent-⊎ {A = A} {A′} = ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-⊎ ⟩ - ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡⟨ ∥∥-IdempotentL-⊎ ⟩ - ∥ A ⊎ A′ ∥₁ ∎ - -∥∥-IdempotentL-×-≃ : ∥ ∥ A ∥₁ × A′ ∥₁ ≃ ∥ A × A′ ∥₁ -∥∥-IdempotentL-×-≃ = isoToEquiv ∥∥-IdempotentL-×-Iso - where ∥∥-IdempotentL-×-Iso : Iso (∥ ∥ A ∥₁ × A′ ∥₁) (∥ A × A′ ∥₁) - Iso.fun ∥∥-IdempotentL-×-Iso x = rec squash₁ lem x - where lem : ∥ A ∥₁ × A′ → ∥ A × A′ ∥₁ - lem (a , a′) = map2 (λ a a′ → a , a′) a ∣ a′ ∣₁ - Iso.inv ∥∥-IdempotentL-×-Iso x = map lem x - where lem : A × A′ → ∥ A ∥₁ × A′ - lem (a , a′) = ∣ a ∣₁ , a′ - Iso.rightInv ∥∥-IdempotentL-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-×-Iso (Iso.inv ∥∥-IdempotentL-×-Iso x)) x - Iso.leftInv ∥∥-IdempotentL-×-Iso x = squash₁ (Iso.inv ∥∥-IdempotentL-×-Iso (Iso.fun ∥∥-IdempotentL-×-Iso x)) x - -∥∥-IdempotentL-× : ∥ ∥ A ∥₁ × A′ ∥₁ ≡ ∥ A × A′ ∥₁ -∥∥-IdempotentL-× = ua ∥∥-IdempotentL-×-≃ - -∥∥-IdempotentR-×-≃ : ∥ A × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁ -∥∥-IdempotentR-×-≃ = isoToEquiv ∥∥-IdempotentR-×-Iso - where ∥∥-IdempotentR-×-Iso : Iso (∥ A × ∥ A′ ∥₁ ∥₁) (∥ A × A′ ∥₁) - Iso.fun ∥∥-IdempotentR-×-Iso x = rec squash₁ lem x - where lem : A × ∥ A′ ∥₁ → ∥ A × A′ ∥₁ - lem (a , a′) = map2 (λ a a′ → a , a′) ∣ a ∣₁ a′ - Iso.inv ∥∥-IdempotentR-×-Iso x = map lem x - where lem : A × A′ → A × ∥ A′ ∥₁ - lem (a , a′) = a , ∣ a′ ∣₁ - Iso.rightInv ∥∥-IdempotentR-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-×-Iso (Iso.inv ∥∥-IdempotentR-×-Iso x)) x - Iso.leftInv ∥∥-IdempotentR-×-Iso x = squash₁ (Iso.inv ∥∥-IdempotentR-×-Iso (Iso.fun ∥∥-IdempotentR-×-Iso x)) x - -∥∥-IdempotentR-× : ∥ A × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁ -∥∥-IdempotentR-× = ua ∥∥-IdempotentR-×-≃ - -∥∥-Idempotent-× : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁ -∥∥-Idempotent-× {A = A} {A′} = ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-× ⟩ - ∥ ∥ A ∥₁ × A′ ∥₁ ≡⟨ ∥∥-IdempotentL-× ⟩ - ∥ A × A′ ∥₁ ∎ - -∥∥-Idempotent-×-≃ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁ -∥∥-Idempotent-×-≃ {A = A} {A′} = compEquiv ∥∥-IdempotentR-×-≃ ∥∥-IdempotentL-×-≃ - -∥∥-×-≃ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ A ∥₁ × ∥ A′ ∥₁ ≃ ∥ A × A′ ∥₁ -∥∥-×-≃ {A = A} {A′} = compEquiv (invEquiv (propTruncIdempotent≃ (isProp× isPropPropTrunc isPropPropTrunc))) ∥∥-Idempotent-×-≃ - -∥∥-× : {A : Type ℓ} {A′ : Type ℓ'} → ∥ A ∥₁ × ∥ A′ ∥₁ ≡ ∥ A × A′ ∥₁ -∥∥-× = ua ∥∥-×-≃ - --- using this we get a convenient recursor/eliminator for binary functions into sets -rec2→Set : {A B C : Type ℓ} (Cset : isSet C) - → (f : A → B → C) - → (∀ (a a' : A) (b b' : B) → f a b ≡ f a' b') - → ∥ A ∥₁ → ∥ B ∥₁ → C -rec2→Set {A = A} {B = B} {C = C} Cset f fconst = curry (g ∘ ∥∥-×-≃ .fst) - where - g : ∥ A × B ∥₁ → C - g = rec→Set Cset (uncurry f) λ x y → fconst (fst x) (fst y) (snd x) (snd y) +RecHProp P kP = rec→Set isSetHProp P kP + +squash₁ᵗ + : ∀(x y z : A) + → Square (squash₁ ∣ x ∣₁ ∣ y ∣₁) (squash₁ ∣ x ∣₁ ∣ z ∣₁) refl (squash₁ ∣ y ∣₁ ∣ z ∣₁) +squash₁ᵗ x y z i = squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) + +module _ (B : ∥ A ∥₁ → Type ℓ) + (B-gpd : (a : _) → isGroupoid (B a)) + (f : (a : A) → B ∣ a ∣₁) + (f-coh : (x y : A) → PathP (λ i → B (squash₁ ∣ x ∣₁ ∣ y ∣₁ i)) (f x) (f y)) + (f-coh-coh : (x y z : A) → SquareP + (λ i j → B (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) j)) + (f-coh x y) (f-coh x z) refl (f-coh y z)) + where + elim→Gpd : (t : ∥ A ∥₁) → B t + private + pathHelper : (t u : ∥ A ∥₁) → PathP (λ i → B (squash₁ t u i)) (elim→Gpd t) (elim→Gpd u) + triHelper₁ + : (t u v : ∥ A ∥₁) + → SquareP (λ i j → B (squash₁ t (squash₁ u v i) j)) + (pathHelper t u) (pathHelper t v) + refl (pathHelper u v) + triHelper₂ + : (t u v : ∥ A ∥₁) + → SquareP (λ i j → B (squash₁ (squash₁ t u i) v j)) + (pathHelper t v) (pathHelper u v) + (pathHelper t u) refl + triHelper₂Cube : (x y z : ∥ A ∥₁) + → Cube (λ j k → squash₁ x z (k ∧ j)) + (λ j k → squash₁ y z j) + (λ i k → squash₁ x y i) + (λ i k → squash₁ x z (i ∨ k)) + (λ i j → squash₁ x (squash₁ y z j) i) + (λ i j → squash₁ (squash₁ x y i) z j) + + elim→Gpd ∣ x ∣₁ = f x + elim→Gpd (squash₁ t u i) = pathHelper t u i + triHelper₂Cube x y z = + isProp→PathP (λ _ → isOfHLevelPathP 1 (isOfHLevelPath 1 squash₁ _ _) _ _) _ _ + + pathHelper ∣ x ∣₁ ∣ y ∣₁ = f-coh x y + pathHelper (squash₁ t u j) v = triHelper₂ t u v j + pathHelper ∣ x ∣₁ (squash₁ u v j) = triHelper₁ ∣ x ∣₁ u v j + + triHelper₁ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ = f-coh-coh x y z + triHelper₁ (squash₁ s t i) u v + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ (squash₁ s t i) (squash₁ u v i₁) j)) + (triHelper₁ s u v) (triHelper₁ t u v) + (triHelper₂ s t u) + (triHelper₂ s t v) + (λ i j → pathHelper s t i) + (λ i j → pathHelper u v j) + (B-gpd v) i + + triHelper₁ ∣ x ∣₁ (squash₁ t u i) v + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ ∣ x ∣₁ (squash₁ (squash₁ t u i) v i₁) j)) + (triHelper₁ ∣ x ∣₁ t v) (triHelper₁ ∣ x ∣₁ u v) + (triHelper₁ ∣ x ∣₁ t u) + (λ i j → pathHelper ∣ x ∣₁ v j) + refl (triHelper₂ t u v) + (B-gpd v) i + triHelper₁ ∣ x ∣₁ ∣ y ∣₁ (squash₁ u v i) + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ (squash₁ u v i) i₁) j)) + (triHelper₁ ∣ x ∣₁ ∣ y ∣₁ u) (triHelper₁ ∣ x ∣₁ ∣ y ∣₁ v) + (λ i j → f-coh x y j) (triHelper₁ ∣ x ∣₁ u v) + refl (triHelper₁ ∣ y ∣₁ u v) + (B-gpd v) i + triHelper₂ ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ i j = + comp (λ k → B (triHelper₂Cube ∣ x ∣₁ ∣ y ∣₁ ∣ z ∣₁ i j k)) + (λ k → λ {(i = i0) → f-coh x z (k ∧ j) + ; (i = i1) → f-coh y z j + ; (j = i0) → f-coh x y i + ; (j = i1) → f-coh x z (i ∨ k)}) + (f-coh-coh x y z j i) + triHelper₂ (squash₁ s t i) u v + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ (squash₁ (squash₁ s t i) u i₁) v j)) + (triHelper₂ s u v) (triHelper₂ t u v) + (triHelper₂ s t v) (λ i j → pathHelper u v j) + (triHelper₂ s t u) refl + (B-gpd v) i + triHelper₂ ∣ x ∣₁ (squash₁ t u i) v + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ (squash₁ ∣ x ∣₁ (squash₁ t u i) i₁) v j)) + (triHelper₂ ∣ x ∣₁ t v) (triHelper₂ ∣ x ∣₁ u v) + (λ i j → pathHelper ∣ x ∣₁ v j) (triHelper₂ t u v) + (triHelper₁ ∣ x ∣₁ t u) refl + (B-gpd v) i + triHelper₂ ∣ x ∣₁ ∣ y ∣₁ (squash₁ u v i) + = isGroupoid→CubeP (λ i i₁ j → B (squash₁ (squash₁ ∣ x ∣₁ ∣ y ∣₁ i₁) (squash₁ u v i) j)) + (triHelper₂ ∣ x ∣₁ ∣ y ∣₁ u) (triHelper₂ ∣ x ∣₁ ∣ y ∣₁ v) + (triHelper₁ ∣ x ∣₁ u v) (triHelper₁ ∣ y ∣₁ u v) + refl (λ i j → pathHelper u v i) + (B-gpd v) i + + +module GpdElim (Bgpd : isGroupoid B) where + Bgpd' : isGroupoid' B + Bgpd' = isGroupoid→isGroupoid' Bgpd + + module _ (f : A → B) (3kf : 3-Constant f) where + open 3-Constant 3kf + + rec→Gpd : ∥ A ∥₁ → B + rec→Gpd = elim→Gpd (λ _ → B) (λ _ → Bgpd) f link coh₁ + + preEquiv₁ : (∥ A ∥₁ → Σ (A → B) 3-Constant) ≃ Σ (A → B) 3-Constant + preEquiv₁ = isoToEquiv (iso fn const (λ _ → refl) retr) + where + open 3-Constant + + fn : (∥ A ∥₁ → Σ (A → B) 3-Constant) → Σ (A → B) 3-Constant + fn f .fst x = f ∣ x ∣₁ .fst x + fn f .snd .link x y i = f (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) .snd .link x y i + fn f .snd .coh₁ x y z i j + = f (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) j) .snd .coh₁ x y z i j + + retr : retract fn const + retr f i t .fst x = f (squash₁ ∣ x ∣₁ t i) .fst x + retr f i t .snd .link x y j + = f (squash₁ (squash₁ ∣ x ∣₁ ∣ y ∣₁ j) t i) .snd .link x y j + retr f i t .snd .coh₁ x y z + = Bgpd' + (λ k j → f (cb k j i0) .snd .coh₁ x y z k j ) + (λ k j → f (cb k j i1) .snd .coh₁ x y z k j) + (λ k j → f (cb i0 j k) .snd .link x y j) + (λ k j → f (cb i1 j k) .snd .link x z j) + (λ _ → refl) + (λ k j → f (cb j i1 k) .snd .link y z j) + i + where + cb : I → I → I → ∥ _ ∥₁ + cb i j k = squash₁ (squash₁ ∣ x ∣₁ (squash₁ ∣ y ∣₁ ∣ z ∣₁ i) j) t k + + e : B → Σ (A → B) 3-Constant + e b .fst _ = b + e b .snd = record + { link = λ _ _ _ → b + ; coh₁ = λ _ _ _ _ _ → b + } + + eval : A → Σ (A → B) 3-Constant → B + eval a₀ (g , _) = g a₀ + + module _ where + open 3-Constant + e-eval : ∀(a₀ : A) γ → e (eval a₀ γ) ≡ γ + e-eval a₀ (g , 3kg) i .fst x = 3kg .link a₀ x i + e-eval a₀ (g , 3kg) i .snd .link x y = λ j → 3kg .coh₁ a₀ x y j i + e-eval a₀ (g , 3kg) i .snd .coh₁ x y z + = Bgpd' + (λ _ _ → g a₀) + (3kg .coh₁ x y z) + (λ k j → 3kg .coh₁ a₀ x y j k) + (λ k j → 3kg .coh₁ a₀ x z j k) + (λ _ → refl) + (λ k j → 3kg .coh₁ a₀ y z j k) + i + + e-isEquiv : A → isEquiv (e {A = A}) + e-isEquiv a₀ = isoToIsEquiv (iso e (eval a₀) (e-eval a₀) λ _ → refl) + + preEquiv₂ : ∥ A ∥₁ → B ≃ Σ (A → B) 3-Constant + preEquiv₂ t = e , rec (isPropIsEquiv e) e-isEquiv t + + trunc→Gpd≃ : (∥ A ∥₁ → B) ≃ Σ (A → B) 3-Constant + trunc→Gpd≃ = compEquiv (equivΠCod preEquiv₂) preEquiv₁ + +open GpdElim using (rec→Gpd; trunc→Gpd≃) public + +RecHSet : (P : A → TypeOfHLevel ℓ 2) → 3-Constant P → ∥ A ∥₁ → TypeOfHLevel ℓ 2 +RecHSet P 3kP = rec→Gpd (isOfHLevelTypeOfHLevel 2) P 3kP + +∥∥-IdempotentL-⊎-≃ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≃ ∥ A ⊎ A′ ∥₁ +∥∥-IdempotentL-⊎-≃ = isoToEquiv ∥∥-IdempotentL-⊎-Iso + where ∥∥-IdempotentL-⊎-Iso : Iso (∥ ∥ A ∥₁ ⊎ A′ ∥₁) (∥ A ⊎ A′ ∥₁) + Iso.fun ∥∥-IdempotentL-⊎-Iso x = rec squash₁ lem x + where lem : ∥ A ∥₁ ⊎ A′ → ∥ A ⊎ A′ ∥₁ + lem (inl x) = map (λ a → inl a) x + lem (inr x) = ∣ inr x ∣₁ + Iso.inv ∥∥-IdempotentL-⊎-Iso x = map lem x + where lem : A ⊎ A′ → ∥ A ∥₁ ⊎ A′ + lem (inl x) = inl ∣ x ∣₁ + lem (inr x) = inr x + Iso.rightInv ∥∥-IdempotentL-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-⊎-Iso (Iso.inv ∥∥-IdempotentL-⊎-Iso x)) x + Iso.leftInv ∥∥-IdempotentL-⊎-Iso x = squash₁ (Iso.inv ∥∥-IdempotentL-⊎-Iso (Iso.fun ∥∥-IdempotentL-⊎-Iso x)) x + +∥∥-IdempotentL-⊎ : ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ +∥∥-IdempotentL-⊎ = ua ∥∥-IdempotentL-⊎-≃ + +∥∥-IdempotentR-⊎-≃ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≃ ∥ A ⊎ A′ ∥₁ +∥∥-IdempotentR-⊎-≃ = isoToEquiv ∥∥-IdempotentR-⊎-Iso + where ∥∥-IdempotentR-⊎-Iso : Iso (∥ A ⊎ ∥ A′ ∥₁ ∥₁) (∥ A ⊎ A′ ∥₁) + Iso.fun ∥∥-IdempotentR-⊎-Iso x = rec squash₁ lem x + where lem : A ⊎ ∥ A′ ∥₁ → ∥ A ⊎ A′ ∥₁ + lem (inl x) = ∣ inl x ∣₁ + lem (inr x) = map (λ a → inr a) x + Iso.inv ∥∥-IdempotentR-⊎-Iso x = map lem x + where lem : A ⊎ A′ → A ⊎ ∥ A′ ∥₁ + lem (inl x) = inl x + lem (inr x) = inr ∣ x ∣₁ + Iso.rightInv ∥∥-IdempotentR-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-⊎-Iso (Iso.inv ∥∥-IdempotentR-⊎-Iso x)) x + Iso.leftInv ∥∥-IdempotentR-⊎-Iso x = squash₁ (Iso.inv ∥∥-IdempotentR-⊎-Iso (Iso.fun ∥∥-IdempotentR-⊎-Iso x)) x + +∥∥-IdempotentR-⊎ : ∥ A ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ +∥∥-IdempotentR-⊎ = ua ∥∥-IdempotentR-⊎-≃ + +∥∥-Idempotent-⊎ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡ ∥ A ⊎ A′ ∥₁ +∥∥-Idempotent-⊎ {A = A} {A′} = ∥ ∥ A ∥₁ ⊎ ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-⊎ ⟩ + ∥ ∥ A ∥₁ ⊎ A′ ∥₁ ≡⟨ ∥∥-IdempotentL-⊎ ⟩ + ∥ A ⊎ A′ ∥₁ ∎ + +∥∥-IdempotentL-×-≃ : ∥ ∥ A ∥₁ × A′ ∥₁ ≃ ∥ A × A′ ∥₁ +∥∥-IdempotentL-×-≃ = isoToEquiv ∥∥-IdempotentL-×-Iso + where ∥∥-IdempotentL-×-Iso : Iso (∥ ∥ A ∥₁ × A′ ∥₁) (∥ A × A′ ∥₁) + Iso.fun ∥∥-IdempotentL-×-Iso x = rec squash₁ lem x + where lem : ∥ A ∥₁ × A′ → ∥ A × A′ ∥₁ + lem (a , a′) = map2 (λ a a′ → a , a′) a ∣ a′ ∣₁ + Iso.inv ∥∥-IdempotentL-×-Iso x = map lem x + where lem : A × A′ → ∥ A ∥₁ × A′ + lem (a , a′) = ∣ a ∣₁ , a′ + Iso.rightInv ∥∥-IdempotentL-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-×-Iso (Iso.inv ∥∥-IdempotentL-×-Iso x)) x + Iso.leftInv ∥∥-IdempotentL-×-Iso x = squash₁ (Iso.inv ∥∥-IdempotentL-×-Iso (Iso.fun ∥∥-IdempotentL-×-Iso x)) x + +∥∥-IdempotentL-× : ∥ ∥ A ∥₁ × A′ ∥₁ ≡ ∥ A × A′ ∥₁ +∥∥-IdempotentL-× = ua ∥∥-IdempotentL-×-≃ + +∥∥-IdempotentR-×-≃ : ∥ A × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁ +∥∥-IdempotentR-×-≃ = isoToEquiv ∥∥-IdempotentR-×-Iso + where ∥∥-IdempotentR-×-Iso : Iso (∥ A × ∥ A′ ∥₁ ∥₁) (∥ A × A′ ∥₁) + Iso.fun ∥∥-IdempotentR-×-Iso x = rec squash₁ lem x + where lem : A × ∥ A′ ∥₁ → ∥ A × A′ ∥₁ + lem (a , a′) = map2 (λ a a′ → a , a′) ∣ a ∣₁ a′ + Iso.inv ∥∥-IdempotentR-×-Iso x = map lem x + where lem : A × A′ → A × ∥ A′ ∥₁ + lem (a , a′) = a , ∣ a′ ∣₁ + Iso.rightInv ∥∥-IdempotentR-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-×-Iso (Iso.inv ∥∥-IdempotentR-×-Iso x)) x + Iso.leftInv ∥∥-IdempotentR-×-Iso x = squash₁ (Iso.inv ∥∥-IdempotentR-×-Iso (Iso.fun ∥∥-IdempotentR-×-Iso x)) x + +∥∥-IdempotentR-× : ∥ A × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁ +∥∥-IdempotentR-× = ua ∥∥-IdempotentR-×-≃ + +∥∥-Idempotent-× : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡ ∥ A × A′ ∥₁ +∥∥-Idempotent-× {A = A} {A′} = ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≡⟨ ∥∥-IdempotentR-× ⟩ + ∥ ∥ A ∥₁ × A′ ∥₁ ≡⟨ ∥∥-IdempotentL-× ⟩ + ∥ A × A′ ∥₁ ∎ + +∥∥-Idempotent-×-≃ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ ∥ A ∥₁ × ∥ A′ ∥₁ ∥₁ ≃ ∥ A × A′ ∥₁ +∥∥-Idempotent-×-≃ {A = A} {A′} = compEquiv ∥∥-IdempotentR-×-≃ ∥∥-IdempotentL-×-≃ + +∥∥-×-≃ : {A : Type ℓ} {A′ : Type ℓ'} → ∥ A ∥₁ × ∥ A′ ∥₁ ≃ ∥ A × A′ ∥₁ +∥∥-×-≃ {A = A} {A′} = compEquiv (invEquiv (propTruncIdempotent≃ (isProp× isPropPropTrunc isPropPropTrunc))) ∥∥-Idempotent-×-≃ + +∥∥-× : {A : Type ℓ} {A′ : Type ℓ'} → ∥ A ∥₁ × ∥ A′ ∥₁ ≡ ∥ A × A′ ∥₁ +∥∥-× = ua ∥∥-×-≃ + +-- using this we get a convenient recursor/eliminator for binary functions into sets +rec2→Set : {A B C : Type ℓ} (Cset : isSet C) + → (f : A → B → C) + → (∀ (a a' : A) (b b' : B) → f a b ≡ f a' b') + → ∥ A ∥₁ → ∥ B ∥₁ → C +rec2→Set {A = A} {B = B} {C = C} Cset f fconst = curry (g ∘ ∥∥-×-≃ .fst) + where + g : ∥ A × B ∥₁ → C + g = rec→Set Cset (uncurry f) λ x y → fconst (fst x) (fst y) (snd x) (snd y) \ No newline at end of file diff --git a/docs/Cubical.HITs.SetQuotients.Properties.html b/docs/Cubical.HITs.SetQuotients.Properties.html index 21f8edd..0ecf9d2 100644 --- a/docs/Cubical.HITs.SetQuotients.Properties.html +++ b/docs/Cubical.HITs.SetQuotients.Properties.html @@ -31,7 +31,7 @@ open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥₁ ; ∣_∣₁ ; squash₁) renaming (rec to propRec) open import Cubical.HITs.SetTruncation as SetTrunc - using (∥_∥₂ ; ∣_∣₂ ; squash₂ ; isSetSetTrunc) + using (∥_∥₂ ; ∣_∣₂ ; squash₂ ; isSetSetTrunc) private @@ -41,20 +41,20 @@ R S T W : A → A → Type ℓ elimProp : {P : A / R → Type ℓ} - → (∀ x → isProp (P x)) + → (∀ x → isProp (P x)) → (∀ a → P [ a ]) → ∀ x → P x elimProp prop f [ x ] = f x elimProp prop f (squash/ x y p q i j) = - isOfHLevel→isOfHLevelDep 2 (λ x → isProp→isSet (prop x)) + isOfHLevel→isOfHLevelDep 2 (λ x → isProp→isSet (prop x)) (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j where g = elimProp prop f elimProp prop f (eq/ a b r i) = - isProp→PathP (λ i → prop (eq/ a b r i)) (f a) (f b) i + isProp→PathP (λ i → prop (eq/ a b r i)) (f a) (f b) i elimProp2 : {P : A / R → B / S → Type ℓ} - → (∀ x y → isProp (P x y)) + → (∀ x y → isProp (P x y)) → (∀ a b → P [ a ] [ b ]) → ∀ x y → P x y elimProp2 prop f = @@ -62,7 +62,7 @@ elimProp (prop [ a ]) (f a) elimProp3 : {P : A / R → B / S → C / T → Type ℓ} - → (∀ x y z → isProp (P x y z)) + → (∀ x y z → isProp (P x y z)) → (∀ a b c → P [ a ] [ b ] [ c ]) → ∀ x y z → P x y z elimProp3 prop f = @@ -70,7 +70,7 @@ elimProp2 (prop [ a ]) (f a) elimProp4 : {P : A / R → B / S → C / T → Q / W → Type ℓ} - → (∀ x y z t → isProp (P x y z t)) + → (∀ x y z t → isProp (P x y z t)) → (∀ a b c d → P [ a ] [ b ] [ c ] [ d ]) → ∀ x y z t → P x y z t elimProp4 prop f = @@ -79,37 +79,37 @@ -- sometimes more convenient: elimContr : {P : A / R → Type ℓ} - → (∀ a → isContr (P [ a ])) + → (∀ a → isContr (P [ a ])) → ∀ x → P x elimContr contr = - elimProp (elimProp (λ _ → isPropIsProp) λ _ → isContr→isProp (contr _)) λ _ → + elimProp (elimProp (λ _ → isPropIsProp) λ _ → isContr→isProp (contr _)) λ _ → contr _ .fst elimContr2 : {P : A / R → B / S → Type ℓ} - → (∀ a b → isContr (P [ a ] [ b ])) + → (∀ a b → isContr (P [ a ] [ b ])) → ∀ x y → P x y elimContr2 contr = elimContr λ _ → - isOfHLevelΠ 0 (elimContr λ _ → inhProp→isContr (contr _ _) isPropIsContr) + isOfHLevelΠ 0 (elimContr λ _ → inhProp→isContr (contr _ _) isPropIsContr) -- lemma 6.10.2 in hott book []surjective : (x : A / R) → ∃[ a ∈ A ] [ a ] ≡ x []surjective = elimProp (λ x → squash₁) (λ a → ∣ a , refl ∣₁) elim : {P : A / R → Type ℓ} - → (∀ x → isSet (P x)) + → (∀ x → isSet (P x)) → (f : (a : A) → (P [ a ])) → ((a b : A) (r : R a b) → PathP (λ i → P (eq/ a b r i)) (f a) (f b)) → ∀ x → P x elim set f feq [ a ] = f a elim set f feq (eq/ a b r i) = feq a b r i elim set f feq (squash/ x y p q i j) = - isOfHLevel→isOfHLevelDep 2 set + isOfHLevel→isOfHLevelDep 2 set (g x) (g y) (cong g p) (cong g q) (squash/ x y p q) i j where g = elim set f feq -rec : isSet B +rec : isSet B → (f : A → B) → ((a b : A) (r : R a b) → f a ≡ f b) → A / R → B @@ -119,7 +119,7 @@ where g = rec set f feq -rec2 : isSet C +rec2 : isSet C → (f : A → B → C) → (∀ a b c → R a b → f a c ≡ f b c) → (∀ a b c → S b c → f a b ≡ f a c) @@ -156,24 +156,24 @@ -- We start by proving that we can recover the set-quotient -- by set-truncating the (non-truncated type quotient) typeQuotSetTruncIso : Iso (A / R) ∥ A /ₜ R ∥₂ -Iso.fun typeQuotSetTruncIso = rec isSetSetTrunc (λ a → ∣ [ a ] ∣₂) +Iso.fun typeQuotSetTruncIso = rec isSetSetTrunc (λ a → ∣ [ a ] ∣₂) λ a b r → cong ∣_∣₂ (eq/ a b r) -Iso.inv typeQuotSetTruncIso = SetTrunc.rec squash/ (TypeQuot.rec [_] eq/) -Iso.rightInv typeQuotSetTruncIso = SetTrunc.elim (λ _ → isProp→isSet (squash₂ _ _)) +Iso.inv typeQuotSetTruncIso = SetTrunc.rec squash/ (TypeQuot.rec [_] eq/) +Iso.rightInv typeQuotSetTruncIso = SetTrunc.elim (λ _ → isProp→isSet (squash₂ _ _)) (TypeQuot.elimProp (λ _ → squash₂ _ _) λ _ → refl) Iso.leftInv typeQuotSetTruncIso = elimProp (λ _ → squash/ _ _) λ _ → refl -module rec→Gpd {B : Type ℓ''} (Bgpd : isGroupoid B) +module rec→Gpd {B : Type ℓ''} (Bgpd : isGroupoid B) (f : A → B) (feq : ∀ (a b : A) → R a b → f a ≡ f b) - (fprop : ∀ (a b : A) → isProp (f a ≡ f b)) + (fprop : ∀ (a b : A) → isProp (f a ≡ f b)) where fun : A / R → B fun = f₁ ∘ f₂ where f₁ : ∥ A /ₜ R ∥₂ → B - f₁ = SetTrunc.rec→Gpd.fun Bgpd f/ congF/Const + f₁ = SetTrunc.rec→Gpd.fun Bgpd f/ congF/Const where f/ : A /ₜ R → B f/ = TypeQuot.rec f feq @@ -188,7 +188,7 @@ f₂ = Iso.fun typeQuotSetTruncIso -setQuotUniversalIso : isSet B +setQuotUniversalIso : isSet B → Iso (A / R → B) (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b)) Iso.fun (setQuotUniversalIso Bset) g = (λ a → g [ a ]) , λ a b r i → g (eq/ a b r i) Iso.inv (setQuotUniversalIso Bset) h = rec Bset (fst h) (snd h) @@ -203,11 +203,11 @@ intro = Iso.fun (setQuotUniversalIso Bset) out = Iso.inv (setQuotUniversalIso Bset) -setQuotUniversal : isSet B +setQuotUniversal : isSet B → (A / R → B) ≃ (Σ[ f ∈ (A → B) ] ((a b : A) → R a b → f a ≡ f b)) setQuotUniversal Bset = isoToEquiv (setQuotUniversalIso Bset) -open BinaryRelation +open BinaryRelation setQuotUnaryOp : (-_ : A → A) → (∀ a a' → R a a' → R (- a) (- a')) @@ -215,7 +215,7 @@ setQuotUnaryOp -_ h = rec squash/ (λ a → [ - a ]) (λ a b x → eq/ _ _ (h _ _ x)) -- characterisation of binary functions/operations on set-quotients -setQuotUniversal2Iso : isSet C → isRefl R → isRefl S +setQuotUniversal2Iso : isSet C → isRefl R → isRefl S → Iso (A / R → B / S → C) (Σ[ _∗_ ∈ (A → B → C) ] (∀ a a' b b' → R a a' → S b b' → a ∗ b ≡ a' ∗ b')) Iso.fun (setQuotUniversal2Iso {R = R} {S = S} Bset isReflR isReflS) _∗/_ = _∗_ , h @@ -237,7 +237,7 @@ Iso.leftInv (setQuotUniversal2Iso Bset isReflR isReflS) _∗/_ = funExt₂ (elimProp2 (λ _ _ → Bset _ _) λ _ _ → refl) -setQuotUniversal2 : isSet C → isRefl R → isRefl S +setQuotUniversal2 : isSet C → isRefl R → isRefl S → (A / R → B / S → C) ≃ (Σ[ _∗_ ∈ (A → B → C) ] (∀ a a' b b' → R a a' → S b b' → a ∗ b ≡ a' ∗ b')) setQuotUniversal2 Bset isReflR isReflS = @@ -245,7 +245,7 @@ -- corollary for binary operations -- TODO: prove truncated inverse for effective relations -setQuotBinOp : isRefl R → isRefl S +setQuotBinOp : isRefl R → isRefl S → (_∗_ : A → B → C) → (∀ a a' b b' → R a a' → S b b' → T (a ∗ b) (a' ∗ b')) → (A / R → B / S → C / T) @@ -254,7 +254,7 @@ (λ _ _ _ r → eq/ _ _ (h _ _ _ _ r (isReflS _))) (λ _ _ _ s → eq/ _ _ (h _ _ _ _ (isReflR _) s)) -setQuotSymmBinOp : isRefl R → isTrans R +setQuotSymmBinOp : isRefl R → isTrans R → (_∗_ : A → A → A) → (∀ a b → R (a ∗ b) (b ∗ a)) → (∀ a a' b → R a a' → R (a ∗ b) (a' ∗ b)) @@ -268,17 +268,17 @@ (isTransR _ _ _ (∗Rsymm a' b) (isTransR _ _ _ (h b b' a' rb) (∗Rsymm b' a'))) -effective : (Rprop : isPropValued R) (Requiv : isEquivRel R) +effective : (Rprop : isPropValued R) (Requiv : isEquivRel R) → (a b : A) → [ a ] ≡ [ b ] → R a b -effective {A = A} {R = R} Rprop (equivRel R/refl R/sym R/trans) a b p = +effective {A = A} {R = R} Rprop (equivRel R/refl R/sym R/trans) a b p = transport aa≡ab (R/refl _) where helper : A / R → hProp _ helper = - rec isSetHProp + rec isSetHProp (λ c → (R a c , Rprop a c)) (λ c d cd → - Σ≡Prop (λ _ → isPropIsProp) + Σ≡Prop (λ _ → isPropIsProp) (hPropExt (Rprop a c) (Rprop a d) (λ ac → R/trans _ _ _ ac cd) (λ ad → R/trans _ _ _ ad (R/sym _ _ cd)))) @@ -286,14 +286,14 @@ aa≡ab : R a a ≡ R a b aa≡ab i = helper (p i) .fst -isEquivRel→effectiveIso : isPropValued R → isEquivRel R +isEquivRel→effectiveIso : isPropValued R → isEquivRel R → (a b : A) → Iso ([ a ] ≡ [ b ]) (R a b) Iso.fun (isEquivRel→effectiveIso {R = R} Rprop Req a b) = effective Rprop Req a b Iso.inv (isEquivRel→effectiveIso {R = R} Rprop Req a b) = eq/ a b Iso.rightInv (isEquivRel→effectiveIso {R = R} Rprop Req a b) _ = Rprop a b _ _ Iso.leftInv (isEquivRel→effectiveIso {R = R} Rprop Req a b) _ = squash/ _ _ _ _ -isEquivRel→isEffective : isPropValued R → isEquivRel R → isEffective R +isEquivRel→isEffective : isPropValued R → isEquivRel R → isEffective R isEquivRel→isEffective Rprop Req a b = isoToIsEquiv (invIso (isEquivRel→effectiveIso Rprop Req a b)) @@ -311,20 +311,20 @@ -- path-types for equivalence relations (not prop-valued) -- and their quotients -isEquivRel→TruncIso : isEquivRel R → (a b : A) → Iso ([ a ] ≡ [ b ]) ∥ R a b ∥₁ +isEquivRel→TruncIso : isEquivRel R → (a b : A) → Iso ([ a ] ≡ [ b ]) ∥ R a b ∥₁ isEquivRel→TruncIso {A = A} {R = R} Req a b = compIso (isProp→Iso (squash/ _ _) (squash/ _ _) (cong (Iso.fun truncRelIso)) (cong (Iso.inv truncRelIso))) (isEquivRel→effectiveIso (λ _ _ → PropTrunc.isPropPropTrunc) ∥R∥eq a b) where - open isEquivRel - ∥R∥eq : isEquivRel λ a b → ∥ R a b ∥₁ - reflexive ∥R∥eq a = ∣ reflexive Req a ∣₁ - symmetric ∥R∥eq a b = PropTrunc.map (symmetric Req a b) - transitive ∥R∥eq a b c = PropTrunc.map2 (transitive Req a b c) + open isEquivRel + ∥R∥eq : isEquivRel λ a b → ∥ R a b ∥₁ + reflexive ∥R∥eq a = ∣ reflexive Req a ∣₁ + symmetric ∥R∥eq a b = PropTrunc.map (symmetric Req a b) + transitive ∥R∥eq a b c = PropTrunc.map2 (transitive Req a b c) -discreteSetQuotients : isEquivRel R +discreteSetQuotients : isEquivRel R → (∀ a₀ a₁ → Dec (R a₀ a₁)) → Discrete (A / R) discreteSetQuotients {A = A} {R = R} Req Rdec = @@ -341,7 +341,7 @@ Iso.rightInv (relBiimpl→TruncIso R→S S→R) = elimProp (λ _ → squash/ _ _) λ _ → refl Iso.leftInv (relBiimpl→TruncIso R→S S→R) = elimProp (λ _ → squash/ _ _) λ _ → refl -descendMapPath : {M : Type ℓ} (f g : A / R → M) (isSetM : isSet M) +descendMapPath : {M : Type ℓ} (f g : A / R → M) (isSetM : isSet M) → ((x : A) → f [ x ] ≡ g [ x ]) → f ≡ g descendMapPath f g isSetM path i x = diff --git a/docs/Cubical.HITs.SetTruncation.Properties.html b/docs/Cubical.HITs.SetTruncation.Properties.html index 8092c6c..0f93aec 100644 --- a/docs/Cubical.HITs.SetTruncation.Properties.html +++ b/docs/Cubical.HITs.SetTruncation.Properties.html @@ -25,318 +25,322 @@ private variable - ℓ ℓ' ℓ'' : Level - A B C D : Type ℓ - -isSetPathImplicit : {x y : ∥ A ∥₂} → isSet (x ≡ y) -isSetPathImplicit = isOfHLevelPath 2 squash₂ _ _ - -rec : isSet B → (A → B) → ∥ A ∥₂ → B -rec Bset f ∣ x ∣₂ = f x -rec Bset f (squash₂ x y p q i j) = - Bset _ _ (cong (rec Bset f) p) (cong (rec Bset f) q) i j - -rec2 : isSet C → (A → B → C) → ∥ A ∥₂ → ∥ B ∥₂ → C -rec2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y -rec2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) = - Cset _ _ (cong (rec2 Cset f ∣ x ∣₂) p) (cong (rec2 Cset f ∣ x ∣₂) q) i j -rec2 Cset f (squash₂ x y p q i j) z = - Cset _ _ (cong (λ a → rec2 Cset f a z) p) (cong (λ a → rec2 Cset f a z) q) i j - --- Old version: --- rec2 Cset f = rec (isSetΠ λ _ → Cset) λ x → rec Cset (f x) - --- lemma 6.9.1 in HoTT book -elim : {B : ∥ A ∥₂ → Type ℓ} - (Bset : (x : ∥ A ∥₂) → isSet (B x)) - (f : (a : A) → B (∣ a ∣₂)) - (x : ∥ A ∥₂) → B x -elim Bset f ∣ a ∣₂ = f a -elim Bset f (squash₂ x y p q i j) = - isOfHLevel→isOfHLevelDep 2 Bset _ _ - (cong (elim Bset f) p) (cong (elim Bset f) q) (squash₂ x y p q) i j - -elim2 : {C : ∥ A ∥₂ → ∥ B ∥₂ → Type ℓ} - (Cset : ((x : ∥ A ∥₂) (y : ∥ B ∥₂) → isSet (C x y))) - (f : (a : A) (b : B) → C ∣ a ∣₂ ∣ b ∣₂) - (x : ∥ A ∥₂) (y : ∥ B ∥₂) → C x y -elim2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y -elim2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) = - isOfHLevel→isOfHLevelDep 2 (λ a → Cset ∣ x ∣₂ a) _ _ - (cong (elim2 Cset f ∣ x ∣₂) p) (cong (elim2 Cset f ∣ x ∣₂) q) (squash₂ y z p q) i j -elim2 Cset f (squash₂ x y p q i j) z = - isOfHLevel→isOfHLevelDep 2 (λ a → Cset a z) _ _ - (cong (λ a → elim2 Cset f a z) p) (cong (λ a → elim2 Cset f a z) q) (squash₂ x y p q) i j - --- Old version: --- elim2 Cset f = elim (λ _ → isSetΠ (λ _ → Cset _ _)) --- (λ a → elim (λ _ → Cset _ _) (f a)) - --- TODO: generalize -elim3 : {B : (x y z : ∥ A ∥₂) → Type ℓ} - (Bset : ((x y z : ∥ A ∥₂) → isSet (B x y z))) - (g : (a b c : A) → B ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂) - (x y z : ∥ A ∥₂) → B x y z -elim3 Bset g = elim2 (λ _ _ → isSetΠ (λ _ → Bset _ _ _)) - (λ a b → elim (λ _ → Bset _ _ _) (g a b)) - -elim4 : {B : (w x y z : ∥ A ∥₂) → Type ℓ} - (Bset : ((w x y z : ∥ A ∥₂) → isSet (B w x y z))) - (g : (a b c d : A) → B ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂ ∣ d ∣₂) - (w x y z : ∥ A ∥₂) → B w x y z -elim4 Bset g = elim3 (λ _ _ _ → isSetΠ λ _ → Bset _ _ _ _) - λ a b c → elim (λ _ → Bset _ _ _ _) (g a b c) - - --- the recursor for maps into groupoids following the "HIT proof" in: --- https://arxiv.org/abs/1507.01150 --- i.e. for any type A and groupoid B we can construct a map ∥ A ∥₂ → B --- from a map A → B satisfying the condition --- ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q --- TODO: prove that this is an equivalence -module rec→Gpd {A : Type ℓ} {B : Type ℓ'} (Bgpd : isGroupoid B) (f : A → B) - (congFConst : ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q) where - - data H : Type ℓ where - η : A → H - ε : ∀ (a b : A) → ∥ a ≡ b ∥₁ → η a ≡ η b -- prop. trunc. of a≡b - δ : ∀ (a b : A) (p : a ≡ b) → ε a b ∣ p ∣₁ ≡ cong η p - gtrunc : isGroupoid H - - -- write elimination principle for H - module Helim {P : H → Type ℓ''} (Pgpd : ∀ h → isGroupoid (P h)) - (η* : (a : A) → P (η a)) - (ε* : ∀ (a b : A) (∣p∣₁ : ∥ a ≡ b ∥₁) - → PathP (λ i → P (ε a b ∣p∣₁ i)) (η* a) (η* b)) - (δ* : ∀ (a b : A) (p : a ≡ b) - → PathP (λ i → PathP (λ j → P (δ a b p i j)) (η* a) (η* b)) - (ε* a b ∣ p ∣₁) (cong η* p)) where - - fun : (h : H) → P h - fun (η a) = η* a - fun (ε a b ∣p∣₁ i) = ε* a b ∣p∣₁ i - fun (δ a b p i j) = δ* a b p i j - fun (gtrunc x y p q α β i j k) = isOfHLevel→isOfHLevelDep 3 Pgpd - (fun x) (fun y) - (cong fun p) (cong fun q) - (cong (cong fun) α) (cong (cong fun) β) - (gtrunc x y p q α β) i j k - - module Hrec {C : Type ℓ''} (Cgpd : isGroupoid C) - (η* : A → C) - (ε* : ∀ (a b : A) → ∥ a ≡ b ∥₁ → η* a ≡ η* b) - (δ* : ∀ (a b : A) (p : a ≡ b) → ε* a b ∣ p ∣₁ ≡ cong η* p) where - - fun : H → C - fun (η a) = η* a - fun (ε a b ∣p∣₁ i) = ε* a b ∣p∣₁ i - fun (δ a b p i j) = δ* a b p i j - fun (gtrunc x y p q α β i j k) = Cgpd (fun x) (fun y) (cong fun p) (cong fun q) - (cong (cong fun) α) (cong (cong fun) β) i j k - - module HelimProp {P : H → Type ℓ''} (Pprop : ∀ h → isProp (P h)) - (η* : (a : A) → P (η a)) where - - fun : ∀ h → P h - fun = Helim.fun (λ _ → isSet→isGroupoid (isProp→isSet (Pprop _))) η* - (λ a b ∣p∣₁ → isOfHLevel→isOfHLevelDep 1 Pprop _ _ (ε a b ∣p∣₁)) - λ a b p → isOfHLevel→isOfHLevelDep 1 - {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)} - (λ _ → isOfHLevelPathP 1 (Pprop _) _ _) _ _ (δ a b p) - - -- The main trick: eliminating into hsets is easy - -- i.e. H has the universal property of set truncation... - module HelimSet {P : H → Type ℓ''} (Pset : ∀ h → isSet (P h)) - (η* : ∀ a → P (η a)) where - - fun : (h : H) → P h - fun = Helim.fun (λ _ → isSet→isGroupoid (Pset _)) η* ε* - λ a b p → isOfHLevel→isOfHLevelDep 1 - {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)} - (λ _ → isOfHLevelPathP' 1 (Pset _) _ _) _ _ (δ a b p) - where - ε* : (a b : A) (∣p∣₁ : ∥ a ≡ b ∥₁) → PathP (λ i → P (ε a b ∣p∣₁ i)) (η* a) (η* b) - ε* a b = pElim (λ _ → isOfHLevelPathP' 1 (Pset _) (η* a) (η* b)) - λ p → subst (λ x → PathP (λ i → P (x i)) (η* a) (η* b)) - (sym (δ a b p)) (cong η* p) - - - -- Now we need to prove that H is a set. - -- We start with a little lemma: - localHedbergLemma : {X : Type ℓ''} (P : X → Type ℓ'') - → (∀ x → isProp (P x)) - → ((x : X) → P x → (y : X) → P y → x ≡ y) - -------------------------------------------------- - → (x : X) → P x → (y : X) → isProp (x ≡ y) - localHedbergLemma {X = X} P Pprop P→≡ x px y = isPropRetract - (λ p → subst P p px) (λ py → sym (P→≡ x px x px) ∙ P→≡ x px y py) - isRetract (Pprop y) - where - isRetract : (p : x ≡ y) → (sym (P→≡ x px x px)) ∙ P→≡ x px y (subst P p px) ≡ p - isRetract = J (λ y' p' → (sym (P→≡ x px x px)) ∙ P→≡ x px y' (subst P p' px) ≡ p') - (subst (λ px' → sym (P→≡ x px x px) ∙ P→≡ x px x px' ≡ refl) - (sym (substRefl {B = P} px)) (lCancel (P→≡ x px x px))) - - Hset : isSet H - Hset = HelimProp.fun (λ _ → isPropΠ λ _ → isPropIsProp) baseCaseLeft - where - baseCaseLeft : (a₀ : A) (y : H) → isProp (η a₀ ≡ y) - baseCaseLeft a₀ = localHedbergLemma (λ x → Q x .fst) (λ x → Q x .snd) Q→≡ _ ∣ refl ∣₁ - where - Q : H → hProp ℓ - Q = HelimSet.fun (λ _ → isSetHProp) λ b → ∥ a₀ ≡ b ∥₁ , isPropPropTrunc - -- Q (η b) = ∥ a ≡ b ∥₁ - - Q→≡ : (x : H) → Q x .fst → (y : H) → Q y .fst → x ≡ y - Q→≡ = HelimSet.fun (λ _ → isSetΠ3 λ _ _ _ → gtrunc _ _) - λ a p → HelimSet.fun (λ _ → isSetΠ λ _ → gtrunc _ _) - λ b q → sym (ε a₀ a p) ∙ ε a₀ b q - - -- our desired function will split through H, - -- i.e. we get a function ∥ A ∥₂ → H → B - fun : ∥ A ∥₂ → B - fun = f₁ ∘ f₂ - where - f₁ : H → B - f₁ = Hrec.fun Bgpd f εᶠ λ _ _ _ → refl - where - εᶠ : (a b : A) → ∥ a ≡ b ∥₁ → f a ≡ f b - εᶠ a b = rec→Set (Bgpd _ _) (cong f) λ p q → congFConst a b p q - -- this is the inductive step, - -- we use that maps ∥ A ∥₁ → B for an hset B - -- correspond to 2-Constant maps A → B (which cong f is by assumption) - f₂ : ∥ A ∥₂ → H - f₂ = rec Hset η - - -map : (A → B) → ∥ A ∥₂ → ∥ B ∥₂ -map f = rec squash₂ λ x → ∣ f x ∣₂ - -map∙ : {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} - (f : A →∙ B) → ∥ A ∥₂∙ →∙ ∥ B ∥₂∙ -fst (map∙ f) = map (fst f) -snd (map∙ f) = cong ∣_∣₂ (snd f) - -setTruncUniversal : isSet B → (∥ A ∥₂ → B) ≃ (A → B) -setTruncUniversal {B = B} Bset = - isoToEquiv (iso (λ h x → h ∣ x ∣₂) (rec Bset) (λ _ → refl) rinv) - where - rinv : (f : ∥ A ∥₂ → B) → rec Bset (λ x → f ∣ x ∣₂) ≡ f - rinv f i x = - elim (λ x → isProp→isSet (Bset (rec Bset (λ x → f ∣ x ∣₂) x) (f x))) - (λ _ → refl) x i - -isSetSetTrunc : isSet ∥ A ∥₂ -isSetSetTrunc a b p q = squash₂ a b p q - -setTruncIdempotentIso : isSet A → Iso ∥ A ∥₂ A -Iso.fun (setTruncIdempotentIso hA) = rec hA (idfun _) -Iso.inv (setTruncIdempotentIso hA) x = ∣ x ∣₂ -Iso.rightInv (setTruncIdempotentIso hA) _ = refl -Iso.leftInv (setTruncIdempotentIso hA) = elim (λ _ → isSet→isGroupoid isSetSetTrunc _ _) (λ _ → refl) - -setTruncIdempotent≃ : isSet A → ∥ A ∥₂ ≃ A -setTruncIdempotent≃ {A = A} hA = isoToEquiv (setTruncIdempotentIso hA) - -setTruncIdempotent : isSet A → ∥ A ∥₂ ≡ A -setTruncIdempotent hA = ua (setTruncIdempotent≃ hA) - -isContr→isContrSetTrunc : isContr A → isContr (∥ A ∥₂) -isContr→isContrSetTrunc contr = ∣ fst contr ∣₂ - , elim (λ _ → isOfHLevelPath 2 (isSetSetTrunc) _ _) - λ a → cong ∣_∣₂ (snd contr a) - - -setTruncIso : Iso A B → Iso ∥ A ∥₂ ∥ B ∥₂ -Iso.fun (setTruncIso is) = rec isSetSetTrunc (λ x → ∣ Iso.fun is x ∣₂) -Iso.inv (setTruncIso is) = rec isSetSetTrunc (λ x → ∣ Iso.inv is x ∣₂) -Iso.rightInv (setTruncIso is) = - elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ a → cong ∣_∣₂ (Iso.rightInv is a) -Iso.leftInv (setTruncIso is) = - elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ a → cong ∣_∣₂ (Iso.leftInv is a) - -setSigmaIso : {B : A → Type ℓ} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ -setSigmaIso {A = A} {B = B} = iso fun funinv sect retr - where - {- writing it out explicitly to avoid yellow highlighting -} - fun : ∥ Σ A B ∥₂ → ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ - fun = rec isSetSetTrunc λ {(a , p) → ∣ a , ∣ p ∣₂ ∣₂} - funinv : ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ → ∥ Σ A B ∥₂ - funinv = rec isSetSetTrunc (λ {(a , p) → rec isSetSetTrunc (λ p → ∣ a , p ∣₂) p}) - sect : section fun funinv - sect = elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ { (a , p) → elim {B = λ p → fun (funinv ∣ a , p ∣₂) ≡ ∣ a , p ∣₂} - (λ p → isOfHLevelPath 2 isSetSetTrunc _ _) (λ _ → refl) p } - retr : retract fun funinv - retr = elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ { _ → refl } - -sigmaElim : {B : ∥ A ∥₂ → Type ℓ} {C : Σ ∥ A ∥₂ B → Type ℓ'} - (Bset : (x : Σ ∥ A ∥₂ B) → isSet (C x)) - (g : (a : A) (b : B ∣ a ∣₂) → C (∣ a ∣₂ , b)) - (x : Σ ∥ A ∥₂ B) → C x -sigmaElim {B = B} {C = C} set g (x , y) = - elim {B = λ x → (y : B x) → C (x , y)} (λ _ → isSetΠ λ _ → set _) g x y - -sigmaProdElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} {D : Σ (∥ A ∥₂ × ∥ B ∥₂) C → Type ℓ'} - (Bset : (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → isSet (D x)) - (g : (a : A) (b : B) (c : C (∣ a ∣₂ , ∣ b ∣₂)) → D ((∣ a ∣₂ , ∣ b ∣₂) , c)) - (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → D x -sigmaProdElim {B = B} {C = C} {D = D} set g ((x , y) , c) = - elim {B = λ x → (y : ∥ B ∥₂) (c : C (x , y)) → D ((x , y) , c)} - (λ _ → isSetΠ λ _ → isSetΠ λ _ → set _) - (λ x → elim (λ _ → isSetΠ λ _ → set _) (g x)) - x y c - -prodElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} - → ((x : ∥ A ∥₂ × ∥ B ∥₂) → isSet (C x)) - → ((a : A) (b : B) → C (∣ a ∣₂ , ∣ b ∣₂)) - → (x : ∥ A ∥₂ × ∥ B ∥₂) → C x -prodElim setC f (a , b) = elim2 (λ x y → setC (x , y)) f a b - -prodRec : {C : Type ℓ} → isSet C → (A → B → C) → ∥ A ∥₂ × ∥ B ∥₂ → C -prodRec setC f (a , b) = rec2 setC f a b - -prodElim2 : {E : (∥ A ∥₂ × ∥ B ∥₂) → (∥ C ∥₂ × ∥ D ∥₂) → Type ℓ} - → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → isSet (E x y)) - → ((a : A) (b : B) (c : C) (d : D) → E (∣ a ∣₂ , ∣ b ∣₂) (∣ c ∣₂ , ∣ d ∣₂)) - → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → (E x y)) -prodElim2 isset f = prodElim (λ _ → isSetΠ λ _ → isset _ _) - λ a b → prodElim (λ _ → isset _ _) - λ c d → f a b c d - -setTruncOfProdIso : Iso ∥ A × B ∥₂ (∥ A ∥₂ × ∥ B ∥₂) -Iso.fun setTruncOfProdIso = rec (isSet× isSetSetTrunc isSetSetTrunc) λ { (a , b) → ∣ a ∣₂ , ∣ b ∣₂ } -Iso.inv setTruncOfProdIso = prodRec isSetSetTrunc λ a b → ∣ a , b ∣₂ -Iso.rightInv setTruncOfProdIso = - prodElim (λ _ → isOfHLevelPath 2 (isSet× isSetSetTrunc isSetSetTrunc) _ _) λ _ _ → refl -Iso.leftInv setTruncOfProdIso = - elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) λ {(a , b) → refl} - -IsoSetTruncateSndΣ : {A : Type ℓ} {B : A → Type ℓ'} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ -Iso.fun IsoSetTruncateSndΣ = map λ a → (fst a) , ∣ snd a ∣₂ -Iso.inv IsoSetTruncateSndΣ = rec isSetSetTrunc (uncurry λ x → map λ b → x , b) -Iso.rightInv IsoSetTruncateSndΣ = - elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - (uncurry λ a → elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ _ → refl) -Iso.leftInv IsoSetTruncateSndΣ = - elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) - λ _ → refl - -PathIdTrunc₀Iso : {a b : A} → Iso (∣ a ∣₂ ≡ ∣ b ∣₂) ∥ a ≡ b ∥₁ -Iso.fun (PathIdTrunc₀Iso {b = b}) p = - transport (λ i → rec {B = TypeOfHLevel _ 1} (isOfHLevelTypeOfHLevel 1) - (λ a → ∥ a ≡ b ∥₁ , squash₁) (p (~ i)) .fst) - ∣ refl ∣₁ -Iso.inv PathIdTrunc₀Iso = pRec (squash₂ _ _) (cong ∣_∣₂) -Iso.rightInv PathIdTrunc₀Iso _ = squash₁ _ _ -Iso.leftInv PathIdTrunc₀Iso _ = squash₂ _ _ _ _ - -mapFunctorial : {A B C : Type ℓ} (f : A → B) (g : B → C) - → map g ∘ map f ≡ map (g ∘ f) -mapFunctorial f g = - funExt (elim (λ x → isSetPathImplicit) λ a → refl) + ℓ ℓ' ℓ'' ℓa ℓb ℓc ℓd : Level + A : Type ℓa + B : Type ℓb + C : Type ℓc + D : Type ℓd + +isSetPathImplicit : {x y : ∥ A ∥₂} → isSet (x ≡ y) +isSetPathImplicit = isOfHLevelPath 2 squash₂ _ _ + +rec : isSet B → (A → B) → ∥ A ∥₂ → B +rec Bset f ∣ x ∣₂ = f x +rec Bset f (squash₂ x y p q i j) = + Bset _ _ (cong (rec Bset f) p) (cong (rec Bset f) q) i j + +rec2 : isSet C → (A → B → C) → ∥ A ∥₂ → ∥ B ∥₂ → C +rec2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y +rec2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) = + Cset _ _ (cong (rec2 Cset f ∣ x ∣₂) p) (cong (rec2 Cset f ∣ x ∣₂) q) i j +rec2 Cset f (squash₂ x y p q i j) z = + Cset _ _ (cong (λ a → rec2 Cset f a z) p) (cong (λ a → rec2 Cset f a z) q) i j + +-- Old version: +-- rec2 Cset f = rec (isSetΠ λ _ → Cset) λ x → rec Cset (f x) + +-- lemma 6.9.1 in HoTT book +elim : {B : ∥ A ∥₂ → Type ℓ} + (Bset : (x : ∥ A ∥₂) → isSet (B x)) + (f : (a : A) → B (∣ a ∣₂)) + (x : ∥ A ∥₂) → B x +elim Bset f ∣ a ∣₂ = f a +elim Bset f (squash₂ x y p q i j) = + isOfHLevel→isOfHLevelDep 2 Bset _ _ + (cong (elim Bset f) p) (cong (elim Bset f) q) (squash₂ x y p q) i j + +elim2 : {C : ∥ A ∥₂ → ∥ B ∥₂ → Type ℓ} + (Cset : ((x : ∥ A ∥₂) (y : ∥ B ∥₂) → isSet (C x y))) + (f : (a : A) (b : B) → C ∣ a ∣₂ ∣ b ∣₂) + (x : ∥ A ∥₂) (y : ∥ B ∥₂) → C x y +elim2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y +elim2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) = + isOfHLevel→isOfHLevelDep 2 (λ a → Cset ∣ x ∣₂ a) _ _ + (cong (elim2 Cset f ∣ x ∣₂) p) (cong (elim2 Cset f ∣ x ∣₂) q) (squash₂ y z p q) i j +elim2 Cset f (squash₂ x y p q i j) z = + isOfHLevel→isOfHLevelDep 2 (λ a → Cset a z) _ _ + (cong (λ a → elim2 Cset f a z) p) (cong (λ a → elim2 Cset f a z) q) (squash₂ x y p q) i j + +-- Old version: +-- elim2 Cset f = elim (λ _ → isSetΠ (λ _ → Cset _ _)) +-- (λ a → elim (λ _ → Cset _ _) (f a)) + +-- TODO: generalize +elim3 : {D : ∥ A ∥₂ → ∥ B ∥₂ → ∥ C ∥₂ → Type ℓ} + (Dset : ((x : ∥ A ∥₂) (y : ∥ B ∥₂) (z : ∥ C ∥₂) → isSet (D x y z))) + (g : (a : A) (b : B) (c : C) → D ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂) + (x : ∥ A ∥₂) (y : ∥ B ∥₂) (z : ∥ C ∥₂) → D x y z +elim3 Dset g = elim2 (λ _ _ → isSetΠ (λ _ → Dset _ _ _)) + (λ a b → elim (λ _ → Dset _ _ _) (g a b)) + +elim4 : {E : ∥ A ∥₂ → ∥ B ∥₂ → ∥ C ∥₂ → ∥ D ∥₂ → Type ℓ} + (Eset : ((w : ∥ A ∥₂) (x : ∥ B ∥₂) (y : ∥ C ∥₂) (z : ∥ D ∥₂) + → isSet (E w x y z))) + (g : (a : A) (b : B) (c : C) (d : D) → E ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂ ∣ d ∣₂) + (w : ∥ A ∥₂) (x : ∥ B ∥₂) (y : ∥ C ∥₂) (z : ∥ D ∥₂) → E w x y z +elim4 Eset g = elim3 (λ _ _ _ → isSetΠ λ _ → Eset _ _ _ _) + λ a b c → elim (λ _ → Eset _ _ _ _) (g a b c) + + +-- the recursor for maps into groupoids following the "HIT proof" in: +-- https://arxiv.org/abs/1507.01150 +-- i.e. for any type A and groupoid B we can construct a map ∥ A ∥₂ → B +-- from a map A → B satisfying the condition +-- ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q +-- TODO: prove that this is an equivalence +module rec→Gpd {A : Type ℓ} {B : Type ℓ'} (Bgpd : isGroupoid B) (f : A → B) + (congFConst : ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q) where + + data H : Type ℓ where + η : A → H + ε : ∀ (a b : A) → ∥ a ≡ b ∥₁ → η a ≡ η b -- prop. trunc. of a≡b + δ : ∀ (a b : A) (p : a ≡ b) → ε a b ∣ p ∣₁ ≡ cong η p + gtrunc : isGroupoid H + + -- write elimination principle for H + module Helim {P : H → Type ℓ''} (Pgpd : ∀ h → isGroupoid (P h)) + (η* : (a : A) → P (η a)) + (ε* : ∀ (a b : A) (∣p∣₁ : ∥ a ≡ b ∥₁) + → PathP (λ i → P (ε a b ∣p∣₁ i)) (η* a) (η* b)) + (δ* : ∀ (a b : A) (p : a ≡ b) + → PathP (λ i → PathP (λ j → P (δ a b p i j)) (η* a) (η* b)) + (ε* a b ∣ p ∣₁) (cong η* p)) where + + fun : (h : H) → P h + fun (η a) = η* a + fun (ε a b ∣p∣₁ i) = ε* a b ∣p∣₁ i + fun (δ a b p i j) = δ* a b p i j + fun (gtrunc x y p q α β i j k) = isOfHLevel→isOfHLevelDep 3 Pgpd + (fun x) (fun y) + (cong fun p) (cong fun q) + (cong (cong fun) α) (cong (cong fun) β) + (gtrunc x y p q α β) i j k + + module Hrec {C : Type ℓ''} (Cgpd : isGroupoid C) + (η* : A → C) + (ε* : ∀ (a b : A) → ∥ a ≡ b ∥₁ → η* a ≡ η* b) + (δ* : ∀ (a b : A) (p : a ≡ b) → ε* a b ∣ p ∣₁ ≡ cong η* p) where + + fun : H → C + fun (η a) = η* a + fun (ε a b ∣p∣₁ i) = ε* a b ∣p∣₁ i + fun (δ a b p i j) = δ* a b p i j + fun (gtrunc x y p q α β i j k) = Cgpd (fun x) (fun y) (cong fun p) (cong fun q) + (cong (cong fun) α) (cong (cong fun) β) i j k + + module HelimProp {P : H → Type ℓ''} (Pprop : ∀ h → isProp (P h)) + (η* : (a : A) → P (η a)) where + + fun : ∀ h → P h + fun = Helim.fun (λ _ → isSet→isGroupoid (isProp→isSet (Pprop _))) η* + (λ a b ∣p∣₁ → isOfHLevel→isOfHLevelDep 1 Pprop _ _ (ε a b ∣p∣₁)) + λ a b p → isOfHLevel→isOfHLevelDep 1 + {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)} + (λ _ → isOfHLevelPathP 1 (Pprop _) _ _) _ _ (δ a b p) + + -- The main trick: eliminating into hsets is easy + -- i.e. H has the universal property of set truncation... + module HelimSet {P : H → Type ℓ''} (Pset : ∀ h → isSet (P h)) + (η* : ∀ a → P (η a)) where + + fun : (h : H) → P h + fun = Helim.fun (λ _ → isSet→isGroupoid (Pset _)) η* ε* + λ a b p → isOfHLevel→isOfHLevelDep 1 + {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)} + (λ _ → isOfHLevelPathP' 1 (Pset _) _ _) _ _ (δ a b p) + where + ε* : (a b : A) (∣p∣₁ : ∥ a ≡ b ∥₁) → PathP (λ i → P (ε a b ∣p∣₁ i)) (η* a) (η* b) + ε* a b = pElim (λ _ → isOfHLevelPathP' 1 (Pset _) (η* a) (η* b)) + λ p → subst (λ x → PathP (λ i → P (x i)) (η* a) (η* b)) + (sym (δ a b p)) (cong η* p) + + + -- Now we need to prove that H is a set. + -- We start with a little lemma: + localHedbergLemma : {X : Type ℓ''} (P : X → Type ℓ'') + → (∀ x → isProp (P x)) + → ((x : X) → P x → (y : X) → P y → x ≡ y) + -------------------------------------------------- + → (x : X) → P x → (y : X) → isProp (x ≡ y) + localHedbergLemma {X = X} P Pprop P→≡ x px y = isPropRetract + (λ p → subst P p px) (λ py → sym (P→≡ x px x px) ∙ P→≡ x px y py) + isRetract (Pprop y) + where + isRetract : (p : x ≡ y) → (sym (P→≡ x px x px)) ∙ P→≡ x px y (subst P p px) ≡ p + isRetract = J (λ y' p' → (sym (P→≡ x px x px)) ∙ P→≡ x px y' (subst P p' px) ≡ p') + (subst (λ px' → sym (P→≡ x px x px) ∙ P→≡ x px x px' ≡ refl) + (sym (substRefl {B = P} px)) (lCancel (P→≡ x px x px))) + + Hset : isSet H + Hset = HelimProp.fun (λ _ → isPropΠ λ _ → isPropIsProp) baseCaseLeft + where + baseCaseLeft : (a₀ : A) (y : H) → isProp (η a₀ ≡ y) + baseCaseLeft a₀ = localHedbergLemma (λ x → Q x .fst) (λ x → Q x .snd) Q→≡ _ ∣ refl ∣₁ + where + Q : H → hProp ℓ + Q = HelimSet.fun (λ _ → isSetHProp) λ b → ∥ a₀ ≡ b ∥₁ , isPropPropTrunc + -- Q (η b) = ∥ a ≡ b ∥₁ + + Q→≡ : (x : H) → Q x .fst → (y : H) → Q y .fst → x ≡ y + Q→≡ = HelimSet.fun (λ _ → isSetΠ3 λ _ _ _ → gtrunc _ _) + λ a p → HelimSet.fun (λ _ → isSetΠ λ _ → gtrunc _ _) + λ b q → sym (ε a₀ a p) ∙ ε a₀ b q + + -- our desired function will split through H, + -- i.e. we get a function ∥ A ∥₂ → H → B + fun : ∥ A ∥₂ → B + fun = f₁ ∘ f₂ + where + f₁ : H → B + f₁ = Hrec.fun Bgpd f εᶠ λ _ _ _ → refl + where + εᶠ : (a b : A) → ∥ a ≡ b ∥₁ → f a ≡ f b + εᶠ a b = rec→Set (Bgpd _ _) (cong f) λ p q → congFConst a b p q + -- this is the inductive step, + -- we use that maps ∥ A ∥₁ → B for an hset B + -- correspond to 2-Constant maps A → B (which cong f is by assumption) + f₂ : ∥ A ∥₂ → H + f₂ = rec Hset η + + +map : (A → B) → ∥ A ∥₂ → ∥ B ∥₂ +map f = rec squash₂ λ x → ∣ f x ∣₂ + +map∙ : {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} + (f : A →∙ B) → ∥ A ∥₂∙ →∙ ∥ B ∥₂∙ +fst (map∙ f) = map (fst f) +snd (map∙ f) = cong ∣_∣₂ (snd f) + +setTruncUniversal : isSet B → (∥ A ∥₂ → B) ≃ (A → B) +setTruncUniversal {B = B} Bset = + isoToEquiv (iso (λ h x → h ∣ x ∣₂) (rec Bset) (λ _ → refl) rinv) + where + rinv : (f : ∥ A ∥₂ → B) → rec Bset (λ x → f ∣ x ∣₂) ≡ f + rinv f i x = + elim (λ x → isProp→isSet (Bset (rec Bset (λ x → f ∣ x ∣₂) x) (f x))) + (λ _ → refl) x i + +isSetSetTrunc : isSet ∥ A ∥₂ +isSetSetTrunc a b p q = squash₂ a b p q + +setTruncIdempotentIso : isSet A → Iso ∥ A ∥₂ A +Iso.fun (setTruncIdempotentIso hA) = rec hA (idfun _) +Iso.inv (setTruncIdempotentIso hA) x = ∣ x ∣₂ +Iso.rightInv (setTruncIdempotentIso hA) _ = refl +Iso.leftInv (setTruncIdempotentIso hA) = elim (λ _ → isSet→isGroupoid isSetSetTrunc _ _) (λ _ → refl) + +setTruncIdempotent≃ : isSet A → ∥ A ∥₂ ≃ A +setTruncIdempotent≃ {A = A} hA = isoToEquiv (setTruncIdempotentIso hA) + +setTruncIdempotent : isSet A → ∥ A ∥₂ ≡ A +setTruncIdempotent hA = ua (setTruncIdempotent≃ hA) + +isContr→isContrSetTrunc : isContr A → isContr (∥ A ∥₂) +isContr→isContrSetTrunc contr = ∣ fst contr ∣₂ + , elim (λ _ → isOfHLevelPath 2 (isSetSetTrunc) _ _) + λ a → cong ∣_∣₂ (snd contr a) + + +setTruncIso : Iso A B → Iso ∥ A ∥₂ ∥ B ∥₂ +Iso.fun (setTruncIso is) = rec isSetSetTrunc (λ x → ∣ Iso.fun is x ∣₂) +Iso.inv (setTruncIso is) = rec isSetSetTrunc (λ x → ∣ Iso.inv is x ∣₂) +Iso.rightInv (setTruncIso is) = + elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ a → cong ∣_∣₂ (Iso.rightInv is a) +Iso.leftInv (setTruncIso is) = + elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ a → cong ∣_∣₂ (Iso.leftInv is a) + +setSigmaIso : {B : A → Type ℓ} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ +setSigmaIso {A = A} {B = B} = iso fun funinv sect retr + where + {- writing it out explicitly to avoid yellow highlighting -} + fun : ∥ Σ A B ∥₂ → ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ + fun = rec isSetSetTrunc λ {(a , p) → ∣ a , ∣ p ∣₂ ∣₂} + funinv : ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ → ∥ Σ A B ∥₂ + funinv = rec isSetSetTrunc (λ {(a , p) → rec isSetSetTrunc (λ p → ∣ a , p ∣₂) p}) + sect : section fun funinv + sect = elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ { (a , p) → elim {B = λ p → fun (funinv ∣ a , p ∣₂) ≡ ∣ a , p ∣₂} + (λ p → isOfHLevelPath 2 isSetSetTrunc _ _) (λ _ → refl) p } + retr : retract fun funinv + retr = elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ { _ → refl } + +sigmaElim : {B : ∥ A ∥₂ → Type ℓ} {C : Σ ∥ A ∥₂ B → Type ℓ'} + (Bset : (x : Σ ∥ A ∥₂ B) → isSet (C x)) + (g : (a : A) (b : B ∣ a ∣₂) → C (∣ a ∣₂ , b)) + (x : Σ ∥ A ∥₂ B) → C x +sigmaElim {B = B} {C = C} set g (x , y) = + elim {B = λ x → (y : B x) → C (x , y)} (λ _ → isSetΠ λ _ → set _) g x y + +sigmaProdElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} {D : Σ (∥ A ∥₂ × ∥ B ∥₂) C → Type ℓ'} + (Bset : (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → isSet (D x)) + (g : (a : A) (b : B) (c : C (∣ a ∣₂ , ∣ b ∣₂)) → D ((∣ a ∣₂ , ∣ b ∣₂) , c)) + (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → D x +sigmaProdElim {B = B} {C = C} {D = D} set g ((x , y) , c) = + elim {B = λ x → (y : ∥ B ∥₂) (c : C (x , y)) → D ((x , y) , c)} + (λ _ → isSetΠ λ _ → isSetΠ λ _ → set _) + (λ x → elim (λ _ → isSetΠ λ _ → set _) (g x)) + x y c + +prodElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} + → ((x : ∥ A ∥₂ × ∥ B ∥₂) → isSet (C x)) + → ((a : A) (b : B) → C (∣ a ∣₂ , ∣ b ∣₂)) + → (x : ∥ A ∥₂ × ∥ B ∥₂) → C x +prodElim setC f (a , b) = elim2 (λ x y → setC (x , y)) f a b + +prodRec : {C : Type ℓ} → isSet C → (A → B → C) → ∥ A ∥₂ × ∥ B ∥₂ → C +prodRec setC f (a , b) = rec2 setC f a b + +prodElim2 : {E : (∥ A ∥₂ × ∥ B ∥₂) → (∥ C ∥₂ × ∥ D ∥₂) → Type ℓ} + → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → isSet (E x y)) + → ((a : A) (b : B) (c : C) (d : D) → E (∣ a ∣₂ , ∣ b ∣₂) (∣ c ∣₂ , ∣ d ∣₂)) + → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → (E x y)) +prodElim2 isset f = prodElim (λ _ → isSetΠ λ _ → isset _ _) + λ a b → prodElim (λ _ → isset _ _) + λ c d → f a b c d + +setTruncOfProdIso : Iso ∥ A × B ∥₂ (∥ A ∥₂ × ∥ B ∥₂) +Iso.fun setTruncOfProdIso = rec (isSet× isSetSetTrunc isSetSetTrunc) λ { (a , b) → ∣ a ∣₂ , ∣ b ∣₂ } +Iso.inv setTruncOfProdIso = prodRec isSetSetTrunc λ a b → ∣ a , b ∣₂ +Iso.rightInv setTruncOfProdIso = + prodElim (λ _ → isOfHLevelPath 2 (isSet× isSetSetTrunc isSetSetTrunc) _ _) λ _ _ → refl +Iso.leftInv setTruncOfProdIso = + elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) λ {(a , b) → refl} + +IsoSetTruncateSndΣ : {A : Type ℓ} {B : A → Type ℓ'} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ +Iso.fun IsoSetTruncateSndΣ = map λ a → (fst a) , ∣ snd a ∣₂ +Iso.inv IsoSetTruncateSndΣ = rec isSetSetTrunc (uncurry λ x → map λ b → x , b) +Iso.rightInv IsoSetTruncateSndΣ = + elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + (uncurry λ a → elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ _ → refl) +Iso.leftInv IsoSetTruncateSndΣ = + elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) + λ _ → refl + +PathIdTrunc₀Iso : {a b : A} → Iso (∣ a ∣₂ ≡ ∣ b ∣₂) ∥ a ≡ b ∥₁ +Iso.fun (PathIdTrunc₀Iso {b = b}) p = + transport (λ i → rec {B = TypeOfHLevel _ 1} (isOfHLevelTypeOfHLevel 1) + (λ a → ∥ a ≡ b ∥₁ , squash₁) (p (~ i)) .fst) + ∣ refl ∣₁ +Iso.inv PathIdTrunc₀Iso = pRec (squash₂ _ _) (cong ∣_∣₂) +Iso.rightInv PathIdTrunc₀Iso _ = squash₁ _ _ +Iso.leftInv PathIdTrunc₀Iso _ = squash₂ _ _ _ _ + +mapFunctorial : {A B C : Type ℓ} (f : A → B) (g : B → C) + → map g ∘ map f ≡ map (g ∘ f) +mapFunctorial f g = + funExt (elim (λ x → isSetPathImplicit) λ a → refl) \ No newline at end of file diff --git a/docs/Cubical.HITs.TypeQuotients.Properties.html b/docs/Cubical.HITs.TypeQuotients.Properties.html index 94976bc..c3f69f9 100644 --- a/docs/Cubical.HITs.TypeQuotients.Properties.html +++ b/docs/Cubical.HITs.TypeQuotients.Properties.html @@ -40,14 +40,14 @@ rec f feq [ a ] = f a rec f feq (eq/ a b r i) = feq a b r i -elimProp : ((x : A /ₜ R ) → isProp (B x)) +elimProp : ((x : A /ₜ R ) → isProp (B x)) → ((a : A) → B ( [ a ])) --------------------------------- → (x : A /ₜ R) → B x elimProp Bprop f [ a ] = f a -elimProp Bprop f (eq/ a b r i) = isOfHLevel→isOfHLevelDep 1 Bprop (f a) (f b) (eq/ a b r) i +elimProp Bprop f (eq/ a b r i) = isOfHLevel→isOfHLevelDep 1 Bprop (f a) (f b) (eq/ a b r) i -elimProp2 : ((x y : A /ₜ R ) → isProp (C x y)) +elimProp2 : ((x y : A /ₜ R ) → isProp (C x y)) → ((a b : A) → C [ a ] [ b ]) -------------------------------------- → (x y : A /ₜ R) → C x y diff --git a/docs/Cubical.Induction.WellFounded.html b/docs/Cubical.Induction.WellFounded.html index eaa8701..c691557 100644 --- a/docs/Cubical.Induction.WellFounded.html +++ b/docs/Cubical.Induction.WellFounded.html @@ -5,45 +5,45 @@ open import Cubical.Foundations.Prelude -Rel : ∀{ℓ} → Type ℓ → ∀ ℓ' → Type _ -Rel A ℓ = A → A → Type ℓ +module _ {ℓ ℓ'} {A : Type ℓ} (_<_ : A → A → Type ℓ') where + WFRec : ∀{ℓ''} → (A → Type ℓ'') → A → Type _ + WFRec P x = ∀ y → y < x → P y -module _ {ℓ ℓ'} {A : Type ℓ} (_<_ : A → A → Type ℓ') where - WFRec : ∀{ℓ''} → (A → Type ℓ'') → A → Type _ - WFRec P x = ∀ y → y < x → P y + data Acc (x : A) : Type (ℓ-max ℓ ℓ') where + acc : WFRec Acc x → Acc x - data Acc (x : A) : Type (ℓ-max ℓ ℓ') where - acc : WFRec Acc x → Acc x + WellFounded : Type _ + WellFounded = ∀ x → Acc x - WellFounded : Type _ - WellFounded = ∀ x → Acc x +module _ {ℓ ℓ'} {A : Type ℓ} {_<_ : A → A → Type ℓ'} where + isPropAcc : ∀ x → isProp (Acc _<_ x) + isPropAcc x (acc p) (acc q) + = λ i → acc (λ y y<x → isPropAcc y (p y y<x) (q y y<x) i) -module _ {ℓ ℓ'} {A : Type ℓ} {_<_ : A → A → Type ℓ'} where - isPropAcc : ∀ x → isProp (Acc _<_ x) - isPropAcc x (acc p) (acc q) - = λ i → acc (λ y y<x → isPropAcc y (p y y<x) (q y y<x) i) + isPropWellFounded : isProp (WellFounded _<_) + isPropWellFounded p q i a = isPropAcc a (p a) (q a) i - access : ∀{x} → Acc _<_ x → WFRec _<_ (Acc _<_) x - access (acc r) = r + access : ∀{x} → Acc _<_ x → WFRec _<_ (Acc _<_) x + access (acc r) = r - private - wfi : ∀{ℓ''} {P : A → Type ℓ''} - → ∀ x → (wf : Acc _<_ x) - → (∀ x → (∀ y → y < x → P y) → P x) - → P x - wfi x (acc p) e = e x λ y y<x → wfi y (p y y<x) e + private + wfi : ∀{ℓ''} {P : A → Type ℓ''} + → ∀ x → (wf : Acc _<_ x) + → (∀ x → (∀ y → y < x → P y) → P x) + → P x + wfi x (acc p) e = e x λ y y<x → wfi y (p y y<x) e - module WFI (wf : WellFounded _<_) where - module _ {ℓ''} {P : A → Type ℓ''} (e : ∀ x → (∀ y → y < x → P y) → P x) where - private - wfi-compute : ∀ x ax → wfi x ax e ≡ e x (λ y _ → wfi y (wf y) e) - wfi-compute x (acc p) - = λ i → e x (λ y y<x → wfi y (isPropAcc y (p y y<x) (wf y) i) e) + module WFI (wf : WellFounded _<_) where + module _ {ℓ''} {P : A → Type ℓ''} (e : ∀ x → (∀ y → y < x → P y) → P x) where + private + wfi-compute : ∀ x ax → wfi x ax e ≡ e x (λ y _ → wfi y (wf y) e) + wfi-compute x (acc p) + = λ i → e x (λ y y<x → wfi y (isPropAcc y (p y y<x) (wf y) i) e) - induction : ∀ x → P x - induction x = wfi x (wf x) e + induction : ∀ x → P x + induction x = wfi x (wf x) e - induction-compute : ∀ x → induction x ≡ (e x λ y _ → induction y) - induction-compute x = wfi-compute x (wf x) + induction-compute : ∀ x → induction x ≡ (e x λ y _ → induction y) + induction-compute x = wfi-compute x (wf x) \ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Base.html b/docs/Cubical.Relation.Binary.Base.html index 3a9046b..81e028b 100644 --- a/docs/Cubical.Relation.Binary.Base.html +++ b/docs/Cubical.Relation.Binary.Base.html @@ -20,234 +20,245 @@ open import Cubical.Relation.Nullary.Base -private - variable - ℓA ℓ≅A ℓA' ℓ≅A' : Level +open import Cubical.Induction.WellFounded -Rel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -Rel A B ℓ' = A → B → Type ℓ' +private + variable + ℓA ℓ≅A ℓA' ℓ≅A' : Level -PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b) +Rel : ∀ {ℓa ℓb} (A : Type ℓa) (B : Type ℓb) (ℓ' : Level) → Type (ℓ-max (ℓ-max ℓa ℓb) (ℓ-suc ℓ')) +Rel A B ℓ' = A → B → Type ℓ' -idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ -idPropRel A .fst a a' = ∥ a ≡ a' ∥₁ -idPropRel A .snd _ _ = squash₁ +PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b) -invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ} - → PropRel A B ℓ' → PropRel B A ℓ' -invPropRel R .fst b a = R .fst a b -invPropRel R .snd b a = R .snd a b +idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ +idPropRel A .fst a a' = ∥ a ≡ a' ∥₁ +idPropRel A .snd _ _ = squash₁ -compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ} - → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) -compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥₁ -compPropRel R S .snd _ _ = squash₁ +invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ} + → PropRel A B ℓ' → PropRel B A ℓ' +invPropRel R .fst b a = R .fst a b +invPropRel R .snd b a = R .snd a b -graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ -graphRel f a b = f a ≡ b +compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ} + → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) +compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥₁ +compPropRel R S .snd _ _ = squash₁ -module HeterogenousRelation {ℓ ℓ' : Level} {A B : Type ℓ} (R : Rel A B ℓ') where - isUniversalRel : Type (ℓ-max ℓ ℓ') - isUniversalRel = (a : A) (b : B) → R a b +graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ +graphRel f a b = f a ≡ b -module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where - isRefl : Type (ℓ-max ℓ ℓ') - isRefl = (a : A) → R a a +module HeterogenousRelation {ℓ ℓ' : Level} {A B : Type ℓ} (R : Rel A B ℓ') where + isUniversalRel : Type (ℓ-max ℓ ℓ') + isUniversalRel = (a : A) (b : B) → R a b - isIrrefl : Type (ℓ-max ℓ ℓ') - isIrrefl = (a : A) → ¬ R a a +module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where + isRefl : Type (ℓ-max ℓ ℓ') + isRefl = (a : A) → R a a - isSym : Type (ℓ-max ℓ ℓ') - isSym = (a b : A) → R a b → R b a + isRefl' : Type (ℓ-max ℓ ℓ') + isRefl' = {a : A} → R a a - isAsym : Type (ℓ-max ℓ ℓ') - isAsym = (a b : A) → R a b → ¬ R b a + isIrrefl : Type (ℓ-max ℓ ℓ') + isIrrefl = (a : A) → ¬ R a a - isAntisym : Type (ℓ-max ℓ ℓ') - isAntisym = (a b : A) → R a b → R b a → a ≡ b + isSym : Type (ℓ-max ℓ ℓ') + isSym = (a b : A) → R a b → R b a - isTrans : Type (ℓ-max ℓ ℓ') - isTrans = (a b c : A) → R a b → R b c → R a c + isAsym : Type (ℓ-max ℓ ℓ') + isAsym = (a b : A) → R a b → ¬ R b a - -- Sum types don't play nicely with props, so we truncate - isCotrans : Type (ℓ-max ℓ ℓ') - isCotrans = (a b c : A) → R a b → (R a c ⊔′ R b c) + isAntisym : Type (ℓ-max ℓ ℓ') + isAntisym = (a b : A) → R a b → R b a → a ≡ b - isWeaklyLinear : Type (ℓ-max ℓ ℓ') - isWeaklyLinear = (a b c : A) → R a b → R a c ⊔′ R c b + isTrans : Type (ℓ-max ℓ ℓ') + isTrans = (a b c : A) → R a b → R b c → R a c - isConnected : Type (ℓ-max ℓ ℓ') - isConnected = (a b : A) → ¬ (a ≡ b) → R a b ⊔′ R b a + isTrans' : Type (ℓ-max ℓ ℓ') + isTrans' = {a b c : A} → R a b → R b c → R a c - isStronglyConnected : Type (ℓ-max ℓ ℓ') - isStronglyConnected = (a b : A) → R a b ⊔′ R b a + -- Sum types don't play nicely with props, so we truncate + isCotrans : Type (ℓ-max ℓ ℓ') + isCotrans = (a b c : A) → R a b → (R a c ⊔′ R b c) - isStronglyConnected→isConnected : isStronglyConnected → isConnected - isStronglyConnected→isConnected strong a b _ = strong a b + isWeaklyLinear : Type (ℓ-max ℓ ℓ') + isWeaklyLinear = (a b c : A) → R a b → R a c ⊔′ R c b - isIrrefl×isTrans→isAsym : isIrrefl × isTrans → isAsym - isIrrefl×isTrans→isAsym (irrefl , trans) a₀ a₁ Ra₀a₁ Ra₁a₀ - = irrefl a₀ (trans a₀ a₁ a₀ Ra₀a₁ Ra₁a₀) + isConnected : Type (ℓ-max ℓ ℓ') + isConnected = (a b : A) → ¬ (a ≡ b) → R a b ⊔′ R b a - IrreflKernel : Rel A A (ℓ-max ℓ ℓ') - IrreflKernel a b = R a b × (¬ a ≡ b) + isStronglyConnected : Type (ℓ-max ℓ ℓ') + isStronglyConnected = (a b : A) → R a b ⊔′ R b a - ReflClosure : Rel A A (ℓ-max ℓ ℓ') - ReflClosure a b = R a b ⊎ (a ≡ b) + isStronglyConnected→isConnected : isStronglyConnected → isConnected + isStronglyConnected→isConnected strong a b _ = strong a b - SymKernel : Rel A A ℓ' - SymKernel a b = R a b × R b a + isIrrefl×isTrans→isAsym : isIrrefl × isTrans → isAsym + isIrrefl×isTrans→isAsym (irrefl , trans) a₀ a₁ Ra₀a₁ Ra₁a₀ + = irrefl a₀ (trans a₀ a₁ a₀ Ra₀a₁ Ra₁a₀) - SymClosure : Rel A A ℓ' - SymClosure a b = R a b ⊎ R b a + WellFounded→isIrrefl : WellFounded R → isIrrefl + WellFounded→isIrrefl well = WFI.induction well λ a f Raa → f a Raa Raa - AsymKernel : Rel A A ℓ' - AsymKernel a b = R a b × (¬ R b a) + IrreflKernel : Rel A A (ℓ-max ℓ ℓ') + IrreflKernel a b = R a b × (¬ a ≡ b) - NegationRel : Rel A A ℓ' - NegationRel a b = ¬ (R a b) + ReflClosure : Rel A A (ℓ-max ℓ ℓ') + ReflClosure a b = R a b ⊎ (a ≡ b) - module _ - {ℓ'' : Level} - (P : Embedding A ℓ'') + SymKernel : Rel A A ℓ' + SymKernel a b = R a b × R b a - where + SymClosure : Rel A A ℓ' + SymClosure a b = R a b ⊎ R b a - private - subtype : Type ℓ'' - subtype = (fst P) + AsymKernel : Rel A A ℓ' + AsymKernel a b = R a b × (¬ R b a) - toA : subtype → A - toA = fst (snd P) + NegationRel : Rel A A ℓ' + NegationRel a b = ¬ (R a b) - InducedRelation : Rel subtype subtype ℓ' - InducedRelation a b = R (toA a) (toA b) + module _ + {ℓ'' : Level} + (P : Embedding A ℓ'') - record isEquivRel : Type (ℓ-max ℓ ℓ') where - constructor equivRel - field - reflexive : isRefl - symmetric : isSym - transitive : isTrans - - isUniversalRel→isEquivRel : HeterogenousRelation.isUniversalRel R → isEquivRel - isUniversalRel→isEquivRel u .isEquivRel.reflexive a = u a a - isUniversalRel→isEquivRel u .isEquivRel.symmetric a b _ = u b a - isUniversalRel→isEquivRel u .isEquivRel.transitive a _ c _ _ = u a c - - isPropValued : Type (ℓ-max ℓ ℓ') - isPropValued = (a b : A) → isProp (R a b) - - isSetValued : Type (ℓ-max ℓ ℓ') - isSetValued = (a b : A) → isSet (R a b) - - isEffective : Type (ℓ-max ℓ ℓ') - isEffective = - (a b : A) → isEquiv (eq/ {R = R} a b) - - - impliesIdentity : Type _ - impliesIdentity = {a a' : A} → (R a a') → (a ≡ a') - - inequalityImplies : Type _ - inequalityImplies = (a b : A) → ¬ a ≡ b → R a b - - -- the total space corresponding to the binary relation w.r.t. a - relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ') - relSinglAt a = Σ[ a' ∈ A ] (R a a') - - -- the statement that the total space is contractible at any a - contrRelSingl : Type (ℓ-max ℓ ℓ') - contrRelSingl = (a : A) → isContr (relSinglAt a) - - isUnivalent : Type (ℓ-max ℓ ℓ') - isUnivalent = (a a' : A) → (R a a') ≃ (a ≡ a') - - contrRelSingl→isUnivalent : isRefl → contrRelSingl → isUnivalent - contrRelSingl→isUnivalent ρ c a a' = isoToEquiv i - where - h : isProp (relSinglAt a) - h = isContr→isProp (c a) - aρa : relSinglAt a - aρa = a , ρ a - Q : (y : A) → a ≡ y → _ - Q y _ = R a y - i : Iso (R a a') (a ≡ a') - Iso.fun i r = cong fst (h aρa (a' , r)) - Iso.inv i = J Q (ρ a) - Iso.rightInv i = J (λ y p → cong fst (h aρa (y , J Q (ρ a) p)) ≡ p) - (J (λ q _ → cong fst (h aρa (a , q)) ≡ refl) - (J (λ α _ → cong fst α ≡ refl) refl - (isProp→isSet h _ _ refl (h _ _))) - (sym (JRefl Q (ρ a)))) - Iso.leftInv i r = J (λ w β → J Q (ρ a) (cong fst β) ≡ snd w) - (JRefl Q (ρ a)) (h aρa (a' , r)) - - isUnivalent→contrRelSingl : isUnivalent → contrRelSingl - isUnivalent→contrRelSingl u a = q - where - abstract - f : (x : A) → a ≡ x → R a x - f x p = invEq (u a x) p - - t : singl a → relSinglAt a - t (x , p) = x , f x p - - q : isContr (relSinglAt a) - q = isOfHLevelRespectEquiv 0 (t , totalEquiv _ _ f λ x → invEquiv (u a x) .snd) - (isContrSingl a) - -EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -EquivRel A ℓ' = Σ[ R ∈ Rel A A ℓ' ] BinaryRelation.isEquivRel R - -EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) -EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] BinaryRelation.isEquivRel (R .fst) - -record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A) - {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where - constructor reliso - field - fun : A → A' - inv : A' → A - rightInv : (a' : A') → fun (inv a') ≅' a' - leftInv : (a : A) → inv (fun a) ≅ a - -open BinaryRelation - -RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'} - (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A') - (uni : impliesIdentity _≅_) (uni' : impliesIdentity _≅'_) - (f : RelIso _≅_ _≅'_) - → Iso A A' -Iso.fun (RelIso→Iso _ _ _ _ f) = RelIso.fun f -Iso.inv (RelIso→Iso _ _ _ _ f) = RelIso.inv f -Iso.rightInv (RelIso→Iso _ _ uni uni' f) a' - = uni' (RelIso.rightInv f a') -Iso.leftInv (RelIso→Iso _ _ uni uni' f) a - = uni (RelIso.leftInv f a) - -isIrreflIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isIrrefl (IrreflKernel R) -isIrreflIrreflKernel _ _ (_ , ¬a≡a) = ¬a≡a refl - -isReflReflClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isRefl (ReflClosure R) -isReflReflClosure _ _ = inr refl - -isConnectedStronglyConnectedIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') - → isStronglyConnected R - → isConnected (IrreflKernel R) -isConnectedStronglyConnectedIrreflKernel R strong a b ¬a≡b - = ∥₁.map (λ x → ⊎.rec (λ Rab → inl (Rab , ¬a≡b)) - (λ Rba → inr (Rba , (λ b≡a → ¬a≡b (sym b≡a)))) x) - (strong a b) - -isSymSymKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymKernel R) -isSymSymKernel _ _ _ (Rab , Rba) = Rba , Rab - -isSymSymClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymClosure R) -isSymSymClosure _ _ _ (inl Rab) = inr Rab -isSymSymClosure _ _ _ (inr Rba) = inl Rba - -isAsymAsymKernel : ∀ {ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isAsym (AsymKernel R) -isAsymAsymKernel _ _ _ (Rab , _) (_ , ¬Rab) = ¬Rab Rab + where + + private + subtype : Type ℓ'' + subtype = (fst P) + + toA : subtype → A + toA = fst (snd P) + + InducedRelation : Rel subtype subtype ℓ' + InducedRelation a b = R (toA a) (toA b) + + record isEquivRel : Type (ℓ-max ℓ ℓ') where + constructor equivRel + field + reflexive : isRefl + symmetric : isSym + transitive : isTrans + + isUniversalRel→isEquivRel : HeterogenousRelation.isUniversalRel R → isEquivRel + isUniversalRel→isEquivRel u .isEquivRel.reflexive a = u a a + isUniversalRel→isEquivRel u .isEquivRel.symmetric a b _ = u b a + isUniversalRel→isEquivRel u .isEquivRel.transitive a _ c _ _ = u a c + + isPropValued : Type (ℓ-max ℓ ℓ') + isPropValued = (a b : A) → isProp (R a b) + + isSetValued : Type (ℓ-max ℓ ℓ') + isSetValued = (a b : A) → isSet (R a b) + + isEffective : Type (ℓ-max ℓ ℓ') + isEffective = + (a b : A) → isEquiv (eq/ {R = R} a b) + + + impliesIdentity : Type _ + impliesIdentity = {a a' : A} → (R a a') → (a ≡ a') + + inequalityImplies : Type _ + inequalityImplies = (a b : A) → ¬ a ≡ b → R a b + + -- the total space corresponding to the binary relation w.r.t. a + relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ') + relSinglAt a = Σ[ a' ∈ A ] (R a a') + + -- the statement that the total space is contractible at any a + contrRelSingl : Type (ℓ-max ℓ ℓ') + contrRelSingl = (a : A) → isContr (relSinglAt a) + + isUnivalent : Type (ℓ-max ℓ ℓ') + isUnivalent = (a a' : A) → (R a a') ≃ (a ≡ a') + + contrRelSingl→isUnivalent : isRefl → contrRelSingl → isUnivalent + contrRelSingl→isUnivalent ρ c a a' = isoToEquiv i + where + h : isProp (relSinglAt a) + h = isContr→isProp (c a) + aρa : relSinglAt a + aρa = a , ρ a + Q : (y : A) → a ≡ y → _ + Q y _ = R a y + i : Iso (R a a') (a ≡ a') + Iso.fun i r = cong fst (h aρa (a' , r)) + Iso.inv i = J Q (ρ a) + Iso.rightInv i = J (λ y p → cong fst (h aρa (y , J Q (ρ a) p)) ≡ p) + (J (λ q _ → cong fst (h aρa (a , q)) ≡ refl) + (J (λ α _ → cong fst α ≡ refl) refl + (isProp→isSet h _ _ refl (h _ _))) + (sym (JRefl Q (ρ a)))) + Iso.leftInv i r = J (λ w β → J Q (ρ a) (cong fst β) ≡ snd w) + (JRefl Q (ρ a)) (h aρa (a' , r)) + + isUnivalent→contrRelSingl : isUnivalent → contrRelSingl + isUnivalent→contrRelSingl u a = q + where + abstract + f : (x : A) → a ≡ x → R a x + f x p = invEq (u a x) p + + t : singl a → relSinglAt a + t (x , p) = x , f x p + + q : isContr (relSinglAt a) + q = isOfHLevelRespectEquiv 0 (t , totalEquiv _ _ f λ x → invEquiv (u a x) .snd) + (isContrSingl a) + +EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +EquivRel A ℓ' = Σ[ R ∈ Rel A A ℓ' ] BinaryRelation.isEquivRel R + +EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) +EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] BinaryRelation.isEquivRel (R .fst) + +record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A) + {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where + constructor reliso + field + fun : A → A' + inv : A' → A + rightInv : (a' : A') → fun (inv a') ≅' a' + leftInv : (a : A) → inv (fun a) ≅ a + +open BinaryRelation + +RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'} + (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A') + (uni : impliesIdentity _≅_) (uni' : impliesIdentity _≅'_) + (f : RelIso _≅_ _≅'_) + → Iso A A' +Iso.fun (RelIso→Iso _ _ _ _ f) = RelIso.fun f +Iso.inv (RelIso→Iso _ _ _ _ f) = RelIso.inv f +Iso.rightInv (RelIso→Iso _ _ uni uni' f) a' + = uni' (RelIso.rightInv f a') +Iso.leftInv (RelIso→Iso _ _ uni uni' f) a + = uni (RelIso.leftInv f a) + +isIrreflIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isIrrefl (IrreflKernel R) +isIrreflIrreflKernel _ _ (_ , ¬a≡a) = ¬a≡a refl + +isReflReflClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isRefl (ReflClosure R) +isReflReflClosure _ _ = inr refl + +isConnectedStronglyConnectedIrreflKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') + → isStronglyConnected R + → isConnected (IrreflKernel R) +isConnectedStronglyConnectedIrreflKernel R strong a b ¬a≡b + = ∥₁.map (λ x → ⊎.rec (λ Rab → inl (Rab , ¬a≡b)) + (λ Rba → inr (Rba , (λ b≡a → ¬a≡b (sym b≡a)))) x) + (strong a b) + +isSymSymKernel : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymKernel R) +isSymSymKernel _ _ _ (Rab , Rba) = Rba , Rab + +isSymSymClosure : ∀{ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isSym (SymClosure R) +isSymSymClosure _ _ _ (inl Rab) = inr Rab +isSymSymClosure _ _ _ (inr Rba) = inl Rba + +isAsymAsymKernel : ∀ {ℓ ℓ'} {A : Type ℓ} (R : Rel A A ℓ') → isAsym (AsymKernel R) +isAsymAsymKernel _ _ _ (Rab , _) (_ , ¬Rab) = ¬Rab Rab \ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.Preorder.Base.html b/docs/Cubical.Relation.Binary.Order.Preorder.Base.html index acb6986..7d75a3e 100644 --- a/docs/Cubical.Relation.Binary.Order.Preorder.Base.html +++ b/docs/Cubical.Relation.Binary.Order.Preorder.Base.html @@ -23,7 +23,7 @@ open import Cubical.Relation.Binary.Base open Iso -open BinaryRelation +open BinaryRelation private @@ -35,10 +35,10 @@ constructor ispreorder field - is-set : isSet A - is-prop-valued : isPropValued _≲_ - is-refl : isRefl _≲_ - is-trans : isTrans _≲_ + is-set : isSet A + is-prop-valued : isPropValued _≲_ + is-refl : isRefl _≲_ + is-trans : isTrans _≲_ unquoteDecl IsPreorderIsoΣ = declareRecordIsoΣ IsPreorderIsoΣ (quote IsPreorder) @@ -79,10 +79,10 @@ PreorderEquiv : (M : Preorder ℓ₀ ℓ₀') (M : Preorder ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁')) PreorderEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsPreorderEquiv (M .snd) e (N .snd) -isPropIsPreorder : {A : Type ℓ} (_≲_ : A → A → Type ℓ') → isProp (IsPreorder _≲_) +isPropIsPreorder : {A : Type ℓ} (_≲_ : A → A → Type ℓ') → isProp (IsPreorder _≲_) isPropIsPreorder _≲_ = isOfHLevelRetractFromIso 1 IsPreorderIsoΣ (isPropΣ isPropIsSet - λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp)) + λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp)) λ isPropValued≲ → isProp× (isPropΠ (λ _ → isPropValued≲ _ _)) (isPropΠ4 λ _ _ _ _ → isPropΠ λ _ → isPropValued≲ _ _)) @@ -108,17 +108,17 @@ module S = PreorderStr (S .snd) module _ (isMon : ∀ x y → x P.≲ y → equivFun e x S.≲ equivFun e y) - (isMonInv : ∀ x y → x S.≲ y → invEq e x P.≲ invEq e y) where + (isMonInv : ∀ x y → x S.≲ y → invEq e x P.≲ invEq e y) where open IsPreorderEquiv open IsPreorder makeIsPreorderEquiv : IsPreorderEquiv (P .snd) e (S .snd) - pres≲ makeIsPreorderEquiv x y = propBiimpl→Equiv (P.isPreorder .is-prop-valued _ _) + pres≲ makeIsPreorderEquiv x y = propBiimpl→Equiv (P.isPreorder .is-prop-valued _ _) (S.isPreorder .is-prop-valued _ _) (isMon _ _) (isMonInv' _ _) where isMonInv' : ∀ x y → equivFun e x S.≲ equivFun e y → x P.≲ y - isMonInv' x y ex≲ey = transport (λ i → retEq e x i P.≲ retEq e y i) (isMonInv _ _ ex≲ey) + isMonInv' x y ex≲ey = transport (λ i → retEq e x i P.≲ retEq e y i) (isMonInv _ _ ex≲ey) module PreorderReasoning (P' : Preorder ℓ ℓ') where diff --git a/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html b/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html index 8f4d35a..d2ae906 100644 --- a/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html +++ b/docs/Cubical.Relation.Binary.Order.Preorder.Properties.html @@ -21,21 +21,21 @@ module _ {A : Type ℓ} - {R : Rel A A ℓ'} + {R : Rel A A ℓ'} where - open BinaryRelation + open BinaryRelation - isPreorder→isEquivRelSymKernel : IsPreorder R → isEquivRel (SymKernel R) + isPreorder→isEquivRelSymKernel : IsPreorder R → isEquivRel (SymKernel R) isPreorder→isEquivRelSymKernel preorder - = equivRel (λ a → (IsPreorder.is-refl preorder a) + = equivRel (λ a → (IsPreorder.is-refl preorder a) , (IsPreorder.is-refl preorder a)) - (isSymSymKernel R) + (isSymSymKernel R) (λ a b c (Rab , Rba) (Rbc , Rcb) → IsPreorder.is-trans preorder a b c Rab Rbc , IsPreorder.is-trans preorder c b a Rcb Rba) - isPreorder→isStrictPosetAsymKernel : IsPreorder R → IsStrictPoset (AsymKernel R) + isPreorder→isStrictPosetAsymKernel : IsPreorder R → IsStrictPoset (AsymKernel R) isPreorder→isStrictPosetAsymKernel preorder = isstrictposet (IsPreorder.is-set preorder) (λ a b → isProp× (IsPreorder.is-prop-valued preorder a b) (isProp¬ (R b a))) @@ -43,9 +43,9 @@ (λ a b c (Rab , ¬Rba) (Rbc , ¬Rcb) → IsPreorder.is-trans preorder a b c Rab Rbc , λ Rca → ¬Rcb (IsPreorder.is-trans preorder c a b Rca Rab)) - (isAsymAsymKernel R) + (isAsymAsymKernel R) - isPreorderInduced : IsPreorder R → (B : Type ℓ'') → (f : B ↪ A) → IsPreorder (InducedRelation R (B , f)) + isPreorderInduced : IsPreorder R → (B : Type ℓ'') → (f : B ↪ A) → IsPreorder (InducedRelation R (B , f)) isPreorderInduced pre B (f , emb) = ispreorder (Embedding-into-isSet→isSet (f , emb) (IsPreorder.is-set pre)) (λ a b → IsPreorder.is-prop-valued pre (f a) (f b)) @@ -54,6 +54,6 @@ Preorder→StrictPoset : Preorder ℓ ℓ' → StrictPoset ℓ ℓ' Preorder→StrictPoset (_ , pre) - = _ , strictposetstr (BinaryRelation.AsymKernel (PreorderStr._≲_ pre)) + = _ , strictposetstr (BinaryRelation.AsymKernel (PreorderStr._≲_ pre)) (isPreorder→isStrictPosetAsymKernel (PreorderStr.isPreorder pre)) \ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html b/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html index 253f67c..bc67a99 100644 --- a/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html +++ b/docs/Cubical.Relation.Binary.Order.StrictPoset.Base.html @@ -28,7 +28,7 @@ open import Cubical.Relation.Nullary.Properties open Iso -open BinaryRelation +open BinaryRelation private @@ -40,11 +40,11 @@ constructor isstrictposet field - is-set : isSet A - is-prop-valued : isPropValued _<_ - is-irrefl : isIrrefl _<_ - is-trans : isTrans _<_ - is-asym : isAsym _<_ + is-set : isSet A + is-prop-valued : isPropValued _<_ + is-irrefl : isIrrefl _<_ + is-trans : isTrans _<_ + is-asym : isAsym _<_ unquoteDecl IsStrictPosetIsoΣ = declareRecordIsoΣ IsStrictPosetIsoΣ (quote IsStrictPoset) @@ -85,10 +85,10 @@ StrictPosetEquiv : (M : StrictPoset ℓ₀ ℓ₀') (M : StrictPoset ℓ₁ ℓ₁') → Type (ℓ-max (ℓ-max ℓ₀ ℓ₀') (ℓ-max ℓ₁ ℓ₁')) StrictPosetEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsStrictPosetEquiv (M .snd) e (N .snd) -isPropIsStrictPoset : {A : Type ℓ} (_<_ : A → A → Type ℓ') → isProp (IsStrictPoset _<_) +isPropIsStrictPoset : {A : Type ℓ} (_<_ : A → A → Type ℓ') → isProp (IsStrictPoset _<_) isPropIsStrictPoset _<_ = isOfHLevelRetractFromIso 1 IsStrictPosetIsoΣ (isPropΣ isPropIsSet - λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp)) + λ isSetA → isPropΣ (isPropΠ2 (λ _ _ → isPropIsProp)) λ isPropValued< → isProp×2 (isPropΠ (λ x → isProp¬ (x < x))) (isPropΠ5 (λ _ _ _ _ _ → isPropValued< _ _)) (isPropΠ3 λ x y _ → isProp¬ (y < x))) @@ -114,15 +114,15 @@ module S = StrictPosetStr (S .snd) module _ (isMon : ∀ x y → x P.< y → equivFun e x S.< equivFun e y) - (isMonInv : ∀ x y → x S.< y → invEq e x P.< invEq e y) where + (isMonInv : ∀ x y → x S.< y → invEq e x P.< invEq e y) where open IsStrictPosetEquiv open IsStrictPoset makeIsStrictPosetEquiv : IsStrictPosetEquiv (P .snd) e (S .snd) - pres< makeIsStrictPosetEquiv x y = propBiimpl→Equiv (P.isStrictPoset .is-prop-valued _ _) + pres< makeIsStrictPosetEquiv x y = propBiimpl→Equiv (P.isStrictPoset .is-prop-valued _ _) (S.isStrictPoset .is-prop-valued _ _) (isMon _ _) (isMonInv' _ _) where isMonInv' : ∀ x y → equivFun e x S.< equivFun e y → x P.< y - isMonInv' x y ex<ey = transport (λ i → retEq e x i P.< retEq e y i) (isMonInv _ _ ex<ey) + isMonInv' x y ex<ey = transport (λ i → retEq e x i P.< retEq e y i) (isMonInv _ _ ex<ey) \ No newline at end of file diff --git a/docs/Cubical.Relation.Binary.Properties.html b/docs/Cubical.Relation.Binary.Properties.html index 1a12a37..bae0642 100644 --- a/docs/Cubical.Relation.Binary.Properties.html +++ b/docs/Cubical.Relation.Binary.Properties.html @@ -3,41 +3,78 @@ module Cubical.Relation.Binary.Properties where open import Cubical.Foundations.Prelude -open import Cubical.Relation.Binary.Base +open import Cubical.Foundations.Equiv +open import Cubical.Foundations.Univalence +open import Cubical.Foundations.Function +open import Cubical.Foundations.HLevels +open import Cubical.Functions.FunExtEquiv -private - variable - ℓ : Level - A B : Type ℓ +open import Cubical.Data.Sigma +open import Cubical.Relation.Binary.Base --- Pulling back a relation along a function. --- This can for example be used when restricting an equivalence relation to a subset: --- _~'_ = on fst _~_ +private + variable + ℓ ℓ' : Level + A B : Type ℓ -module _ - (f : A → B) - (R : Rel B B ℓ) - where - open BinaryRelation +-- Pulling back a relation along a function. +-- This can for example be used when restricting an equivalence relation to a subset: +-- _~'_ = on fst _~_ - pulledbackRel : Rel A A ℓ - pulledbackRel x y = R (f x) (f y) +module _ + (f : A → B) + (R : Rel B B ℓ) + where - isReflPulledbackRel : isRefl R → isRefl pulledbackRel - isReflPulledbackRel isReflR a = isReflR (f a) + open BinaryRelation - isSymPulledbackRel : isSym R → isSym pulledbackRel - isSymPulledbackRel isSymR a a' = isSymR (f a) (f a') + pulledbackRel : Rel A A ℓ + pulledbackRel x y = R (f x) (f y) - isTransPulledbackRel : isTrans R → isTrans pulledbackRel - isTransPulledbackRel isTransR a a' a'' = isTransR (f a) (f a') (f a'') + isReflPulledbackRel : isRefl R → isRefl pulledbackRel + isReflPulledbackRel isReflR a = isReflR (f a) - open isEquivRel + isSymPulledbackRel : isSym R → isSym pulledbackRel + isSymPulledbackRel isSymR a a' = isSymR (f a) (f a') - isEquivRelPulledbackRel : isEquivRel R → isEquivRel pulledbackRel - reflexive (isEquivRelPulledbackRel isEquivRelR) = isReflPulledbackRel (reflexive isEquivRelR) - symmetric (isEquivRelPulledbackRel isEquivRelR) = isSymPulledbackRel (symmetric isEquivRelR) - transitive (isEquivRelPulledbackRel isEquivRelR) = isTransPulledbackRel (transitive isEquivRelR) + isTransPulledbackRel : isTrans R → isTrans pulledbackRel + isTransPulledbackRel isTransR a a' a'' = isTransR (f a) (f a') (f a'') + + open isEquivRel + + isEquivRelPulledbackRel : isEquivRel R → isEquivRel pulledbackRel + reflexive (isEquivRelPulledbackRel isEquivRelR) = isReflPulledbackRel (reflexive isEquivRelR) + symmetric (isEquivRelPulledbackRel isEquivRelR) = isSymPulledbackRel (symmetric isEquivRelR) + transitive (isEquivRelPulledbackRel isEquivRelR) = isTransPulledbackRel (transitive isEquivRelR) + +module _ {A B : Type ℓ} (e : A ≃ B) {_∼_ : Rel A A ℓ'} {_∻_ : Rel B B ℓ'} + (_h_ : ∀ x y → (x ∼ y) ≃ ((fst e x) ∻ (fst e y))) where + + RelPathP : PathP (λ i → ua e i → ua e i → Type _) + _∼_ _∻_ + RelPathP i x y = Glue (ua-unglue e i x ∻ ua-unglue e i y) + λ { (i = i0) → _ , x h y + ; (i = i1) → _ , idEquiv _ } + + +module _ {ℓ''} {B : Type ℓ} {_∻_ : B → B → Type ℓ'} where + + JRelPathP-Goal : Type _ + JRelPathP-Goal = ∀ (A : Type ℓ) (e : A ≃ B) (_~_ : A → A → Type ℓ') + → (_h_ : ∀ x y → x ~ y ≃ (fst e x ∻ fst e y)) → Type ℓ'' + + + EquivJRel : (Goal : JRelPathP-Goal) + → (Goal _ (idEquiv _) _∻_ λ _ _ → idEquiv _ ) + → ∀ {A} e _~_ _h_ → Goal A e _~_ _h_ + EquivJRel Goal g {A} = EquivJ (λ A e → ∀ _~_ _h_ → Goal A e _~_ _h_) + λ _~_ _h_ → subst (uncurry (Goal B (idEquiv B))) + ((isPropRetract + (map-snd (λ r → funExt₂ λ x y → sym (ua (r x y)))) + (map-snd (λ r x y → pathToEquiv λ i → r (~ i) x y)) + (λ (o , r) → cong (o ,_) (funExt₂ λ x y → equivEq + (funExt λ _ → transportRefl _))) + (isPropSingl {a = _∻_})) _ _) g \ No newline at end of file diff --git a/docs/Cubical.Relation.Nullary.Base.html b/docs/Cubical.Relation.Nullary.Base.html index 8269c7f..c30a1e8 100644 --- a/docs/Cubical.Relation.Nullary.Base.html +++ b/docs/Cubical.Relation.Nullary.Base.html @@ -43,7 +43,7 @@ SplitSupport A = ∥ A ∥₁ → A Collapsible : Type ℓ → Type ℓ -Collapsible A = Σ[ f ∈ (A → A) ] 2-Constant f +Collapsible A = Σ[ f ∈ (A → A) ] 2-Constant f Populated ⟪_⟫ : Type ℓ → Type ℓ Populated A = (f : Collapsible A) → Fixpoint (f .fst) diff --git a/docs/Cubical.Relation.Nullary.Properties.html b/docs/Cubical.Relation.Nullary.Properties.html index 92d349f..8592ac0 100644 --- a/docs/Cubical.Relation.Nullary.Properties.html +++ b/docs/Cubical.Relation.Nullary.Properties.html @@ -41,9 +41,9 @@ EquivPresDiscrete : ∀ {ℓ ℓ'}{A : Type ℓ} {B : Type ℓ'} → A ≃ B → Discrete A → Discrete B -EquivPresDiscrete e = isoPresDiscrete (equivToIso e) +EquivPresDiscrete e = isoPresDiscrete (equivToIso e) -isProp¬ : (A : Type ℓ) → isProp (¬ A) +isProp¬ : (A : Type ℓ) → isProp (¬ A) isProp¬ A p q i x = isProp⊥ (p x) (q x) i Stable¬ : Stable (¬ A) @@ -76,7 +76,7 @@ discreteDec Adis (no ¬p) (yes p) = ⊥.rec (¬p p) discreteDec {A = A} Adis (no ¬p) (no ¬p') = yes (cong no (isProp¬ A ¬p ¬p')) -isPropDec : (Aprop : isProp A) → isProp (Dec A) +isPropDec : (Aprop : isProp A) → isProp (Dec A) isPropDec Aprop (yes a) (yes a') = cong yes (Aprop a a') isPropDec Aprop (yes a) (no ¬a) = ⊥.rec (¬a a) isPropDec Aprop (no ¬a) (yes a) = ⊥.rec (¬a a) @@ -88,7 +88,7 @@ EquivPresDec : ∀ {ℓ ℓ'}{A : Type ℓ} {B : Type ℓ'} → A ≃ B → Dec A → Dec B -EquivPresDec p = mapDec (p .fst) (λ f → f ∘ invEq p) +EquivPresDec p = mapDec (p .fst) (λ f → f ∘ invEq p) ¬→¬∥∥ : ¬ A → ¬ ∥ A ∥₁ ¬→¬∥∥ ¬p ∣ a ∣₁ = ¬p a @@ -135,7 +135,7 @@ SplitSupport→Collapsible {A = A} hst = h , hIsConst where h : A → A h p = hst ∣ p ∣₁ - hIsConst : 2-Constant h + hIsConst : 2-Constant h hIsConst p q i = hst (squash₁ ∣ p ∣₁ ∣ q ∣₁ i) Collapsible→SplitSupport : Collapsible A → SplitSupport A @@ -149,7 +149,7 @@ -- stability of path space under truncation or path collapsability are necessary and sufficient properties -- for a a type to be a set. -Collapsible≡→isSet : Collapsible≡ A → isSet A +Collapsible≡→isSet : Collapsible≡ A → isSet A Collapsible≡→isSet {A = A} col a b p q = p≡q where f : (x : A) → a ≡ x → a ≡ x f x = col a x .fst @@ -163,10 +163,10 @@ ; (j = i0) → rem p i k ; (j = i1) → rem q i k }) a -HSeparated→isSet : HSeparated A → isSet A +HSeparated→isSet : HSeparated A → isSet A HSeparated→isSet = Collapsible≡→isSet ∘ HSeparated→Collapsible≡ -isSet→HSeparated : isSet A → HSeparated A +isSet→HSeparated : isSet A → HSeparated A isSet→HSeparated setA x y = extract where extract : ∥ x ≡ y ∥₁ → x ≡ y extract ∣ p ∣₁ = p @@ -176,13 +176,13 @@ PStable≡→HSeparated : PStable≡ A → HSeparated A PStable≡→HSeparated pst x y = PStable→SplitSupport (pst x y) -PStable≡→isSet : PStable≡ A → isSet A +PStable≡→isSet : PStable≡ A → isSet A PStable≡→isSet = HSeparated→isSet ∘ PStable≡→HSeparated Separated→PStable≡ : Separated A → PStable≡ A Separated→PStable≡ st x y = Stable→PStable (st x y) -Separated→isSet : Separated A → isSet A +Separated→isSet : Separated A → isSet A Separated→isSet = PStable≡→isSet ∘ Separated→PStable≡ SeparatedΠ : (∀ x → Separated (P x)) -> Separated ((x : A) -> P x) @@ -200,6 +200,6 @@ Discrete→Separated : Discrete A → Separated A Discrete→Separated d x y = Dec→Stable (d x y) -Discrete→isSet : Discrete A → isSet A +Discrete→isSet : Discrete A → isSet A Discrete→isSet = Separated→isSet ∘ Discrete→Separated \ No newline at end of file diff --git a/docs/Cubical.Structures.Axioms.html b/docs/Cubical.Structures.Axioms.html index 2ec96dc..9b01e7c 100644 --- a/docs/Cubical.Structures.Axioms.html +++ b/docs/Cubical.Structures.Axioms.html @@ -36,18 +36,18 @@ axiomsUnivalentStr : {S : Type ℓ → Type ℓ₁} (ι : (A B : TypeWithStr ℓ S) → A .fst ≃ B .fst → Type ℓ₁') {axioms : (X : Type ℓ) → S X → Type ℓ₂} - (axioms-are-Props : (X : Type ℓ) (s : S X) → isProp (axioms X s)) + (axioms-are-Props : (X : Type ℓ) (s : S X) → isProp (axioms X s)) (θ : UnivalentStr S ι) → UnivalentStr (AxiomsStructure S axioms) (AxiomsEquivStr ι axioms) axiomsUnivalentStr {S = S} ι {axioms = axioms} axioms-are-Props θ {X , s , a} {Y , t , b} e = ι (X , s) (Y , t) e - ≃⟨ θ e ⟩ + ≃⟨ θ e ⟩ PathP (λ i → S (ua e i)) s t - ≃⟨ invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (axioms-are-Props _ _) _ _) ⟩ + ≃⟨ invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (axioms-are-Props _ _) _ _) ⟩ Σ[ p ∈ PathP (λ i → S (ua e i)) s t ] PathP (λ i → axioms (ua e i) (p i)) a b - ≃⟨ ΣPath≃PathΣ ⟩ + ≃⟨ ΣPath≃PathΣ ⟩ PathP (λ i → AxiomsStructure S axioms (ua e i)) (s , a) (t , b) - ■ + ■ inducedStructure : {S : Type ℓ → Type ℓ₁} {ι : (A B : TypeWithStr ℓ S) → A .fst ≃ B .fst → Type ℓ₁'} diff --git a/docs/Cubical.Structures.Pointed.html b/docs/Cubical.Structures.Pointed.html index e54549f..f1bf96d 100644 --- a/docs/Cubical.Structures.Pointed.html +++ b/docs/Cubical.Structures.Pointed.html @@ -28,7 +28,7 @@ PointedEquivStr A B f = equivFun f (pt A) ≡ pt B pointedUnivalentStr : UnivalentStr {ℓ} PointedStructure PointedEquivStr -pointedUnivalentStr f = invEquiv (ua-ungluePath-Equiv f) +pointedUnivalentStr f = invEquiv (ua-ungluePath-Equiv f) pointedSIP : (A B : Pointed ℓ) → A ≃[ PointedEquivStr ] B ≃ (A ≡ B) pointedSIP = SIP pointedUnivalentStr @@ -48,10 +48,10 @@ -} abstract pointed-sip⁻ : (A B : Pointed ℓ) → (A ≡ B) → A ≃[ PointedEquivStr ] B - pointed-sip⁻ A B = invEq (pointedSIP A B) + pointed-sip⁻ A B = invEq (pointedSIP A B) pointed-sip⁻-refl : (A : Pointed ℓ) → pointed-sip⁻ A A refl ≡ idEquiv∙ A - pointed-sip⁻-refl A = sym (invEq (equivAdjointEquiv (pointedSIP A A)) (pointed-sip-idEquiv∙ A)) + pointed-sip⁻-refl A = sym (invEq (equivAdjointEquiv (pointedSIP A A)) (pointed-sip-idEquiv∙ A)) pointedEquivAction : EquivAction {ℓ} PointedStructure pointedEquivAction e = e diff --git a/docs/Cubical.Tactics.NatSolver.EvalHom.html b/docs/Cubical.Tactics.NatSolver.EvalHom.html new file mode 100644 index 0000000..3956463 --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.EvalHom.html @@ -0,0 +1,198 @@ + +Cubical.Tactics.NatSolver.EvalHom
{-# OPTIONS --safe #-}
+module Cubical.Tactics.NatSolver.EvalHom where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.Nat
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+
+open import Cubical.Tactics.NatSolver.HornerForms
+
+private
+  variable
+    ℓ : Level
+
+module HomomorphismProperties where
+  open IteratedHornerOperations
+
+  evalHom+0 : {n : ℕ} (P : IteratedHornerForms n) (xs : Vec ℕ n)
+      → eval (0ₕ +ₕ P) xs ≡ eval P xs
+  evalHom+0 (const x) [] = refl
+  evalHom+0 _ (x ∷ xs) = refl
+
+  eval0H : {n : ℕ} (xs : Vec ℕ n)
+         → eval 0ₕ xs ≡ 0
+  eval0H [] = refl
+  eval0H (x ∷ xs) = refl
+
+  eval1ₕ : {n : ℕ} (xs : Vec ℕ n)
+         → eval 1ₕ xs ≡ 1
+  eval1ₕ [] = refl
+  eval1ₕ (x ∷ xs) =
+    eval 1ₕ (x ∷ xs)                             ≡⟨ refl ⟩
+    eval (0H ·X+ 1ₕ) (x ∷ xs)                    ≡⟨ refl ⟩
+    eval 0H (x ∷ xs) · x + eval 1ₕ xs            ≡⟨ cong (λ u → u · x + eval 1ₕ xs)
+                                                        (eval0H (x ∷ xs)) ⟩
+    0 · x + eval 1ₕ xs                           ≡⟨ cong (λ u → 0 · x + u)
+                                                        (eval1ₕ xs) ⟩
+    1 ∎
+
+
+  +ShufflePairs : (a b c d : ℕ)
+                → (a + b) + (c + d) ≡ (a + c) + (b + d)
+  +ShufflePairs a b c d =
+    (a + b) + (c + d) ≡⟨ +-assoc (a + b) c d ⟩
+    ((a + b) + c) + d ≡⟨ cong (λ u → u + d) (sym (+-assoc a b c)) ⟩
+    (a + (b + c)) + d ≡⟨ cong (λ u → (a + u) + d) (+-comm b c) ⟩
+    (a + (c + b)) + d ≡⟨ cong (λ u → u + d) (+-assoc a c b) ⟩
+    ((a + c) + b) + d ≡⟨ sym (+-assoc (a + c) b d) ⟩
+    (a + c) + (b + d) ∎
+
+  +Homeval :
+    {n : ℕ} (P Q : IteratedHornerForms n) (xs : Vec ℕ n)
+    → eval (P +ₕ Q) xs ≡ (eval P xs) + (eval Q xs)
+  +Homeval (const x) (const y) [] = refl
+  +Homeval 0H Q xs =
+    eval (0H +ₕ Q) xs            ≡⟨ refl ⟩
+    0 + eval Q xs               ≡⟨ cong (λ u → u + eval Q xs) (sym (eval0H xs)) ⟩
+    eval 0H xs + eval Q xs ∎
+  +Homeval (P ·X+ Q) 0H xs =
+    eval ((P ·X+ Q) +ₕ 0H) xs       ≡⟨ refl ⟩
+    eval (P ·X+ Q) xs              ≡⟨ sym (+-zero _) ⟩
+    eval (P ·X+ Q) xs + 0          ≡⟨ cong (λ u → eval (P ·X+ Q) xs + u)
+                                           (sym (eval0H xs)) ⟩
+    eval (P ·X+ Q) xs + eval 0H xs ∎
+  +Homeval (P ·X+ Q) (S ·X+ T) (x ∷ xs) =
+    eval ((P ·X+ Q) +ₕ (S ·X+ T)) (x ∷ xs)
+   ≡⟨ refl ⟩
+    eval ((P +ₕ S) ·X+ (Q +ₕ T)) (x ∷ xs)
+   ≡⟨ refl ⟩
+    (eval (P +ₕ S) (x ∷ xs)) · x + eval (Q +ₕ T) xs
+   ≡⟨ cong (λ u → (eval (P +ₕ S) (x ∷ xs)) · x + u) (+Homeval Q T xs) ⟩
+    (eval (P +ₕ S) (x ∷ xs)) · x + (eval Q xs + eval T xs)
+   ≡⟨ cong (λ u → u · x + (eval Q xs + eval T xs)) (+Homeval P S (x ∷ xs)) ⟩
+    (eval P (x ∷ xs) + eval S (x ∷ xs)) · x
+    + (eval Q xs + eval T xs)
+   ≡⟨ cong (λ u → u + (eval Q xs + eval T xs))
+     (sym (·-distribʳ (eval P (x ∷ xs)) (eval S (x ∷ xs)) x)) ⟩
+    (eval P (x ∷ xs)) · x + (eval S (x ∷ xs)) · x
+    + (eval Q xs + eval T xs)
+   ≡⟨ +ShufflePairs ((eval P (x ∷ xs)) · x) ((eval S (x ∷ xs)) · x) (eval Q xs) (eval T xs) ⟩
+    ((eval P (x ∷ xs)) · x + eval Q xs)
+    + ((eval S (x ∷ xs)) · x + eval T xs)
+   ∎
+
+  ⋆Homeval : {n : ℕ}
+             (r : IteratedHornerForms n)
+             (P : IteratedHornerForms (ℕ.suc n)) (x : ℕ) (xs : Vec ℕ n)
+           → eval (r ⋆ P) (x ∷ xs) ≡ eval r xs · eval P (x ∷ xs)
+
+
+  ⋆0LeftAnnihilates :
+    {n : ℕ} (P : IteratedHornerForms (ℕ.suc n)) (xs : Vec ℕ (ℕ.suc n))
+    → eval (0ₕ ⋆ P) xs ≡ 0
+
+  ·Homeval : {n : ℕ} (P Q : IteratedHornerForms n) (xs : Vec ℕ n)
+    → eval (P ·ₕ Q) xs ≡ (eval P xs) · (eval Q xs)
+
+  ⋆0LeftAnnihilates 0H xs = eval0H xs
+  ⋆0LeftAnnihilates (P ·X+ Q) (x ∷ xs) =
+      eval (0ₕ ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
+      eval ((0ₕ ⋆ P) ·X+ (0ₕ ·ₕ Q)) (x ∷ xs)             ≡⟨ refl ⟩
+      (eval (0ₕ ⋆ P) (x ∷ xs)) · x + eval (0ₕ ·ₕ Q) xs
+    ≡⟨ cong (λ u → (u · x) + eval (0ₕ ·ₕ Q) _) (⋆0LeftAnnihilates P (x ∷ xs)) ⟩
+      0 · x + eval (0ₕ ·ₕ Q) xs
+    ≡⟨ ·Homeval 0ₕ Q _ ⟩
+      eval 0ₕ xs · eval Q xs
+    ≡⟨ cong (λ u → u · eval Q xs) (eval0H xs) ⟩
+      0 · eval Q xs ∎
+
+  ⋆Homeval r 0H x xs =
+    eval (r ⋆ 0H) (x ∷ xs)         ≡⟨ refl ⟩
+    0                              ≡⟨ 0≡m·0 (eval r xs) ⟩
+    eval r xs · 0                  ≡⟨ refl ⟩
+    eval r xs · eval 0H (x ∷ xs) ∎
+  ⋆Homeval r (P ·X+ Q) x xs =
+      eval (r ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
+      eval ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs)              ≡⟨ refl ⟩
+      (eval (r ⋆ P) (x ∷ xs)) · x + eval (r ·ₕ Q) xs
+    ≡⟨ cong (λ u → u · x + eval (r ·ₕ Q) xs) (⋆Homeval r P x xs) ⟩
+      (eval r xs · eval P (x ∷ xs)) · x + eval (r ·ₕ Q) xs
+    ≡⟨ cong (λ u → (eval r xs · eval P (x ∷ xs)) · x + u) (·Homeval r Q xs) ⟩
+      (eval r xs · eval P (x ∷ xs)) · x + eval r xs · eval Q xs
+    ≡⟨ cong (λ u → u  + eval r xs · eval Q xs) (sym (·-assoc (eval r xs) (eval P (x ∷ xs)) x)) ⟩
+      eval r xs · (eval P (x ∷ xs) · x) + eval r xs · eval Q xs
+    ≡⟨ ·-distribˡ (eval r xs)  ((eval P (x ∷ xs) · x)) (eval Q xs) ⟩
+      eval r xs · ((eval P (x ∷ xs) · x) + eval Q xs)
+    ≡⟨ refl ⟩
+      eval r xs · eval (P ·X+ Q) (x ∷ xs) ∎
+
+  combineCases :
+    {n : ℕ} (Q : IteratedHornerForms n) (P S : IteratedHornerForms (ℕ.suc n))
+    (xs : Vec ℕ (ℕ.suc n))
+    → eval ((P ·X+ Q) ·ₕ S) xs ≡ eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) xs
+  combineCases Q P S (x ∷ xs) with (P ·ₕ S)
+  ... | 0H =
+    eval (Q ⋆ S) (x ∷ xs)                ≡⟨ refl ⟩
+    0 + eval (Q ⋆ S) (x ∷ xs)           ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs)) lemma ⟩
+    eval (0H ·X+ 0ₕ) (x ∷ xs)
+    + eval (Q ⋆ S) (x ∷ xs)              ≡⟨ sym (+Homeval
+                                                  (0H ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs)) ⟩
+    eval ((0H ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs) ∎
+    where lemma : 0 ≡ eval (0H ·X+ 0ₕ) (x ∷ xs)
+          lemma = 0
+                ≡⟨ refl ⟩
+                  0 + 0
+                ≡⟨ cong (λ u → u + 0) refl ⟩
+                  0 · x + 0
+                ≡⟨ cong (λ u → 0 · x + u) (sym (eval0H xs)) ⟩
+                  0 · x + eval 0ₕ xs
+                ≡⟨ cong (λ u → u · x + eval 0ₕ xs) (sym (eval0H (x ∷ xs))) ⟩
+                  eval 0H (x ∷ xs) · x + eval 0ₕ xs
+                ≡⟨ refl ⟩
+                  eval (0H ·X+ 0ₕ) (x ∷ xs) ∎
+  ... | (_ ·X+ _) = refl
+
+  ·Homeval (const x) (const y) [] = refl
+  ·Homeval 0H Q xs =
+    eval (0H ·ₕ Q) xs        ≡⟨ eval0H xs ⟩
+    0                                 ≡⟨ refl ⟩
+    0 · eval Q xs          ≡⟨ cong (λ u → u · eval Q xs) (sym (eval0H xs)) ⟩
+    eval 0H xs · eval Q xs ∎
+  ·Homeval (P ·X+ Q) S (x ∷ xs) =
+      eval ((P ·X+ Q) ·ₕ S) (x ∷ xs)
+    ≡⟨ combineCases Q P S (x ∷ xs) ⟩
+      eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs)
+    ≡⟨ +Homeval ((P ·ₕ S) ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs) ⟩
+      eval ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs) + eval (Q ⋆ S) (x ∷ xs)
+    ≡⟨ refl ⟩
+      (eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs)
+      + eval (Q ⋆ S) (x ∷ xs)
+    ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs))
+          ((eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs)
+         ≡⟨ cong (λ u → eval (P ·ₕ S) (x ∷ xs) · x + u) (eval0H xs) ⟩
+           (eval (P ·ₕ S) (x ∷ xs) · x + 0)
+         ≡⟨ +-zero _ ⟩
+           (eval (P ·ₕ S) (x ∷ xs) · x)
+         ≡⟨ cong (λ u → u · x) (·Homeval P S (x ∷ xs)) ⟩
+           ((eval P (x ∷ xs) · eval S (x ∷ xs)) · x)
+         ≡⟨ sym (·-assoc (eval P (x ∷ xs)) (eval S (x ∷ xs)) x) ⟩
+           (eval P (x ∷ xs) · (eval S (x ∷ xs) · x))
+         ≡⟨ cong (λ u → eval P (x ∷ xs) · u) (·-comm _ x) ⟩
+           (eval P (x ∷ xs) · (x · eval S (x ∷ xs)))
+         ≡⟨ ·-assoc (eval P (x ∷ xs)) x (eval S (x ∷ xs)) ⟩
+           (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
+          ∎) ⟩
+      (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
+      + eval (Q ⋆ S) (x ∷ xs)
+    ≡⟨ cong (λ u → (eval P (x ∷ xs) · x) · eval S (x ∷ xs) + u)
+            (⋆Homeval Q S x xs) ⟩
+      (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
+      + eval Q xs · eval S (x ∷ xs)
+    ≡⟨ ·-distribʳ (eval P (x ∷ xs) · x) (eval Q xs) (eval S (x ∷ xs)) ⟩
+      ((eval P (x ∷ xs) · x) + eval Q xs) · eval S (x ∷ xs)
+    ≡⟨ refl ⟩
+      eval (P ·X+ Q) (x ∷ xs) · eval S (x ∷ xs) ∎
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.NatSolver.HornerForms.html b/docs/Cubical.Tactics.NatSolver.HornerForms.html new file mode 100644 index 0000000..6a6caa4 --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.HornerForms.html @@ -0,0 +1,102 @@ + +Cubical.Tactics.NatSolver.HornerForms
{-# OPTIONS --safe #-}
+module Cubical.Tactics.NatSolver.HornerForms where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.Nat hiding (isZero)
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Bool using (Bool; true; false; if_then_else_)
+
+private
+  variable
+    ℓ : Level
+
+{-
+  This defines the type of multivariate Polynomials over ℕ.
+  The construction is based on the algebraic fact
+
+    ℕ[X₀][X₁]⋯[Xₙ] ≅ ℕ[X₀,⋯,Xₙ]
+
+  BUT: Contrary to algebraic convetions, we will give 'Xₙ' the lowest index
+  in the definition of 'Variable' below. So if 'Variable n k' is identified
+  with 'Xₖ', what we construct should rather be denoted with
+
+    ℕ[Xₙ][Xₙ₋₁]⋯[X₀]
+
+  or, to be precise about the evaluation order:
+
+    (⋯((ℕ[Xₙ])[Xₙ₋₁])⋯)[X₀]
+
+-}
+
+data IteratedHornerForms : ℕ → Type ℓ-zero where
+  const : ℕ → IteratedHornerForms ℕ.zero
+  0H : {n : ℕ} → IteratedHornerForms (ℕ.suc n)
+  _·X+_ : {n : ℕ} → IteratedHornerForms (ℕ.suc n) → IteratedHornerForms n
+                  → IteratedHornerForms (ℕ.suc n)
+
+eval : {n : ℕ} (P : IteratedHornerForms n)
+       → Vec ℕ n → ℕ
+eval (const r) [] = r
+eval 0H (_ ∷ _) = 0
+eval (P ·X+ Q) (x ∷ xs) =
+  (eval P (x ∷ xs)) · x + eval Q xs
+
+module IteratedHornerOperations where
+
+  private
+    1H' : (n : ℕ) → IteratedHornerForms n
+    1H' ℕ.zero = const 1
+    1H' (ℕ.suc n) = 0H ·X+ 1H' n
+
+    0H' : (n : ℕ) → IteratedHornerForms n
+    0H' ℕ.zero = const 0
+    0H' (ℕ.suc n) = 0H
+
+  1ₕ : {n : ℕ} → IteratedHornerForms n
+  1ₕ {n = n} = 1H' n
+
+  0ₕ : {n : ℕ} → IteratedHornerForms n
+  0ₕ {n = n} = 0H' n
+
+  X : (n : ℕ) (k : Fin n) → IteratedHornerForms n
+  X (ℕ.suc m) zero = 1ₕ ·X+ 0ₕ
+  X (ℕ.suc m) (suc k) = 0ₕ ·X+ X m k
+
+  _+ₕ_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms n
+               → IteratedHornerForms n
+  (const r) +ₕ (const s) = const (r + s)
+  0H +ₕ Q = Q
+  (P ·X+ r) +ₕ 0H = P ·X+ r
+  (P ·X+ r) +ₕ (Q ·X+ s) = (P +ₕ Q) ·X+ (r +ₕ s)
+
+  isZero : {n : ℕ} → IteratedHornerForms (ℕ.suc n)
+                   → Bool
+  isZero 0H = true
+  isZero (P ·X+ P₁) = false
+
+  _⋆_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms (ℕ.suc n)
+                → IteratedHornerForms (ℕ.suc n)
+  _·ₕ_ : {n : ℕ} → IteratedHornerForms n → IteratedHornerForms n
+                → IteratedHornerForms n
+  r ⋆ 0H = 0H
+  r ⋆ (P ·X+ Q) = (r ⋆ P) ·X+ (r ·ₕ Q)
+
+  const x ·ₕ const y = const (x · y)
+  0H ·ₕ Q = 0H
+  (P ·X+ Q) ·ₕ S =
+     let
+        z = (P ·ₕ S)
+     in if (isZero z)
+        then (Q ⋆ S)
+        else (z ·X+ 0ₕ) +ₕ (Q ⋆ S)
+
+Variable : (n : ℕ) (k : Fin n) → IteratedHornerForms n
+Variable n k = IteratedHornerOperations.X n k
+
+Constant : (n : ℕ) (r : ℕ) → IteratedHornerForms n
+Constant ℕ.zero r = const r
+Constant (ℕ.suc n) r = IteratedHornerOperations.0ₕ ·X+ Constant n r
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.NatSolver.NatExpression.html b/docs/Cubical.Tactics.NatSolver.NatExpression.html new file mode 100644 index 0000000..f4e61f1 --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.NatExpression.html @@ -0,0 +1,30 @@ + +Cubical.Tactics.NatSolver.NatExpression
{-# OPTIONS --safe #-}
+module Cubical.Tactics.NatSolver.NatExpression where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.FinData
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order using (zero-≤)
+open import Cubical.Data.Vec.Base
+
+infixl 6 _+'_
+infixl 7 _·'_
+
+-- Expression in a ring on A with n variables
+data Expr (n : ℕ) : Type ℓ-zero where
+  K : ℕ → Expr n
+  ∣ : Fin n → Expr n
+  _+'_ : Expr n → Expr n → Expr n
+  _·'_ : Expr n → Expr n → Expr n
+
+module Eval where
+  open import Cubical.Data.Vec
+
+  ⟦_⟧ : ∀ {n} → Expr n → Vec ℕ n → ℕ
+  ⟦ K r ⟧ v = r
+  ⟦ ∣ k ⟧ v = lookup k v
+  ⟦ x +' y ⟧ v =  ⟦ x ⟧ v + ⟦ y ⟧ v
+  ⟦ x ·' y ⟧ v = ⟦ x ⟧ v · ⟦ y ⟧ v
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.NatSolver.Reflection.html b/docs/Cubical.Tactics.NatSolver.Reflection.html new file mode 100644 index 0000000..0ff39a4 --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.Reflection.html @@ -0,0 +1,147 @@ + +Cubical.Tactics.NatSolver.Reflection
{-# OPTIONS --safe #-}
+{-
+  This is inspired by/copied from:
+  https://github.com/agda/agda-stdlib/blob/master/src/Tactic/MonoidSolver.agda
+  and the 1lab.
+
+  Boilerplate code for calling the ring solver is constructed automatically
+  with agda's reflection features.
+-}
+module Cubical.Tactics.NatSolver.Reflection where
+
+open import Cubical.Foundations.Prelude hiding (Type)
+open import Cubical.Functions.Logic
+
+open import Agda.Builtin.Reflection hiding (Type)
+open import Agda.Builtin.String
+
+open import Cubical.Reflection.Base
+
+open import Cubical.Data.Maybe
+open import Cubical.Data.Sigma
+open import Cubical.Data.List
+open import Cubical.Data.Nat
+open import Cubical.Data.Bool
+open import Cubical.Data.Bool.SwitchStatement
+open import Cubical.Data.Vec using (Vec) renaming ([] to emptyVec; _∷_ to _∷vec_) public
+
+open import Cubical.Tactics.NatSolver.NatExpression
+open import Cubical.Tactics.NatSolver.Solver
+
+open import Cubical.Tactics.Reflection
+open import Cubical.Tactics.Reflection.Variables
+open import Cubical.Tactics.Reflection.Utilities
+
+open EqualityToNormalform renaming (solve to natSolve)
+private
+  variable
+    ℓ : Level
+
+  private
+    solverCallAsTerm : Arg Term → Term → Term → Term
+    solverCallAsTerm varList lhs rhs =
+      def
+         (quote natSolve)
+         (varg lhs ∷ varg rhs
+           ∷ varList
+           ∷ varg (def (quote refl) []) ∷ [])
+
+  solverCallWithVars : ℕ → Vars → Term → Term → Term
+  solverCallWithVars n vars lhs rhs =
+      solverCallAsTerm (variableList vars) lhs rhs
+      where
+        variableList : Vars → Arg Term
+        variableList [] = varg (con (quote emptyVec) [])
+        variableList (t ∷ ts)
+          = varg (con (quote _∷vec_) (t v∷ (variableList ts) ∷ []))
+
+module pr {n : ℕ} where
+  0' : Expr n
+  0' = K 0
+
+  1' : Expr n
+  1' = K 1
+
+module NatSolverReflection where
+  open pr
+
+  buildExpression : Term → TC (Template × Vars)
+
+  op2 : Name → Term → Term → TC (Template × Vars)
+  op2 op x y = do
+    r1 ← buildExpression x
+    r2 ← buildExpression y
+    returnTC ((λ ass → con op (fst r1 ass v∷ fst r2 ass v∷ [])) ,
+             appendWithoutRepetition (snd r1) (snd r2))
+
+  `_·_` : List (Arg Term) → TC (Template × Vars)
+  `_·_` (_ h∷ xs) = `_·_` xs
+  `_·_` (x v∷ y v∷ []) = op2 (quote _·'_) x y
+  `_·_` ts = errorOut ts
+
+  `_+_` : List (Arg Term) → TC (Template × Vars)
+  `_+_` (_ h∷ xs) = `_+_` xs
+  `_+_` (x v∷ y v∷ []) = op2 (quote _+'_) x y
+  `_+_` ts = errorOut ts
+
+  `1+_` : List (Arg Term) → TC (Template × Vars)
+  `1+_` (x v∷ []) = do
+    r1 ← buildExpression x
+    returnTC ((λ ass → con (quote _+'_) ((def (quote 1') []) v∷ fst r1 ass v∷ [])) ,
+              snd r1)
+  `1+_` ts = errorOut ts
+
+  K' : List (Arg Term) → TC (Template × Vars)
+  K' xs = returnTC ((λ _ → con (quote K) xs) , [])
+
+  polynomialVariable : Maybe ℕ → Term
+  polynomialVariable (just n) = con (quote ∣) (finiteNumberAsTerm (just n) v∷ [])
+  polynomialVariable nothing = unknown
+
+  buildExpression v@(var _ _) =
+      returnTC ((λ ass → polynomialVariable (ass v)) ,
+           v ∷ [])
+  buildExpression t@(lit n) = K' (t v∷ [])
+  buildExpression t@(def n xs) =
+    switch (n ==_) cases
+      case (quote _·_) ⇒ `_·_` xs   break
+      case (quote _+_) ⇒ `_+_` xs   break
+      default⇒ (K' xs)
+  buildExpression t@(con n xs) =
+    switch (n ==_) cases
+      case (quote suc) ⇒ `1+_` xs   break
+      default⇒ (K' xs)
+  buildExpression t = errorOut' t
+
+  toNatExpression : Term × Term → TC (Term × Term × Vars)
+  toNatExpression (lhs , rhs) = do
+      r1 ← buildExpression lhs
+      r2 ← buildExpression rhs
+      vars ← returnTC (appendWithoutRepetition (snd r1) (snd r2))
+      returnTC (
+        let ass : VarAss
+            ass n = indexOf n vars
+        in (fst r1 ass , fst r2 ass , vars ))
+
+private
+
+  solve!-macro : Term → TC Unit
+  solve!-macro hole =
+    do
+      goal ← inferType hole >>= normalise
+
+      just (lhs , rhs) ← get-boundary goal
+        where
+          nothing
+            → typeError(strErr "The NatSolver failed to parse the goal "
+                               ∷ termErr goal ∷ [])
+
+      (lhs' , rhs' , vars) ← NatSolverReflection.toNatExpression (lhs , rhs)
+      let solution = solverCallWithVars (length vars) vars lhs' rhs'
+      unify hole solution
+
+macro
+  solveℕ! : Term → TC _
+  solveℕ! = solve!-macro
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.NatSolver.Solver.html b/docs/Cubical.Tactics.NatSolver.Solver.html new file mode 100644 index 0000000..efddecf --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.Solver.html @@ -0,0 +1,125 @@ + +Cubical.Tactics.NatSolver.Solver
{-# OPTIONS --safe #-}
+module Cubical.Tactics.NatSolver.Solver where
+
+open import Cubical.Foundations.Prelude
+
+open import Cubical.Data.FinData
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order using (zero-≤)
+open import Cubical.Data.Vec.Base
+open import Cubical.Tactics.NatSolver.NatExpression
+open import Cubical.Tactics.NatSolver.HornerForms
+open import Cubical.Tactics.NatSolver.EvalHom
+
+private
+  variable
+    ℓ : Level
+
+module EqualityToNormalform where
+  open Eval
+  open IteratedHornerOperations
+  open HomomorphismProperties
+
+  normalize : {n : ℕ} → Expr n → IteratedHornerForms n
+  normalize {n = n} (K r) = Constant n r
+  normalize {n = n} (∣ k) = Variable n k
+  normalize (x +' y) =
+    (normalize x) +ₕ (normalize y)
+  normalize (x ·' y) =
+    (normalize x) ·ₕ (normalize y)
+
+  isEqualToNormalform :
+            {n : ℕ}
+            (e : Expr n) (xs : Vec ℕ n)
+          → eval (normalize e) xs ≡ ⟦ e ⟧ xs
+  isEqualToNormalform (K r) [] = refl
+  isEqualToNormalform {n = ℕ.suc n} (K r) (x ∷ xs) =
+     eval (Constant (ℕ.suc n) r) (x ∷ xs)           ≡⟨ refl ⟩
+     eval (0ₕ ·X+ Constant n r) (x ∷ xs)             ≡⟨ refl ⟩
+     eval 0ₕ (x ∷ xs) · x + eval (Constant n r) xs
+    ≡⟨ cong (λ u → u · x + eval (Constant n r) xs) (eval0H (x ∷ xs)) ⟩
+     0 · x + eval (Constant n r) xs
+    ≡⟨ refl ⟩
+     eval (Constant n r) xs
+    ≡⟨ isEqualToNormalform (K r) xs ⟩
+     r ∎
+
+  isEqualToNormalform (∣ zero) (x ∷ xs) =
+    eval (1ₕ ·X+ 0ₕ) (x ∷ xs)           ≡⟨ refl ⟩
+    eval 1ₕ (x ∷ xs) · x + eval 0ₕ xs   ≡⟨ cong (λ u → u · x + eval 0ₕ xs)
+                                               (eval1ₕ (x ∷ xs)) ⟩
+    1 · x + eval 0ₕ xs                  ≡⟨ cong (λ u → 1 · x + u ) (eval0H xs) ⟩
+    1 · x + 0                          ≡⟨ +-zero _ ⟩
+    1 · x                               ≡⟨ ·-identityˡ _ ⟩
+    x ∎
+  isEqualToNormalform {n = ℕ.suc n} (∣ (suc k)) (x ∷ xs) =
+      eval (0ₕ ·X+ Variable n k) (x ∷ xs)             ≡⟨ refl ⟩
+      eval 0ₕ (x ∷ xs) · x + eval (Variable n k) xs
+    ≡⟨ cong (λ u → u · x + eval (Variable n k) xs) (eval0H (x ∷ xs)) ⟩
+      0 · x + eval (Variable n k) xs
+    ≡⟨ refl ⟩
+      eval (Variable n k) xs
+    ≡⟨ isEqualToNormalform (∣ k) xs ⟩
+      ⟦ ∣ (suc k) ⟧ (x ∷ xs) ∎
+
+  isEqualToNormalform (e +' e₁) [] =
+        eval (normalize e +ₕ normalize e₁) []
+      ≡⟨ +Homeval (normalize e) _ [] ⟩
+        eval (normalize e) []
+        + eval (normalize e₁) []
+      ≡⟨ cong (λ u → u + eval (normalize e₁) [])
+              (isEqualToNormalform e []) ⟩
+        ⟦ e ⟧ []
+        + eval (normalize e₁) []
+      ≡⟨ cong (λ u → ⟦ e ⟧ [] + u) (isEqualToNormalform e₁ []) ⟩
+        ⟦ e ⟧ [] + ⟦ e₁ ⟧ [] ∎
+  isEqualToNormalform (e +' e₁) (x ∷ xs) =
+        eval (normalize e
+              +ₕ normalize e₁) (x ∷ xs)
+      ≡⟨ +Homeval (normalize e) _ (x ∷ xs) ⟩
+        eval (normalize e) (x ∷ xs)
+        + eval (normalize e₁) (x ∷ xs)
+      ≡⟨ cong (λ u → u + eval (normalize e₁) (x ∷ xs))
+              (isEqualToNormalform e (x ∷ xs)) ⟩
+        ⟦ e ⟧ (x ∷ xs)
+        + eval (normalize e₁) (x ∷ xs)
+      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) + u)
+              (isEqualToNormalform e₁ (x ∷ xs)) ⟩
+        ⟦ e ⟧ (x ∷ xs) + ⟦ e₁ ⟧ (x ∷ xs) ∎
+
+  isEqualToNormalform (e ·' e₁) [] =
+        eval (normalize e ·ₕ normalize e₁) []
+      ≡⟨ ·Homeval (normalize e) _ [] ⟩
+        eval (normalize e) []
+        · eval (normalize e₁) []
+      ≡⟨ cong (λ u → u · eval (normalize e₁) [])
+              (isEqualToNormalform e []) ⟩
+        ⟦ e ⟧ []
+        · eval (normalize e₁) []
+      ≡⟨ cong (λ u → ⟦ e ⟧ [] · u) (isEqualToNormalform e₁ []) ⟩
+        ⟦ e ⟧ [] · ⟦ e₁ ⟧ [] ∎
+
+  isEqualToNormalform (e ·' e₁) (x ∷ xs) =
+        eval (normalize e ·ₕ normalize e₁) (x ∷ xs)
+      ≡⟨ ·Homeval (normalize e) _ (x ∷ xs) ⟩
+        eval (normalize e) (x ∷ xs)
+        · eval (normalize e₁) (x ∷ xs)
+      ≡⟨ cong (λ u → u · eval (normalize e₁) (x ∷ xs))
+              (isEqualToNormalform e (x ∷ xs)) ⟩
+        ⟦ e ⟧ (x ∷ xs)
+        · eval (normalize e₁) (x ∷ xs)
+      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) · u)
+              (isEqualToNormalform e₁ (x ∷ xs)) ⟩
+        ⟦ e ⟧ (x ∷ xs) · ⟦ e₁ ⟧ (x ∷ xs) ∎
+
+  solve :
+    {n : ℕ} (e₁ e₂ : Expr n) (xs : Vec ℕ n)
+    (p : eval (normalize e₁) xs ≡ eval (normalize e₂) xs)
+    → ⟦ e₁ ⟧ xs ≡ ⟦ e₂ ⟧ xs
+  solve e₁ e₂ xs p =
+    ⟦ e₁ ⟧ xs                ≡⟨ sym (isEqualToNormalform e₁ xs) ⟩
+    eval (normalize e₁) xs ≡⟨ p ⟩
+    eval (normalize e₂) xs ≡⟨ isEqualToNormalform e₂ xs ⟩
+    ⟦ e₂ ⟧ xs ∎
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.NatSolver.html b/docs/Cubical.Tactics.NatSolver.html new file mode 100644 index 0000000..8ae748c --- /dev/null +++ b/docs/Cubical.Tactics.NatSolver.html @@ -0,0 +1,14 @@ + +Cubical.Tactics.NatSolver
{-# OPTIONS --safe #-}
+{-
+  This is inspired by/copied from:
+  https://github.com/agda/agda-stdlib/blob/master/src/Tactic/MonoidSolver.agda
+  and the 1lab.
+
+  Boilerplate code for calling the ring solver is constructed automatically
+  with agda's reflection features.
+-}
+module Cubical.Tactics.NatSolver where
+
+open import Cubical.Tactics.NatSolver.Reflection public
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.Reflection.Utilities.html b/docs/Cubical.Tactics.Reflection.Utilities.html new file mode 100644 index 0000000..9fc2fa5 --- /dev/null +++ b/docs/Cubical.Tactics.Reflection.Utilities.html @@ -0,0 +1,37 @@ + +Cubical.Tactics.Reflection.Utilities
{-# OPTIONS --safe #-}
+module Cubical.Tactics.Reflection.Utilities where
+
+open import Cubical.Foundations.Prelude hiding (Type)
+
+open import Agda.Builtin.Reflection hiding (Type)
+open import Agda.Builtin.String
+open import Agda.Builtin.Nat using () renaming (_==_ to _=ℕ_)
+
+open import Cubical.Reflection.Base
+open import Cubical.Data.List
+open import Cubical.Data.Maybe
+open import Cubical.Data.FinData using () renaming (zero to fzero; suc to fsuc)
+open import Cubical.Data.Sigma
+open import Cubical.Data.Nat using (ℕ)
+
+open import Cubical.Tactics.Reflection
+open import Cubical.Tactics.Reflection.Variables
+
+
+finiteNumberAsTerm : Maybe ℕ → Term
+finiteNumberAsTerm (just ℕ.zero) = con (quote fzero) []
+finiteNumberAsTerm (just (ℕ.suc n)) = con (quote fsuc) (finiteNumberAsTerm (just n) v∷ [])
+finiteNumberAsTerm _ = unknown
+
+-- error message helper
+errorOut : List (Arg Term) → TC (Template × Vars)
+errorOut something = typeError (strErr "Don't know what to do with " ∷ map (λ {(arg _ t) → termErr t}) something)
+
+errorOut' : Term → TC (Template × Vars)
+errorOut' something = typeError (strErr "Don't know what to do with " ∷ termErr something ∷ [])
+
+
+_==_ = primQNameEquality
+{-# INLINE _==_ #-}
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.Reflection.Variables.html b/docs/Cubical.Tactics.Reflection.Variables.html new file mode 100644 index 0000000..a1cc374 --- /dev/null +++ b/docs/Cubical.Tactics.Reflection.Variables.html @@ -0,0 +1,83 @@ + +Cubical.Tactics.Reflection.Variables
{-# OPTIONS --safe #-}
+{-
+  This code contains some helper functions for solvers.
+  Variables in the sense of this files are things that are treated like variables by a solver.
+  A ring solver might want to treat "f x" in an equation "f x + 0 ≡ f x" like a variable "y".
+  During the inspection of the lhs and rhs of an equation, terms like "f x" are found and saved
+  and later, indices are assigned to them. These indices will be the indices of the variables
+  in the normal forms the solver uses.
+-}
+module Cubical.Tactics.Reflection.Variables where
+
+open import Cubical.Foundations.Prelude hiding (Type)
+
+open import Agda.Builtin.Reflection hiding (Type)
+open import Agda.Builtin.String
+open import Agda.Builtin.Float
+open import Agda.Builtin.Word
+open import Agda.Builtin.Char
+open import Agda.Builtin.Nat using () renaming (_==_ to _=ℕ_)
+
+open import Cubical.Reflection.Base
+open import Cubical.Data.Bool
+open import Cubical.Data.List
+open import Cubical.Data.Maybe
+open import Cubical.Data.Nat using (ℕ)
+
+open import Cubical.Tactics.Reflection
+
+private
+  variable
+    ℓ : Level
+
+
+Vars = List Term
+VarAss = Term → Maybe ℕ
+Template = VarAss → Term
+
+private
+  _=N_ = primQNameEquality
+  _=M_ = primMetaEquality
+
+  _=L_ : Literal → Literal → Bool
+  nat n =L nat m = n =ℕ m
+  word64 n =L word64 m = primWord64ToNat n =ℕ primWord64ToNat m
+  float x =L float y = primFloatEquality x y
+  char c =L char c' = primCharEquality c c'
+  string s =L string s' = primStringEquality s s'
+  name x =L name y = x =N y
+  meta x =L meta y = x =M y
+  _ =L _ = false
+
+  compareVargs : List (Arg Term) → List (Arg Term) → Bool
+
+  _=T_ : Term → Term → Bool  -- this should be a TC, since it should error out sometimes
+  var index args =T var index' args' = (index =ℕ index') and compareVargs args args'
+  con c args =T con c' args'   = (c =N c') and compareVargs args args'
+  def f args =T def f' args'   = (f =N f') and compareVargs args args'
+  lit l =T lit l'              = l =L l'
+  meta x args =T meta x' args' = (x =M x') and compareVargs args args'
+  _ =T _                       = false  -- this should be fixed
+
+compareVargs [] [] = true
+compareVargs (x v∷ l) (x' v∷ l') = (x =T x') and compareVargs l l'
+compareVargs (_ h∷ l) (_ h∷ l') = compareVargs l l' -- ignore hargs, not sure this is good
+compareVargs _ _ = false
+
+addWithoutRepetition : Term → Vars → Vars
+addWithoutRepetition t l@(t' ∷ l') = if (t =T t') then l else t' ∷ addWithoutRepetition t l'
+addWithoutRepetition t []      = t ∷ []
+
+appendWithoutRepetition : Vars → Vars → Vars
+appendWithoutRepetition (x ∷ l) l' = appendWithoutRepetition l (addWithoutRepetition x l')
+appendWithoutRepetition [] l' = l'
+
+-- this can be used to get a map from variables to numbers 0,...,n
+indexOf : Term → Vars → Maybe ℕ
+indexOf t (t' ∷ l) =
+  if (t =T t')
+  then just 0
+  else map-Maybe (λ k → ℕ.suc k) (indexOf t l)
+indexOf t [] = nothing
+
\ No newline at end of file diff --git a/docs/Cubical.Tactics.Reflection.html b/docs/Cubical.Tactics.Reflection.html new file mode 100644 index 0000000..9e15672 --- /dev/null +++ b/docs/Cubical.Tactics.Reflection.html @@ -0,0 +1,116 @@ + +Cubical.Tactics.Reflection
-- SPDX-License-Identifier: BSD-3-Clause
+{-# OPTIONS --safe #-}
+module Cubical.Tactics.Reflection where
+
+{- Utilities common to different reflection solvers.
+
+  Most of these are copied/adapted from the 1Lab
+-}
+
+open import Cubical.Foundations.Prelude
+
+open import Agda.Builtin.Reflection hiding (Type)
+
+open import Cubical.Data.Bool
+open import Cubical.Data.List
+open import Cubical.Data.Maybe
+open import Cubical.Data.Sigma
+open import Cubical.Data.Unit
+
+open import Cubical.Reflection.Base
+
+private
+  variable
+    ℓ ℓ' : Level
+
+_<$>_ : ∀ {ℓ ℓ'} {A : Type ℓ}{B : Type ℓ'} → (A → B) → TC A → TC B
+f <$> t = t >>= λ x → returnTC (f x)
+
+_<*>_ : ∀ {ℓ ℓ'} {A : Type ℓ}{B : Type ℓ'} → TC (A → B) → TC A → TC B
+s <*> t = s >>= λ f → t >>= λ x → returnTC (f x)
+
+wait-for-args : List (Arg Term) → TC (List (Arg Term))
+wait-for-type : Term → TC Term
+
+wait-for-type (var x args) = var x <$> wait-for-args args
+wait-for-type (con c args) = con c <$> wait-for-args args
+wait-for-type (def f args) = def f <$> wait-for-args args
+wait-for-type (lam v (abs x t)) = returnTC (lam v (abs x t))
+wait-for-type (pat-lam cs args) = returnTC (pat-lam cs args)
+wait-for-type (pi (arg i a) (abs x b)) = do
+  a ← wait-for-type a
+  b ← wait-for-type b
+  returnTC (pi (arg i a) (abs x b))
+wait-for-type (agda-sort s) = returnTC (agda-sort s)
+wait-for-type (lit l) = returnTC (lit l)
+wait-for-type (meta x x₁) = blockOnMeta x
+wait-for-type unknown = returnTC unknown
+
+wait-for-args [] = returnTC []
+wait-for-args (arg i a ∷ xs) =
+  (_∷_ <$> (arg i <$> wait-for-type a)) <*> wait-for-args xs
+
+unapply-path : Term → TC (Maybe (Term × Term × Term))
+unapply-path red@(def (quote PathP) (l h∷ T v∷ x v∷ y v∷ [])) = do
+  domain ← newMeta (def (quote Type) (l v∷ []))
+  ty ← returnTC (def (quote Path) (domain v∷ x v∷ y v∷ []))
+  debugPrint "tactic" 50
+    (strErr "(no reduction) unapply-path: got a " ∷ termErr red
+    ∷ strErr " but I really want it to be " ∷ termErr ty ∷ [])
+  unify red ty
+  returnTC (just (domain , x , y))
+unapply-path tm = reduce tm >>= λ where
+  tm@(meta _ _) → do
+    dom ← newMeta (def (quote Type) [])
+    l ← newMeta dom
+    r ← newMeta dom
+    unify tm (def (quote Type) (dom v∷ l v∷ r v∷ []))
+    wait-for-type l
+    wait-for-type r
+    returnTC (just (dom , l , r))
+  red@(def (quote PathP) (l h∷ T v∷ x v∷ y v∷ [])) → do
+    domain ← newMeta (def (quote Type) (l v∷ []))
+    ty ← returnTC (def (quote Path) (domain v∷ x v∷ y v∷ []))
+    debugPrint "tactic" 50
+      (strErr "unapply-path: got a " ∷ termErr red
+      ∷ strErr " but I really want it to be " ∷ termErr ty ∷ [])
+    unify red ty
+    returnTC (just (domain , x , y))
+  _ → returnTC nothing
+
+{-
+  get-boundary maps a term 'x ≡ y' to the pair '(x,y)'
+-}
+get-boundary : Term → TC (Maybe (Term × Term))
+get-boundary tm = unapply-path tm >>= λ where
+  (just (_ , x , y)) → returnTC (just (x , y))
+  nothing            → returnTC nothing
+
+equation-solver : List Name → (Term -> Term -> TC Term) → Bool → Term → TC Unit
+equation-solver don't-Reduce mk-call debug hole =
+    withNormalisation false (
+    withReduceDefs (false , don't-Reduce) (
+    do
+      -- | First we normalize the goal
+      goal ← inferType hole >>= reduce
+      -- | Then we parse the goal into an AST
+      just (lhs , rhs) ← get-boundary goal
+        where
+          nothing
+            → typeError(strErr "The functor solver failed to parse the goal"
+                               ∷ termErr goal ∷ [])
+      -- | Then we invoke the solver
+      -- | And we unify the result of the solver with the original hole.
+      elhs ← normalise lhs
+      erhs ← normalise rhs
+      call ← mk-call elhs erhs
+      let unify-with-goal = (unify hole call)
+      noConstraints (
+        if debug
+        then unify-with-goal
+        else (
+        unify-with-goal <|>
+        typeError ((strErr "Could not equate the following expressions:\n  "
+                  ∷ termErr elhs ∷ strErr "\nAnd\n  " ∷ termErr erhs ∷ []))))))
+
\ No newline at end of file diff --git a/docs/Realizability.ApplicativeStructure.html b/docs/Realizability.ApplicativeStructure.html index ef9bf67..8499598 100644 --- a/docs/Realizability.ApplicativeStructure.html +++ b/docs/Realizability.ApplicativeStructure.html @@ -1,145 +1,173 @@ -Realizability.ApplicativeStructure
{-# OPTIONS --cubical --without-K --allow-unsolved-metas #-}
-open import Cubical.Core.Everything
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Relation.Nullary
-open import Cubical.Data.Nat
-open import Cubical.Data.Nat.Order
-open import Cubical.Data.Fin
-open import Cubical.Data.Vec
-open import Cubical.Data.Empty renaming (elim to ⊥elim)
-
-module Realizability.ApplicativeStructure where
-
-record ApplicativeStructure {ℓ} (A : Type ℓ) : Type ℓ where
-  infixl 20 _⨾_
-  field
-    isSetA : isSet A
-    _⨾_ : A → A → A
-
-module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where
-  open ApplicativeStructure as
-  infix 23 `_
-  infixl 22 _̇_
-  data Term (n : ℕ) : Type ℓ where
-    # : Fin n → Term n
-    `_ : A → Term n
-    _̇_ : Term n → Term n → Term n
-
-  upgrade : ∀ {n m} → n < m → Term n → Term m
-  upgrade _ (` a) = ` a
-  upgrade {n} {m} n<m (# k) = # (k .fst , <-trans (k .snd) n<m)
-  upgrade {n} {m} n<m (a ̇ b) = upgrade n<m a ̇ upgrade n<m b
-
-  substitute : ∀ {n} → Term n → Vec A n → A
-  substitute (` a) _ = a
-  substitute {n} (# k) subs = lookup (Fin→FinData n k) subs
-  substitute (a ̇ b) subs = (substitute a subs) ⨾ (substitute b subs)
-
-  apply : ∀ {n} → A → Vec A n → A
-  apply a [] = a
-  apply a (x ∷ xs) = apply' (x ∷ xs) a where
-                            apply' : ∀ {n} → Vec A n → A → A
-                            apply' [] acc = acc
-                            apply' (x ∷ xs) acc = apply' xs (acc ⨾ x)
-
-  applyWorks : ∀ K a b → apply K (a ∷ b ∷ []) ≡ K ⨾ a ⨾ b
-  applyWorks K a b = refl
-
-  record isInterpreted {n} (t : Term n) : Type ℓ where
-    field
-      interpretation : A
-      naturality : ∀ (subs : Vec A n) → apply interpretation subs ≡ substitute t subs
-
-  isCombinatoriallyComplete : Type ℓ
-  isCombinatoriallyComplete = ∀ {n} (t : Term n) → isInterpreted t
-
-  record Feferman : Type ℓ where
-    field
-      s : A
-      k : A
-      kab≡a : ∀ a b → k ⨾ a ⨾ b ≡ a
-      sabc≡ac_bc : ∀ a b c → s ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
-
-  module _ (completeness : isCombinatoriallyComplete) where
-    open isInterpreted
-
-    preS : Term 3
-    preS = ((# 0) ̇ (# 2)) ̇ ((# 1) ̇ (# 2))
-
-    S : A
-    S = (completeness preS) .interpretation
-
-    preK : Term 2
-    preK = # 0
-
-    K : A
-    K = (completeness preK) .interpretation
-
-    Kab≡a : ∀ a b → K ⨾ a ⨾ b ≡ a
-    Kab≡a a b = (completeness preK) .naturality (a ∷ b ∷ [])
-
-    Sabc≡ac_bc : ∀ a b c → S ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
-    Sabc≡ac_bc a b c = (completeness preS) .naturality (a ∷ b ∷ c ∷ [])
-    open Feferman
-    completeness→feferman : Feferman
-    completeness→feferman .s = S
-    completeness→feferman .k = K
-    completeness→feferman .kab≡a = Kab≡a
-    completeness→feferman .sabc≡ac_bc = Sabc≡ac_bc
-
-  module _ (feferman : Feferman) where
-    open Feferman feferman
-    {-
-    This goofy definition is there to ensure that λ* computes.
-    For some reason the last branch of pattern-matching cannot definitionally equate y .fst and suc m
-    So we must postulate it.
-    But since we already know that y .fst = suc m we can use discreteℕ to get an actual proof and extract
-    it using fromYes. fromYes then gets a dummy proof
-    -}
-    λ* : ∀ {n} (e : Term (suc n)) → Term n
-    λ* (` a) = ` k ̇ ` a
-    λ* (a ̇ b) = ` s ̇ (λ* a) ̇ (λ* b)
-    λ* {n} (# y) with (discreteℕ (y .fst) zero)
-    ... | yes _ = ` s ̇ ` k ̇ ` k
-    ... | no ¬y≡zero with (y .fst)
-    ...     | zero = ⊥elim (¬y≡zero refl)
-    ...     | (suc m) = # (m , pred-≤-pred (subst (λ y' → suc y' ≤ suc n) (fromYes fsty≡sucm (discreteℕ (y .fst) (suc m))) (y .snd))) where postulate fsty≡sucm : fst y ≡ suc m
-
-    λ*-chainTerm : ∀ n → Term n → Term zero
-    λ*-chainTerm zero t = t
-    λ*-chainTerm (suc n) t = λ*-chainTerm n (λ* t)
-
-    λ*-chain : ∀ {n} → Term n → A
-    λ*-chain {n} t = substitute (λ*-chainTerm n t) []
-
-    ⟦_⟧ : Term zero → A
-    ⟦ ` a ⟧ = a
-    ⟦ a ̇ b ⟧ = ⟦ a ⟧ ⨾ ⟦ b ⟧
-    ⟦ # x ⟧ = ⊥elim {A = λ _ → A} (¬Fin0 x)
-
-    λ*Computation : ∀ (T : Term 1) (e : Term zero) → ⟦ λ* T ⟧ ⨾ ⟦ e ⟧ ≡ substitute T (⟦ e ⟧ ∷ [])
-    λ*Computation (# x) e = {!subst (λ x≡zero → ⟦ λ* (# x) ⟧ ⨾ ⟦ e ⟧ ≡ lookup (Fin→FinData 1 x) (⟦ e ⟧ ∷ [])) ? ?!}
-    λ*Computation (` x) e = kab≡a x ⟦ e ⟧
-    λ*Computation (U ̇ V) e =
-      s ⨾ ⟦ λ* U ⟧ ⨾ ⟦ λ* V ⟧ ⨾ ⟦ e ⟧
-        ≡⟨ sabc≡ac_bc _ _ _ ⟩
-       (⟦ λ* U ⟧ ⨾ ⟦ e ⟧) ⨾ (⟦ λ* V ⟧ ⨾ ⟦ e ⟧)
-        ≡⟨ cong (λ x → x ⨾ _) (λ*Computation U e) ⟩
-        (substitute U (⟦ e ⟧ ∷ [])) ⨾ (⟦ λ* V ⟧ ⨾ ⟦ e ⟧)
-        ≡⟨ cong (λ x → _ ⨾ x) (λ*Computation V e) ⟩
-        (substitute U (⟦ e ⟧ ∷ [])) ⨾ (substitute V (⟦ e ⟧ ∷ []))
-        ∎
-    
-
-    open isInterpreted
-
-    postulate λ*-naturality : ∀ {n} (t : Term n) (subs : Vec A n) → apply (λ*-chain t) subs ≡ substitute t subs
-    
-    feferman→completeness : isCombinatoriallyComplete
-    feferman→completeness t .interpretation = λ*-chain t
-    feferman→completeness t .naturality subs = λ*-naturality t subs
-    
-
+Realizability.ApplicativeStructure
open import Cubical.Core.Everything
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Relation.Nullary
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Empty renaming (elim to ⊥elim)
+open import Cubical.Tactics.NatSolver
+
+module Realizability.ApplicativeStructure where
+
+private module _ {ℓ} {A : Type ℓ} where
+  -- Taken from Data.Vec.Base from agda-stdlib
+  foldlOp : ∀ {ℓ'} (B : ℕ → Type ℓ') → Type _
+  foldlOp B = ∀ {n} → B n → A → B (suc n)
+
+  opaque
+    foldl : ∀ {ℓ'} {n : ℕ} (B : ℕ → Type ℓ') → foldlOp B → B zero → Vec A n → B n
+    foldl {ℓ'} {.zero} B op acc emptyVec = acc
+    foldl {ℓ'} {.(suc _)} B op acc (x ∷vec vec) = foldl (λ n → B (suc n)) op (op acc x) vec
+
+  opaque
+    reverse : ∀ {n} → Vec A n → Vec A n
+    reverse vec = foldl (λ n → Vec A n) (λ acc curr → curr ∷ acc) [] vec
+
+  opaque
+    chain : ∀ {n} → Vec A (suc n) → (A → A → A) → A
+    chain {n} (x ∷vec vec) op = foldl (λ _ → A) (λ acc curr → op acc curr) x vec
+
+record ApplicativeStructure {ℓ} (A : Type ℓ) : Type ℓ where
+  infixl 20 _⨾_
+  field
+    isSetA : isSet A
+    _⨾_ : A → A → A
+
+module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where
+  open ApplicativeStructure as
+  infix 23 `_
+  infixl 22 _̇_
+  data Term (n : ℕ) : Type ℓ where
+    # : Fin n → Term n
+    `_ : A → Term n
+    _̇_ : Term n → Term n → Term n
+
+  ⟦_⟧ : ∀ {n} → Term n → Vec A n → A
+  ⟦_⟧ (` a) _ = a
+  ⟦_⟧ {n} (# k) subs = lookup k subs
+  ⟦_⟧ (a ̇ b) subs = (⟦ a ⟧ subs) ⨾ (⟦ b ⟧ subs)
+
+  applicationChain : ∀ {n m} → Vec (Term m) (suc n) → Term m
+  applicationChain {n} {m} vec = chain vec (λ x y → x ̇ y)
+
+  apply : ∀ {n} → A → Vec A n → A
+  apply {n} a vec = chain (a ∷ vec) (λ x y → x ⨾ y)
+  
+  private
+    opaque
+      unfolding reverse
+      unfolding foldl
+      unfolding chain
+      applyWorks : ∀ K a b → apply K (a ∷ b ∷ []) ≡ K ⨾ a ⨾ b
+      applyWorks K a b = refl
+
+  record Feferman : Type ℓ where
+    field
+      s : A
+      k : A
+      kab≡a : ∀ a b → k ⨾ a ⨾ b ≡ a
+      sabc≡ac_bc : ∀ a b c → s ⨾ a ⨾ b ⨾ c ≡ (a ⨾ c) ⨾ (b ⨾ c)
+      
+  module ComputationRules (feferman : Feferman) where
+    open Feferman feferman
+
+    opaque
+      λ*abst : ∀ {n} → (e : Term (suc n)) → Term n
+      λ*abst {n} (# zero) = ` s ̇ ` k ̇ ` k
+      λ*abst {n} (# (suc x)) = ` k ̇ # x
+      λ*abst {n} (` x) = ` k ̇ ` x
+      λ*abst {n} (e ̇ e₁) = ` s ̇ λ*abst e ̇ λ*abst e₁
+
+    -- Some shortcuts
+
+    λ* : Term one → A
+    λ* t = ⟦ λ*abst t ⟧ []
+
+    λ*2 : Term two → A
+    λ*2 t = ⟦ λ*abst (λ*abst t) ⟧ []
+
+    λ*3 : Term three → A
+    λ*3 t = ⟦ λ*abst (λ*abst (λ*abst t)) ⟧ []
+
+    λ*4 : Term four → A
+    λ*4 t = ⟦ λ*abst (λ*abst (λ*abst (λ*abst t))) ⟧ []
+
+    opaque
+      unfolding λ*abst
+      βreduction : ∀ {n} → (body : Term (suc n)) → (prim : A) → (subs : Vec A n) → ⟦ λ*abst body ̇ ` prim ⟧ subs ≡ ⟦ body ⟧ (prim ∷ subs)
+      βreduction {n} (# zero) prim subs =
+        s ⨾ k ⨾ k ⨾ prim
+          ≡⟨ sabc≡ac_bc _ _ _ ⟩
+        k ⨾ prim ⨾ (k ⨾ prim)
+          ≡⟨ kab≡a _ _ ⟩
+        prim
+          ∎
+      βreduction {n} (# (suc x)) prim subs = kab≡a _ _
+      βreduction {n} (` x) prim subs = kab≡a _ _
+      βreduction {n} (rator ̇ rand) prim subs =
+        s ⨾ ⟦ λ*abst rator ⟧ subs ⨾ ⟦ λ*abst rand ⟧ subs ⨾ prim
+          ≡⟨ sabc≡ac_bc _ _ _ ⟩
+        ⟦ λ*abst rator ⟧ subs ⨾ prim ⨾ (⟦ λ*abst rand ⟧ subs ⨾ prim)
+          ≡⟨ cong₂ (λ x y → x ⨾ y) (βreduction rator prim subs) (βreduction rand prim subs) ⟩
+        ⟦ rator ⟧ (prim ∷ subs) ⨾ ⟦ rand ⟧ (prim ∷ subs)
+          ∎
+
+    λ*chainTerm : ∀ n → Term n → Term zero
+    λ*chainTerm zero t = t
+    λ*chainTerm (suc n) t = λ*chainTerm n (λ*abst t)
+
+    λ*chain : ∀ {n} → Term n → A
+    λ*chain {n} t = ⟦ λ*chainTerm n t ⟧ []
+
+    opaque
+      unfolding reverse
+      unfolding foldl
+      unfolding chain
+
+      λ*ComputationRule : ∀ (t : Term 1) (a : A) → λ* t ⨾ a ≡ ⟦ t ⟧ (a ∷ [])
+      λ*ComputationRule t a =
+        ⟦ λ*abst t ⟧ [] ⨾ a
+          ≡⟨ βreduction t a [] ⟩
+        ⟦ t ⟧ (a ∷ [])
+          ∎
+
+      λ*2ComputationRule : ∀ (t : Term 2) (a b : A) → λ*2 t ⨾ a ⨾ b ≡ ⟦ t ⟧ (b ∷ a ∷ [])
+      λ*2ComputationRule t a b =
+        ⟦ λ*abst (λ*abst t) ⟧ [] ⨾ a ⨾ b
+          ≡⟨ refl ⟩
+        ⟦ λ*abst (λ*abst t) ⟧ [] ⨾ ⟦ ` a ⟧ [] ⨾ ⟦ ` b ⟧ []
+          ≡⟨ refl ⟩
+        ⟦ λ*abst (λ*abst t) ̇ ` a ⟧ [] ⨾ ⟦ ` b ⟧ []
+          ≡⟨ cong (λ x → x ⨾ b) (βreduction (λ*abst t) a []) ⟩
+        ⟦ λ*abst t ⟧ (a ∷ []) ⨾ b
+          ≡⟨ βreduction t b (a ∷ []) ⟩
+        ⟦ t ⟧ (b ∷ a ∷ [])
+          ∎
+          
+      λ*3ComputationRule : ∀ (t : Term 3) (a b c : A) → λ*3 t ⨾ a ⨾ b ⨾ c ≡ ⟦ t ⟧ (c ∷ b ∷ a ∷ [])
+      λ*3ComputationRule t a b c =
+        ⟦ λ*abst (λ*abst (λ*abst t)) ⟧ [] ⨾ ⟦ ` a ⟧ [] ⨾ ⟦ ` b ⟧ [] ⨾ ⟦ ` c ⟧ []
+          ≡⟨ cong (λ x → x ⨾ b ⨾ c) (βreduction (λ*abst (λ*abst t)) a []) ⟩
+        ⟦ λ*abst (λ*abst t) ⟧ (a ∷ []) ⨾ ⟦ ` b ⟧ (a ∷ []) ⨾ ⟦ ` c ⟧ (a ∷ [])
+          ≡⟨ cong (λ x → x ⨾ c) (βreduction (λ*abst t) b (a ∷ [])) ⟩
+        ⟦ λ*abst t ⟧ (b ∷ a ∷ []) ⨾ ⟦ ` c ⟧ (b ∷ a ∷ [])
+          ≡⟨ βreduction t c (b ∷ a ∷ []) ⟩
+        ⟦ t ⟧ (c ∷ b ∷ a ∷ [])
+          ∎
+
+      λ*4ComputationRule : ∀ (t : Term 4) (a b c d : A) → λ*4 t ⨾ a ⨾ b ⨾ c ⨾ d ≡ ⟦ t ⟧ (d ∷ c ∷ b ∷ a ∷ [])
+      λ*4ComputationRule t a b c d =
+        ⟦ λ*abst (λ*abst (λ*abst (λ*abst t))) ⟧ [] ⨾ ⟦ ` a ⟧ [] ⨾ ⟦ ` b ⟧ [] ⨾ ⟦ ` c ⟧ [] ⨾ ⟦ ` d ⟧ []
+          ≡⟨ cong (λ x → x ⨾ b ⨾ c ⨾ d) (βreduction (λ*abst (λ*abst (λ*abst t))) a []) ⟩
+        ⟦ λ*abst (λ*abst (λ*abst t)) ⟧ (a ∷ []) ⨾ ⟦ ` b ⟧ (a ∷ []) ⨾ ⟦ ` c ⟧ (a ∷ []) ⨾ ⟦ ` d ⟧ (a ∷ [])
+          ≡⟨ cong (λ x → x ⨾ c ⨾ d) (βreduction (λ*abst (λ*abst t)) b (a ∷ [])) ⟩
+        ⟦ λ*abst (λ*abst t) ⟧ (b ∷ a ∷ []) ⨾ ⟦ ` c ⟧ (b ∷ a ∷ []) ⨾ ⟦ ` d ⟧ (b ∷ a ∷ [])
+          ≡⟨ cong (λ x → x ⨾ d) (βreduction (λ*abst t) c (b ∷ a ∷ [])) ⟩
+        ⟦ λ*abst t ⟧ (c ∷ b ∷ a ∷ []) ⨾ ⟦ ` d ⟧ (c ∷ b ∷ a ∷ [])
+          ≡⟨ βreduction t d (c ∷ b ∷ a ∷ []) ⟩
+        ⟦ t ⟧ (d ∷ c ∷ b ∷ a ∷ [])
+          ∎
 

\ No newline at end of file
diff --git a/docs/Realizability.Choice.html b/docs/Realizability.Choice.html
index 8d7739a..1980acf 100644
--- a/docs/Realizability.Choice.html
+++ b/docs/Realizability.Choice.html
@@ -10,5 +10,5 @@
 module Realizability.Choice where
 
 Choice : ∀ ℓ ℓ' → Type (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ'))
-Choice ℓ ℓ' = (A : Type ℓ) (B : Type ℓ') → isSet A → isSet B → (f : A → B) → isSurjection f → ∃[ f' ∈ (B → A) ] section f f'
+Choice ℓ ℓ' = (A : Type ℓ) (B : Type ℓ') → isSet A → isSet B → (f : A → B) → isSurjection f → ∃[ f' ∈ (B → A) ] section f f'
\ No newline at end of file diff --git a/docs/Realizability.CombinatoryAlgebra.html b/docs/Realizability.CombinatoryAlgebra.html index a8dc055..1cb4a61 100644 --- a/docs/Realizability.CombinatoryAlgebra.html +++ b/docs/Realizability.CombinatoryAlgebra.html @@ -6,192 +6,195 @@ open import Cubical.Data.Unit open import Cubical.Data.Nat -open import Realizability.ApplicativeStructure hiding (S;K) +open import Realizability.ApplicativeStructure -module Realizability.CombinatoryAlgebra where +module Realizability.CombinatoryAlgebra where -record CombinatoryAlgebra {ℓ} (A : Type ℓ) : Type ℓ where - field - as : ApplicativeStructure A - completeness : isCombinatoriallyComplete as - fefermanStructure : Feferman as - fefermanStructure = completeness→feferman as completeness - open Feferman fefermanStructure public - open ApplicativeStructure as public +record CombinatoryAlgebra {ℓ} (A : Type ℓ) : Type ℓ where + field + as : ApplicativeStructure A + fefermanStructure : Feferman as + open Feferman fefermanStructure public + open ApplicativeStructure as public + open ComputationRules as fefermanStructure public -module Combinators {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where - open CombinatoryAlgebra ca +module Combinators {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where + open CombinatoryAlgebra ca - i : A - i = s ⨾ k ⨾ k - - k' : A - k' = k ⨾ i - - ia≡a : ∀ a → i ⨾ a ≡ a - ia≡a a = (cong (λ x → x ⨾ a) refl) ∙ (sabc≡ac_bc k k a) ∙ (kab≡a a (k ⨾ a)) - - k'ab≡b : ∀ a b → k' ⨾ a ⨾ b ≡ b - k'ab≡b a b = k' ⨾ a ⨾ b - ≡⟨ refl ⟩ - (k ⨾ i ⨾ a ⨾ b) - ≡⟨ cong (λ x → x ⨾ b) (kab≡a i a) ⟩ - (i ⨾ b) - ≡⟨ ia≡a b ⟩ - b - ∎ - - true : A - true = k - - false : A - false = k' - - if_then_else_ : ∀ c t e → A - if c then t else e = i ⨾ c ⨾ t ⨾ e - - ifTrueThen : ∀ t e → if true then t else e ≡ t - ifTrueThen t e = if true then t else e - ≡⟨ refl ⟩ - i ⨾ true ⨾ t ⨾ e - ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ - i ⨾ k ⨾ t ⨾ e - ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k) ⟩ - k ⨾ t ⨾ e - ≡⟨ kab≡a t e ⟩ - t - ∎ - - ifFalseElse : ∀ t e → if false then t else e ≡ e - ifFalseElse t e = if false then t else e - ≡⟨ refl ⟩ - i ⨾ false ⨾ t ⨾ e - ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ - i ⨾ k' ⨾ t ⨾ e - ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k') ⟩ - k' ⨾ t ⨾ e - ≡⟨ k'ab≡b t e ⟩ - e - ∎ - - -- I used a Scheme script to generate this - pair : A - pair = s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ - (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k))))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))))) ⨾ (s ⨾ - (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (s ⨾ (k) ⨾ (k))))))) ⨾ - (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (k ⨾ (k))) ⨾ (k ⨾ (k)))) - - pr₁ : A - pr₁ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) - - pr₂ : A - pr₂ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k') - - -- TODO : Prove computation rules - postulate pr₁pxy≡x : ∀ x y → pr₁ ⨾ (pair ⨾ x ⨾ y) ≡ x - postulate pr₂pxy≡y : ∀ x y → pr₂ ⨾ (pair ⨾ x ⨾ y) ≡ y - - -- Curry numbers - ℕ→curry : ℕ → A - ℕ→curry zero = i - ℕ→curry (suc n) = pair ⨾ k' ⨾ (ℕ→curry n) - - Z : A - Z = pr₁ - - Zzero≡true : Z ⨾ (ℕ→curry zero) ≡ true - Zzero≡true = Z ⨾ (ℕ→curry zero) - ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ - Z ⨾ i - ≡⟨ cong (λ x → x ⨾ i) refl ⟩ - s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) ⨾ i - ≡⟨ sabc≡ac_bc (s ⨾ k ⨾ k) (k ⨾ k) i ⟩ - ((s ⨾ k ⨾ k) ⨾ i) ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → (x ⨾ i) ⨾ (k ⨾ k ⨾ i)) refl ⟩ - (i ⨾ i) ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ i)) (ia≡a i) ⟩ - i ⨾ (k ⨾ k ⨾ i) - ≡⟨ cong (λ x → i ⨾ x) (kab≡a k i) ⟩ - i ⨾ k - ≡⟨ ia≡a k ⟩ - k - ∎ - - Zsuc≡false : ∀ n → Z ⨾ (ℕ→curry (suc n)) ≡ false - Zsuc≡false n = Z ⨾ (ℕ→curry (suc n)) - ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ - Z ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) - ≡⟨ cong (λ x → x ⨾ (pair ⨾ k' ⨾ (ℕ→curry n))) refl ⟩ - pr₁ ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) - ≡⟨ pr₁pxy≡x k' (ℕ→curry n) ⟩ - false - ∎ - - S : A - S = pair ⨾ k' - - Sn≡sucn : ∀ n → S ⨾ (ℕ→curry n) ≡ ℕ→curry (suc n) - Sn≡sucn n = S ⨾ (ℕ→curry n) - ≡⟨ cong (λ x → x ⨾ (ℕ→curry n)) refl ⟩ - pair ⨾ k' ⨾ (ℕ→curry n) - ∎ - - P : A - P = s ⨾ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ i) ⨾ (k ⨾ (ℕ→curry zero))) ⨾ (s ⨾ (k ⨾ (pr₂)) ⨾ i) - - postulate Pzero≡zero : P ⨾ (ℕ→curry zero) ≡ ℕ→curry zero - postulate Psucn≡n : ∀ n → P ⨾ (ℕ→curry (suc n)) ≡ ℕ→curry n - - B : ∀ g f → A - B g f = s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) - - Ba≡gfa : ∀ g f a → B g f ⨾ a ≡ g ⨾ (f ⨾ a) - Ba≡gfa g f a = - s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) ⨾ a - ≡⟨ sabc≡ac_bc (k ⨾ g) (s ⨾ (k ⨾ f) ⨾ i) a ⟩ - (k ⨾ g ⨾ a) ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) - ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a)) (kab≡a g a) ⟩ - g ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) - ≡⟨ cong (λ x → g ⨾ x) (sabc≡ac_bc (k ⨾ f) i a) ⟩ - g ⨾ ((k ⨾ f ⨾ a) ⨾ (i ⨾ a)) - ≡⟨ cong (λ x → g ⨾ (x ⨾ (i ⨾ a))) (kab≡a f a) ⟩ - g ⨾ (f ⨾ (i ⨾ a)) - ≡⟨ cong (λ x → g ⨾ (f ⨾ x)) (ia≡a a) ⟩ - g ⨾ (f ⨾ a) - ∎ - - -module Trivial {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where - open CombinatoryAlgebra ca - open Combinators ca - module _ (isNonTrivial : s ≡ k → ⊥) where - - k≠k' : k ≡ k' → ⊥ - k≠k' k≡k' = isNonTrivial s≡k where - cond = if true then s else k - cond' = if false then s else k - condEq : cond ≡ cond' - condEq = cong (λ x → if x then s else k) k≡k' + i : A + i = s ⨾ k ⨾ k + + k' : A + k' = k ⨾ i + + ia≡a : ∀ a → i ⨾ a ≡ a + ia≡a a = (cong (λ x → x ⨾ a) refl) ∙ (sabc≡ac_bc k k a) ∙ (kab≡a a (k ⨾ a)) + + k'ab≡b : ∀ a b → k' ⨾ a ⨾ b ≡ b + k'ab≡b a b = k' ⨾ a ⨾ b + ≡⟨ refl ⟩ + (k ⨾ i ⨾ a ⨾ b) + ≡⟨ cong (λ x → x ⨾ b) (kab≡a i a) ⟩ + (i ⨾ b) + ≡⟨ ia≡a b ⟩ + b + ∎ + + true : A + true = k + + false : A + false = k' + + if_then_else_ : ∀ c t e → A + if c then t else e = i ⨾ c ⨾ t ⨾ e + + ifTrueThen : ∀ t e → if true then t else e ≡ t + ifTrueThen t e = if true then t else e + ≡⟨ refl ⟩ + i ⨾ true ⨾ t ⨾ e + ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ + i ⨾ k ⨾ t ⨾ e + ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k) ⟩ + k ⨾ t ⨾ e + ≡⟨ kab≡a t e ⟩ + t + ∎ + + ifFalseElse : ∀ t e → if false then t else e ≡ e + ifFalseElse t e = if false then t else e + ≡⟨ refl ⟩ + i ⨾ false ⨾ t ⨾ e + ≡⟨ cong (λ x → i ⨾ x ⨾ t ⨾ e) refl ⟩ + i ⨾ k' ⨾ t ⨾ e + ≡⟨ cong (λ x → x ⨾ t ⨾ e) (ia≡a k') ⟩ + k' ⨾ t ⨾ e + ≡⟨ k'ab≡b t e ⟩ + e + ∎ + + -- I used a Scheme script to generate this + opaque + pair : A + pair = s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (s)))) ⨾ + (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k))))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))))) ⨾ (s ⨾ + (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (s ⨾ (k) ⨾ (k))))))) ⨾ + (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (s ⨾ (k ⨾ (k)) ⨾ (k ⨾ (k)))) ⨾ (s ⨾ (s ⨾ (k ⨾ (s)) ⨾ (k ⨾ (k))) ⨾ (k ⨾ (k)))) + + opaque + pr₁ : A + pr₁ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) + + pr₂ : A + pr₂ = s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k') + + -- TODO : Prove computation rules + postulate pr₁pxy≡x : ∀ x y → pr₁ ⨾ (pair ⨾ x ⨾ y) ≡ x + postulate pr₂pxy≡y : ∀ x y → pr₂ ⨾ (pair ⨾ x ⨾ y) ≡ y + + -- Curry numbers + ℕ→curry : ℕ → A + ℕ→curry zero = i + ℕ→curry (suc n) = pair ⨾ k' ⨾ (ℕ→curry n) + + Z : A + Z = pr₁ + + opaque + unfolding pr₁ + Zzero≡true : Z ⨾ (ℕ→curry zero) ≡ true + Zzero≡true = Z ⨾ (ℕ→curry zero) + ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ + Z ⨾ i + ≡⟨ cong (λ x → x ⨾ i) refl ⟩ + s ⨾ (s ⨾ k ⨾ k) ⨾ (k ⨾ k) ⨾ i + ≡⟨ sabc≡ac_bc (s ⨾ k ⨾ k) (k ⨾ k) i ⟩ + ((s ⨾ k ⨾ k) ⨾ i) ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → (x ⨾ i) ⨾ (k ⨾ k ⨾ i)) refl ⟩ + (i ⨾ i) ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ i)) (ia≡a i) ⟩ + i ⨾ (k ⨾ k ⨾ i) + ≡⟨ cong (λ x → i ⨾ x) (kab≡a k i) ⟩ + i ⨾ k + ≡⟨ ia≡a k ⟩ + k + ∎ + + Zsuc≡false : ∀ n → Z ⨾ (ℕ→curry (suc n)) ≡ false + Zsuc≡false n = Z ⨾ (ℕ→curry (suc n)) + ≡⟨ cong (λ x → Z ⨾ x) refl ⟩ + Z ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) + ≡⟨ cong (λ x → x ⨾ (pair ⨾ k' ⨾ (ℕ→curry n))) refl ⟩ + pr₁ ⨾ (pair ⨾ k' ⨾ (ℕ→curry n)) + ≡⟨ pr₁pxy≡x k' (ℕ→curry n) ⟩ + false + ∎ + + S : A + S = pair ⨾ k' + + Sn≡sucn : ∀ n → S ⨾ (ℕ→curry n) ≡ ℕ→curry (suc n) + Sn≡sucn n = S ⨾ (ℕ→curry n) + ≡⟨ cong (λ x → x ⨾ (ℕ→curry n)) refl ⟩ + pair ⨾ k' ⨾ (ℕ→curry n) + ∎ + + P : A + P = s ⨾ (s ⨾ (s ⨾ (k ⨾ pr₁) ⨾ i) ⨾ (k ⨾ (ℕ→curry zero))) ⨾ (s ⨾ (k ⨾ (pr₂)) ⨾ i) + + postulate Pzero≡zero : P ⨾ (ℕ→curry zero) ≡ ℕ→curry zero + postulate Psucn≡n : ∀ n → P ⨾ (ℕ→curry (suc n)) ≡ ℕ→curry n + + B : ∀ g f → A + B g f = s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) + + Ba≡gfa : ∀ g f a → B g f ⨾ a ≡ g ⨾ (f ⨾ a) + Ba≡gfa g f a = + s ⨾ (k ⨾ g) ⨾ (s ⨾ (k ⨾ f) ⨾ i) ⨾ a + ≡⟨ sabc≡ac_bc (k ⨾ g) (s ⨾ (k ⨾ f) ⨾ i) a ⟩ + (k ⨾ g ⨾ a) ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) + ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a)) (kab≡a g a) ⟩ + g ⨾ (s ⨾ (k ⨾ f) ⨾ i ⨾ a) + ≡⟨ cong (λ x → g ⨾ x) (sabc≡ac_bc (k ⨾ f) i a) ⟩ + g ⨾ ((k ⨾ f ⨾ a) ⨾ (i ⨾ a)) + ≡⟨ cong (λ x → g ⨾ (x ⨾ (i ⨾ a))) (kab≡a f a) ⟩ + g ⨾ (f ⨾ (i ⨾ a)) + ≡⟨ cong (λ x → g ⨾ (f ⨾ x)) (ia≡a a) ⟩ + g ⨾ (f ⨾ a) + ∎ + + +module Trivial {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where + open CombinatoryAlgebra ca + open Combinators ca + module _ (isNonTrivial : s ≡ k → ⊥) where + + k≠k' : k ≡ k' → ⊥ + k≠k' k≡k' = isNonTrivial s≡k where + cond = if true then s else k + cond' = if false then s else k + condEq : cond ≡ cond' + condEq = cong (λ x → if x then s else k) k≡k' - cond≡s : cond ≡ s - cond≡s = ifTrueThen _ _ - - cond'≡k : cond' ≡ k - cond'≡k = ifFalseElse _ _ - - cond≡k : cond ≡ k - cond≡k = subst (λ x → x ≡ k) (sym condEq) cond'≡k - - s≡k : s ≡ k - s≡k = - s - ≡⟨ sym cond≡s ⟩ - cond - ≡⟨ cond≡k ⟩ - k - ∎ + cond≡s : cond ≡ s + cond≡s = ifTrueThen _ _ + + cond'≡k : cond' ≡ k + cond'≡k = ifFalseElse _ _ + + cond≡k : cond ≡ k + cond≡k = subst (λ x → x ≡ k) (sym condEq) cond'≡k + + s≡k : s ≡ k + s≡k = + s + ≡⟨ sym cond≡s ⟩ + cond + ≡⟨ cond≡k ⟩ + k + ∎ \ No newline at end of file diff --git a/docs/Realizability.PropResizing.html b/docs/Realizability.PropResizing.html new file mode 100644 index 0000000..5c3006b --- /dev/null +++ b/docs/Realizability.PropResizing.html @@ -0,0 +1,25 @@ + +Realizability.PropResizing
open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Structure
+open import Cubical.Data.Sigma
+
+module Realizability.PropResizing where
+
+-- Formulation of propositional resizing inspired by the corresponding formulation
+-- in TypeTopology
+-- https://www.cs.bham.ac.uk/~mhe/TypeTopology/UF.Size.html
+
+copyOf : ∀ {ℓ} → Type ℓ → (ℓ' : Level) → Type _
+copyOf {ℓ} X ℓ' = Σ[ copy ∈ Type ℓ' ] X ≃ copy
+
+copy = fst
+copyEquiv = snd
+
+-- We need the principle that TypeTopology calls Ω resizing
+-- that the universe of props in a universe 𝓤 has a copy in 𝓤
+-- This we call hPropResizing
+hPropResizing : ∀ ℓ → Type _
+hPropResizing ℓ = copyOf (hProp ℓ) ℓ
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.BinProducts.html b/docs/Realizability.Topos.BinProducts.html new file mode 100644 index 0000000..aa2db2e --- /dev/null +++ b/docs/Realizability.Topos.BinProducts.html @@ -0,0 +1,602 @@ + +Realizability.Topos.BinProducts
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Data.Unit
+open import Cubical.Data.Empty
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Sigma
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Limits.BinProduct
+
+module Realizability.Topos.BinProducts
+  {ℓ ℓ' ℓ''} {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial 
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open PredicateProperties
+open Morphism
+
+open FunctionalRelation
+open PartialEquivalenceRelation hiding (isSetX)
+module _
+  {X : Type ℓ'}
+  {Y : Type ℓ'}
+  (perX : PartialEquivalenceRelation X)
+  (perY : PartialEquivalenceRelation Y) where
+
+  opaque private
+    isSetX : isSet X
+    isSetX = PartialEquivalenceRelation.isSetX perX
+    isSetY : isSet Y
+    isSetY = PartialEquivalenceRelation.isSetX perY
+
+  opaque
+    {-# TERMINATING #-}
+    binProdObRT : PartialEquivalenceRelation (X × Y)
+    Predicate.isSetX (PartialEquivalenceRelation.equality binProdObRT) =
+      isSet× (isSet× isSetX isSetY) (isSet× isSetX isSetY)
+    Predicate.∣ PartialEquivalenceRelation.equality binProdObRT ∣ ((x , y) , x' , y') r =
+      (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ perY .equality ∣ (y , y')
+    Predicate.isPropValued (PartialEquivalenceRelation.equality binProdObRT) ((x , y) , x' , y') r =
+      isProp× (perX .equality .isPropValued _ _) (perY .equality .isPropValued _ _)
+    isPartialEquivalenceRelation.isSetX (PartialEquivalenceRelation.isPerEquality binProdObRT) = isSet× isSetX isSetY
+    isPartialEquivalenceRelation.isSymmetric (PartialEquivalenceRelation.isPerEquality binProdObRT) =
+      do
+        (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+        (sY , sY⊩isSymmetricY) ← perY .isSymmetric
+        let
+          prover : ApplStrTerm as 1
+          prover = ` pair ̇ (` sX ̇ (` pr₁ ̇ # zero)) ̇ (` sY ̇ (` pr₂ ̇ # zero))
+        return
+          (λ* prover ,
+          (λ { (x , y) (x' , y') r (pr₁r⊩x~x' , pr₂r⊩y~y') →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+              (sX⊩isSymmetricX x x' (pr₁ ⨾ r) pr₁r⊩x~x') ,
+            subst
+              (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y))
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+              (sY⊩isSymmetricY y y' (pr₂ ⨾ r) pr₂r⊩y~y') }))
+    isPartialEquivalenceRelation.isTransitive (PartialEquivalenceRelation.isPerEquality binProdObRT) =
+      do
+        (tX , tX⊩isTransitiveX) ← perX .isTransitive
+        (tY , tY⊩isTransitiveY) ← perY .isTransitive
+        let
+          prover : ApplStrTerm as 2
+          prover = ` pair ̇ (` tX ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` tY ̇ (` pr₂ ̇ # one) ̇ (` pr₂ ̇ # zero))
+        return
+          (λ*2 prover ,
+          (λ { (x , y) (x' , y') (x'' , y'') a b (pr₁a⊩x~x' , pr₂a⊩y~y') (pr₁b⊩x'~x'' , pr₂b⊩y'~y'') →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x''))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule prover a b) ∙ pr₁pxy≡x _ _))
+              (tX⊩isTransitiveX x x' x'' (pr₁ ⨾ a) (pr₁ ⨾ b) pr₁a⊩x~x' pr₁b⊩x'~x'') ,
+            subst
+              (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y''))
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule prover a b) ∙ pr₂pxy≡y _ _))
+              (tY⊩isTransitiveY y y' y'' (pr₂ ⨾ a) (pr₂ ⨾ b) pr₂a⊩y~y' pr₂b⊩y'~y'') }))
+
+  opaque
+    unfolding binProdObRT
+    unfolding idFuncRel
+    binProdPr₁FuncRel : FunctionalRelation binProdObRT perX
+    FunctionalRelation.relation binProdPr₁FuncRel =
+      record
+        { isSetX = isSet× (isSet× isSetX isSetY) isSetX
+        ; ∣_∣ = λ { ((x , y) , x') r → (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ perY .equality ∣ (y , y) }
+        ; isPropValued = (λ { ((x , y) , x') r → isProp× (perX .equality .isPropValued _ _) (perY .equality .isPropValued _ _) }) }
+    FunctionalRelation.isFuncRel binProdPr₁FuncRel =
+      record
+       { isStrictDomain =
+         do
+           (stD , stD⊩isStrictDomainEqX) ← idFuncRel perX .isStrictDomain
+           let
+             prover : ApplStrTerm as 1
+             prover = ` pair ̇ (` stD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ (# zero))
+           return
+             (λ* prover ,
+             (λ { (x , y) x' r (pr₁r⊩x~x' , pr₂r⊩y~y) →
+               subst
+                 (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                 (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                 (stD⊩isStrictDomainEqX x x' (pr₁ ⨾ r) pr₁r⊩x~x') ,
+               subst
+                 (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y))
+                 (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                 pr₂r⊩y~y }))
+       ; isStrictCodomain =
+         do
+           (stC , stC⊩isStrictCodomainEqX) ← idFuncRel perX .isStrictCodomain
+           let
+             prover : ApplStrTerm as 1
+             prover = ` stC ̇ (` pr₁ ̇ # zero)
+           return
+             (λ* prover ,
+              λ { (x , y) x' r (pr₁r⊩x~x' , pr₂r⊩y~y) →
+                subst
+                  (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'))
+                  (sym (λ*ComputationRule prover r))
+                  (stC⊩isStrictCodomainEqX x x' (pr₁ ⨾ r) pr₁r⊩x~x') })
+       ; isRelational =
+         do
+           (stC , stC⊩isStrictCodomainEqY) ← idFuncRel perY .isStrictCodomain
+           (t , t⊩isTransitiveX) ← perX .isTransitive
+           (s , s⊩isSymmetricX) ← perX .isSymmetric
+           let
+             prover : ApplStrTerm as 3
+             prover = ` pair ̇ (` t ̇ (` s ̇ (` pr₁ ̇ # two)) ̇ (` t ̇ (` pr₁ ̇ # one) ̇ # zero)) ̇ (` stC ̇ (` pr₂ ̇ # two))
+           return
+             (λ*3 prover ,
+              ((λ { (x , y) (x' , y') x'' x''' a b c (pr₁a⊩x~x' , pr₂a⊩y~y') (pr₁b⊩x~x'' , pr₂b⊩y~y) c⊩x''~x''' →
+                subst
+                  (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'''))
+                  (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₁pxy≡x _ _))
+                  (t⊩isTransitiveX
+                    x' x x'''
+                    (s ⨾ (pr₁ ⨾ a)) (t ⨾ (pr₁ ⨾ b) ⨾ c)
+                    (s⊩isSymmetricX x x' (pr₁ ⨾ a) pr₁a⊩x~x')
+                    (t⊩isTransitiveX x x'' x''' (pr₁ ⨾ b) c pr₁b⊩x~x'' c⊩x''~x''')) ,
+                subst
+                  (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y'))
+                  (sym (cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₂pxy≡y _ _))
+                  (stC⊩isStrictCodomainEqY y y' (pr₂ ⨾ a) pr₂a⊩y~y') })))
+       ; isSingleValued =
+         do
+           (t , t⊩isTransitive) ← perX .isTransitive
+           (s , s⊩isSymmetric) ← perX .isSymmetric
+           let
+             prover : ApplStrTerm as 2
+             prover = ` t ̇ (` s ̇ (` pr₁ ̇ # one)) ̇ (` pr₁ ̇ # zero)
+           return
+             (λ*2 prover ,
+              (λ { (x , y) x' x'' r₁ r₂ (pr₁r₁⊩x~x' , pr₂r₁⊩y~y) (pr₁r₂⊩x~x'' , pr₂r₂⊩y~y) →
+                subst
+                  (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x''))
+                  (sym (λ*2ComputationRule prover r₁ r₂))
+                  (t⊩isTransitive x' x x'' (s ⨾ (pr₁ ⨾ r₁)) (pr₁ ⨾ r₂) (s⊩isSymmetric x x' (pr₁ ⨾ r₁) pr₁r₁⊩x~x') pr₁r₂⊩x~x'')}))
+       ; isTotal =
+         do
+           return
+             (Id ,
+              (λ { (x , y) r (pr₁r⊩x~x , pr₂r⊩y~y) →
+                return
+                  (x ,
+                  ((subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (cong (λ x → pr₁ ⨾ x) (sym (Ida≡a _))) pr₁r⊩x~x) ,
+                   (subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y)) (cong (λ x → pr₂ ⨾ x) (sym (Ida≡a _))) pr₂r⊩y~y))) }))
+       }
+
+  opaque
+    binProdPr₁RT : RTMorphism binProdObRT perX
+    binProdPr₁RT = [ binProdPr₁FuncRel ]
+
+  -- Code repetition to a degree
+  -- TODO : Refactor into a proper abstraction
+  opaque
+    unfolding binProdObRT
+    unfolding idFuncRel
+    binProdPr₂FuncRel : FunctionalRelation binProdObRT perY
+    FunctionalRelation.relation binProdPr₂FuncRel =
+      record
+        { isSetX = isSet× (isSet× isSetX isSetY) isSetY
+        ; ∣_∣ = λ { ((x , y) , y') r → (pr₁ ⨾ r) ⊩ ∣ perY .equality ∣ (y , y') × (pr₂ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x) }
+        ; isPropValued = λ { ((x , y) , y') r → isProp× (perY .equality .isPropValued _ _) (perX .equality .isPropValued _ _) } }
+    FunctionalRelation.isFuncRel binProdPr₂FuncRel =
+      record
+       { isStrictDomain =
+         do
+           (stD , stD⊩isStrictDomainEqY) ← idFuncRel perY .isStrictDomain
+           let
+             prover : ApplStrTerm as 1
+             prover = ` pair ̇ (` pr₂ ̇ (# zero)) ̇ (` stD ̇ (` pr₁ ̇ # zero))
+           return
+             (λ* prover ,
+             (λ { (x , y) y' r (pr₁r⊩y~y' , pr₂r⊩x~x) →
+                subst
+                  (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                  (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                  pr₂r⊩x~x ,
+                subst
+                  (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y))
+                  (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                  (stD⊩isStrictDomainEqY y y' (pr₁ ⨾ r) pr₁r⊩y~y') }))
+       ; isStrictCodomain =
+         do
+           (stC , stC⊩isStrictCodomainEqY) ← idFuncRel perY .isStrictCodomain
+           let
+             prover : ApplStrTerm as 1
+             prover = ` stC ̇ (` pr₁ ̇ # zero)
+           return
+             (λ* prover ,
+             (λ { (x , y) y' r (pr₁r⊩y~y' , pr₂r⊩x~x) →
+               subst
+                 (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y'))
+                 (sym (λ*ComputationRule prover r))
+                 (stC⊩isStrictCodomainEqY y y' (pr₁ ⨾ r) pr₁r⊩y~y') }))
+       ; isRelational =
+         do
+           (stC , stC⊩isStrictCodomainEqX) ← idFuncRel perX .isStrictCodomain
+           (relY , relY⊩isRelationalEqY) ← idFuncRel perY .isRelational
+           let
+             prover : ApplStrTerm as 3
+             prover = ` pair ̇ (` relY ̇ (` pr₂ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ # zero) ̇ (` stC ̇ (` pr₁ ̇ # two))
+           return
+             (λ*3 prover ,
+             (λ { (x , y₁) (x' , y₂) y₃ y₄ a b c (pr₁a⊩x~x' , pr₂a⊩y₁~y₂) (pr₁b⊩y₁~y₃ , pr₂b⊩x~x) c⊩y₃~y₄ →
+               subst
+                 (λ r' → r' ⊩ ∣ perY .equality ∣ (y₂ , y₄))
+                 (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₁pxy≡x _ _))
+                 (relY⊩isRelationalEqY y₁ y₂ y₃ y₄ (pr₂ ⨾ a) (pr₁ ⨾ b) c pr₂a⊩y₁~y₂ pr₁b⊩y₁~y₃ c⊩y₃~y₄) ,
+               subst
+                 (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'))
+                 (sym (cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₂pxy≡y _ _))
+                 (stC⊩isStrictCodomainEqX x x' (pr₁ ⨾ a) pr₁a⊩x~x') }))
+       ; isSingleValued =
+         do
+           (svY , svY⊩isSingleValuedY) ← idFuncRel perY .isSingleValued
+           let
+             prover : ApplStrTerm as 2
+             prover = ` svY ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)
+           return
+             (λ*2 prover ,
+             (λ { (x , y) y' y'' r₁ r₂ (pr₁r₁⊩y~y' , pr₂r₁⊩x~x) (pr₁r₂⊩y~y'' , pr₂r₂⊩) →
+               subst
+                 (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y''))
+                 (sym (λ*2ComputationRule prover r₁ r₂))
+                 (svY⊩isSingleValuedY y y' y'' (pr₁ ⨾ r₁) (pr₁ ⨾ r₂) pr₁r₁⊩y~y' pr₁r₂⊩y~y'') }))
+       ; isTotal =
+         do
+           let
+             prover : ApplStrTerm as 1
+             prover = ` pair ̇ (` pr₂ ̇ # zero) ̇ (` pr₁ ̇ # zero)
+           return
+             (λ* prover ,
+             (λ { (x , y) r (pr₁r⊩x~x , pr₂r⊩y~y) →
+               return
+                 (y ,
+                   (subst
+                     (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y))
+                     (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                     pr₂r⊩y~y ,
+                    subst
+                     (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                     (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                     pr₁r⊩x~x)) }))
+       }
+
+  binProdPr₂RT : RTMorphism binProdObRT perY
+  binProdPr₂RT = [ binProdPr₂FuncRel ]
+
+  module UnivProp
+    {Z : Type ℓ'}
+    (perZ : PartialEquivalenceRelation Z)
+    (f : RTMorphism perZ perX)
+    (g : RTMorphism perZ perY) where
+
+    isSetZ = PartialEquivalenceRelation.isSetX perZ
+
+    opaque
+      unfolding binProdObRT
+      theFuncRel : (F : FunctionalRelation perZ perX) → (G : FunctionalRelation perZ perY) → FunctionalRelation perZ binProdObRT
+      theFuncRel F G =
+        record
+              { relation =
+                record
+                  { isSetX = isSet× isSetZ (isSet× isSetX isSetY)
+                  ; ∣_∣ = λ { (z , x , y) r → (pr₁ ⨾ r) ⊩ ∣ F .relation ∣ (z , x) × (pr₂ ⨾ r) ⊩ ∣ G .relation ∣ (z , y) }
+                ; isPropValued = λ { (z , x , y) r → isProp× (F .relation .isPropValued _ _) (G .relation .isPropValued _ _) } }
+              ; isFuncRel =
+                record
+                 { isStrictDomain =
+                   do
+                     (stFD , stFD⊩isStrictDomain) ← F .isStrictDomain
+                     let
+                       prover : ApplStrTerm as 1
+                       prover = ` stFD ̇ (` pr₁ ̇ # zero)
+                     return
+                       (λ* prover ,
+                        (λ { z (x , y) r (pr₁r⊩Fzx , pr₂r⊩Gzy) →
+                          subst
+                            (λ r' → r' ⊩ ∣ perZ .equality ∣ (z , z))
+                            (sym (λ*ComputationRule prover r))
+                            (stFD⊩isStrictDomain z x (pr₁ ⨾ r) pr₁r⊩Fzx) }))
+                 ; isStrictCodomain =
+                   do
+                     (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+                     (stGC , stGC⊩isStrictCodomainG) ← G .isStrictCodomain
+                     let
+                       prover : ApplStrTerm as 1
+                       prover = ` pair ̇ (` stFC ̇ (` pr₁ ̇ # zero)) ̇ (` stGC ̇ (` pr₂ ̇ # zero))
+                     return
+                       (λ* prover ,
+                       (λ { z (x , y) r (pr₁r⊩Fzx , pr₂r⊩Gzy) →
+                         subst
+                           (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                           (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                           (stFC⊩isStrictCodomainF z x (pr₁ ⨾ r) pr₁r⊩Fzx) ,
+                         subst
+                           (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y))
+                           (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                           (stGC⊩isStrictCodomainG z y (pr₂ ⨾ r) pr₂r⊩Gzy) }))
+                 ; isRelational =
+                   do
+                     (relF , relF⊩isRelationalF) ← F .isRelational
+                     (relG , relG⊩isRelationalG) ← G .isRelational
+                     let
+                       prover : ApplStrTerm as 3
+                       prover = ` pair ̇ (` relF ̇ # two ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` relG ̇ # two ̇ (` pr₂ ̇ # one) ̇ (` pr₂ ̇ # zero))
+                     return
+                       (λ*3 prover ,
+                       (λ { z z' (x , y) (x' , y') a b c a⊩z~z' (pr₁b⊩Fzx , pr₂b⊩Gzy) (pr₁c⊩x~x' , pr₂c⊩y~y') →
+                         (subst (λ r' → r' ⊩ ∣ F .relation ∣ (z' , x')) (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₁pxy≡x _ _)) (relF⊩isRelationalF z z' x x' _ _ _ a⊩z~z' pr₁b⊩Fzx pr₁c⊩x~x')) ,
+                         subst (λ r' → r' ⊩ ∣ G .relation ∣ (z' , y')) (sym (cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₂pxy≡y _ _)) (relG⊩isRelationalG z z' y y' _ _ _ a⊩z~z' pr₂b⊩Gzy pr₂c⊩y~y') }))
+                 ; isSingleValued =
+                   do
+                     (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+                     (svG , svG⊩isSingleValuedG) ← G .isSingleValued
+                     let
+                       prover : ApplStrTerm as 2
+                       prover = ` pair ̇ (` svF ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` svG ̇ (` pr₂ ̇ # one) ̇ (` pr₂ ̇ # zero))
+                     return
+                       (λ*2 prover ,
+                       (λ { z (x , y) (x' , y') r₁ r₂ (pr₁r₁⊩Fzx , pr₂r₁⊩Gzy) (pr₁r₂⊩Fzx' , pr₂r₂⊩Gzy') →
+                         subst
+                           (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                           (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule prover r₁ r₂) ∙ pr₁pxy≡x _ _))
+                           (svF⊩isSingleValuedF z x x' (pr₁ ⨾ r₁) (pr₁ ⨾ r₂) pr₁r₁⊩Fzx pr₁r₂⊩Fzx') ,
+                         subst
+                           (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y'))
+                           (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule prover r₁ r₂) ∙ pr₂pxy≡y _ _))
+                           (svG⊩isSingleValuedG z y y' (pr₂ ⨾ r₁) (pr₂ ⨾ r₂) pr₂r₁⊩Gzy pr₂r₂⊩Gzy') }))
+                 ; isTotal =
+                   do
+                     (tlF , tlF⊩isTotalF) ← F .isTotal
+                     (tlG , tlG⊩isTotalG) ← G .isTotal
+                     let
+                       prover : ApplStrTerm as 1
+                       prover = ` pair ̇ (` tlF ̇ # zero) ̇ (` tlG ̇ # zero)
+                     return
+                       (λ* prover ,
+                       (λ { z r r⊩z~z →
+                         do
+                           (x , tlFr⊩Fzx) ← tlF⊩isTotalF z r r⊩z~z
+                           (y , tlGr⊩Gzy) ← tlG⊩isTotalG z r r⊩z~z
+                           return
+                             ((x , y) ,
+                              (subst
+                                (λ r' → r' ⊩ ∣ F .relation ∣ (z , x))
+                                (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                                tlFr⊩Fzx ,
+                               subst
+                                (λ r' → r' ⊩ ∣ G .relation ∣ (z , y))
+                                (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                                tlGr⊩Gzy)) }))
+                 }}
+
+    opaque
+      unfolding binProdObRT
+      unfolding theFuncRel
+      theMap : RTMorphism perZ binProdObRT
+      theMap =
+        SQ.rec2
+          squash/
+          (λ F G →
+            [ theFuncRel F G ])
+          (λ { F F' G (F≤F' , F'≤F) →
+            let
+              answer =
+                do
+                  (s , s⊩F≤F') ← F≤F'
+                  let
+                    prover : ApplStrTerm as 1
+                    prover = ` pair ̇ (` s ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero)
+                  return
+                    (λ* prover ,
+                     (λ { z (x , y) r (pr₁r⊩Fzx , pr₂r⊩Gzy) →
+                       subst
+                         (λ r' → r' ⊩ ∣ F' .relation ∣ (z , x))
+                         (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                         (s⊩F≤F' z x (pr₁ ⨾ r) pr₁r⊩Fzx) ,
+                       subst
+                         (λ r' → r' ⊩ ∣ G .relation ∣ (z , y))
+                         (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                         pr₂r⊩Gzy }))
+            in
+            eq/ _ _ (answer , F≤G→G≤F perZ binProdObRT (theFuncRel F G) (theFuncRel F' G) answer) })
+          (λ { F G G' (G≤G' , G'≤G) →
+            let
+              answer =
+                do
+                  (s , s⊩G≤G') ← G≤G'
+                  let
+                    prover : ApplStrTerm as 1
+                    prover = ` pair ̇ (` pr₁ ̇ # zero) ̇ (` s ̇ (` pr₂ ̇ # zero))
+                  return
+                    (λ* prover ,
+                    (λ { z (x , y) r (pr₁r⊩Fzx , pr₂r⊩Gzy) →
+                      (subst
+                        (λ r' → r' ⊩ ∣ F .relation ∣ (z , x))
+                        (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                        pr₁r⊩Fzx) ,
+                      (subst
+                        (λ r' → r' ⊩ ∣ G' .relation ∣ (z , y))
+                        (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                        (s⊩G≤G' z y (pr₂ ⨾ r) pr₂r⊩Gzy)) }))
+            in eq/ _ _ (answer , (F≤G→G≤F perZ binProdObRT (theFuncRel F G) (theFuncRel F G') answer)) })
+          f g
+  opaque
+    unfolding UnivProp.theMap
+    unfolding UnivProp.theFuncRel
+    unfolding binProdPr₁RT
+    unfolding binProdPr₁FuncRel
+    unfolding composeRTMorphism
+    unfolding binProdPr₂FuncRel
+    binProductRT : BinProduct RT (X , perX) (Y , perY)
+    BinProduct.binProdOb binProductRT = X × Y , binProdObRT
+    BinProduct.binProdPr₁ binProductRT = binProdPr₁RT
+    BinProduct.binProdPr₂ binProductRT = binProdPr₂RT
+    BinProduct.univProp binProductRT {Z , perZ} f g =
+      uniqueExists
+        (UnivProp.theMap perZ f g)
+        -- There is probably a better less kluged version of this proof
+        -- But this is the best I could do
+        (SQ.elimProp3
+          {P = λ f g theMap' → ∀ (foo : theMap' ≡ (UnivProp.theMap perZ f g)) → composeRTMorphism _ _ _ theMap' binProdPr₁RT ≡ f}
+          (λ f g h → isPropΠ λ h≡ → squash/ _ _)
+          (λ F G theFuncRel' [theFuncRel']≡theMap →
+            let
+              answer =
+                do
+                  let
+                    (p , q) = (SQ.effective
+                        (λ a b → isProp× isPropPropTrunc isPropPropTrunc)
+                        (isEquivRelBientailment perZ binProdObRT)
+                        theFuncRel'
+                        (UnivProp.theFuncRel perZ [ F ] [ G ] F G)
+                        [theFuncRel']≡theMap)
+                  (p , p⊩theFuncRel'≤theFuncRel) ← p
+                  (q , q⊩theFuncRel≤theFuncRel') ← q
+                  (relF , relF⊩isRelationalF) ← F .isRelational
+                  (stD , stD⊩isStrictDomain) ← theFuncRel' .isStrictDomain
+                  let
+                    prover : ApplStrTerm as 1
+                    prover = ` relF ̇ (` stD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ (` p ̇ (` pr₁ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+                  return
+                    (λ* prover ,
+                    λ z x r r⊩∃ →
+                      transport
+                        (propTruncIdempotent (F .relation .isPropValued _ _))
+                        (do
+                          ((x' , y) , (pr₁r⊩theFuncRel'zx'y , (pr₁pr₂r⊩x~x' , pr₂pr₂r⊩y~y))) ← r⊩∃
+                          return
+                            (subst
+                              (λ r' → r' ⊩ ∣ F .relation ∣ (z , x))
+                              (sym (λ*ComputationRule prover r))
+                              (relF⊩isRelationalF
+                                z z x' x
+                                (stD ⨾ (pr₁ ⨾ r)) (pr₁ ⨾ (p ⨾ (pr₁ ⨾ r))) (pr₁ ⨾ (pr₂ ⨾ r))
+                                (stD⊩isStrictDomain z (x' , y) (pr₁ ⨾ r) pr₁r⊩theFuncRel'zx'y )
+                                (p⊩theFuncRel'≤theFuncRel z (x' , y) (pr₁ ⨾ r) pr₁r⊩theFuncRel'zx'y .fst)
+                                 pr₁pr₂r⊩x~x'))))
+            in
+            eq/ _ _ (answer , F≤G→G≤F perZ perX (composeFuncRel _ _ _ theFuncRel' binProdPr₁FuncRel) F answer))
+          f
+          g
+          (UnivProp.theMap perZ f g)
+          refl ,
+        SQ.elimProp3
+          {P = λ f g theMap' → ∀ (foo : theMap' ≡ (UnivProp.theMap perZ f g)) → composeRTMorphism _ _ _ theMap' binProdPr₂RT ≡ g}
+          (λ f g  h → isPropΠ λ h≡ → squash/ _ _)
+          (λ F G theFuncRel' [theFuncRel']≡theMap →
+            let
+              answer =
+                do
+                  let
+                    (p , q) = (SQ.effective
+                        (λ a b → isProp× isPropPropTrunc isPropPropTrunc)
+                        (isEquivRelBientailment perZ binProdObRT)
+                        theFuncRel'
+                        (UnivProp.theFuncRel perZ [ F ] [ G ] F G)
+                        [theFuncRel']≡theMap)
+                  (p , p⊩theFuncRel'≤theFuncRel) ← p
+                  (q , q⊩theFuncRel≤theFuncRel') ← q
+                  (relG , relG⊩isRelationalG) ← G .isRelational
+                  (st , st⊩isStrictDomainTheFuncRel') ← theFuncRel' .isStrictDomain
+                  let
+                    prover : ApplStrTerm as 1
+                    prover = ` relG ̇ (` st ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ (` p ̇ (` pr₁ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+                  return
+                    (λ* prover ,
+                    (λ z y r r⊩∃ →
+                      transport
+                        (propTruncIdempotent (G .relation .isPropValued _ _))
+                        (do
+                          ((x , y') , (pr₁r⊩theFuncRel'zxy' , pr₁pr₂r⊩y'~y , pr₂pr₂r⊩x~x)) ← r⊩∃
+                          return
+                            (subst
+                              (λ r' → r' ⊩ ∣ G .relation ∣ (z , y))
+                              (sym (λ*ComputationRule prover r)) 
+                              (relG⊩isRelationalG
+                                z z y' y
+                                (st ⨾ (pr₁ ⨾ r)) (pr₂ ⨾ (p ⨾ (pr₁ ⨾ r))) (pr₁ ⨾ (pr₂ ⨾ r))
+                                (st⊩isStrictDomainTheFuncRel' z (x , y') (pr₁ ⨾ r) pr₁r⊩theFuncRel'zxy')
+                                (p⊩theFuncRel'≤theFuncRel z (x , y') (pr₁ ⨾ r) pr₁r⊩theFuncRel'zxy' .snd)
+                                pr₁pr₂r⊩y'~y)))))
+            in
+            eq/ _ _ (answer , F≤G→G≤F perZ perY (composeFuncRel _ _ _ theFuncRel' binProdPr₂FuncRel) G answer))
+          f g
+          (UnivProp.theMap perZ f g)
+          refl)
+        (λ ! → isProp× (squash/ _ _) (squash/ _ _))
+        λ { !' (!'⋆π₁≡f , !'⋆π₂≡g) →
+          SQ.elimProp3
+            {P = λ !' f g → ∀ (foo : composeRTMorphism _ _ _ !' binProdPr₁RT ≡ f) (bar : composeRTMorphism _ _ _ !' binProdPr₂RT ≡ g) → UnivProp.theMap perZ f g ≡ !'}
+            (λ f g !' → isPropΠ λ _ → isPropΠ λ _ → squash/ _ _)
+            (λ !' F G !'⋆π₁≡F !'⋆π₂≡G →
+              let
+                answer =
+                  do
+                    let
+                      (p , q)   = SQ.effective (isPropValuedBientailment perZ perX) (isEquivRelBientailment perZ perX) (composeFuncRel _ _ _ !' binProdPr₁FuncRel) F !'⋆π₁≡F
+                      (p' , q') = SQ.effective (isPropValuedBientailment perZ perY) (isEquivRelBientailment perZ perY) (composeFuncRel _ _ _ !' binProdPr₂FuncRel) G !'⋆π₂≡G
+                    (q , q⊩F≤!'⋆π₁) ← q
+                    (q' , q'⊩G≤!'⋆π₂) ← q'
+                    (rel!' , rel!'⊩isRelational!') ← !' .isRelational
+                    (sv!' , sv!'⊩isSingleValued!') ← !' .isSingleValued
+                    (tX , tX⊩isTransitiveX) ← perX .isTransitive
+                    (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+                    (stD!' , stD!'⊩isStrictDomain!') ← !' .isStrictDomain
+                    let
+                      realizer : ApplStrTerm as 1 -- cursed
+                      realizer =
+                        ` rel!' ̇ (` stD!' ̇ (` pr₁ ̇ (` q ̇ (` pr₁ ̇ # zero)))) ̇
+                          (` pr₁ ̇ (` q' ̇ (` pr₂ ̇ # zero))) ̇
+                          (` pair ̇
+                           (` tX ̇
+                            (` sX ̇
+                             (` pr₁ ̇
+                              (` sv!' ̇ (` pr₁ ̇ (` q ̇ (` pr₁ ̇ # zero))) ̇ (` pr₁ ̇ (` q' ̇ (` pr₂ ̇ # zero)))))) ̇
+                            (` pr₁ ̇ (` pr₂ ̇ (` q ̇ (` pr₁ ̇ # zero))))) ̇
+                           (` pr₁ ̇ (` pr₂ ̇ (` q' ̇ (` pr₂ ̇ # zero)))))
+                    return
+                      (λ* realizer ,
+                      (λ { z (x , y) r (pr₁r⊩Fzx , pr₂r⊩Gzy) →
+                        transport
+                          (propTruncIdempotent (!' .relation .isPropValued _ _))
+                          (do
+                            ((x' , y') , ⊩!'zx'y' , ⊩x'~x , ⊩y'~y') ← q⊩F≤!'⋆π₁ z x _ pr₁r⊩Fzx
+                            ((x'' , y'') , ⊩!'zx''y'' , ⊩y''~y , ⊩x''~x'') ← q'⊩G≤!'⋆π₂ z y _ pr₂r⊩Gzy
+                            let
+                              (⊩x'~x'' , ⊩y'~y'') = sv!'⊩isSingleValued!' z (x' , y') (x'' , y'') _ _ ⊩!'zx'y' ⊩!'zx''y''
+                              ⊩x''~x = tX⊩isTransitiveX x'' x' x _ _ (sX⊩isSymmetricX x' x'' _ ⊩x'~x'') ⊩x'~x 
+                            return
+                              (subst
+                                (λ r' → r' ⊩ ∣ !' .relation ∣ (z , x , y))
+                                (sym (λ*ComputationRule realizer r))
+                                (rel!'⊩isRelational!'
+                                  z z
+                                  (x'' , y'')
+                                  (x , y)
+                                  _ _ _
+                                  (stD!'⊩isStrictDomain!' z (x' , y') _ ⊩!'zx'y') ⊩!'zx''y'' ((subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x'' , x)) (sym (pr₁pxy≡x _ _)) ⊩x''~x) , (subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y'' , y)) (sym (pr₂pxy≡y _ _)) ⊩y''~y))))) }))
+              in
+              eq/ _ _ (answer , F≤G→G≤F perZ binProdObRT (UnivProp.theFuncRel perZ [ F ] [ G ] F G)
+                                 !' answer))
+            !' f g !'⋆π₁≡f !'⋆π₂≡g }
+
+binProductsRT : BinProducts RT
+binProductsRT (X , perX) (Y , perY) = binProductRT perX perY
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.Equalizer.html b/docs/Realizability.Topos.Equalizer.html new file mode 100644 index 0000000..916a1e2 --- /dev/null +++ b/docs/Realizability.Topos.Equalizer.html @@ -0,0 +1,619 @@ + +Realizability.Topos.Equalizer
{-
+
+EQUALISERS IN RT(A)
+────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
+────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
+
+Consider two parallel morphisms f g from (X, _=X_) to (Y , _=Y_)
+
+In order to construct their equaliser we need to first construct an auxillary object (X , _=E_)
+and construct the equaliser as an injection from (X , _=E_) to (X , _=X_)
+
+However, we cannot, in general show that RT has equalisers because the object (X , _=E_) that injects into (X , _=X_) depends
+on choice of representatives of f and g.
+
+We can, however, prove a weaker theorem. We can show that equalisers *merely* exist.
+
+More formally, we can show that ∃[ ob ∈ RTObject ] ∃[ eq ∈ RTMorphism ob (X , _=X_) ] (univPropEqualizer eq)
+
+To do this, we firstly show the universal property for the case when we have already been given the
+representatives.
+
+Since we are eliminating a set quotient into a proposition, we can choose any representatives.
+
+Thus we have shown that RT merely has equalisers.
+
+The idea of showing the mere existence of equalisers was suggested by Jon Sterling.
+
+See also : Remark 2.7 of "Tripos Theory" by JHP
+
+──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
+
+An extra note worth adding is that the code is quite difficult to read and very ugly. This is mostly due to the fact that a lot
+of the things that are "implicit" in an informal setting need to be justified here. More so than usual.
+
+There is additional bureacracy because we have to deal with eliminators of set quotients. This makes things a little more complicated.
+
+-}
+open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Structure
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Unit
+open import Cubical.Data.Empty
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Sigma
+open import Cubical.HITs.PropositionalTruncation as PT
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Limits.BinProduct
+
+module Realizability.Topos.Equalizer
+  {ℓ ℓ' ℓ''} {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial 
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open PredicateProperties
+open Morphism
+
+open FunctionalRelation
+open PartialEquivalenceRelation
+
+equalizerUnivProp :
+  ∀ {X Y : Type ℓ'}
+  → (perX : PartialEquivalenceRelation X)
+  → (perY : PartialEquivalenceRelation Y)
+  → (f g : RTMorphism perX perY)
+  → (equalizerOb : PartialEquivalenceRelation X)
+  → (inc : RTMorphism equalizerOb perX)
+  → Type _
+equalizerUnivProp {X} {Y} perX perY f g equalizerOb inc =
+    ((composeRTMorphism _ _ _ inc f) ≡ (composeRTMorphism _ _ _ inc g)) ×
+    ∀ {Z : Type ℓ'} (perZ : PartialEquivalenceRelation Z) (inc' : RTMorphism perZ perX)
+    → (composeRTMorphism _ _ _ inc' f) ≡ (composeRTMorphism _ _ _ inc' g)
+    -----------------------------------------------------------------------------------
+    → ∃![ ! ∈ RTMorphism perZ equalizerOb ] (composeRTMorphism _ _ _ ! inc ≡ inc')
+
+module _
+  {X : Type ℓ'}
+  {Y : Type ℓ'}
+  (perX : PartialEquivalenceRelation X)
+  (perY : PartialEquivalenceRelation Y)
+  (f g : RTMorphism perX perY) where
+
+  opaque
+    equalizerPer : ∀ (F G : FunctionalRelation perX perY) → PartialEquivalenceRelation X
+    equalizerPer F G =
+      record
+              { equality =
+                record
+                  { isSetX = isSet× (perX .isSetX) (perX .isSetX)
+                  ; ∣_∣ = λ { (x , x') r →
+                    ((pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x')) ×
+                    (∃[ y ∈ Y ] (pr₁ ⨾ (pr₂ ⨾ r)) ⊩ ∣ F .relation ∣ (x , y) × (pr₂ ⨾ (pr₂ ⨾ r)) ⊩ ∣ G .relation ∣ (x , y)) }
+                  ; isPropValued = λ { (x , x') r → isProp× (perX .equality .isPropValued _ _) isPropPropTrunc } }
+              ; isPerEquality =
+                record
+                  { isSetX = perX .isSetX
+                  ; isSymmetric =
+                    do
+                      (s , s⊩isSymmetricX) ← perX .isSymmetric
+                      (relF , relF⊩isRelationalF) ← F .isRelational
+                      (relG , relG⊩isRelationalG) ← G .isRelational
+                      (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+                      let
+                        prover : ApplStrTerm as 1
+                        prover =
+                          ` pair ̇
+                            (` s ̇ (` pr₁ ̇ # zero)) ̇
+                            (` pair ̇
+                              (` relF ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)) ̇ (` stFC ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)))) ̇
+                              (` relG ̇ (` pr₁ ̇ # zero) ̇ (` pr₂ ̇ (` pr₂ ̇ # zero)) ̇ (` stFC ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)))))
+                      return
+                        (λ* prover ,
+                        (λ { x x' r (pr₁r⊩x~x' , pr₂r⊩∃) →
+                          subst
+                            (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x))
+                            (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                            (s⊩isSymmetricX x x' (pr₁ ⨾ r) pr₁r⊩x~x') ,
+                          do
+                            (y , pr₁pr₂r⊩Fxy , pr₂pr₂r⊩Gxy) ← pr₂r⊩∃
+                            return
+                              (y ,
+                              subst
+                                (λ r' → r' ⊩ ∣ F .relation ∣ (x' , y))
+                                (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+                                (relF⊩isRelationalF
+                                  x x' y y
+                                  (pr₁ ⨾ r) (pr₁ ⨾ (pr₂ ⨾ r)) (stFC ⨾ (pr₁ ⨾ (pr₂ ⨾ r)))
+                                  pr₁r⊩x~x'
+                                  pr₁pr₂r⊩Fxy
+                                  (stFC⊩isStrictCodomainF x y (pr₁ ⨾ (pr₂ ⨾ r)) pr₁pr₂r⊩Fxy)) ,
+                              subst
+                                (λ r' → r' ⊩ ∣ G .relation ∣ (x' , y))
+                                (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+                                (relG⊩isRelationalG
+                                  x x' y y
+                                  (pr₁ ⨾ r) (pr₂ ⨾ (pr₂ ⨾ r)) (stFC ⨾ (pr₁ ⨾ (pr₂ ⨾ r)))
+                                  pr₁r⊩x~x'
+                                  pr₂pr₂r⊩Gxy
+                                  (stFC⊩isStrictCodomainF x y (pr₁ ⨾ (pr₂ ⨾ r)) pr₁pr₂r⊩Fxy))) }))
+                  ; isTransitive =
+                    do
+                      (t , t⊩isTransitiveX) ← perX .isTransitive
+                      (relF , relF⊩isRelationalF) ← F .isRelational
+                      (relG , relG⊩isRelationalG) ← G .isRelational
+                      let
+                        prover : ApplStrTerm as 2
+                        prover = ` pair ̇ (` t ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` pair ̇ (` pr₁ ̇ (` pr₂ ̇ # one)) ̇ (` pr₂ ̇ (` pr₂ ̇ # one)))
+                      return
+                        (λ*2 prover ,
+                        λ { x₁ x₂ x₃ a b (pr₁a⊩x₁~x₂ , pr₂a⊩∃) (pr₁b⊩x₂~x₃ , pr₂b⊩∃) →
+                          subst
+                            (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₃))
+                            (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule prover a b) ∙ pr₁pxy≡x _ _))
+                            (t⊩isTransitiveX x₁ x₂ x₃ (pr₁ ⨾ a) (pr₁ ⨾ b) pr₁a⊩x₁~x₂ pr₁b⊩x₂~x₃) ,
+                          do
+                            (y , (pr₁pr₂a⊩Fx₁y , pr₂pr₂a⊩Gx₁y)) ← pr₂a⊩∃
+                            (y' , (pr₁pr₂a⊩Fx₂y' , pr₂pr₂a⊩Gx₂y')) ← pr₂b⊩∃
+                            return
+                              (y ,
+                              subst
+                                (λ r' → r' ⊩ ∣ F .relation ∣ (x₁ , y))
+                                (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*2ComputationRule prover a b) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+                                pr₁pr₂a⊩Fx₁y ,
+                              subst
+                                (λ r' → r' ⊩ ∣ G .relation ∣ (x₁ , y))
+                                (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*2ComputationRule prover a b) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+                                pr₂pr₂a⊩Gx₁y) }) } }
+
+  opaque
+    unfolding idFuncRel
+    unfolding equalizerPer
+    equalizerFuncRel : ∀ (F G : FunctionalRelation perX perY) → FunctionalRelation (equalizerPer F G) perX
+    equalizerFuncRel F G =
+      record
+        { relation = equalizerPer F G .equality
+        ; isFuncRel =
+          record
+           { isStrictDomain = idFuncRel (equalizerPer F G) .isStrictDomain
+           ; isStrictCodomain =
+             do
+               (stC , stC⊩isStrictCodomain) ← idFuncRel perX .isStrictCodomain
+               let
+                 prover : ApplStrTerm as 1
+                 prover = ` stC ̇ (` pr₁ ̇ # zero)
+               return
+                 (λ* prover ,
+                 (λ { x x' r (pr₁r⊩x~x' , pr₂r⊩∃) →
+                   subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x')) (sym (λ*ComputationRule prover r)) (stC⊩isStrictCodomain x x' (pr₁ ⨾ r) pr₁r⊩x~x') }))
+           ; isRelational =
+             do
+               (relEqX , relEqX⊩isRelationalEqX) ← idFuncRel perX .isRelational
+               (relF , relF⊩isRelationalF) ← F .isRelational
+               (relG , relG⊩isRelationalG) ← G .isRelational
+               (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+               let
+                 prover : ApplStrTerm as 3
+                 prover =
+                   ` pair ̇
+                     (` relEqX ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ # zero) ̇
+                     (` pair ̇
+                       (` relF ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ (` pr₂ ̇ # two)) ̇ (` svF ̇ (` pr₁ ̇ (` pr₂ ̇ # two)) ̇ (` pr₁ ̇ (` pr₂ ̇ # one)))) ̇
+                       (` relG ̇ (` pr₁ ̇ # two) ̇ (` pr₂ ̇ (` pr₂ ̇ # two)) ̇ (` svF ̇ (` pr₁ ̇ (` pr₂ ̇ # two)) ̇ (` pr₁ ̇ (` pr₂ ̇ # one)))))
+               return
+                 (λ*3 prover ,
+                 (λ x₁ x₂ x₃ x₄ a b c (pr₁a⊩x₁~x₂ , pr₂a⊩) (pr₁b⊩x₁~x₃ , pr₂b⊩) c⊩x₃~x₄ →
+                   subst
+                     (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄))
+                     (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₁pxy≡x _ _))
+                     (relEqX⊩isRelationalEqX x₁ x₂ x₃ x₄ (pr₁ ⨾ a) (pr₁ ⨾ b) c pr₁a⊩x₁~x₂ pr₁b⊩x₁~x₃ c⊩x₃~x₄) ,
+                   do
+                     (y , pr₁pr₂a⊩Fx₁y , pr₂pr₂a⊩Gx₁y) ← pr₂a⊩
+                     (y' , pr₁pr₂b⊩Fx₁y' , pr₂pr₂b⊩Gx₁y') ← pr₂b⊩
+                     let
+                       y~y' = svF⊩isSingleValuedF x₁ y y' (pr₁ ⨾ (pr₂ ⨾ a)) (pr₁ ⨾ (pr₂ ⨾ b)) pr₁pr₂a⊩Fx₁y pr₁pr₂b⊩Fx₁y'
+                     return
+                       (y' ,
+                       subst
+                         (λ r' → r' ⊩ ∣ F .relation ∣ (x₂ , y'))
+                         (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule prover a b c) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+                         (relF⊩isRelationalF
+                           x₁ x₂ y y'
+                           (pr₁ ⨾ a) (pr₁ ⨾ (pr₂ ⨾ a)) (svF ⨾ (pr₁ ⨾ (pr₂ ⨾ a)) ⨾ (pr₁ ⨾ (pr₂ ⨾ b)))
+                           pr₁a⊩x₁~x₂ pr₁pr₂a⊩Fx₁y y~y') ,
+                       subst
+                         (λ r' → r' ⊩ ∣ G .relation ∣ (x₂ , y'))
+                         (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule prover a b c) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+                         (relG⊩isRelationalG
+                           x₁ x₂ y y'
+                           (pr₁ ⨾ a) (pr₂ ⨾ (pr₂ ⨾ a)) (svF ⨾ (pr₁ ⨾ (pr₂ ⨾ a)) ⨾ (pr₁ ⨾ (pr₂ ⨾ b)))
+                           pr₁a⊩x₁~x₂ pr₂pr₂a⊩Gx₁y y~y'))))
+           ; isSingleValued =
+             do
+               (svEqX , svEqX⊩isSingleValuedEqX) ← idFuncRel perX .isSingleValued
+               let
+                 prover : ApplStrTerm as 2
+                 prover = ` svEqX ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)
+               return
+                 (λ*2 prover ,
+                 (λ x₁ x₂ x₃ r₁ r₂ (pr₁r₁⊩x₁~x₂ , pr₁r₁⊩) (pr₁r₂⊩x₁~x₃ , pr₂r₂⊩) →
+                   subst
+                     (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₃))
+                     (sym (λ*2ComputationRule prover r₁ r₂))
+                     (svEqX⊩isSingleValuedEqX x₁ x₂ x₃ (pr₁ ⨾ r₁) (pr₁ ⨾ r₂) pr₁r₁⊩x₁~x₂ pr₁r₂⊩x₁~x₃)))
+           ; isTotal = idFuncRel (equalizerPer F G) .isTotal
+           } }
+
+  opaque
+    equalizerMorphism : ∀ (F G : FunctionalRelation perX perY) → RTMorphism (equalizerPer F G) perX
+    equalizerMorphism F G = [ equalizerFuncRel F G ]
+
+  opaque
+    unfolding equalizerMorphism
+    unfolding equalizerFuncRel
+    unfolding composeRTMorphism
+    inc⋆f≡inc⋆g : ∀ (F G : FunctionalRelation perX perY) → composeRTMorphism _ _ _ (equalizerMorphism F G) [ F ] ≡ composeRTMorphism _ _ _ (equalizerMorphism F G) [ G ]
+    inc⋆f≡inc⋆g F G =
+      let
+        answer =
+          do
+            (relG , relG⊩isRelationalG) ← G .isRelational
+            (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+            (relF , relF⊩isRelationalF) ← F .isRelational
+            (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+            (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+            let
+              realizer : ApplStrTerm as 1
+              realizer =
+                ` pair ̇
+                  (` pair ̇ (` pr₁ ̇ (` pr₁ ̇ # zero)) ̇ (` pair ̇ (` pr₁ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))))) ̇
+                  (` relG ̇ (` pr₁ ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇
+                     (` svF ̇ (` pr₁ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇
+                     (` relF ̇ (` sX ̇ (` pr₁ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ # zero) ̇ (` stCF ̇ (` pr₂ ̇ # zero)))))
+            return
+              (λ* realizer ,
+              -- unfold everything and bring it back in together
+              (λ x y r r⊩∃ →
+                do
+                  (x' , (⊩x~x' , ∃y) , ⊩Fx'y) ← r⊩∃
+                  (y' , ⊩Fxy' , ⊩Gxy') ← ∃y
+                  let
+                    y'~y =
+                      svF⊩isSingleValuedF x y' y _ _ ⊩Fxy' (relF⊩isRelationalF x' x y y _ _ _ (sX⊩isSymmetricX x x' _ ⊩x~x') ⊩Fx'y (stCF⊩isStrictCodomainF x' y _ ⊩Fx'y))
+                  return
+                    (x' ,
+                    (subst
+                      (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                      (sym (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _))
+                      ⊩x~x' ,
+                    do
+                      return
+                        (y' ,
+                        subst
+                          (λ r' → r' ⊩ ∣ F .relation ∣ (x , y'))
+                          (sym
+                            (cong (λ x → pr₁ ⨾ (pr₂ ⨾ (pr₁ ⨾ x))) (λ*ComputationRule realizer r) ∙
+                             cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (pr₁pxy≡x _ _) ∙
+                             cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙
+                             pr₁pxy≡x _ _))
+                          ⊩Fxy' ,
+                        subst
+                          (λ r' → r' ⊩ ∣ G .relation ∣ (x , y'))
+                          (sym
+                            (cong (λ x → pr₂ ⨾ (pr₂ ⨾ (pr₁ ⨾ x))) (λ*ComputationRule realizer r) ∙
+                             cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (pr₁pxy≡x _ _) ∙
+                             cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙
+                             pr₂pxy≡y _ _))
+                          ⊩Gxy')) ,
+                    subst
+                      (λ r' → r' ⊩ ∣ G .relation ∣ (x' , y))
+                      (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+                      (relG⊩isRelationalG x x' y' y _ _ _ ⊩x~x' ⊩Gxy' y'~y))))
+      in
+      eq/ _ _
+        (answer , F≤G→G≤F (equalizerPer F G) perY (composeFuncRel _ _ _ (equalizerFuncRel F G) F) (composeFuncRel _ _ _ (equalizerFuncRel F G) G) answer)
+
+  module UnivProp
+    (F G : FunctionalRelation perX perY)
+    {Z : Type ℓ'}
+    (perZ : PartialEquivalenceRelation Z)
+    (h : RTMorphism perZ perX)
+    (h⋆f≡h⋆g : composeRTMorphism _ _ _ h [ F ] ≡ composeRTMorphism _ _ _ h [ G ]) where opaque
+    unfolding equalizerPer
+    unfolding composeRTMorphism
+    unfolding equalizerMorphism
+    unfolding equalizerFuncRel
+    
+    private
+      !funcRel : ∀ (H : FunctionalRelation perZ perX) (H⋆F≡H⋆G : composeRTMorphism _ _ _ [ H ] [ F ] ≡ composeRTMorphism _ _ _ [ H ] [ G ]) → FunctionalRelation perZ (equalizerPer F G)
+      !funcRel H H⋆F≡H⋆G =
+        let
+          (p , q) =
+            SQ.effective
+              (isPropValuedBientailment perZ perY)
+              (isEquivRelBientailment perZ perY)
+              (composeFuncRel _ _ _ H F)
+              (composeFuncRel _ _ _ H G)
+              H⋆F≡H⋆G
+        in
+        record
+              { relation = H .relation
+              ; isFuncRel =
+                record
+                 { isStrictDomain = H .isStrictDomain
+                 ; isStrictCodomain =
+                   do
+                     (p , p⊩H⋆F≤H⋆G) ← p
+                     (q , q⊩H⋆G≤H⋆F) ← q
+                     (tlF , tlF⊩isTotalF) ← F .isTotal
+                     (stCH , stCH⊩isStrictCodomainH) ← H .isStrictCodomain
+                     (relG , relG⊩isRelationalG) ← G .isRelational
+                     (svH , svH⊩isSingleValuedH) ← H .isSingleValued
+                     (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+                     let
+                       -- possibly the ugliest realizer out there
+                       prover : ApplStrTerm as 1
+                       prover =
+                         ` pair ̇
+                           (` stCH ̇ # zero) ̇
+                           (` pair ̇
+                             (` tlF ̇ (` stCH ̇ # zero)) ̇
+                             (` relG ̇ (` svH ̇ (` pr₁ ̇ (` p ̇ (` pair ̇ # zero ̇ (` tlF ̇ (` stCH ̇ # zero))))) ̇ # zero) ̇
+                             (` pr₂ ̇ (` p ̇ (` pair ̇ # zero ̇ (` tlF ̇ (` stCH ̇ # zero))))) ̇
+                              (` stCF ̇ (` tlF ̇ (` stCH ̇ # zero)))))
+                     return
+                       (λ* prover ,
+                       (λ z x r r⊩Hzx →
+                         let
+                             x~x = stCH⊩isStrictCodomainH z x r r⊩Hzx
+                         in
+                         subst (λ r → r ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _)) x~x ,
+                         (do
+                           (y , ⊩Fxy) ← tlF⊩isTotalF x (stCH ⨾ r) x~x
+                           let
+                             hope =
+                               p⊩H⋆F≤H⋆G
+                                 z y (pair ⨾ r ⨾ (tlF ⨾ (stCH ⨾ r)))
+                                 (return
+                                   (x ,
+                                    subst (λ r' → r' ⊩ ∣ H .relation ∣ (z , x)) (sym (pr₁pxy≡x _ _)) r⊩Hzx ,
+                                    subst (λ r' → r' ⊩ ∣ F .relation ∣ (x , y)) (sym (pr₂pxy≡y _ _)) ⊩Fxy))
+                           return
+                             (y ,
+                             subst
+                               (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+                               (sym
+                                 (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙
+                                  cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙
+                                  pr₁pxy≡x _ _))
+                               ⊩Fxy ,
+                             -- god I wish there was a better way to do this :(
+                             transport
+                               (propTruncIdempotent (G .relation .isPropValued _ _))
+                               (do
+                                 (x' , ⊩Hzx' , ⊩Gx'y) ← hope
+                                 return
+                                   (subst
+                                     (λ r' → r' ⊩ ∣ G .relation ∣ (x , y))
+                                     (sym
+                                       (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙
+                                        cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙
+                                        pr₂pxy≡y _ _))
+                                     (relG⊩isRelationalG x' x y y _ _ _ (svH⊩isSingleValuedH z x' x _ _ ⊩Hzx' r⊩Hzx) ⊩Gx'y (stCF⊩isStrictCodomainF x y _ ⊩Fxy))))))))
+                 ; isRelational =
+                   do
+                     (relH , relH⊩isRelationalH) ← H .isRelational
+                     let
+                       prover : ApplStrTerm as 3
+                       prover = ` relH ̇ # two ̇ # one ̇ (` pr₁ ̇ # zero)
+                     return
+                       (λ*3 prover ,
+                       (λ z z' x x' a b c a⊩z~z' b⊩Hzx (pr₁c⊩x~x' , pr₂c⊩∃) →
+                         subst
+                           (λ r' → r' ⊩ ∣ H .relation ∣ (z' , x'))
+                           (sym (λ*3ComputationRule prover a b c))
+                           (relH⊩isRelationalH z z' x x' a b (pr₁ ⨾ c) a⊩z~z' b⊩Hzx pr₁c⊩x~x')))
+                 ; isSingleValued =
+                   do
+                     (svH , svH⊩isSingleValuedH) ← H .isSingleValued
+                     (tlF , tlF⊩isTotalF) ← F .isTotal
+                     (tlG , tlG⊩isTotalG) ← G .isTotal
+                     (stCH , stCH⊩isStrictCodomainH) ← H .isStrictCodomain
+                     (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+                     (relG , relG⊩isRelationalG) ← G .isRelational
+                     (p , p⊩H⋆F≤H⋆G) ← p
+                     let
+                       prover : ApplStrTerm as 2
+                       prover =
+                         ` pair ̇
+                           (` svH ̇ # one ̇ # zero) ̇
+                           (` pair ̇
+                             (` tlF ̇ (` stCH ̇ # one)) ̇
+                             (` relG ̇ (` svH ̇ (` pr₁ ̇ (` p ̇ (` pair ̇ # one ̇ (` tlF ̇ (` stCH ̇ # one))))) ̇ # one) ̇
+                               (` pr₂ ̇ (` p ̇ (` pair ̇ # one ̇ (` tlF ̇ (` stCH ̇ # one))))) ̇
+                               (` stCF ̇(` tlF ̇ (` stCH ̇ # one)))))
+                     return
+                       (λ*2 prover ,
+                       (λ z x x' r₁ r₂ r₁⊩Hzx r₂⊩Hzx' →
+                         let
+                           x~x' = svH⊩isSingleValuedH z x x' r₁ r₂ r₁⊩Hzx r₂⊩Hzx'
+                           x~x = stCH⊩isStrictCodomainH z x r₁ r₁⊩Hzx
+                         in
+                         subst
+                           (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                           (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule prover r₁ r₂) ∙ pr₁pxy≡x _ _))
+                           x~x' ,
+                         do
+                           (y , ⊩Fxy) ← tlF⊩isTotalF x _ x~x
+                           let
+                             y~y = stCF⊩isStrictCodomainF x y _ ⊩Fxy
+                             hope =
+                               p⊩H⋆F≤H⋆G z y
+                               (pair ⨾ r₁ ⨾ (tlF ⨾ (stCH ⨾ r₁)))
+                               (do
+                                 return
+                                   (x ,
+                                   (subst (λ r' → r' ⊩ ∣ H .relation ∣ (z , x)) (sym (pr₁pxy≡x _ _)) r₁⊩Hzx) ,
+                                   (subst (λ r' → r' ⊩ ∣ F .relation ∣ (x , y)) (sym (pr₂pxy≡y _ _)) ⊩Fxy)))
+                           (x'' , ⊩Hzx'' , ⊩Gx''y) ← hope
+                           -- Can not use the fact that x ≐ x''
+                           let
+                             x''~x = svH⊩isSingleValuedH z x'' x _ _ ⊩Hzx'' r₁⊩Hzx
+                           return
+                             (y ,
+                             subst
+                               (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+                               (sym
+                                 (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*2ComputationRule prover r₁ r₂) ∙
+                                  cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙
+                                  pr₁pxy≡x _ _)) ⊩Fxy ,
+                             subst
+                               (λ r' → r' ⊩ ∣ G .relation ∣ (x , y))
+                               (sym
+                                 (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*2ComputationRule prover r₁ r₂) ∙
+                                  cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙
+                                  pr₂pxy≡y _ _))
+                               (relG⊩isRelationalG x'' x y y _ _ _ x''~x ⊩Gx''y y~y))))
+                 ; isTotal = H .isTotal
+                 } }
+                 
+    mainMap :
+      Σ[ ! ∈ RTMorphism perZ (equalizerPer F G) ]
+        (composeRTMorphism _ _ _ ! (equalizerMorphism F G) ≡ h) ×
+        (∀ (!' : RTMorphism perZ (equalizerPer F G)) (!'⋆inc≡h : composeRTMorphism _ _ _ !' (equalizerMorphism F G) ≡ h) → !' ≡ !)
+    mainMap =
+      SQ.elim
+        {P =
+          λ h →
+          ∀ (h⋆f≡h⋆g : composeRTMorphism _ _ _ h [ F ] ≡ composeRTMorphism _ _ _ h [ G ])
+          → Σ[ ! ∈ _ ] (composeRTMorphism _ _ _ ! (equalizerMorphism F G) ≡ h) ×
+          (∀ (!' : RTMorphism perZ (equalizerPer F G)) (!'⋆inc≡h : composeRTMorphism _ _ _ !' (equalizerMorphism F G) ≡ h) → !' ≡ !)}
+        (λ h → isSetΠ λ _ → isSetΣ squash/ λ ! → isSet× (isProp→isSet (squash/ _ _)) (isSetΠ λ !' → isSetΠ λ _ → isProp→isSet (squash/ !' !)))
+        (λ H H⋆F≡H⋆G →
+          [ !funcRel H H⋆F≡H⋆G ] ,
+          let    
+            answer =
+              do
+                (relH , relH⊩isRelationalH) ← H .isRelational
+                (stDH , stDH⊩isStrictDomainH) ← H .isStrictDomain
+                let
+                  prover : ApplStrTerm as 1
+                  prover = ` relH ̇ (` stDH ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+                return
+                  (λ* prover ,
+                  (λ z x r r⊩∃x' →
+                    transport
+                      (propTruncIdempotent (H .relation .isPropValued _ _))
+                      (do
+                        (x' , pr₁r⊩Hzx' , (pr₁pr₂r⊩x'~x , _)) ← r⊩∃x'
+                        return
+                          (subst
+                            (λ r' → r' ⊩ ∣ H .relation ∣ (z , x))
+                            (sym (λ*ComputationRule prover r))
+                            (relH⊩isRelationalH z z x' x _ _ _ (stDH⊩isStrictDomainH z x' (pr₁ ⨾ r) pr₁r⊩Hzx') pr₁r⊩Hzx' pr₁pr₂r⊩x'~x)))))
+            !funcRel⋆inc≡H = eq/ _ _ (answer , F≤G→G≤F _ _ (composeFuncRel _ _ _ (!funcRel H H⋆F≡H⋆G) (equalizerFuncRel F G)) H answer)
+          in !funcRel⋆inc≡H ,
+          λ !' !'⋆inc≡H →
+            SQ.elimProp
+              {P =
+                λ !' →
+                ∀ (foo : composeRTMorphism _ _ _ !' (equalizerMorphism F G) ≡ [ H ])
+                → !' ≡ [ !funcRel H H⋆F≡H⋆G ]}
+              (λ !' → isPropΠ λ _ → squash/ _ _)
+              (λ !'funcRel !'funcRel⋆inc≡H →
+                let
+                  (p , q) = SQ.effective (isPropValuedBientailment perZ perX) (isEquivRelBientailment perZ perX) (composeFuncRel _ _ _ !'funcRel (equalizerFuncRel F G)) H !'funcRel⋆inc≡H
+                  (p' , q') = SQ.effective (isPropValuedBientailment perZ perY) (isEquivRelBientailment perZ perY) (composeFuncRel _ _ _ H F) (composeFuncRel _ _ _ H G) H⋆F≡H⋆G
+                  answer =
+                    do
+                      (q , q⊩inc⋆!'≤H) ← q
+                      (rel!' , rel!'⊩isRelational!'FuncRel) ← !'funcRel .isRelational
+                      (stDH , stDH⊩isStrictDomainH) ← H .isStrictDomain
+                      let
+                        prover : ApplStrTerm as 1
+                        prover = ` rel!' ̇ (` stDH ̇ # zero) ̇ (` pr₁ ̇ (` q ̇ # zero)) ̇ (` pr₂ ̇ (` q ̇ # zero))
+                      return
+                        (λ* prover ,
+                        (λ z x r r⊩Hzx →
+                          transport
+                            (propTruncIdempotent (!'funcRel .relation .isPropValued _ _))
+                            (do
+                              (x' , pr₁qr⊩!'zx' , ⊩x~x' , foo) ← q⊩inc⋆!'≤H z x r r⊩Hzx
+                              return
+                                (subst
+                                  (λ r' → r' ⊩ ∣ !'funcRel .relation ∣ (z , x))
+                                  (sym (λ*ComputationRule prover r))
+                                  (rel!'⊩isRelational!'FuncRel
+                                    z z x' x _ _ _
+                                    (stDH⊩isStrictDomainH z x r r⊩Hzx)
+                                    pr₁qr⊩!'zx'
+                                    (⊩x~x' , foo))))))
+                in
+                eq/ _ _ (F≤G→G≤F perZ (equalizerPer F G) (!funcRel H H⋆F≡H⋆G) !'funcRel answer , answer))
+              !'
+              !'⋆inc≡H)
+        (λ { H H' (H≤H' , H'≤H) →
+          funExtDep
+            {A = λ i → composeRTMorphism _ _ _ (eq/ H H' (H≤H' , H'≤H) i) [ F ] ≡ composeRTMorphism _ _ _ (eq/ H H' (H≤H' , H'≤H) i) [ G ]}
+            λ {H⋆F≡H⋆G} {H'⋆F≡H'⋆G} p →
+              ΣPathPProp
+                {A = λ i → RTMorphism perZ (equalizerPer F G)}
+                {B = λ i ! →
+                  ((composeRTMorphism _ _ _ ! (equalizerMorphism F G)) ≡ eq/ H H' (H≤H' , H'≤H) i) ×
+                  (∀ (!' : RTMorphism perZ (equalizerPer F G)) → composeRTMorphism _ _ _ !' (equalizerMorphism F G) ≡ eq/ H H' (H≤H' , H'≤H) i → !' ≡ !)}
+                (λ ! → isProp× (squash/ _ _) (isPropΠ λ !' → isPropΠ λ !'⋆inc≡H' → squash/ _ _))
+                let
+                  answer =
+                    (do
+                      (s , s⊩H≤H') ← H≤H'
+                      return
+                        (s ,
+                        (λ z x r r⊩Hzx →
+                          s⊩H≤H' z x r r⊩Hzx)))
+                in eq/ _ _ (answer , F≤G→G≤F perZ (equalizerPer F G) (!funcRel H H⋆F≡H⋆G) (!funcRel H' H'⋆F≡H'⋆G) answer) })
+        h
+        h⋆f≡h⋆g
+    
+  -- We have now done the major work and can simply eliminate f and g
+  opaque
+    unfolding idFuncRel
+    unfolding equalizerPer
+    equalizer :
+      ∃[ equalizerOb ∈ PartialEquivalenceRelation X ]
+      ∃[ inc ∈ RTMorphism equalizerOb perX ]
+      (equalizerUnivProp perX perY f g equalizerOb inc)
+    equalizer =
+      SQ.elimProp2
+        {P = λ f g → ∃[ equalizerOb ∈ PartialEquivalenceRelation X ] ∃[ inc ∈ RTMorphism equalizerOb perX ] (equalizerUnivProp perX perY f g equalizerOb inc)}
+        (λ f g → isPropPropTrunc)
+        (λ F G →
+            return
+              ((equalizerPer F G) ,
+              (return
+                  ((equalizerMorphism F G) ,
+                  ((inc⋆f≡inc⋆g F G) ,
+                  (λ {Z} perZ inc' inc'⋆f≡inc'⋆g →
+                    let
+                      (! , !⋆inc≡inc' , unique!) = UnivProp.mainMap F G perZ inc' inc'⋆f≡inc'⋆g
+                    in
+                    uniqueExists
+                      !
+                      !⋆inc≡inc'
+                      (λ ! → squash/ _ _)
+                      λ !' !'⋆inc≡inc' → sym (unique! !' !'⋆inc≡inc')))))))
+        f g
+      
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.Everything.html b/docs/Realizability.Topos.Everything.html new file mode 100644 index 0000000..4ec7be1 --- /dev/null +++ b/docs/Realizability.Topos.Everything.html @@ -0,0 +1,13 @@ + +Realizability.Topos.Everything
module Realizability.Topos.Everything where
+
+open import Realizability.Topos.Object
+open import Realizability.Topos.FunctionalRelation
+open import Realizability.Topos.TerminalObject
+open import Realizability.Topos.BinProducts
+open import Realizability.Topos.Equalizer
+open import Realizability.Topos.MonicReprFuncRel
+open import Realizability.Topos.StrictRelation
+open import Realizability.Topos.ResizedPredicate
+open import Realizability.Topos.SubobjectClassifier
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.FunctionalRelation.html b/docs/Realizability.Topos.FunctionalRelation.html new file mode 100644 index 0000000..dcc7b73 --- /dev/null +++ b/docs/Realizability.Topos.FunctionalRelation.html @@ -0,0 +1,611 @@ + +Realizability.Topos.FunctionalRelation
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Structure
+open import Cubical.Foundations.HLevels
+open import Cubical.Data.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.FinData
+open import Cubical.Data.Fin hiding (Fin; _/_)
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty
+open import Cubical.Data.Unit
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Relation.Binary
+
+module Realizability.Topos.FunctionalRelation
+  {ℓ ℓ' ℓ''}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial 
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open PredicateProperties
+open Morphism
+
+open PartialEquivalenceRelation
+
+module _
+  {X Y : Type ℓ'}
+  (perX : PartialEquivalenceRelation X)
+  (perY : PartialEquivalenceRelation Y)
+  (relation : Predicate (X × Y)) where
+  equalityX = perX .equality
+  equalityY = perY .equality
+  
+  realizesStrictDomain : A → Type _
+  realizesStrictDomain stD = (∀ x y r → r ⊩ ∣ relation ∣ (x , y) → (stD ⨾ r) ⊩ ∣ equalityX ∣ (x , x))
+
+  realizesStrictCodomain : A → Type _
+  realizesStrictCodomain stC = (∀ x y r → r ⊩ ∣ relation ∣ (x , y) → (stC ⨾ r) ⊩ ∣ equalityY ∣ (y , y))
+
+  realizesRelational : A → Type _
+  realizesRelational rel =
+        (∀ x x' y y' a b c
+        → a ⊩ ∣ equalityX ∣ (x , x')
+        → b ⊩ ∣ relation ∣ (x , y)
+        → c ⊩ ∣ equalityY ∣ (y , y')
+        ------------------------------------------
+        → (rel ⨾ a ⨾ b ⨾ c) ⊩ ∣ relation ∣ (x' , y'))
+
+  realizesSingleValued : A → Type _
+  realizesSingleValued sv =
+        (∀ x y y' r₁ r₂
+        → r₁ ⊩ ∣ relation ∣ (x , y)
+        → r₂ ⊩ ∣ relation ∣ (x , y')
+        -----------------------------------
+        → (sv ⨾ r₁ ⨾ r₂) ⊩ ∣ equalityY ∣ (y , y'))
+
+  realizesTotal : A → Type _
+  realizesTotal tl =
+        (∀ x r → r ⊩ ∣ equalityX ∣ (x , x) → ∃[ y ∈ Y ] (tl ⨾ r) ⊩ ∣ relation ∣ (x , y))
+    
+  record isFunctionalRelation : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+    constructor makeIsFunctionalRelation
+    field
+      isStrictDomain : ∃[ stD ∈ A ] (realizesStrictDomain stD)
+      isStrictCodomain : ∃[ stC ∈ A ] (realizesStrictCodomain stC)
+      isRelational : ∃[ rl ∈ A ] (realizesRelational rl)
+      isSingleValued : ∃[ sv ∈ A ] (realizesSingleValued sv)
+      isTotal : ∃[ tl ∈ A ] (realizesTotal tl)
+
+record FunctionalRelation {X Y : Type ℓ'} (perX : PartialEquivalenceRelation X) (perY : PartialEquivalenceRelation Y) : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+  constructor makeFunctionalRelation
+  field
+    relation : Predicate (X × Y)
+    isFuncRel : isFunctionalRelation perX perY relation
+  open isFunctionalRelation isFuncRel public
+  
+open FunctionalRelation
+
+pointwiseEntailment : ∀ {X Y : Type ℓ'} → (perX : PartialEquivalenceRelation X) → (perY : PartialEquivalenceRelation Y) → (F G : FunctionalRelation perX perY) → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+pointwiseEntailment {X} {Y} perX perY F G = ∃[ pe ∈ A ] (∀ x y r → r ⊩ ∣ F .relation ∣ (x , y) → (pe ⨾ r) ⊩ ∣ G .relation ∣ (x , y))
+
+-- Directly taken from "Realizability with Scott's Graph Model" by Tom de Jong
+-- Lemma 4.3.5
+opaque
+  F≤G→G≤F :
+    ∀ {X Y : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (F G : FunctionalRelation perX perY)
+    → pointwiseEntailment perX perY F G
+    → pointwiseEntailment perX perY G F
+  F≤G→G≤F {X} {Y} perX perY F G F≤G =
+    do
+      (r , r⊩F≤G) ← F≤G
+      (tlF , tlF⊩isTotalF) ← F .isTotal
+      (svG , svG⊩isSingleValuedG) ← G .isSingleValued
+      (rlF , rlF⊩isRelationalF) ← F .isRelational
+      (stGD , stGD⊩isStrictDomainG) ← G .isStrictDomain
+      let
+        prover : ApplStrTerm as 1
+        prover = ` rlF ̇ (` stGD ̇ # zero) ̇ (` tlF ̇ (` stGD ̇ # zero)) ̇ (` svG ̇ (` r ̇ (` tlF ̇ (` stGD ̇ # zero))) ̇ # zero)
+      return
+        (λ* prover ,
+        (λ x y s s⊩Gxy →
+          subst
+            (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+            (sym (λ*ComputationRule prover s))
+            (transport
+              (propTruncIdempotent (F .relation .isPropValued _ _))
+              (do
+                (y' , tlF⨾stGDs⊩Fxy') ← tlF⊩isTotalF x (stGD ⨾ s) (stGD⊩isStrictDomainG x y s s⊩Gxy)
+                return
+                  (rlF⊩isRelationalF
+                    x x y' y
+                    (stGD ⨾ s) (tlF ⨾ (stGD ⨾ s)) (svG ⨾ (r ⨾ (tlF ⨾ (stGD ⨾ s))) ⨾ s)
+                    (stGD⊩isStrictDomainG x y s s⊩Gxy)
+                    tlF⨾stGDs⊩Fxy'
+                    (svG⊩isSingleValuedG x y' y (r ⨾ (tlF ⨾ (stGD ⨾ s))) s (r⊩F≤G x y' (tlF ⨾ (stGD ⨾ s)) tlF⨾stGDs⊩Fxy') s⊩Gxy))))))
+
+bientailment : ∀ {X Y : Type ℓ'} → (perX : PartialEquivalenceRelation X) → (perY : PartialEquivalenceRelation Y) → FunctionalRelation perX perY → FunctionalRelation perX perY → Type _
+bientailment {X} {Y} perX perY F G = pointwiseEntailment perX perY F G × pointwiseEntailment perX perY G F
+
+isPropValuedBientailment : ∀ {X Y : Type ℓ'} → (perX : PartialEquivalenceRelation X) → (perY : PartialEquivalenceRelation Y) → (F G : FunctionalRelation perX perY) → isProp (bientailment perX perY F G)
+isPropValuedBientailment {X} {Y} perX perY F G = isProp× isPropPropTrunc isPropPropTrunc
+
+RTMorphism : ∀ {X Y : Type ℓ'} → (perX : PartialEquivalenceRelation X) → (perY : PartialEquivalenceRelation Y) → Type _
+RTMorphism {X} {Y} perX perY = FunctionalRelation perX perY / bientailment perX perY
+
+isEquivRelBientailment : ∀ {X Y : Type ℓ'} → (perX : PartialEquivalenceRelation X) → (perY : PartialEquivalenceRelation Y) → BinaryRelation.isEquivRel (bientailment perX perY)
+BinaryRelation.isEquivRel.reflexive (isEquivRelBientailment {X} {Y} perX perY) =
+  λ A →
+  ∣ Id , (λ x y r r⊩Axy → subst (λ r' → r' ⊩ ∣ A .relation ∣ (x , y)) (sym (Ida≡a _)) r⊩Axy) ∣₁ ,
+  ∣ Id , (λ x y r r⊩Axy → subst (λ r' → r' ⊩ ∣ A .relation ∣ (x , y)) (sym (Ida≡a _)) r⊩Axy) ∣₁
+BinaryRelation.isEquivRel.symmetric (isEquivRelBientailment {X} {Y} perX perY) F G (F≤G , G≤F) = G≤F , F≤G
+BinaryRelation.isEquivRel.transitive (isEquivRelBientailment {X} {Y} perX perY) F G H (F≤G , G≤F) (G≤H , H≤G) =
+  let
+    answer =
+      do
+        (s , s⊩F≤G) ← F≤G
+        (p , p⊩G≤H) ← G≤H
+        let
+          prover : ApplStrTerm as 1
+          prover = ` p ̇ (` s ̇ # zero)
+        return
+          (λ* prover ,
+          (λ x y r r⊩Fxy → subst (λ r' → r' ⊩ ∣ H .relation ∣ (x , y)) (sym (λ*ComputationRule prover r)) (p⊩G≤H x y (s ⨾ r) (s⊩F≤G x y r r⊩Fxy))))
+  in
+  answer , F≤G→G≤F perX perY F H answer
+
+opaque
+  idFuncRel : ∀ {X : Type ℓ'} → (perX : PartialEquivalenceRelation X) → FunctionalRelation perX perX
+  relation (idFuncRel {X} perX) = perX .equality
+  isFunctionalRelation.isStrictDomain (isFuncRel (idFuncRel {X} perX)) =
+    do
+      (s , s⊩isSymmetric) ← perX .isSymmetric
+      (t , t⊩isTransitive) ← perX .isTransitive
+      let
+        prover : ApplStrTerm as 1
+        prover = ` t ̇ # zero ̇ (` s ̇ # zero)
+      return
+        (λ* prover ,
+         λ x x' r r⊩x~x' →
+           subst
+             (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+             (sym (λ*ComputationRule prover r))
+             (t⊩isTransitive x x' x r (s ⨾ r) r⊩x~x' (s⊩isSymmetric x x' r r⊩x~x')))
+  isFunctionalRelation.isStrictCodomain (isFuncRel (idFuncRel {X} perX)) =
+    do
+      (s , s⊩isSymmetric) ← perX .isSymmetric
+      (t , t⊩isTransitive) ← perX .isTransitive
+      let
+        prover : ApplStrTerm as 1
+        prover = ` t ̇ (` s ̇ # zero) ̇ # zero
+      return
+        (λ* prover ,
+        (λ x x' r r⊩x~x' →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'))
+            (sym (λ*ComputationRule prover r))
+            (t⊩isTransitive x' x x' (s ⨾ r) r (s⊩isSymmetric x x' r r⊩x~x') r⊩x~x')))
+  isFunctionalRelation.isRelational (isFuncRel (idFuncRel {X} perX)) =
+    do
+      (s , s⊩isSymmetric) ← perX .isSymmetric
+      (t , t⊩isTransitive) ← perX .isTransitive
+      let
+        prover : ApplStrTerm as 3
+        prover = ` t ̇ (` t ̇ (` s ̇ # two) ̇ # one) ̇ # zero
+      return
+        (λ*3 prover ,
+        (λ x₁ x₂ x₃ x₄ a b c a⊩x₁~x₂ b⊩x₁~x₃ c⊩x₃~x₄ →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄))
+            (sym (λ*3ComputationRule prover a b c))
+            (t⊩isTransitive x₂ x₃ x₄ (t ⨾ (s ⨾ a) ⨾ b) c (t⊩isTransitive x₂ x₁ x₃ (s ⨾ a) b (s⊩isSymmetric x₁ x₂ a a⊩x₁~x₂) b⊩x₁~x₃) c⊩x₃~x₄)))
+  isFunctionalRelation.isSingleValued (isFuncRel (idFuncRel {X} perX)) =
+    do
+      (s , s⊩isSymmetric) ← perX .isSymmetric
+      (t , t⊩isTransitive) ← perX .isTransitive
+      let
+        prover : ApplStrTerm as 2
+        prover = ` t ̇ (` s ̇ # one) ̇ # zero
+      return
+        (λ*2 prover ,
+        (λ x₁ x₂ x₃ r₁ r₂ r₁⊩x₁~x₂ r₂⊩x₁~x₃ →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₃))
+            (sym (λ*2ComputationRule prover r₁ r₂))
+            (t⊩isTransitive x₂ x₁ x₃ (s ⨾ r₁) r₂ (s⊩isSymmetric x₁ x₂ r₁ r₁⊩x₁~x₂) r₂⊩x₁~x₃)))
+  isFunctionalRelation.isTotal (isFuncRel (idFuncRel {X} perX)) =
+    do
+      (s , s⊩isSymmetric) ← perX .isSymmetric
+      (t , t⊩isTransitive) ← perX .isTransitive
+      return
+        (Id ,
+        (λ x r r⊩x~x → ∣ x , subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (Ida≡a _)) r⊩x~x ∣₁))
+
+idRTMorphism : ∀ {X : Type ℓ'} → (perX : PartialEquivalenceRelation X) → RTMorphism perX perX
+idRTMorphism {X} perX = [ idFuncRel perX ]
+
+opaque
+  {-# TERMINATING #-} -- bye bye, type-checking with --safe 😔💔
+  composeFuncRel :
+    ∀ {X Y Z : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (perZ : PartialEquivalenceRelation Z)
+    → FunctionalRelation perX perY
+    → FunctionalRelation perY perZ
+    → FunctionalRelation perX perZ
+  isSetPredicateBase (relation (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) = isSet× (perX .isSetX) (perZ .isSetX)
+  ∣ relation (composeFuncRel {X} {Y} {Z} perX perY perZ F G) ∣ (x , z) r =
+    ∃[ y ∈ Y ] (pr₁ ⨾ r) ⊩ ∣ F .relation ∣ (x , y) × (pr₂ ⨾ r) ⊩ ∣ G .relation ∣ (y , z)
+  isPropValued (relation (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) (x , z) r = isPropPropTrunc
+  isFunctionalRelation.isStrictDomain (isFuncRel (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) =
+    do
+      (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+      let
+        prover : ApplStrTerm as 1
+        prover = ` stFD ̇ (` pr₁ ̇ # zero)
+      return
+        (λ* prover ,
+        (λ x z r r⊩∃y →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+            (sym (λ*ComputationRule prover r))
+            (transport
+              (propTruncIdempotent (perX .equality .isPropValued _ _))
+              (do
+                (y , pr₁r⊩Fxy , pr₂r⊩Gyz) ← r⊩∃y
+                return (stFD⊩isStrictDomainF x y (pr₁ ⨾ r) pr₁r⊩Fxy)))))
+  isFunctionalRelation.isStrictCodomain (isFuncRel (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) =
+    do
+      (stGC , stGC⊩isStrictCodomainG) ← G .isStrictCodomain
+      let
+        prover : ApplStrTerm as 1
+        prover = ` stGC ̇ (` pr₂ ̇ # zero)
+      return
+        (λ* prover ,
+         λ x z r r⊩∃y →
+           subst
+             (λ r' → r' ⊩ ∣ perZ .equality ∣ (z , z))
+             (sym (λ*ComputationRule prover r))
+             (transport
+               (propTruncIdempotent (perZ .equality .isPropValued _ _))
+               (do
+                 (y , pr₁r⊩Fxy , pr₂r⊩Gyz) ← r⊩∃y
+                 return (stGC⊩isStrictCodomainG y z (pr₂ ⨾ r) pr₂r⊩Gyz))))
+  isFunctionalRelation.isRelational (isFuncRel (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) =
+    do
+      (rlF , rlF⊩isRelationalF) ← F .isRelational
+      (rlG , rlG⊩isRelationalG) ← G .isRelational
+      (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+      let
+        prover : ApplStrTerm as 3
+        prover = ` pair ̇ (` rlF ̇ # two ̇ (` pr₁ ̇ # one) ̇ (` stFC ̇ (` pr₁ ̇ # one))) ̇ (` rlG ̇ (` stFC ̇ (` pr₁ ̇ # one)) ̇ (` pr₂ ̇ # one) ̇ # zero)
+      return
+        (λ*3 prover ,
+        (λ x x' z z' a b c a⊩x~x' b⊩∃y c⊩z~z' →
+          do
+            (y , pr₁b⊩Fxy , pr₂b⊩Gyz) ← b⊩∃y
+            let
+              pr₁proofEq : pr₁ ⨾ (λ*3 prover ⨾ a ⨾ b ⨾ c) ≡ rlF ⨾ a ⨾ (pr₁ ⨾ b) ⨾ (stFC ⨾ (pr₁ ⨾ b))
+              pr₁proofEq = cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₁pxy≡x _ _
+
+              pr₂proofEq : pr₂ ⨾ (λ*3 prover ⨾ a ⨾ b ⨾ c) ≡ rlG ⨾ (stFC ⨾ (pr₁ ⨾ b)) ⨾ (pr₂ ⨾ b) ⨾ c
+              pr₂proofEq = cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule prover a b c) ∙ pr₂pxy≡y _ _
+            return
+              (y ,
+               subst
+                 (λ r' → r' ⊩ ∣ F .relation ∣ (x' , y))
+                 (sym pr₁proofEq)
+                 (rlF⊩isRelationalF x x' y y a (pr₁ ⨾ b) (stFC ⨾ (pr₁ ⨾ b)) a⊩x~x' pr₁b⊩Fxy (stFC⊩isStrictCodomainF x y (pr₁ ⨾ b) pr₁b⊩Fxy)) ,
+               subst
+                 (λ r' → r' ⊩ ∣ G .relation ∣ (y , z'))
+                 (sym pr₂proofEq)
+                 (rlG⊩isRelationalG y y z z' (stFC ⨾ (pr₁ ⨾ b)) (pr₂ ⨾ b) c (stFC⊩isStrictCodomainF x y (pr₁ ⨾ b) pr₁b⊩Fxy) pr₂b⊩Gyz c⊩z~z'))))
+  isFunctionalRelation.isSingleValued (isFuncRel (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) =
+    do
+      (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+      (svG , svG⊩isSingleValuedG) ← G .isSingleValued
+      (relG , relG⊩isRelationalG) ← G .isRelational
+      (stGC , stGC⊩isStrictCodomainG) ← G .isStrictCodomain
+      let
+        prover : ApplStrTerm as 2
+        prover = ` svG ̇ (` pr₂ ̇ # one) ̇ (` relG ̇ (` svF ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ # one)) ̇ (` pr₂ ̇ # zero) ̇ (` stGC ̇ (` pr₂ ̇ # zero)))
+      return
+        (λ*2 prover ,
+        (λ x z z' r₁ r₂ r₁⊩∃y r₂⊩∃y →
+          transport
+            (propTruncIdempotent (perZ .equality .isPropValued _ _))
+            (do
+              (y , pr₁r₁⊩Fxy , pr₂r₁⊩Gyz) ← r₁⊩∃y
+              (y' , pr₁r₂⊩Fxy' , pr₂r₂⊩Gy'z') ← r₂⊩∃y
+              return
+                (subst
+                  (λ r' → r' ⊩ ∣ perZ .equality ∣ (z , z'))
+                  (sym (λ*2ComputationRule prover r₁ r₂))
+                  (svG⊩isSingleValuedG
+                    y z z'
+                    (pr₂ ⨾ r₁)
+                    (relG ⨾ (svF ⨾ (pr₁ ⨾ r₂) ⨾ (pr₁ ⨾ r₁)) ⨾ (pr₂ ⨾ r₂) ⨾ (stGC ⨾ (pr₂ ⨾ r₂)))
+                    pr₂r₁⊩Gyz
+                    (relG⊩isRelationalG
+                      y' y z' z'
+                      (svF ⨾ (pr₁ ⨾ r₂) ⨾ (pr₁ ⨾ r₁))
+                      (pr₂ ⨾ r₂)
+                      (stGC ⨾ (pr₂ ⨾ r₂))
+                      (svF⊩isSingleValuedF x y' y (pr₁ ⨾ r₂) (pr₁ ⨾ r₁) pr₁r₂⊩Fxy' pr₁r₁⊩Fxy)
+                      pr₂r₂⊩Gy'z'
+                      (stGC⊩isStrictCodomainG y' z' (pr₂ ⨾ r₂) pr₂r₂⊩Gy'z')))))))
+  isFunctionalRelation.isTotal (isFuncRel (composeFuncRel {X} {Y} {Z} perX perY perZ F G)) =
+    do
+      (tlF , tlF⊩isTotalF) ← F .isTotal
+      (tlG , tlG⊩isTotalG) ← G .isTotal
+      (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pair ̇ (` tlF ̇ # zero) ̇ (` tlG ̇ (` stFC ̇ (` tlF ̇ # zero)))
+      return
+        (λ* prover ,
+        (λ x r r⊩x~x →
+          do
+            (y , ⊩Fxy) ← tlF⊩isTotalF x r r⊩x~x
+            (z , ⊩Gyz) ← tlG⊩isTotalG y (stFC ⨾ (tlF ⨾ r)) (stFC⊩isStrictCodomainF x y (tlF ⨾ r) ⊩Fxy)
+            return
+              (z ,
+              return
+                (y ,
+                ((subst (λ r' → r' ⊩ ∣ F .relation ∣ (x , y)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _)) ⊩Fxy) ,
+                 (subst (λ r' → r' ⊩ ∣ G .relation ∣ (y , z)) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _)) ⊩Gyz))))))
+
+opaque
+  unfolding composeFuncRel
+  composeRTMorphism :
+    ∀ {X Y Z : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (perZ : PartialEquivalenceRelation Z)
+    → (f : RTMorphism perX perY)
+    → (g : RTMorphism perY perZ)
+    ----------------------------------------
+    → RTMorphism perX perZ
+  composeRTMorphism {X} {Y} {Z} perX perY perZ f g =
+    SQ.rec2
+      squash/
+      (λ F G → [ composeFuncRel perX perY perZ F G ])
+      (λ { F F' G (F≤F' , F'≤F) →
+        eq/ _ _
+          let answer = (do
+              (s , s⊩F≤F') ← F≤F'
+              let
+                prover : ApplStrTerm as 1
+                prover = ` pair ̇ (` s ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero)
+              return
+                (λ* prover ,
+                (λ x z r r⊩∃y →
+                  do
+                    (y , pr₁r⊩Fxy , pr₂r⊩Gyz) ← r⊩∃y
+                    return
+                      (y ,
+                       subst
+                         (λ r' → r' ⊩ ∣ F' .relation ∣ (x , y))
+                         (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                         (s⊩F≤F' x y (pr₁ ⨾ r) pr₁r⊩Fxy) ,
+                       subst
+                         (λ r' → r' ⊩ ∣ G .relation ∣ (y , z))
+                         (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _))
+                         pr₂r⊩Gyz))))
+          in
+        (answer , F≤G→G≤F perX perZ (composeFuncRel perX perY perZ F G) (composeFuncRel perX perY perZ F' G) answer) })
+      (λ { F G G' (G≤G' , G'≤G) →
+        eq/ _ _
+          let answer = (do
+            (s , s⊩G≤G') ← G≤G'
+            let
+              prover : ApplStrTerm as 1
+              prover = ` pair ̇ (` pr₁ ̇ # zero) ̇ (` s ̇ (` pr₂ ̇ # zero))
+            return
+              (λ* prover ,
+              (λ x z r r⊩∃y →
+                 do
+                   (y , pr₁r⊩Fxy , pr₂r⊩Gyz) ← r⊩∃y
+
+                   return
+                     (y ,
+                      subst (λ r' → r' ⊩ ∣ F .relation ∣ (x , y)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _)) pr₁r⊩Fxy ,
+                      subst (λ r' → r' ⊩ ∣ G' .relation ∣ (y , z)) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover r) ∙ pr₂pxy≡y _ _)) (s⊩G≤G' y z (pr₂ ⨾ r) pr₂r⊩Gyz)))))
+          in
+        (answer , F≤G→G≤F perX perZ (composeFuncRel perX perY perZ F G) (composeFuncRel perX perY perZ F G') answer) })
+      f g
+
+opaque
+  unfolding composeRTMorphism
+  unfolding idFuncRel
+  idLRTMorphism :
+    ∀ {X Y : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (f : RTMorphism perX perY)
+    → composeRTMorphism perX perX perY (idRTMorphism perX) f ≡ f
+  idLRTMorphism {X} {Y} perX perY f =
+    SQ.elimProp
+      (λ f → squash/ (composeRTMorphism perX perX perY (idRTMorphism perX) f) f)
+      (λ F →
+        let
+          answer : pointwiseEntailment perX perY (composeFuncRel perX perX perY (idFuncRel perX) F) F
+          answer =
+            do
+              (relF , relF⊩isRelationalF) ← F .isRelational
+              (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+              (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+              let
+                prover : ApplStrTerm as 1
+                prover = ` relF ̇ (` sX ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero) ̇ (` stFC ̇ (` pr₂ ̇ # zero))
+              return
+                (λ* prover ,
+                 (λ x y r r⊩∃x' →
+                   transport
+                     (propTruncIdempotent (F .relation .isPropValued _ _))
+                     (do
+                       (x' , pr₁r⊩x~x' , pr₂r⊩Fx'y) ← r⊩∃x'
+                       return
+                         (subst
+                           (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+                           (sym (λ*ComputationRule prover r))
+                           (relF⊩isRelationalF
+                             x' x y y
+                             (sX ⨾ (pr₁ ⨾ r)) (pr₂ ⨾ r) (stFC ⨾ (pr₂ ⨾ r))
+                             (sX⊩isSymmetricX x x' (pr₁ ⨾ r) pr₁r⊩x~x')
+                             pr₂r⊩Fx'y
+                             (stFC⊩isStrictCodomainF x' y (pr₂ ⨾ r) pr₂r⊩Fx'y))))))
+        in
+        eq/ _ _ (answer , F≤G→G≤F perX perY (composeFuncRel perX perX perY (idFuncRel perX) F) F answer))
+      f
+
+opaque
+  unfolding composeRTMorphism
+  unfolding idFuncRel
+  idRRTMorphism :
+    ∀ {X Y : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (f : RTMorphism perX perY)
+    → composeRTMorphism perX perY perY f (idRTMorphism perY) ≡ f
+  idRRTMorphism {X} {Y} perX perY f =
+    SQ.elimProp
+      (λ f → squash/ (composeRTMorphism perX perY perY f (idRTMorphism perY)) f)
+      (λ F →
+        let
+          answer : pointwiseEntailment perX perY (composeFuncRel perX perY perY F (idFuncRel perY)) F
+          answer =
+            do
+              (relF , relF⊩isRelationalF) ← F .isRelational
+              (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+              let
+                prover : ApplStrTerm as 1
+                prover = ` relF ̇ (` stFD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₂ ̇ # zero)
+              return
+                (λ* prover ,
+                (λ x y r r⊩∃y' →
+                  transport
+                    (propTruncIdempotent (F .relation .isPropValued _ _))
+                    (do
+                      (y' , pr₁r⊩Fxy' , pr₂r⊩y'~y) ← r⊩∃y'
+                      return
+                        (subst
+                          (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+                          (sym (λ*ComputationRule prover r))
+                          (relF⊩isRelationalF x x y' y (stFD ⨾ (pr₁ ⨾ r)) (pr₁ ⨾ r) (pr₂ ⨾ r) (stFD⊩isStrictDomainF x y' (pr₁ ⨾ r) pr₁r⊩Fxy') pr₁r⊩Fxy' pr₂r⊩y'~y)))))
+        in
+        eq/ _ _ (answer , F≤G→G≤F perX perY (composeFuncRel perX perY perY F (idFuncRel perY)) F answer))
+      f
+
+opaque
+  unfolding composeRTMorphism
+  assocRTMorphism :
+    ∀ {X Y Z W : Type ℓ'}
+    → (perX : PartialEquivalenceRelation X)
+    → (perY : PartialEquivalenceRelation Y)
+    → (perZ : PartialEquivalenceRelation Z)
+    → (perW : PartialEquivalenceRelation W)
+    → (f : RTMorphism perX perY)
+    → (g : RTMorphism perY perZ)
+    → (h : RTMorphism perZ perW)
+    → composeRTMorphism perX perZ perW (composeRTMorphism perX perY perZ f g) h ≡ composeRTMorphism perX perY perW f (composeRTMorphism perY perZ perW g h)
+  assocRTMorphism {X} {Y} {Z} {W} perX perY perZ perW f g h =
+    SQ.elimProp3
+      (λ f g h →
+        squash/
+          (composeRTMorphism perX perZ perW (composeRTMorphism perX perY perZ f g) h)
+          (composeRTMorphism perX perY perW f (composeRTMorphism perY perZ perW g h)))
+      (λ F G H →
+        let
+          answer =
+            do
+              let
+                prover : ApplStrTerm as 1
+                prover = ` pair ̇ (` pr₁ ̇ (` pr₁ ̇ # zero)) ̇ (` pair ̇ (` pr₂ ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero))
+              return
+                (λ* prover ,
+                (λ x w r r⊩∃z →
+                  transport
+                    (propTruncIdempotent isPropPropTrunc)
+                    (do
+                      (z , pr₁r⊩∃y , pr₂r⊩Hzw) ← r⊩∃z
+                      (y , pr₁pr₁r⊩Fxy , pr₂pr₁r⊩Gyz) ← pr₁r⊩∃y
+                      return
+                        (return
+                          (y ,
+                            (subst
+                              (λ r' → r' ⊩ ∣ F .relation ∣ (x , y))
+                              (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover r) ∙ pr₁pxy≡x _ _))
+                              pr₁pr₁r⊩Fxy ,
+                            return
+                              (z ,
+                                ((subst
+                                  (λ r' → r' ⊩ ∣ G .relation ∣ (y , z))
+                                  (sym
+                                    (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙
+                                     cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+                                  pr₂pr₁r⊩Gyz) ,
+                                 (subst
+                                  (λ r' → r' ⊩ ∣ H .relation ∣ (z , w))
+                                  (sym
+                                    (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule prover r) ∙
+                                     cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+                                  pr₂r⊩Hzw)))))))))
+        in
+        eq/ _ _
+          (answer ,
+           F≤G→G≤F
+             perX perW
+             (composeFuncRel perX perZ perW (composeFuncRel perX perY perZ F G) H)
+             (composeFuncRel perX perY perW F (composeFuncRel perY perZ perW G H))
+             answer))
+      f g h
+
+-- Very useful helper functions to prevent type-checking time from exploding
+opaque
+  [F]≡[G]→F≤G : ∀ {X Y : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} → (F G : FunctionalRelation perX perY) → [_] {R = bientailment perX perY} F ≡ [_] {R = bientailment perX perY} G → pointwiseEntailment perX perY F G
+  [F]≡[G]→F≤G {X} {Y} {perX} {perY} F G iso = SQ.effective (isPropValuedBientailment perX perY) (isEquivRelBientailment perX perY) F G iso .fst
+
+  [F]≡[G]→G≤F : ∀ {X Y : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} → (F G : FunctionalRelation perX perY) → [_] {R = bientailment perX perY} F ≡ [_] {R = bientailment perX perY} G → pointwiseEntailment perX perY G F
+  [F]≡[G]→G≤F {X} {Y} {perX} {perY} F G iso = SQ.effective (isPropValuedBientailment perX perY) (isEquivRelBientailment perX perY) F G iso .snd
+
+opaque
+  unfolding composeRTMorphism
+  [F]⋆[G]≡[H]⋆[I]→F⋆G≤H⋆I : ∀ {X Y Z W : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} {perZ : PartialEquivalenceRelation Z} {perW : PartialEquivalenceRelation W} → (F : FunctionalRelation perX perY) (G : FunctionalRelation perY perZ) (H : FunctionalRelation perX perW) (I : FunctionalRelation perW perZ) → composeRTMorphism _ _ _ [ F ] [ G ] ≡ composeRTMorphism _ _ _ [ H ] [ I ] → pointwiseEntailment _ _ (composeFuncRel _ _ _ F G) (composeFuncRel _ _ _ H I)
+  [F]⋆[G]≡[H]⋆[I]→F⋆G≤H⋆I {X} {Y} {Z} {W} {perX} {perY} {perZ} {perW} F G H I iso =
+    SQ.effective (isPropValuedBientailment perX perZ) (isEquivRelBientailment perX perZ) (composeFuncRel _ _ _ F G) (composeFuncRel _ _ _ H I) iso .fst
+
+opaque
+  unfolding composeRTMorphism
+  [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G : ∀ {X Y Z W : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} {perZ : PartialEquivalenceRelation Z} {perW : PartialEquivalenceRelation W} → (F : FunctionalRelation perX perY) (G : FunctionalRelation perY perZ) (H : FunctionalRelation perX perW) (I : FunctionalRelation perW perZ) → composeRTMorphism _ _ _ [ F ] [ G ] ≡ composeRTMorphism _ _ _ [ H ] [ I ] → pointwiseEntailment _ _ (composeFuncRel _ _ _ H I) (composeFuncRel _ _ _ F G)
+  [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G {X} {Y} {Z} {W} {perX} {perY} {perZ} {perW} F G H I iso =
+    SQ.effective (isPropValuedBientailment perX perZ) (isEquivRelBientailment perX perZ) (composeFuncRel _ _ _ F G) (composeFuncRel _ _ _ H I) iso .snd
+
+opaque
+  unfolding composeRTMorphism
+  [F]≡[G]⋆[H]→F≤G⋆H : ∀ {X Y Z : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} {perZ : PartialEquivalenceRelation Z} → (F : FunctionalRelation perX perZ) (G : FunctionalRelation perX perY) (H : FunctionalRelation perY perZ) → [ F ] ≡ composeRTMorphism _ _ _ [ G ] [ H ] → pointwiseEntailment _ _ F (composeFuncRel _ _ _ G H)
+  [F]≡[G]⋆[H]→F≤G⋆H {X} {Y} {Z} {perX} {perY} {perZ} F G H iso =
+    SQ.effective (isPropValuedBientailment perX perZ) (isEquivRelBientailment perX perZ) F (composeFuncRel _ _ _ G H) iso .fst
+
+opaque
+  unfolding composeRTMorphism
+  [F]≡[G]⋆[H]→G⋆H≤F : ∀ {X Y Z : Type ℓ'} {perX : PartialEquivalenceRelation X} {perY : PartialEquivalenceRelation Y} {perZ : PartialEquivalenceRelation Z} → (F : FunctionalRelation perX perZ) (G : FunctionalRelation perX perY) (H : FunctionalRelation perY perZ) → [ F ] ≡ composeRTMorphism _ _ _ [ G ] [ H ] → pointwiseEntailment _ _ (composeFuncRel _ _ _ G H) F
+  [F]≡[G]⋆[H]→G⋆H≤F {X} {Y} {Z} {perX} {perY} {perZ} F G H iso = SQ.effective (isPropValuedBientailment perX perZ) (isEquivRelBientailment perX perZ) F (composeFuncRel _ _ _ G H) iso .snd
+
+RT : Category (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-suc ℓ') (ℓ-suc ℓ''))) (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-suc ℓ') (ℓ-suc ℓ'')))
+Category.ob RT = Σ[ X ∈ Type ℓ' ] PartialEquivalenceRelation X
+Category.Hom[_,_] RT (X , perX) (Y , perY) = RTMorphism perX perY
+Category.id RT {X , perX} = idRTMorphism perX
+Category._⋆_ RT {X , perX} {y , perY} {Z , perZ} f g = composeRTMorphism perX perY perZ f g
+Category.⋆IdL RT {X , perX} {Y , perY} f = idLRTMorphism perX perY f
+Category.⋆IdR RT {X , perX} {Y , perY} f = idRRTMorphism perX perY f
+Category.⋆Assoc RT {X , perX} {Y , perY} {Z , perZ} {W , perW} f g h = assocRTMorphism perX perY perZ perW f g h
+Category.isSetHom RT = squash/
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.MonicReprFuncRel.html b/docs/Realizability.Topos.MonicReprFuncRel.html new file mode 100644 index 0000000..5c0622c --- /dev/null +++ b/docs/Realizability.Topos.MonicReprFuncRel.html @@ -0,0 +1,280 @@ + +Realizability.Topos.MonicReprFuncRel
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Structure
+open import Cubical.Foundations.HLevels
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.FinData
+open import Cubical.Data.Fin hiding (Fin; _/_)
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty
+open import Cubical.Data.Unit
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Morphism
+open import Cubical.Relation.Binary
+
+module Realizability.Topos.MonicReprFuncRel
+  {ℓ ℓ' ℓ''}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial 
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.Equalizer {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.BinProducts {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open PredicateProperties
+open Morphism
+open PartialEquivalenceRelation
+open FunctionalRelation
+open Category RT
+
+-- Monics in RT
+module _ {X Y : Type ℓ'} (perX : PartialEquivalenceRelation X) (perY : PartialEquivalenceRelation Y) (F : FunctionalRelation perX perY) where
+
+  opaque
+    isInjectiveFuncRel : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ''))
+    isInjectiveFuncRel =
+      ∃[ inj ∈ A ] (∀ x x' y r₁ r₂ → r₁ ⊩ ∣ F .relation ∣ (x , y) → r₂ ⊩ ∣ F .relation ∣ (x' , y) → (inj ⨾ r₁ ⨾ r₂) ⊩ ∣ perX .equality ∣ (x , x'))
+
+  opaque
+    unfolding isInjectiveFuncRel
+    isPropIsInjectiveFuncRel : isProp isInjectiveFuncRel
+    isPropIsInjectiveFuncRel = isPropPropTrunc
+
+  -- This is the easier part
+  -- Essentially just a giant realizer that uses the injectivity
+  opaque
+    unfolding composeRTMorphism
+    unfolding composeFuncRel
+    unfolding isInjectiveFuncRel
+    isInjectiveFuncRel→isMonic : isInjectiveFuncRel → isMonic RT [ F ]
+    isInjectiveFuncRel→isMonic isInjectiveF {Z , perZ} {a} {b} a⋆[F]≡b⋆[F] =
+      SQ.elimProp2
+        {P = λ a b → composeRTMorphism _ _ _ a [ F ] ≡ composeRTMorphism _ _ _ b [ F ] → a ≡ b}
+        (λ a b → isPropΠ λ _ → squash/ a b)
+        (λ A B A⋆F≡B⋆F →
+          let
+            (p , q) = SQ.effective (isPropValuedBientailment perZ perY) (isEquivRelBientailment perZ perY) _ _ A⋆F≡B⋆F
+            answer =
+              do
+                (p , p⊩A⋆F≤B⋆F) ← p
+                (stCA , stCA⊩isStrictCodomainA) ← A .isStrictCodomain
+                (stDA , stDA⊩isStrictDomainA) ← A .isStrictDomain
+                (tlF , tlF⊩isTotalF) ← F .isTotal
+                (relB , relB⊩isRelationalB) ← B .isRelational
+                (injF , injF⊩isInjectiveF) ← isInjectiveF
+                let
+                  realizer : ApplStrTerm as 1
+                  realizer =
+                    ` relB ̇ (` stDA ̇ # zero) ̇ (` pr₁ ̇ (` p ̇ (` pair ̇ # zero ̇ (` tlF ̇ (` stCA ̇ # zero))))) ̇
+                      (` injF ̇ (` pr₂ ̇ (` p ̇ (` pair ̇ # zero ̇ (` tlF ̇ (` stCA ̇ # zero))))) ̇
+                      (` tlF ̇ (` stCA ̇ # zero)))
+                return
+                  (λ* realizer ,
+                  (λ z x r r⊩Azx →
+                    transport
+                      (propTruncIdempotent (B .relation .isPropValued _ _))
+                      (do
+                        let
+                          x~x = stCA⊩isStrictCodomainA z x r r⊩Azx
+                          z~z = stDA⊩isStrictDomainA z x r r⊩Azx
+                        (y , ⊩Fxy) ← tlF⊩isTotalF x _ x~x
+                        (x' , ⊩Bzx' , ⊩Fx'y)  ←
+                          p⊩A⋆F≤B⋆F
+                            z y
+                            (pair ⨾ r ⨾ (tlF ⨾ (stCA ⨾ r)))
+                            (return
+                              (x ,
+                              subst (λ r' → r' ⊩ ∣ A .relation ∣ (z , x)) (sym (pr₁pxy≡x _ _)) r⊩Azx ,
+                              subst (λ r' → r' ⊩ ∣ F .relation ∣ (x , y)) (sym (pr₂pxy≡y _ _)) ⊩Fxy))
+                        let
+                          x'~x = injF⊩isInjectiveF x' x y _ _ ⊩Fx'y ⊩Fxy -- this is the only place where we actually need the injectivity
+                        return
+                          (subst
+                            (λ r' → r' ⊩ ∣ B .relation ∣ (z , x))
+                            (sym (λ*ComputationRule realizer r))
+                            (relB⊩isRelationalB z z x' x _ _ _ z~z ⊩Bzx' x'~x)))))
+          in
+          eq/ A B (answer , F≤G→G≤F perZ perX A B answer))
+        a b
+        a⋆[F]≡b⋆[F]
+
+  opaque
+    unfolding binProdPr₁RT
+    unfolding binProdPr₁FuncRel
+    unfolding binProdPr₂FuncRel
+    unfolding equalizerMorphism
+    unfolding composeRTMorphism
+
+    π₁ : FunctionalRelation (binProdObRT perX perX) perX
+    π₁ = binProdPr₁FuncRel perX perX
+
+    π₂ : FunctionalRelation (binProdObRT perX perX) perX
+    π₂ = binProdPr₂FuncRel perX perX
+
+    kernelPairEqualizerFuncRel :
+      FunctionalRelation
+        (equalizerPer -- hehe
+          (binProdObRT perX perX) perY
+          ([ π₁ ] ⋆ [ F ])
+          ([ π₂ ] ⋆ [ F ])
+          (composeFuncRel _ _ _ π₁ F)
+          (composeFuncRel _ _ _ π₂ F))
+        (binProdObRT perX perX)
+    kernelPairEqualizerFuncRel =
+      equalizerFuncRel _ _
+        ((binProdPr₁RT perX perX) ⋆ [ F ])
+        ((binProdPr₂RT perX perX) ⋆ [ F ])
+        (composeFuncRel _ _ _ (binProdPr₁FuncRel perX perX) F)
+        (composeFuncRel _ _ _ (binProdPr₂FuncRel perX perX) F)
+
+    kernelPairEqualizer⋆π₁≡kernelPairEqualizer⋆π₂ :
+      composeRTMorphism _ _ _ [ kernelPairEqualizerFuncRel ] (composeRTMorphism _ _ _ [ π₁ ] [ F ]) ≡ composeRTMorphism _ _ _ [ kernelPairEqualizerFuncRel ] (composeRTMorphism _ _ _ [ π₂ ] [ F ])
+    kernelPairEqualizer⋆π₁≡kernelPairEqualizer⋆π₂ =
+      inc⋆f≡inc⋆g
+        (binProdObRT perX perX) perY
+        (composeRTMorphism _ _ _ [ π₁ ] [ F ])
+        (composeRTMorphism _ _ _ [ π₂ ] [ F ])
+        (composeFuncRel _ _ _ π₁ F)
+        (composeFuncRel _ _ _ π₂ F)
+
+    mainKernelPairEquation : ([ kernelPairEqualizerFuncRel ] ⋆ [ π₁ ]) ⋆ [ F ] ≡ ([ kernelPairEqualizerFuncRel ] ⋆ [ π₂ ]) ⋆ [ F ]
+    mainKernelPairEquation =
+      ([ kernelPairEqualizerFuncRel ] ⋆ [ π₁ ]) ⋆ [ F ]
+        ≡⟨ ⋆Assoc [ kernelPairEqualizerFuncRel ] [ π₁ ] [ F ]  ⟩ -- Agda cannot solve these as constraints 😔
+      [ kernelPairEqualizerFuncRel ] ⋆ ([ π₁ ] ⋆ [ F ])
+        ≡⟨ kernelPairEqualizer⋆π₁≡kernelPairEqualizer⋆π₂ ⟩
+      [ kernelPairEqualizerFuncRel ] ⋆ ([ π₂ ] ⋆ [ F ])
+        ≡⟨ sym (⋆Assoc [ kernelPairEqualizerFuncRel ] [ π₂ ] [ F ]) ⟩
+      ([ kernelPairEqualizerFuncRel ] ⋆ [ π₂ ]) ⋆ [ F ]
+        ∎
+
+  opaque
+    unfolding isInjectiveFuncRel
+    unfolding composeRTMorphism
+    unfolding kernelPairEqualizerFuncRel
+    unfolding equalizerFuncRel
+    unfolding equalizerPer
+    unfolding binProdPr₁RT
+    unfolding binProdPr₂FuncRel
+    isMonic→isInjectiveFuncRel : isMonic RT [ F ] → isInjectiveFuncRel
+    isMonic→isInjectiveFuncRel isMonicF =
+      do
+        let
+          equation = isMonicF {a = [ kernelPairEqualizerFuncRel ] ⋆ [ π₁ ]} {a' = [ kernelPairEqualizerFuncRel ] ⋆ [ π₂ ]} mainKernelPairEquation
+          (p , q) = SQ.effective (isPropValuedBientailment _ _) (isEquivRelBientailment _ _) _ _ equation
+        (p , p⊩kπ₁≤kπ₂) ← p
+        (q , q⊩kπ₂≤kπ₁) ← q
+        (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+        (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain
+        (s , s⊩isSymmetricEqX) ← perX .isSymmetric
+        (t , t⊩isTransitiveEqX) ← perX .isTransitive
+        let
+          cursed : ApplStrTerm as 2
+          cursed =
+             (` pair ̇
+                  (` pair ̇
+                    (` pair ̇ (` stDF ̇ # one) ̇ (` stDF ̇ # zero)) ̇
+                    (` pair ̇ (` pair ̇ (` pair ̇ (` stDF ̇ # one) ̇ (` stDF ̇ # zero)) ̇ # one) ̇ (` pair ̇ (` pair ̇ (` stDF ̇ # zero) ̇ (` stDF ̇ # one)) ̇ # zero))) ̇
+                  (` pair ̇ (` stDF ̇ # one) ̇ (` stDF ̇ # zero)))
+          realizer : ApplStrTerm as 2
+          realizer = ` t ̇ (` s ̇ (` pr₁ ̇ (` pr₂ ̇ (` p ̇ cursed)))) ̇ (` s ̇ (` pr₂ ̇ (` pr₁ ̇ (` pr₁ ̇ (` p ̇ cursed)))))
+        return
+          (λ*2 realizer ,
+          (λ x₁ x₂ y r₁ r₂ r₁⊩Fx₁y r₂⊩Fx₂y →
+            let
+              x₁~x₁ = stDF⊩isStrictDomainF x₁ y r₁ r₁⊩Fx₁y
+              x₂~x₂ = stDF⊩isStrictDomainF x₂ y r₂ r₂⊩Fx₂y
+              foo =
+                p⊩kπ₁≤kπ₂ (x₁ , x₂) x₁
+                (pair ⨾
+                  (pair ⨾
+                    (pair ⨾ (stDF ⨾ r₁) ⨾ (stDF ⨾ r₂)) ⨾
+                    (pair ⨾ (pair ⨾ (pair ⨾ (stDF ⨾ r₁) ⨾ (stDF ⨾ r₂)) ⨾ r₁) ⨾ (pair ⨾ (pair ⨾ (stDF ⨾ r₂) ⨾ (stDF ⨾ r₁)) ⨾ r₂))) ⨾
+                  (pair ⨾ (stDF ⨾ r₁) ⨾ (stDF ⨾ r₂)))
+                (return
+                  (((x₁ , x₂)) ,
+                  ((subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₁)) (sym (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (pr₁pxy≡x _ _) ∙ cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _)) x₁~x₁ ,
+                    subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₂)) (sym (cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (pr₁pxy≡x _ _) ∙ cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₂pxy≡y _ _)) x₂~x₂) ,
+                 return
+                  (y ,
+                    return
+                      (x₁ ,
+                        (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₁))
+                          (sym
+                            (cong (λ x → pr₁ ⨾ (pr₁ ⨾ (pr₁ ⨾ (pr₂ ⨾ x)))) (pr₁pxy≡x _ _) ∙
+                             cong (λ x → pr₁ ⨾ (pr₁ ⨾ (pr₁ ⨾ x))) (pr₂pxy≡y _ _) ∙
+                             cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (pr₁pxy≡x _ _) ∙
+                             cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙
+                             pr₁pxy≡x _ _))
+                          x₁~x₁ ,
+                         subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₂))
+                           (sym
+                             (cong (λ x → pr₂ ⨾ (pr₁ ⨾ (pr₁ ⨾ (pr₂ ⨾ x)))) (pr₁pxy≡x _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₁ ⨾ (pr₁ ⨾ x))) (pr₂pxy≡y _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (pr₁pxy≡x _ _) ∙
+                              cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙
+                              pr₂pxy≡y _ _))
+                           x₂~x₂) ,
+                         subst (λ r' → r' ⊩ ∣ F .relation ∣ (x₁ , y))
+                           (sym
+                             (cong (λ x → pr₂ ⨾ (pr₁ ⨾ (pr₂ ⨾ x))) (pr₁pxy≡x _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (pr₂pxy≡y _ _) ∙
+                              cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙
+                              pr₂pxy≡y _ _))
+                           r₁⊩Fx₁y) ,
+                    return
+                      (x₂ ,
+                        (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₂))
+                          (sym
+                            (cong (λ x → pr₁ ⨾ (pr₁ ⨾ (pr₂ ⨾ (pr₂ ⨾ x)))) (pr₁pxy≡x _ _) ∙
+                             cong (λ x → pr₁ ⨾ (pr₁ ⨾ (pr₂ ⨾ x))) (pr₂pxy≡y _ _) ∙
+                             cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (pr₂pxy≡y _ _) ∙
+                             cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙
+                             pr₁pxy≡x _ _))
+                          x₂~x₂ ,
+                         subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₁))
+                           (sym
+                             (cong (λ x → pr₂ ⨾ (pr₁ ⨾ (pr₂ ⨾ (pr₂ ⨾ x)))) (pr₁pxy≡x _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₁ ⨾ (pr₂ ⨾ x))) (pr₂pxy≡y _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (pr₂pxy≡y _ _) ∙
+                              cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙
+                              pr₂pxy≡y _ _))
+                           x₁~x₁) ,
+                         subst (λ r' → r' ⊩ ∣ F .relation ∣ (x₂ , y))
+                           (sym
+                             (cong (λ x → pr₂ ⨾ (pr₂ ⨾ (pr₂ ⨾ x))) (pr₁pxy≡x _ _) ∙
+                              cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (pr₂pxy≡y _ _) ∙
+                              cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙
+                              pr₂pxy≡y _ _)) r₂⊩Fx₂y))) ,
+                         subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₁)) (sym (cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _)) x₁~x₁ ,
+                         subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₂)) (sym (cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _)) x₂~x₂))
+            in
+            transport
+              (propTruncIdempotent (perX .equality .isPropValued _ _))
+              (do
+                ((x₁' , x₂') , ((x₁~x₁' , x₂~x₂') , kp2) , p2) ← foo
+                (y' , bar1 , bar2) ← kp2
+                (x₁'' , (x₁~x₁'' , x₂~'x₂) , ⊩Fx₁''y') ← bar1
+                (x₂'' , (x₂~x₂'' , x₁~'x₁) , ⊩Fx₂''y') ← bar2
+                let
+                  (x₂'~x₁ , foo') = p2
+                return
+                  (subst
+                    (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₂))
+                    (sym (λ*2ComputationRule realizer r₁ r₂))
+                    (t⊩isTransitiveEqX x₁ x₂' x₂ _ _ (s⊩isSymmetricEqX x₂' x₁ _ x₂'~x₁) (s⊩isSymmetricEqX x₂ x₂' _ x₂~x₂'))))))
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.Object.html b/docs/Realizability.Topos.Object.html new file mode 100644 index 0000000..1737fdc --- /dev/null +++ b/docs/Realizability.Topos.Object.html @@ -0,0 +1,80 @@ + +Realizability.Topos.Object
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Structure
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Powerset
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.Reflection.RecordEquiv
+
+module Realizability.Topos.Object
+  {ℓ ℓ' ℓ''}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  where
+  
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open PredicateProperties
+open Morphism
+
+record isPartialEquivalenceRelation (X : Type ℓ') (equality : Predicate (X × X)) : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+  field
+    isSetX : isSet X
+    isSymmetric : ∃[ s ∈ A ] (∀ x y r → r ⊩ ∣ equality ∣ (x , y) → (s ⨾ r) ⊩ ∣ equality ∣ (y , x))
+    isTransitive : ∃[ t ∈ A ] (∀ x y z a b → a ⊩ ∣ equality ∣ (x , y) → b ⊩ ∣ equality ∣ (y , z) → (t ⨾ a ⨾ b) ⊩ ∣ equality ∣ (x , z))
+
+open isPartialEquivalenceRelation
+isPropIsPartialEquivalenceRelation : ∀ {X : Type ℓ'} → (equality : Predicate (X × X)) → isProp (isPartialEquivalenceRelation X equality)
+isPropIsPartialEquivalenceRelation {X} equality x y i =
+  record { isSetX = isProp→PathP (λ i → isPropIsSet) (x .isSetX) (y .isSetX) i ; isSymmetric = squash₁ (x .isSymmetric) (y .isSymmetric) i ; isTransitive = squash₁ (x .isTransitive) (y .isTransitive) i }
+
+record PartialEquivalenceRelation (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+  field
+    equality : Predicate (X × X)
+    isPerEquality : isPartialEquivalenceRelation X equality
+  open isPartialEquivalenceRelation isPerEquality public
+
+-- Directly from previous commit
+unquoteDecl PartialEquivalenceRelationIsoΣ = declareRecordIsoΣ PartialEquivalenceRelationIsoΣ (quote PartialEquivalenceRelation)
+
+PartialEquivalenceRelationΣ : (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ''))
+PartialEquivalenceRelationΣ X = Σ[ equality ∈ Predicate (X × X) ] isPartialEquivalenceRelation X equality
+
+open PartialEquivalenceRelation
+module _ (X : Type ℓ') where opaque
+  open Iso
+  PartialEquivalenceRelationΣ≡ : (perA perB : PartialEquivalenceRelationΣ X) → perA .fst ≡ perB .fst → perA ≡ perB
+  PartialEquivalenceRelationΣ≡ perA perB predicateEq = Σ≡Prop (λ x → isPropIsPartialEquivalenceRelation x) predicateEq 
+
+  PartialEquivalenceRelationΣ≃ : (perA perB : PartialEquivalenceRelationΣ X) → (perA .fst ≡ perB .fst) ≃ (perA ≡ perB)
+  PartialEquivalenceRelationΣ≃ perA perB = Σ≡PropEquiv λ x → isPropIsPartialEquivalenceRelation x
+
+  PartialEquivalenceRelationIso : (perA perB : PartialEquivalenceRelation X) → Iso (Iso.fun PartialEquivalenceRelationIsoΣ perA ≡ Iso.fun PartialEquivalenceRelationIsoΣ perB) (perA ≡ perB)
+  Iso.fun (PartialEquivalenceRelationIso perA perB) p i = Iso.inv PartialEquivalenceRelationIsoΣ (p i)
+  inv (PartialEquivalenceRelationIso perA perB) = cong (λ x → Iso.fun PartialEquivalenceRelationIsoΣ x)
+  rightInv (PartialEquivalenceRelationIso perA perB) b = refl
+  leftInv (PartialEquivalenceRelationIso perA perB) a = refl
+
+  -- Main SIP
+  PartialEquivalenceRelation≃ : (perA perB : PartialEquivalenceRelation X) → (perA .equality ≡ perB .equality) ≃ (perA ≡ perB)
+  PartialEquivalenceRelation≃ perA perB =
+    perA .equality ≡ perB .equality
+      ≃⟨ idEquiv (perA .equality ≡ perB .equality) ⟩
+    Iso.fun PartialEquivalenceRelationIsoΣ perA .fst ≡ Iso.fun PartialEquivalenceRelationIsoΣ perB .fst
+      ≃⟨ PartialEquivalenceRelationΣ≃ (Iso.fun PartialEquivalenceRelationIsoΣ perA) (Iso.fun PartialEquivalenceRelationIsoΣ perB) ⟩
+    Iso.fun PartialEquivalenceRelationIsoΣ perA ≡ Iso.fun PartialEquivalenceRelationIsoΣ perB
+      ≃⟨ isoToEquiv (PartialEquivalenceRelationIso perA perB) ⟩
+    perA ≡ perB
+      ■
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.ResizedPredicate.html b/docs/Realizability.Topos.ResizedPredicate.html new file mode 100644 index 0000000..0a56df2 --- /dev/null +++ b/docs/Realizability.Topos.ResizedPredicate.html @@ -0,0 +1,94 @@ + +Realizability.Topos.ResizedPredicate
-- Before we can talk about power objects in RT
+-- we need to use propositional resizing to get
+-- a copy of A-valued predicates in Type ℓ'
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.Empty
+open import Cubical.Data.Sigma
+open import Realizability.PropResizing
+open import Realizability.CombinatoryAlgebra
+
+module Realizability.Topos.ResizedPredicate
+  {ℓ}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  (resizing : hPropResizing ℓ)
+  where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ} {ℓ'' = ℓ} ca
+open import Realizability.Topos.Object {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+
+open CombinatoryAlgebra ca
+open Predicate renaming (isSetX to isSetPredicateBase)
+
+smallHProp = resizing .fst
+smallHProp≃hProp = resizing .snd
+
+ResizedPredicate : Type ℓ → Type ℓ
+ResizedPredicate X = Σ[ rel ∈ (X → A → smallHProp) ] isSet X
+
+PredicateΣ≃ResizedPredicate : ∀ X → PredicateΣ X ≃ ResizedPredicate X
+PredicateΣ≃ResizedPredicate X =
+  Σ-cong-equiv-prop
+    (equivΠ
+      (idEquiv X)
+      (λ x →
+        equivΠ
+          (idEquiv A)
+          λ a →
+            smallHProp≃hProp))
+    (λ _ → isPropIsSet)
+    (λ _ → isPropIsSet)
+    (λ _ answer → answer)
+    (λ _ answer → answer)
+
+Predicate≃ResizedPredicate : ∀ X → Predicate X ≃ ResizedPredicate X
+Predicate≃ResizedPredicate X = compEquiv (Predicate≃PredicateΣ X) (PredicateΣ≃ResizedPredicate X)
+
+isSetResizedPredicate : ∀ {X} → isSet (ResizedPredicate X)
+isSetResizedPredicate {X} = isOfHLevelRespectEquiv 2 (Predicate≃ResizedPredicate X) (isSetPredicate X)
+
+ResizedPredicate≃Predicate : ∀ X → ResizedPredicate X ≃ Predicate X
+ResizedPredicate≃Predicate X = invEquiv (Predicate≃ResizedPredicate X)
+
+toPredicate : ∀ {X} → ResizedPredicate X → Predicate X
+toPredicate {X} ϕ = equivFun (ResizedPredicate≃Predicate X) ϕ
+
+fromPredicate : ∀ {X} → Predicate X → ResizedPredicate X
+fromPredicate {X} ϕ = equivFun (Predicate≃ResizedPredicate X) ϕ
+
+compIsIdEquiv : ∀ X → compEquiv (Predicate≃ResizedPredicate X) (ResizedPredicate≃Predicate X) ≡ idEquiv (Predicate X)
+compIsIdEquiv X = invEquiv-is-rinv (Predicate≃ResizedPredicate X)
+
+compIsIdFunc : ∀ {X} → (p : Predicate X) → toPredicate (fromPredicate p) ≡ p
+compIsIdFunc {X} p i = equivFun (compIsIdEquiv X i) p
+
+module ResizedPredicateProps {X} (perX : PartialEquivalenceRelation X) where
+  open PartialEquivalenceRelation
+
+  entailmentResizedPredicate : ∀ (ϕ ψ : ResizedPredicate X) → A → Type ℓ
+  entailmentResizedPredicate ϕ ψ r = ∀ (x : X) (a : A) (⊩ϕx : a ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a) ⊩ ∣ toPredicate ψ ∣ x
+
+  isPropEntailmentResizedPredicate : ∀ ϕ ψ a → isProp (entailmentResizedPredicate ϕ ψ a)
+  isPropEntailmentResizedPredicate ϕ ψ a =
+    isPropΠ λ x → isPropΠ λ b → isPropΠ λ _ → (toPredicate ψ) .isPropValued _ _
+
+  isStrictResizedPredicate : ∀ (ϕ : ResizedPredicate X) → A → Type ℓ
+  isStrictResizedPredicate ϕ r = ∀ (x : X) (a : A) (⊩ϕx : a ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a) ⊩ ∣ perX .equality ∣ (x , x)
+
+  isPropIsStrictResizedPredicate : ∀ ϕ r → isProp (isStrictResizedPredicate ϕ r)
+  isPropIsStrictResizedPredicate ϕ r =
+    isPropΠ λ x → isPropΠ λ a → isPropΠ λ _ → perX .equality .isPropValued _ _
+
+  isRelationalResizedPredicate : ∀ (ϕ : ResizedPredicate X) → A → Type ℓ
+  isRelationalResizedPredicate ϕ r =
+    ∀ (x x' : X) (a b : A) (⊩x~x' : a ⊩ ∣ perX .equality ∣ (x , x')) (⊩ϕx : b ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a ⨾ b) ⊩ ∣ toPredicate ϕ ∣ x'
+
+  isPropIsRelationalResizedPredicate : ∀ ϕ r → isProp (isRelationalResizedPredicate ϕ r)
+  isPropIsRelationalResizedPredicate ϕ r =
+    isPropΠ λ x → isPropΠ λ x' → isPropΠ λ a → isPropΠ λ b → isPropΠ λ _ → isPropΠ λ _ → toPredicate ϕ .isPropValued _ _
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.StrictRelation.html b/docs/Realizability.Topos.StrictRelation.html new file mode 100644 index 0000000..5594652 --- /dev/null +++ b/docs/Realizability.Topos.StrictRelation.html @@ -0,0 +1,634 @@ + +Realizability.Topos.StrictRelation
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Structure
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.FinData
+open import Cubical.Data.Fin hiding (Fin; _/_)
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty
+open import Cubical.Data.Unit
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Morphism
+open import Cubical.Categories.Constructions.SubObject
+open import Cubical.Categories.Constructions.Slice
+open import Cubical.Relation.Binary
+
+module Realizability.Topos.StrictRelation
+  {ℓ ℓ' ℓ''}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  where
+
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial 
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.Equalizer {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.BinProducts {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.MonicReprFuncRel {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open Morphism
+open PartialEquivalenceRelation
+open FunctionalRelation
+open Category RT
+
+record isStrictRelation {X : Type ℓ'} (perX : PartialEquivalenceRelation X) (ϕ : Predicate X) : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) where
+  field
+    isStrict : ∃[ st ∈ A ] (∀ x r → r ⊩ ∣ ϕ ∣ x → (st ⨾ r) ⊩ ∣ perX .equality ∣ (x , x))
+    isRelational : ∃[ rel ∈ A ] (∀ x x' r s → r ⊩ ∣ ϕ ∣ x → s ⊩ ∣ perX .equality ∣ (x , x') → (rel ⨾ r ⨾ s) ⊩ ∣ ϕ ∣ x')
+
+record StrictRelation {X : Type ℓ'} (perX : PartialEquivalenceRelation X) : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-suc ℓ') (ℓ-suc ℓ''))) where
+  field
+    predicate : Predicate X
+    isStrictRelationPredicate : isStrictRelation perX predicate
+  open isStrictRelation isStrictRelationPredicate public
+
+-- Every strict relation induces a subobject
+module InducedSubobject {X : Type ℓ'} (perX : PartialEquivalenceRelation X) (ϕ : StrictRelation perX) where
+  open StrictRelation
+  -- the subobject induced by ϕ
+  {-# TERMINATING #-}
+  subPer : PartialEquivalenceRelation X
+  Predicate.isSetX (equality subPer) = isSet× (perX .isSetX) (perX .isSetX)
+  ∣ equality subPer ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ ϕ .predicate ∣ x
+  isPropValued (equality subPer) (x , x') r = isProp× (perX .equality .isPropValued _ _) (ϕ .predicate .isPropValued _ _)
+  isPartialEquivalenceRelation.isSetX (isPerEquality subPer) = perX .isSetX
+  isPartialEquivalenceRelation.isSymmetric (isPerEquality subPer) =
+    do
+      -- Trivial : use symmetry of ~X and relationality of ϕ
+      (s , s⊩isSymmetricX) ← perX .isSymmetric
+      (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational
+      let
+        realizer : ApplStrTerm as 1
+        realizer = ` pair ̇ (` s ̇ (` pr₁ ̇ # zero)) ̇ (` relϕ ̇ (` pr₂ ̇ # zero) ̇ (` pr₁ ̇ # zero))
+      return
+        (λ* realizer ,
+        (λ { x x' r (pr₁r⊩x~x' , pr₂r⊩ϕx) →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x))
+            (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+            (s⊩isSymmetricX x x' _ pr₁r⊩x~x') ,
+          subst
+            (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x')
+            (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+            (relϕ⊩isRelationalϕ x x' _ _ pr₂r⊩ϕx pr₁r⊩x~x') }))
+  isPartialEquivalenceRelation.isTransitive (isPerEquality subPer) =
+    do
+      (t , t⊩isTransitiveX) ← perX .isTransitive
+      (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational
+      let
+        realizer : ApplStrTerm as 2
+        realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # one)
+      return
+        (λ*2 realizer ,
+        (λ { x₁ x₂ x₃ a b (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₂~x₃ , ⊩ϕx₂) →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₃))
+            (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer a b) ∙ pr₁pxy≡x _ _))
+            (t⊩isTransitiveX x₁ x₂ x₃ _ _ ⊩x₁~x₂ ⊩x₂~x₃) ,
+          subst
+            (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₁)
+            (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer a b) ∙ pr₂pxy≡y _ _))
+            ⊩ϕx₁ }))
+
+  opaque
+    unfolding idFuncRel
+    {-# TERMINATING #-}
+    incFuncRel : FunctionalRelation subPer perX
+    Predicate.isSetX (relation incFuncRel) = isSet× (perX .isSetX) (perX .isSetX)
+    Predicate.∣ relation incFuncRel ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ ϕ .predicate ∣ x
+    Predicate.isPropValued (relation incFuncRel) (x , x') r = isProp× (perX .equality .isPropValued _ _) (ϕ .predicate .isPropValued _ _)
+    isFunctionalRelation.isStrictDomain (isFuncRel incFuncRel) =
+      do
+        (stD , stD⊩isStrictDomain) ← idFuncRel perX .isStrictDomain
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` pair ̇ (` stD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero)
+        return
+          (λ* realizer ,
+          (λ { x x' r (⊩x~x' , ⊩ϕx) →
+            (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) (stD⊩isStrictDomain x x' _ ⊩x~x')) ,
+            (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx) }))
+    isFunctionalRelation.isStrictCodomain (isFuncRel incFuncRel) =
+      do
+        (stC , stC⊩isStrictCodomain) ← idFuncRel perX .isStrictCodomain
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` stC ̇ (` pr₁ ̇ # zero)
+        return
+          (λ* realizer ,
+          (λ { x x' r (⊩x~x' , ⊩ϕx) → subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x')) (sym (λ*ComputationRule realizer r)) (stC⊩isStrictCodomain x x' _ ⊩x~x')}))
+    isFunctionalRelation.isRelational (isFuncRel incFuncRel) =
+      do
+        (relX , relX⊩isRelationalX) ← idFuncRel perX .isRelational
+        (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational
+        let
+          realizer : ApplStrTerm as 3
+          realizer = ` pair ̇ (` relX ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ # zero) ̇ (` relϕ ̇ (` pr₂ ̇ # two) ̇ (` pr₁ ̇ # two))
+        return
+          (λ*3 realizer ,
+          (λ { x₁ x₂ x₃ x₄ a b c (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₁~x₃ , ⊩ϕx₁') c⊩x₃~x₄ →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _))
+              (relX⊩isRelationalX x₁ x₂ x₃ x₄ _ _ _ ⊩x₁~x₂ ⊩x₁~x₃ c⊩x₃~x₄) ,
+            subst
+              (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₂)
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₂pxy≡y _ _))
+              (relϕ⊩isRelationalϕ x₁ x₂ _ _ ⊩ϕx₁ ⊩x₁~x₂) }))
+    isFunctionalRelation.isSingleValued (isFuncRel incFuncRel) =
+      do
+        (sv , sv⊩isSingleValuedX) ← idFuncRel perX .isSingleValued
+        let
+          realizer : ApplStrTerm as 2
+          realizer = ` sv ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)
+        return
+          (λ*2 realizer ,
+          (λ { x x' x'' r₁ r₂ (⊩x~x' , ⊩ϕx) (⊩x~x'' , ⊩ϕx') →
+            subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'')) (sym (λ*2ComputationRule realizer r₁ r₂)) (sv⊩isSingleValuedX x x' x'' _ _ ⊩x~x' ⊩x~x'') }))
+    isFunctionalRelation.isTotal (isFuncRel incFuncRel) =
+      do
+        return
+          (Id ,
+          (λ { x r (pr₁r⊩x~x , pr₂r⊩ϕx) →
+            return
+              (x ,
+              subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (cong (λ x → pr₁ ⨾ x) (sym (Ida≡a _))) pr₁r⊩x~x ,
+              subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (cong (λ x → pr₂ ⨾ x) (sym (Ida≡a _))) pr₂r⊩ϕx) }))
+
+  opaque
+    unfolding isInjectiveFuncRel
+    unfolding incFuncRel
+    isInjectiveIncFuncRel : isInjectiveFuncRel subPer perX incFuncRel
+    isInjectiveIncFuncRel =
+      do
+        (t , t⊩isTransitiveX) ← perX .isTransitive
+        (s , s⊩isSymmetricX) ← perX .isSymmetric
+        let
+          realizer : ApplStrTerm as 2
+          realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ # one) ̇ (` s ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ # one)
+        return
+          (λ*2 realizer ,
+          (λ x₁ x₂ x₃ r₁ r₂ (⊩x₁~x₃ , ⊩ϕx₁) (⊩x₂~x₃ , ⊩ϕx₂) →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₂))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _))
+              (t⊩isTransitiveX x₁ x₃ x₂ _ _ ⊩x₁~x₃ (s⊩isSymmetricX x₂ x₃ _ ⊩x₂~x₃)) ,
+            subst
+              (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₁)
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁  r₂) ∙ pr₂pxy≡y _ _))
+              ⊩ϕx₁))
+
+  isMonicInc : isMonic RT [ incFuncRel ]
+  isMonicInc = isInjectiveFuncRel→isMonic subPer perX incFuncRel isInjectiveIncFuncRel
+
+-- Every subobject representing functional relation is isomorphic (as a subobject) to a subobject induced by a strict relation
+module SubobjectIsoMonicFuncRel
+  {X Y : Type ℓ'}
+  (perX : PartialEquivalenceRelation X)
+  (perY : PartialEquivalenceRelation Y)
+  (F : FunctionalRelation perY perX)
+  (isMonicF : isMonic RT [ F ]) where
+
+  {-# TERMINATING #-}
+  ψ : StrictRelation perX
+  Predicate.isSetX (StrictRelation.predicate ψ) = perX .isSetX
+  Predicate.∣ StrictRelation.predicate ψ ∣ x r = ∃[ y ∈ Y ] r ⊩ ∣ F .relation ∣ (y , x)
+  Predicate.isPropValued (StrictRelation.predicate ψ) x r = isPropPropTrunc
+  isStrictRelation.isStrict (StrictRelation.isStrictRelationPredicate ψ) =
+    do
+      (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+      return
+        (stCF ,
+        (λ x r r⊩∃y →
+          transport
+            (propTruncIdempotent (perX .equality .isPropValued _ _))
+            (do
+              (y , ⊩Fyx) ← r⊩∃y
+              return (stCF⊩isStrictCodomainF y x _ ⊩Fyx))))
+  isStrictRelation.isRelational (StrictRelation.isStrictRelationPredicate ψ) =
+    do
+      (relF , relF⊩isRelationalF) ← F .isRelational
+      (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain
+      let
+        realizer : ApplStrTerm as 2
+        realizer = ` relF ̇ (` stDF ̇ # one) ̇ # one ̇ # zero
+      return
+        (λ*2 realizer ,
+        (λ x x' r s r⊩∃y s⊩x~x' →
+          do
+            (y , ⊩Fyx) ← r⊩∃y
+            return
+              (y ,
+              subst
+                (λ r' → r' ⊩ ∣ F .relation ∣ (y , x'))
+                (sym (λ*2ComputationRule realizer r s))
+                (relF⊩isRelationalF y y x x' _ _ _ (stDF⊩isStrictDomainF y x _ ⊩Fyx) ⊩Fyx s⊩x~x'))))
+
+  perψ : PartialEquivalenceRelation X
+  perψ = InducedSubobject.subPer perX ψ
+
+  -- ≤ as subobjects
+  -- TODO : formalise the preorder category of subobjects
+  {-# TERMINATING #-}
+  perY≤perψFuncRel : FunctionalRelation perY perψ
+  Predicate.isSetX (relation perY≤perψFuncRel) = isSet× (perY .isSetX) (perX .isSetX)
+  Predicate.∣ relation perY≤perψFuncRel ∣ = ∣ F .relation ∣
+  Predicate.isPropValued (relation perY≤perψFuncRel) = F .relation .isPropValued
+  isFunctionalRelation.isStrictDomain (isFuncRel perY≤perψFuncRel) =
+    isFunctionalRelation.isStrictDomain (F .isFuncRel)
+  isFunctionalRelation.isStrictCodomain (isFuncRel perY≤perψFuncRel) =
+    do
+      (stCF , stCF⊩isStrictCodomain) ← F .isStrictCodomain
+      let
+        realizer : ApplStrTerm as 1
+        realizer = ` pair ̇ (` stCF ̇ # zero) ̇ # zero
+      return
+        (λ* realizer ,
+        (λ y x r ⊩Fyx →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+            (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+            (stCF⊩isStrictCodomain y x _ ⊩Fyx) ,
+          ∣ y ,
+            subst
+              (λ r' → r' ⊩ ∣ F .relation ∣ (y , x))
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+              ⊩Fyx ∣₁))
+  isFunctionalRelation.isRelational (isFuncRel perY≤perψFuncRel) =
+    do
+      (relF , relF⊩isRelationalF) ← F .isRelational
+      let
+        realizer : ApplStrTerm as 3
+        realizer = ` relF ̇ # two ̇ # one ̇ (` pr₁ ̇ # zero)
+      return
+        (λ*3 realizer ,
+        (λ { y y' x x' a b c ⊩y~y' ⊩Fyx (⊩x~x' , ⊩Fy''x) →
+          subst (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x')) (sym (λ*3ComputationRule realizer a b c)) (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x') }))
+  isFunctionalRelation.isSingleValued (isFuncRel perY≤perψFuncRel) =
+    do
+      (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+      let
+        realizer : ApplStrTerm as 2
+        realizer = ` pair ̇ (` svF ̇ # one ̇ # zero) ̇ # one
+      return
+        (λ*2 realizer ,
+        (λ y x x' r₁ r₂ ⊩Fyx ⊩Fyx' →
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+            (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _))
+            (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') ,
+          ∣ y ,
+            (subst
+              (λ r' → r' ⊩ ∣ F .relation ∣ (y , x))
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _))
+              ⊩Fyx) ∣₁))
+  isFunctionalRelation.isTotal (isFuncRel perY≤perψFuncRel) =
+    do
+      (tlF , tlF⊩isTotalF) ← F .isTotal
+      return
+        (tlF ,
+        (λ y r ⊩y~y →
+          do
+            (x , ⊩Fyx) ← tlF⊩isTotalF y _ ⊩y~y
+            return (x , ⊩Fyx)))
+
+  -- perY truly is ≤ perψ
+  opaque
+    unfolding composeRTMorphism
+    unfolding InducedSubobject.incFuncRel
+    perY≤perψCommutes : [ perY≤perψFuncRel ] ⋆ [ InducedSubobject.incFuncRel perX ψ ] ≡ [ F ]
+    perY≤perψCommutes =
+      let
+        answer =
+          do
+            (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain
+            (relF , relF⊩isRelationalF) ← F .isRelational
+            let
+              realizer : ApplStrTerm as 1
+              realizer = ` relF ̇ (` stDF ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+            return
+              (λ* realizer ,
+              (λ y x r r⊩∃x' →
+                transport
+                  (propTruncIdempotent (F .relation .isPropValued _ _))
+                  (do
+                    (x' , ⊩Fyx' , ⊩x'~x , ⊩ψx') ← r⊩∃x'
+                    return
+                      (subst
+                        (λ r → r ⊩ ∣ F .relation ∣ (y , x))
+                        (sym (λ*ComputationRule realizer r))
+                        (relF⊩isRelationalF y y x' x _ _ _ (stDF⊩isStrictDomainF y x' _ ⊩Fyx') ⊩Fyx' ⊩x'~x)))))
+      in
+      eq/ _ _ (answer , F≤G→G≤F perY perX (composeFuncRel _ _ _ perY≤perψFuncRel (InducedSubobject.incFuncRel perX ψ)) F answer)
+
+  opaque
+    unfolding isInjectiveFuncRel
+    {-# TERMINATING #-}
+    perψ≤perYFuncRel : FunctionalRelation perψ perY
+    Predicate.isSetX (relation perψ≤perYFuncRel) = isSet× (perX .isSetX) (perY .isSetX)
+    Predicate.∣ relation perψ≤perYFuncRel ∣ (x , y) r = r ⊩ ∣ F .relation ∣ (y , x)
+    Predicate.isPropValued (relation perψ≤perYFuncRel) (x , y) r = F .relation .isPropValued _ _
+    isFunctionalRelation.isStrictDomain (isFuncRel perψ≤perYFuncRel) =
+      do
+        (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` pair ̇ (` stCF ̇ # zero) ̇ # zero
+        return
+          (λ* realizer ,
+          (λ x y r ⊩Fyx →
+            (subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+              (stCF⊩isStrictCodomainF y x _ ⊩Fyx)) ,
+            (return
+              (y ,
+              (subst
+                (λ r' → r' ⊩ ∣ F .relation ∣ (y , x))
+                (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+                ⊩Fyx)))))
+    isFunctionalRelation.isStrictCodomain (isFuncRel perψ≤perYFuncRel) =
+      do
+        (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain
+        return
+          (stDF ,
+          (λ x y r ⊩Fyx → stDF⊩isStrictDomainF y x _ ⊩Fyx))
+    isFunctionalRelation.isRelational (isFuncRel perψ≤perYFuncRel) =
+      do
+        (relF , relF⊩isRelationalF) ← F .isRelational
+        let
+          realizer : ApplStrTerm as 3
+          realizer = ` relF ̇ # zero ̇ # one ̇ (` pr₁ ̇ # two)
+        return
+          (λ*3 realizer ,
+          (λ { x x' y y' a b c (⊩x~x' , ⊩ψx) ⊩Fyx ⊩y~y' →
+            subst (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x')) (sym (λ*3ComputationRule realizer a b c)) (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x') }))
+    isFunctionalRelation.isSingleValued (isFuncRel perψ≤perYFuncRel) =
+      let
+        isInjectiveFuncRelF = isMonic→isInjectiveFuncRel perY perX F isMonicF
+      in
+      do
+        (injF , injF⊩isInjectiveF) ← isInjectiveFuncRelF
+        return
+          (injF ,
+          (λ x y y' r₁ r₂ ⊩Fyx ⊩Fy'x →
+            injF⊩isInjectiveF y y' x _ _ ⊩Fyx ⊩Fy'x))
+    isFunctionalRelation.isTotal (isFuncRel perψ≤perYFuncRel) =
+        return
+          (pr₂ ,
+          (λ { x r (⊩x~x , ⊩ψx) → ⊩ψx }))
+
+  opaque
+    unfolding composeRTMorphism
+    unfolding composeFuncRel
+    unfolding InducedSubobject.incFuncRel
+    unfolding perψ≤perYFuncRel
+    perψ≤perYCommutes : [ perψ≤perYFuncRel ] ⋆ [ F ] ≡ [ InducedSubobject.incFuncRel perX ψ ]
+    perψ≤perYCommutes =
+      let
+        answer =
+          do
+            (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+            let
+              realizer : ApplStrTerm as 1
+              realizer = ` pair ̇ (` svF ̇ (` pr₁ ̇ # zero) ̇ (` pr₂ ̇ # zero)) ̇ (` pr₁ ̇ # zero)
+            return
+              (λ* realizer ,
+              (λ x x' r r⊩∃y →
+                transport
+                  (propTruncIdempotent (isProp× (perX .equality .isPropValued _ _) isPropPropTrunc))
+                  (do
+                    (y , ⊩Fyx , ⊩Fyx') ← r⊩∃y
+                    return
+                      (subst
+                        (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                        (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+                        (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') ,
+                      return
+                        (y ,
+                        (subst
+                          (λ r' → r' ⊩ ∣ F .relation ∣ (y , x))
+                          (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+                          ⊩Fyx))))))
+      in
+      eq/ _ _ (answer , F≤G→G≤F perψ perX (composeFuncRel _ _ _ perψ≤perYFuncRel F) (InducedSubobject.incFuncRel perX ψ) answer)
+
+-- For strict relations, subobject inclusion is identified with pointwise entailment
+module InclusionEntailment
+  {X : Type ℓ'}
+  (perX : PartialEquivalenceRelation X)
+  (ϕ ψ : StrictRelation perX) where
+  open StrictRelation
+  open PredicateProperties X
+  SubObjX = SubObjCat RT (X , perX)
+  SubObjHom = Category.Hom[_,_] SubObjX
+
+  perϕ = InducedSubobject.subPer perX ϕ
+  perψ = InducedSubobject.subPer perX ψ
+
+  incϕ = InducedSubobject.incFuncRel perX ϕ
+  incψ = InducedSubobject.incFuncRel perX ψ
+
+  ϕsubObject : Category.ob SubObjX
+  ϕsubObject = sliceob [ InducedSubobject.incFuncRel perX ϕ ] , InducedSubobject.isMonicInc perX ϕ
+
+  ψsubObject : Category.ob SubObjX
+  ψsubObject = sliceob [ InducedSubobject.incFuncRel perX ψ ] , InducedSubobject.isMonicInc perX ψ
+
+  opaque
+    unfolding composeRTMorphism
+    unfolding composeFuncRel
+    unfolding InducedSubobject.incFuncRel
+    SubObjHom→ϕ≤ψ : SubObjHom ϕsubObject ψsubObject → (ϕ .predicate ≤ ψ .predicate)
+    SubObjHom→ϕ≤ψ (slicehom f f⋆incψ≡incϕ) =
+      SQ.elimProp
+        {P = λ f → (f ⋆ [ incψ ] ≡ [ incϕ ]) → ϕ .predicate ≤ ψ .predicate}
+        (λ f → isPropΠ λ f⋆incψ≡incϕ → isProp≤ (ϕ .predicate) (ψ .predicate))
+        (λ F F⋆incψ≡incϕ →
+          let
+            (p , q) =
+              SQ.effective
+                (isPropValuedBientailment (InducedSubobject.subPer perX ϕ) perX)
+                (isEquivRelBientailment (InducedSubobject.subPer perX ϕ) perX)
+                (composeFuncRel _ _ _ F incψ)
+                incϕ
+                F⋆incψ≡incϕ
+          in
+          do
+            (stϕ , stϕ⊩isStrictϕ) ← ϕ .isStrict
+            (relψ , relψ⊩isRelationalψ) ← ψ .isRelational
+            (q , q⊩incϕ≤F⋆incψ) ← q
+            let
+              realizer : ApplStrTerm as 1
+              realizer = ` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ (` q ̇ (` pair ̇ (` stϕ ̇ # zero) ̇ # zero)))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` q ̇ (` pair ̇ (` stϕ ̇ # zero) ̇ # zero))))
+            return
+              (λ* realizer ,
+              (λ x a a⊩ϕx →
+                transport
+                  (propTruncIdempotent (ψ .predicate .isPropValued _ _))
+                  (do
+                    (x' , ⊩Fxx' , ⊩x'~x , ⊩ψx') ←
+                      q⊩incϕ≤F⋆incψ
+                        x x
+                        (pair ⨾ (stϕ ⨾ a) ⨾ a)
+                        ((subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (pr₁pxy≡x _ _)) (stϕ⊩isStrictϕ x a a⊩ϕx)) ,
+                         (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (pr₂pxy≡y _ _)) a⊩ϕx))
+                    return (subst (λ r' → r' ⊩ ∣ ψ .predicate ∣ x) (sym (λ*ComputationRule realizer a)) (relψ⊩isRelationalψ x' x _ _ ⊩ψx' ⊩x'~x))))))
+        f
+        f⋆incψ≡incϕ
+
+  module _ (ϕ≤ψ : ϕ .predicate ≤ ψ .predicate) where opaque
+    unfolding idFuncRel
+    unfolding composeRTMorphism
+    unfolding composeFuncRel
+    unfolding InducedSubobject.incFuncRel
+
+    {-# TERMINATING #-}
+    funcRel : FunctionalRelation perϕ perψ
+    Predicate.isSetX (relation funcRel) = isSet× (perX .isSetX) (perX .isSetX)
+    Predicate.∣ relation funcRel ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × ((pr₁ ⨾ (pr₂ ⨾ r)) ⊩ ∣ ϕ .predicate ∣ x) × ((pr₂ ⨾ (pr₂ ⨾ r)) ⊩ ∣ ψ .predicate ∣ x)
+    Predicate.isPropValued (relation funcRel) (x , x') r = isProp× (perX .equality .isPropValued _ _) (isProp× (ϕ .predicate .isPropValued _ _) (ψ .predicate .isPropValued _ _))
+    isFunctionalRelation.isStrictDomain (isFuncRel funcRel) =
+      do
+        (stϕ , stϕ⊩isStrictϕ) ← ϕ .isStrict
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` pair ̇ (` stϕ ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+        return
+          (λ* realizer ,
+          (λ { x x' r (⊩x~x' , ⊩ϕx , ⊩ψx) →
+            subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) (stϕ⊩isStrictϕ x _ ⊩ϕx) ,
+            subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx}))
+    isFunctionalRelation.isStrictCodomain (isFuncRel funcRel) =
+      do
+        (stCX , stCX⊩isStrictCodomainX) ← idFuncRel perX .isStrictCodomain
+        (relψ , relψ⊩isRelationalψ) ← ψ .isRelational
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` pair ̇ (` stCX ̇ (` pr₁ ̇ # zero)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # zero)) ̇ (` pr₁ ̇ # zero))
+        return
+          (λ* realizer ,
+          (λ { x x' r (⊩x~x' , ⊩ϕx , ⊩ψx) →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+              (stCX⊩isStrictCodomainX x x' _ ⊩x~x') ,
+            subst
+              (λ r' → r' ⊩ ∣ ψ .predicate ∣ x')
+              (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+              (relψ⊩isRelationalψ x x' _ _ ⊩ψx ⊩x~x')}))
+    isFunctionalRelation.isRelational (isFuncRel funcRel) =
+      do
+        (relX , relX⊩isRelationalX) ← idFuncRel perX .isRelational
+        (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational
+        (relψ , relψ⊩isRelationalψ) ← ψ .isRelational
+        let
+          realizer : ApplStrTerm as 3
+          realizer =
+            ` pair ̇ (` relX ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` pair ̇ (` relϕ ̇ (` pr₂ ̇ # two) ̇ (` pr₁ ̇ # two)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` pr₁ ̇ # two)))
+        return
+          (λ*3 realizer ,
+          λ { x₁ x₂ x₃ x₄ a b c (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₁~x₃ , ⊩'ϕx₁ , ⊩ψx₁) (⊩x₃~x₄ , ⊩ψx₃) →
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _))
+              (relX⊩isRelationalX x₁ x₂ x₃ x₄ _ _ _ ⊩x₁~x₂ ⊩x₁~x₃ ⊩x₃~x₄) ,
+            subst
+              (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₂)
+              (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule realizer a b c) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+              (relϕ⊩isRelationalϕ x₁ x₂ _ _ ⊩ϕx₁ ⊩x₁~x₂) ,
+            subst
+              (λ r' → r' ⊩ ∣ ψ .predicate ∣ x₂)
+              (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule realizer a b c) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+              (relψ⊩isRelationalψ x₁ x₂ _ _ ⊩ψx₁ ⊩x₁~x₂)})
+    isFunctionalRelation.isSingleValued (isFuncRel funcRel) =
+      do
+        (svX , svX⊩isSingleValuedX) ← idFuncRel perX .isSingleValued
+        (relψ , relψ⊩isRelationalψ) ← ψ .isRelational
+        let
+          realizer : ApplStrTerm as 2
+          realizer = ` pair ̇ (` svX ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` pr₁ ̇ # one))
+        return
+          (λ*2 realizer ,
+          (λ { x₁ x₂ x₃ r₁ r₂ (⊩x₁~x₂ , ⊩ϕx , ⊩ψx) (⊩x₁~x₃ , ⊩'ϕx , ⊩'ψx) →
+            (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₃)) (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _)) (svX⊩isSingleValuedX x₁ x₂ x₃ _ _ ⊩x₁~x₂ ⊩x₁~x₃)) ,
+             subst (λ r' → r' ⊩ ∣ ψ .predicate ∣ x₂) (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _)) (relψ⊩isRelationalψ x₁ x₂ _ _ ⊩ψx ⊩x₁~x₂)}))
+    isFunctionalRelation.isTotal (isFuncRel funcRel) =
+      do
+        (tl , tl⊩isTotalIncψ) ← incψ .isTotal
+        (s , s⊩ϕ≤ψ) ← ϕ≤ψ
+        let
+          realizer : ApplStrTerm as 1
+          realizer = ` pair ̇ (` pr₁ ̇ # zero) ̇ (` pair ̇ (` pr₂ ̇ # zero) ̇ (` s ̇ (` pr₂ ̇ # zero)))
+        return
+          (λ* realizer ,
+          (λ { x r (⊩x~x , ⊩ϕx) →
+            return
+              (x ,
+              subst
+                (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+                ⊩x~x ,
+              subst
+                (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x)
+                (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _))
+                ⊩ϕx ,
+              subst
+                (λ r' → r' ⊩ ∣ ψ .predicate ∣ x)
+                (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _))
+                (s⊩ϕ≤ψ x _ ⊩ϕx))}))
+    
+    funcRel⋆incψ≡incϕ : [ funcRel ] ⋆ [ incψ ] ≡ [ incϕ ]
+    funcRel⋆incψ≡incϕ =
+      let
+        answer =
+          do
+            (t , t⊩isTransitiveX) ← perX .isTransitive
+            let
+              realizer : ApplStrTerm as 1
+              realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero)))
+            return
+              (λ* realizer ,
+              (λ { x x' r ⊩∃x'' →
+                transport
+                  (propTruncIdempotent (isPropΣ (perX .equality .isPropValued _ _) λ _ → ϕ .predicate .isPropValued _ _))
+                  (do
+                    (x'' , (⊩x~x'' , ⊩ϕx , ⊩ψx) , (⊩x''~x' , ⊩'ψx)) ← ⊩∃x''
+                    return
+                      ((subst
+                        (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                        (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+                        (t⊩isTransitiveX x x'' x' _ _ ⊩x~x'' ⊩x''~x')) ,
+                       (subst
+                         (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x)
+                         (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _))
+                         ⊩ϕx)))}))
+      in
+      eq/ _ _ (answer , F≤G→G≤F perϕ perX (composeFuncRel _ _ _ funcRel incψ) incϕ answer)
+
+    ϕ≤ψ→SubObjHom : SubObjHom ϕsubObject ψsubObject
+    ϕ≤ψ→SubObjHom =
+      slicehom [ funcRel ] funcRel⋆incψ≡incϕ
+
+  SubObjHom≃ϕ≤ψ : SubObjHom ϕsubObject ψsubObject ≃ (ϕ .predicate ≤ ψ .predicate)
+  SubObjHom≃ϕ≤ψ =
+    propBiimpl→Equiv
+      (isPropSubObjMor RT (X , perX) ϕsubObject ψsubObject)
+      (isProp≤ (ϕ .predicate) (ψ .predicate))
+      SubObjHom→ϕ≤ψ
+      ϕ≤ψ→SubObjHom
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.SubobjectClassifier.html b/docs/Realizability.Topos.SubobjectClassifier.html new file mode 100644 index 0000000..4d86d16 --- /dev/null +++ b/docs/Realizability.Topos.SubobjectClassifier.html @@ -0,0 +1,940 @@ + +Realizability.Topos.SubobjectClassifier
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm; ⟦_⟧ to pre⟦_⟧)
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.Empty
+open import Cubical.Data.Sigma
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Unit
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Limits.Pullback
+open import Cubical.Categories.Morphism
+open import Realizability.PropResizing
+open import Realizability.CombinatoryAlgebra
+
+module Realizability.Topos.SubobjectClassifier
+  {ℓ}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥)
+  (resizing : hPropResizing ℓ)
+  where
+  
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ} {ℓ'' = ℓ} ca
+open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ} {ℓ'' = ℓ} ca
+open import Realizability.Topos.Object {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial 
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+open import Realizability.Topos.Equalizer {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+open import Realizability.Topos.BinProducts {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+open import Realizability.Topos.MonicReprFuncRel {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+open import Realizability.Topos.ResizedPredicate ca isNonTrivial resizing
+open import Realizability.Topos.TerminalObject {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+open import Realizability.Topos.StrictRelation {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate renaming (isSetX to isSetPredicateBase)
+open Morphism
+open PartialEquivalenceRelation
+open FunctionalRelation
+open Category RT
+
+⟦_⟧ = pre⟦_⟧ as
+
+Ωper : PartialEquivalenceRelation (ResizedPredicate Unit*)
+Predicate.isSetX (equality Ωper) = isSet× isSetResizedPredicate isSetResizedPredicate
+Predicate.∣ equality Ωper ∣ (α , β) r =
+  (∀ (a : A) (⊩α : a ⊩ ∣ toPredicate α ∣ tt*) → ((pr₁ ⨾ r) ⨾ a) ⊩ ∣ toPredicate β ∣ tt*) ×
+  (∀ (a : A) (⊩β : a ⊩ ∣ toPredicate β ∣ tt*) → ((pr₂ ⨾ r) ⨾ a) ⊩ ∣ toPredicate α ∣ tt*)
+Predicate.isPropValued (equality Ωper) (α , β) r =
+  isProp×
+    (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate β) .isPropValued _ _))
+    (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate α) .isPropValued _ _))
+isPartialEquivalenceRelation.isSetX (isPerEquality Ωper) = isSetResizedPredicate
+isPartialEquivalenceRelation.isSymmetric (isPerEquality Ωper) =
+  do
+    let
+      ent₁ : ApplStrTerm as 2
+      ent₁ = ` pr₂ ̇ # one ̇ # zero
+
+      ent₂ : ApplStrTerm as 2
+      ent₂ = ` pr₁ ̇ # one ̇ # zero
+
+      realizer : ApplStrTerm as 1
+      realizer = ` pair ̇ (λ*abst ent₁) ̇ (λ*abst ent₂)
+    return
+      (λ* realizer ,
+      λ { α β r (pr₁r⊩α≤β , pr₂r⊩β≤α) →
+        (λ a a⊩β →
+          let
+            eq : pr₁ ⨾ (λ* realizer ⨾ r) ⨾ a ≡ pr₂ ⨾ r ⨾ a
+            eq =
+              pr₁ ⨾ (λ* realizer ⨾ r) ⨾ a
+                ≡⟨ cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ⟩
+              pr₁ ⨾ (pair ⨾ _ ⨾ _) ⨾ a
+                ≡⟨ cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ⟩
+              ⟦ (λ*abst ent₁) ⟧ (r ∷ []) ⨾ a
+                ≡⟨ βreduction ent₁ a (r ∷ []) ⟩
+              pr₂ ⨾ r ⨾ a
+                ∎
+          in
+          subst (λ r' → r' ⊩ ∣ toPredicate α ∣ tt*) (sym eq) (pr₂r⊩β≤α a a⊩β)) ,
+        (λ a a⊩α →
+          let
+            eq : pr₂ ⨾ (λ* realizer ⨾ r) ⨾ a ≡ pr₁ ⨾ r ⨾ a
+            eq =
+              pr₂ ⨾ (λ* realizer ⨾ r) ⨾ a
+                ≡⟨ cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ⟩
+              pr₂ ⨾ (pair ⨾ _ ⨾ _) ⨾ a
+                ≡⟨ cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ⟩
+              ⟦ λ*abst ent₂ ⟧ (r ∷ []) ⨾ a
+                ≡⟨ βreduction ent₂ a (r ∷ []) ⟩
+              pr₁ ⨾ r ⨾ a
+                ∎
+          in
+          subst (λ r' → r' ⊩ ∣ toPredicate β ∣ tt*) (sym eq) (pr₁r⊩α≤β a a⊩α)) })
+isPartialEquivalenceRelation.isTransitive (isPerEquality Ωper) =
+  do
+    let
+      closure1 : ApplStrTerm as 3
+      closure1 = ` pr₁ ̇ # one ̇ (` pr₁ ̇ # two ̇ # zero)
+
+      closure2 : ApplStrTerm as 3
+      closure2 = ` pr₂ ̇ # two ̇ (` pr₂ ̇ # one ̇ # zero)
+
+      realizer = ` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2)
+    return
+      (λ*2 realizer ,
+      (λ { x y z a b (⊩x≤y , ⊩y≤x) (⊩y≤z , ⊩z≤y) →
+        (λ r r⊩x →
+          subst
+            (λ r' → r' ⊩ ∣ toPredicate z ∣ tt*)
+            (sym
+              (cong (λ x → pr₁ ⨾ x ⨾ r) (λ*2ComputationRule realizer a b) ∙
+               cong (λ x → x ⨾ r) (pr₁pxy≡x _ _) ∙
+               βreduction closure1 r (b ∷ a ∷ [])))
+            (⊩y≤z _ (⊩x≤y r r⊩x))) ,
+        (λ r r⊩z →
+          subst
+            (λ r' → r' ⊩ ∣ toPredicate x ∣ tt*)
+            (sym
+              (cong (λ x → pr₂ ⨾ x ⨾ r) (λ*2ComputationRule realizer a b) ∙
+               cong (λ x → x ⨾ r) (pr₂pxy≡y _ _) ∙
+               βreduction closure2 r (b ∷ a ∷ [])))
+            (⊩y≤x _ (⊩z≤y r r⊩z))) }))
+
+opaque
+  unfolding terminalPer
+  trueFuncRel : FunctionalRelation terminalPer Ωper
+  Predicate.isSetX (relation trueFuncRel) = isSet× isSetUnit* isSetResizedPredicate
+  Predicate.∣ relation trueFuncRel ∣ (tt* , p) r = ∀ (a : A) → (r ⨾ a) ⊩ ∣ toPredicate p ∣ tt*
+  Predicate.isPropValued (relation trueFuncRel) (tt* , p) r = isPropΠ λ a → (toPredicate p) .isPropValued _ _
+  isFunctionalRelation.isStrictDomain (isFuncRel trueFuncRel) =
+    do
+      return
+        (k ,
+        (λ { tt* y r r⊩⊤≤y → tt*}))
+  isFunctionalRelation.isStrictCodomain (isFuncRel trueFuncRel) =
+    do
+      let
+        idClosure : ApplStrTerm as 2
+        idClosure = # zero
+        realizer : ApplStrTerm as 1
+        realizer = ` pair ̇ (λ*abst idClosure) ̇ (λ*abst idClosure)
+      return
+        (λ* realizer ,
+        (λ { tt* y r r⊩⊤≤y →
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym
+                (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙
+                 cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙
+                 βreduction idClosure a (r ∷ [])))
+              a⊩y) ,
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym
+                (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙
+                 cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙
+                 βreduction idClosure a (r ∷ [])))
+              a⊩y)}))
+  isFunctionalRelation.isRelational (isFuncRel trueFuncRel) =
+    do
+      let
+        realizer : ApplStrTerm as 4
+        realizer = ` pr₁ ̇ # one ̇ (# two  ̇ ` k)
+      return
+        (λ*4 realizer ,
+        (λ { tt* tt* x y a b c tt* b⊩⊤≤x (pr₁c⊩x≤y , pr₂c⊩y≤x) r →
+          subst
+            (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+            (sym (λ*4ComputationRule realizer a b c r))
+            (pr₁c⊩x≤y (b ⨾ k) (b⊩⊤≤x k))}))
+  isFunctionalRelation.isSingleValued (isFuncRel trueFuncRel) =
+    do
+      let
+        closure1 : ApplStrTerm as 3
+        closure1 = # one ̇ ` k
+
+        closure2 : ApplStrTerm as 3
+        closure2 = # two ̇ ` k
+        
+        realizer : ApplStrTerm as 2
+        realizer = ` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2)
+      return
+        (λ*2 realizer ,
+        (λ { tt* x y r₁ r₂ r₁⊩⊤≤x r₂⊩⊤≤y →
+          (λ a a⊩x →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym
+                (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙
+                 cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙
+                 βreduction closure1 a (r₂ ∷ r₁ ∷ [])))
+              (r₂⊩⊤≤y k)) ,
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate x ∣ tt*)
+              (sym
+                (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙
+                 cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙
+                 βreduction closure2 a (r₂ ∷ r₁ ∷ [])))
+              (r₁⊩⊤≤x k))}))
+  isFunctionalRelation.isTotal (isFuncRel trueFuncRel) =
+    do
+      return
+        (k ,
+        (λ { tt* r tt* →
+          let
+            ⊤ = pre1 Unit* isSetUnit* isNonTrivial
+          in
+          ∣
+            fromPredicate ⊤ ,
+            (λ a →
+              subst (λ p → (k ⨾ r ⨾ a) ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc ⊤)) tt*)
+          ∣₁ }))
+
+opaque
+  unfolding isInjectiveFuncRel
+  unfolding terminalPer
+  isInjectiveTrueFuncRel : isInjectiveFuncRel _ _ trueFuncRel
+  isInjectiveTrueFuncRel =
+    do
+      return
+        (k ,
+        (λ { tt* tt* p r₁ r₂ r₁⊩⊤≤p r₂⊩⊤≤p → tt* }))
+
+truePredicate : Predicate Unit*
+Predicate.isSetX truePredicate = isSetUnit*
+Predicate.∣ truePredicate ∣ tt* r = Unit*
+Predicate.isPropValued truePredicate tt* r = isPropUnit*
+
+⊤ = fromPredicate truePredicate
+
+-- The subobject classifier classifies subobjects represented by strict relations
+module ClassifiesStrictRelations
+  (X : Type ℓ)
+  (perX : PartialEquivalenceRelation X)
+  (ϕ : StrictRelation perX) where
+
+  open InducedSubobject perX ϕ
+  open StrictRelation
+  resizedϕ = fromPredicate (ϕ .predicate)
+
+  -- the functional relation that represents the unique indicator map
+  {-# TERMINATING #-}
+  charFuncRel : FunctionalRelation perX Ωper
+  Predicate.isSetX (relation charFuncRel) = isSet× (perX .isSetX) isSetResizedPredicate
+  Predicate.∣ relation charFuncRel ∣ (x , p) r =
+    (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x) ×
+    (∀ (b : A) (b⊩ϕx : b ⊩ ∣ ϕ .predicate ∣ x) → (pr₁ ⨾ (pr₂ ⨾ r) ⨾ b) ⊩ ∣ toPredicate p ∣ tt*) ×
+    (∀ (b : A) (b⊩px : b ⊩ ∣ toPredicate p ∣ tt*) → (pr₂ ⨾ (pr₂ ⨾ r) ⨾ b) ⊩ ∣ ϕ .predicate ∣ x)
+  Predicate.isPropValued (relation charFuncRel) (x , p) r =
+    isProp×
+      (perX .equality .isPropValued _ _)
+      (isProp×
+        (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate p) .isPropValued _ _))
+        (isPropΠ λ _ → isPropΠ λ _ → ϕ .predicate .isPropValued _ _))
+  isFunctionalRelation.isStrictDomain (isFuncRel charFuncRel) =
+    do
+      return
+        (pr₁ ,
+        (λ { x p r (pr₁r⊩x~x , ⊩ϕx≤p , ⊩p≤ϕx) → pr₁r⊩x~x}))
+  isFunctionalRelation.isStrictCodomain (isFuncRel charFuncRel) =
+    do
+      let
+        idClosure : ApplStrTerm as 2
+        idClosure = # zero
+        realizer : ApplStrTerm as 1
+        realizer = ` pair ̇ (λ*abst idClosure) ̇ (λ*abst idClosure)
+      return
+        (λ* realizer ,
+        (λ x y r x₁ →
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym
+                (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙
+                 cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙
+                 βreduction idClosure a (r ∷ [])))
+              a⊩y) ,
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym
+                (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙
+                 cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙
+                 βreduction idClosure a (r ∷ [])))
+              a⊩y)))
+  isFunctionalRelation.isRelational (isFuncRel charFuncRel) =
+    do
+      (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+      (tX , tX⊩isTransitiveX) ← perX .isTransitive
+      (relϕ , relϕ⊩isRelationalϕ) ← isStrictRelation.isRelational (ϕ .isStrictRelationPredicate)
+      let
+        closure1 : ApplStrTerm as 4
+        closure1 = ` pr₁ ̇ # one ̇ (` pr₁ ̇ (` pr₂ ̇ # two) ̇ (` relϕ ̇ # zero ̇ (` sX ̇ # three)))
+
+        closure2 : ApplStrTerm as 4
+        closure2 = ` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ # two) ̇ (` pr₂ ̇ # one ̇ # zero)) ̇ # three
+
+        realizer : ApplStrTerm as 3
+        realizer = ` pair ̇ (` tX ̇ (` sX ̇ # two) ̇ # two) ̇ (` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2))
+      return
+        (λ*3 realizer ,
+        (λ { x x' p p' a b c a⊩x~x' (⊩x~x , ⊩ϕx≤p , ⊩p≤ϕx) (⊩p≤p' , ⊩p'≤p) →
+          let
+            ⊩x'~x = sX⊩isSymmetricX x x' a a⊩x~x'
+            ⊩x'~x' = tX⊩isTransitiveX x' x x' _ _ ⊩x'~x a⊩x~x'
+          in
+          subst
+            (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'))
+            (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _))
+            ⊩x'~x' ,
+          (λ r r⊩ϕx' →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate p' ∣ tt*)
+              (sym
+                (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ r) (λ*3ComputationRule realizer a b c) ∙
+                 cong (λ x → pr₁ ⨾ x ⨾ r) (pr₂pxy≡y _ _) ∙
+                 cong (λ x → x ⨾ r) (pr₁pxy≡x _ _) ∙
+                 βreduction closure1 r (c ∷ b ∷ a ∷ [])))
+              (⊩p≤p' _ (⊩ϕx≤p _ (relϕ⊩isRelationalϕ x' x _ _ r⊩ϕx' ⊩x'~x)))) ,
+          λ r r⊩p' →
+            subst
+              (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x')
+              (sym
+                (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ r) (λ*3ComputationRule realizer a b c) ∙
+                 cong (λ x → pr₂ ⨾ x ⨾ r) (pr₂pxy≡y _ _) ∙
+                 cong (λ x → x ⨾ r) (pr₂pxy≡y _ _) ∙
+                 βreduction closure2 r (c ∷ b ∷ a ∷ [])))
+              (relϕ⊩isRelationalϕ x x' _ _ (⊩p≤ϕx _ (⊩p'≤p r r⊩p')) a⊩x~x') }))
+  isFunctionalRelation.isSingleValued (isFuncRel charFuncRel) =
+    do
+      let
+        closure1 : ApplStrTerm as 3
+        closure1 = ` pr₁ ̇ (` pr₂ ̇ # one) ̇ (` pr₂ ̇ (` pr₂ ̇ # two) ̇ # zero)
+
+        closure2 : ApplStrTerm as 3
+        closure2 = ` pr₁ ̇ (` pr₂ ̇ # two) ̇ (` pr₂ ̇ (` pr₂ ̇ # one) ̇ # zero)
+
+        realizer : ApplStrTerm as 2
+        realizer = ` pair ̇ λ*abst closure1 ̇ λ*abst closure2
+      return
+        (λ*2 realizer ,
+        (λ { x y y' r₁ r₂ (⊩x~x , ⊩ϕx≤y , ⊩y≤ϕx) (⊩'x~x , ⊩ϕx≤y' , ⊩y'≤ϕx) →
+          (λ a a⊩y →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y' ∣ tt*)
+              (sym (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙ βreduction closure1 a (r₂ ∷ r₁ ∷ [])))
+              (⊩ϕx≤y' _ (⊩y≤ϕx a a⊩y))) ,
+          (λ a a⊩y' →
+            subst
+              (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*)
+              (sym (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ βreduction closure2 a (r₂ ∷ r₁ ∷ [])))
+              (⊩ϕx≤y _ (⊩y'≤ϕx a a⊩y'))) }))
+  isFunctionalRelation.isTotal (isFuncRel charFuncRel) =
+    do
+      let
+        idClosure : ApplStrTerm as 2
+        idClosure = # zero
+
+        realizer : ApplStrTerm as 1
+        realizer = ` pair ̇ # zero ̇ (` pair ̇ λ*abst idClosure ̇ λ*abst idClosure)
+      return
+        (λ* realizer ,
+        (λ x r r⊩x~x →
+          let
+            resultPredicate : Predicate Unit*
+            resultPredicate =
+              makePredicate
+                isSetUnit*
+                (λ { tt* s → s ⊩ ∣ ϕ .predicate ∣ x })
+                (λ { tt* s → ϕ .predicate .isPropValued _ _ })
+          in
+          return
+            (fromPredicate resultPredicate ,
+            subst
+              (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+              (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+              r⊩x~x ,
+            (λ b b⊩ϕx →
+              subst
+                (λ r → r ⊩ ∣ toPredicate (fromPredicate resultPredicate) ∣ tt*)
+                (sym
+                  (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙
+                   cong (λ x → pr₁ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙
+                   cong (λ x → x ⨾ b) (pr₁pxy≡x _ _) ∙
+                   βreduction idClosure b (r ∷ [])))
+                (subst (λ p → b ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc resultPredicate)) b⊩ϕx)) ,
+            (λ b b⊩'ϕx →
+              subst
+                (λ r → r ⊩ ∣ ϕ .predicate ∣ x)
+                (sym
+                  (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙
+                   cong (λ x → pr₂ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙
+                   cong (λ x → x ⨾ b) (pr₂pxy≡y _ _) ∙
+                   βreduction idClosure b (r ∷ [])))
+                let foo = subst (λ p → b ⊩ ∣ p ∣ tt*) (compIsIdFunc resultPredicate) b⊩'ϕx in foo))))
+
+  subobjectCospan : ∀ char → Cospan RT
+  Cospan.l (subobjectCospan char) = X , perX
+  Cospan.m (subobjectCospan char) = ResizedPredicate Unit* , Ωper
+  Cospan.r (subobjectCospan char) = Unit* , terminalPer
+  Cospan.s₁ (subobjectCospan char) = char
+  Cospan.s₂ (subobjectCospan char) = [ trueFuncRel ]
+
+  opaque
+    unfolding composeRTMorphism
+    unfolding composeFuncRel
+    unfolding terminalFuncRel
+    unfolding trueFuncRel
+    unfolding incFuncRel
+    subobjectSquareCommutes : [ incFuncRel ] ⋆ [ charFuncRel ] ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ]
+    subobjectSquareCommutes =
+      let
+        answer =
+          do
+            (stX , stX⊩isStrictDomainX) ← idFuncRel perX .isStrictDomain
+            (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ
+            let
+              closure : ApplStrTerm as 2
+              closure = (` pr₁ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` relϕ ̇ (` pr₂ ̇ (` pr₁ ̇ # one)) ̇ (` pr₁ ̇ (` pr₁ ̇ # one))))
+              realizer : ApplStrTerm as 1
+              realizer =
+                ` pair ̇
+                  (` pair ̇ (` stX ̇ (` pr₁ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇
+                  λ*abst closure
+            return
+              (λ* realizer ,
+              (λ { x p r r⊩∃x' →
+                do
+                  (x' , (⊩x~x' , ⊩ϕx) , ⊩x'~x' , ⊩ϕx'≤p , ⊩p≤ϕx') ← r⊩∃x'
+                  return
+                    (tt* ,
+                    ((subst
+                      (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                      (sym (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _))
+                      (stX⊩isStrictDomainX x x' _ ⊩x~x')) ,
+                     (subst
+                       (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x)
+                       (sym (cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₂pxy≡y _ _))
+                       ⊩ϕx)) ,
+                    λ r' →
+                      let
+                        eq : pr₂ ⨾ (λ* realizer ⨾ r) ⨾ r' ≡ pr₁ ⨾ (pr₂ ⨾ (pr₂ ⨾ r)) ⨾ (relϕ ⨾ (pr₂ ⨾ (pr₁ ⨾ r)) ⨾ (pr₁ ⨾ (pr₁ ⨾ r)))
+                        eq =
+                          cong (λ x → pr₂ ⨾ x ⨾ r') (λ*ComputationRule realizer r) ∙
+                          cong (λ x → x ⨾ r') (pr₂pxy≡y _ _) ∙
+                          βreduction closure r' (r ∷ [])
+                      in
+                      subst
+                        (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*)
+                        (sym eq)
+                        (⊩ϕx'≤p _ (relϕ⊩isRelationalϕ x x' _ _ ⊩ϕx ⊩x~x'))) }))
+      in
+      eq/ _ _ (answer , F≤G→G≤F subPer Ωper (composeFuncRel _ _ _ incFuncRel charFuncRel) (composeFuncRel _ _ _ (terminalFuncRel subPer) trueFuncRel) answer)
+
+  module
+    UnivPropWithRepr
+    {Y : Type ℓ}
+    (perY : PartialEquivalenceRelation Y)
+    (F : FunctionalRelation perY perX)
+    (G : FunctionalRelation perY terminalPer)
+    (entailment : pointwiseEntailment perY Ωper (composeFuncRel _ _ _ G trueFuncRel) (composeFuncRel _ _ _ F charFuncRel)) where
+
+    opaque
+      unfolding terminalFuncRel
+      G≤idY : pointwiseEntailment perY terminalPer G (terminalFuncRel perY)
+      G≤idY =
+        do
+          (stDG , stDG⊩isStrictDomainG) ← G .isStrictDomain
+          return
+            (stDG ,
+            (λ { y tt* r r⊩Gy → stDG⊩isStrictDomainG y tt* r r⊩Gy }))
+
+    opaque
+      idY≤G : pointwiseEntailment perY terminalPer (terminalFuncRel perY) G
+      idY≤G = F≤G→G≤F perY terminalPer G (terminalFuncRel perY) G≤idY
+
+    opaque
+      unfolding trueFuncRel
+      trueFuncRelTruePredicate : ∀ a → (a ⊩ ∣ trueFuncRel .relation ∣ (tt* , fromPredicate truePredicate))
+      trueFuncRelTruePredicate a = λ b → subst (λ p → (a ⨾ b) ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*
+
+    opaque
+      unfolding composeFuncRel
+      unfolding terminalFuncRel
+      {-# TERMINATING #-}
+      H : FunctionalRelation perY subPer
+      Predicate.isSetX (relation H) = isSet× (perY .isSetX) (perX .isSetX)
+      Predicate.∣ relation H ∣ (y , x) r = r ⊩ ∣ F .relation ∣ (y , x)
+      Predicate.isPropValued (relation H) (y , x) r = F .relation .isPropValued _ _
+      isFunctionalRelation.isStrictDomain (isFuncRel H) =
+        do
+          (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+          return
+            (stFD ,
+             (λ y x r r⊩Hyx → stFD⊩isStrictDomainF y x r r⊩Hyx))
+      isFunctionalRelation.isStrictCodomain (isFuncRel H) =
+        do
+          (ent , ent⊩entailment) ← entailment
+          (a , a⊩idY≤G) ← idY≤G
+          (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+          (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain
+          (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+          (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ
+          let
+            realizer : ApplStrTerm as 1
+            realizer =
+              ` pair ̇
+                (` stFC ̇ # zero) ̇
+                (` relϕ ̇
+                  (` pr₂ ̇ (` pr₂ ̇ (` pr₂ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # zero)) ̇ ` k)))) ̇ ` k) ̇
+                  (` svF ̇ (` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # zero)) ̇ ` k))) ̇ # zero))
+          return
+            (λ* realizer ,
+             (λ y x r r⊩Hyx →
+               subst
+                 (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                 (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _))
+                 (stFC⊩isStrictCodomainF y x _ r⊩Hyx) ,
+               (equivFun
+                 (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _))
+                 (do
+                   (x' , ⊩Fyx' , ⊩x'~x' , ⊩ϕx'≤⊤ , ⊩⊤≤ϕx') ←
+                     ent⊩entailment
+                     y
+                     (fromPredicate truePredicate)
+                     (pair ⨾ (a ⨾ (stFD ⨾ r)) ⨾ k)
+                     (return
+                       (tt* ,
+                        subst
+                          (λ r → r ⊩ ∣ G .relation ∣ (y , tt*))
+                          (sym (pr₁pxy≡x _ _))
+                          (a⊩idY≤G y tt* (stFD ⨾ r) (stFD⊩isStrictDomainF y x _ r⊩Hyx))  ,
+                        trueFuncRelTruePredicate _))
+                   let
+                     ⊩x'~x = svF⊩isSingleValuedF y x' x _ _ ⊩Fyx' r⊩Hyx
+                     ⊩ϕx = relϕ⊩isRelationalϕ x' x _ _ (⊩⊤≤ϕx' k (subst (λ p → k ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*)) ⊩x'~x
+                   return (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx)))))
+      isFunctionalRelation.isRelational (isFuncRel H) =
+        do
+          (relF , relF⊩isRelationalF) ← isFunctionalRelation.isRelational (F .isFuncRel)
+          let
+            realizer : ApplStrTerm as 3
+            realizer = ` relF ̇ # two ̇ # one ̇ (` pr₁ ̇ # zero)
+          return
+            (λ*3 realizer ,
+             (λ y y' x x' a b c ⊩y~y' ⊩Fyx (⊩x~x' , ⊩ϕx) →
+               subst
+                 (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x'))
+                 (sym (λ*3ComputationRule realizer a b c))
+                 (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x')))
+      isFunctionalRelation.isSingleValued (isFuncRel H) =
+        do
+          (ent , ent⊩entailment) ← entailment
+          (a , a⊩idY≤G) ← idY≤G
+          (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+          (svF , svF⊩isSingleValuedF) ← F .isSingleValued
+          (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ
+          let
+            realizer : ApplStrTerm as 2
+            realizer =
+              ` pair ̇
+                (` svF ̇ # one ̇ # zero) ̇
+                (` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ (` pr₂ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD  ̇ # one)) ̇ ` k)))) ̇ ` k) ̇ (` svF ̇ (` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # one)) ̇ ` k))) ̇ # one))
+          return
+            (λ*2 realizer ,
+             (λ y x x' r₁ r₂ ⊩Fyx ⊩Fyx' →
+               subst
+                 (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x'))
+                 (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _))
+                 (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') ,
+               (equivFun
+                 (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _))
+                 (do
+                   (x'' , ⊩Fyx'' , ⊩x''~x'' , ⊩ϕx''≤⊤ , ⊩⊤≤ϕx'') ←
+                     ent⊩entailment
+                     y
+                     (fromPredicate truePredicate)
+                     (pair ⨾ (a ⨾ (stFD ⨾ r₁)) ⨾ k)
+                     (return
+                       (tt* ,
+                        subst (λ r → r ⊩ ∣ G .relation ∣ (y , tt*)) (sym (pr₁pxy≡x _ _)) (a⊩idY≤G y tt* _ (stFD⊩isStrictDomainF y x _ ⊩Fyx))  ,
+                        trueFuncRelTruePredicate _))
+                   let
+                     ⊩x''~x = svF⊩isSingleValuedF y x'' x _ _ ⊩Fyx'' ⊩Fyx
+                     ⊩ϕx = relϕ⊩isRelationalϕ x'' x _ _ (⊩⊤≤ϕx'' k (subst (λ p → k ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*)) ⊩x''~x
+                   return
+                     (subst
+                       (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x)
+                       (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _))
+                       ⊩ϕx)))))
+      isFunctionalRelation.isTotal (isFuncRel H) =
+        do
+          (ent , ent⊩entailment) ← entailment
+          (a , a⊩idY≤G) ← idY≤G
+          let
+            realizer : ApplStrTerm as 1
+            realizer = ` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ # zero) ̇ ` k))
+          return
+            (λ* realizer ,
+            (λ { y r r⊩y~y →
+              do
+                (x , ⊩Fyx , ⊩x~x , ⊩ϕx≤⊤ , ⊩⊤≤ϕx) ←
+                  ent⊩entailment
+                    y
+                    (fromPredicate truePredicate)
+                    (pair ⨾ (a ⨾ r) ⨾ k)
+                    (return
+                      (tt* ,
+                       subst (λ r → r ⊩ ∣ G .relation ∣ (y , tt*)) (sym (pr₁pxy≡x _ _)) (a⊩idY≤G y tt* r r⊩y~y)  ,
+                       trueFuncRelTruePredicate _))
+                return (x , subst (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) (sym (λ*ComputationRule realizer r)) ⊩Fyx) }))
+
+    opaque
+      unfolding composeRTMorphism
+      unfolding incFuncRel
+      unfolding H
+      F≡H⋆inc : [ F ] ≡ [ H ] ⋆ [ incFuncRel ]
+      F≡H⋆inc =
+        let
+          answer =
+            do
+              (relF , relF⊩isRelationalF) ← isFunctionalRelation.isRelational (F .isFuncRel)
+              (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+              let
+                realizer : ApplStrTerm as 1
+                realizer = ` relF ̇ (` stFD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))
+              return
+                 (λ* realizer ,
+                 (λ y x r ⊩∃x' →
+                   equivFun
+                     (propTruncIdempotent≃ (F .relation .isPropValued _ _))
+                     (do
+                       (x' , ⊩Hyx' , ⊩x'~x , ⊩ϕx') ← ⊩∃x'
+                       return
+                         (subst
+                           (λ r' → r' ⊩ ∣ F .relation ∣ (y , x))
+                           (sym (λ*ComputationRule realizer r))
+                           (relF⊩isRelationalF y y x' x _ _ _ (stFD⊩isStrictDomainF y x' _ ⊩Hyx') ⊩Hyx' ⊩x'~x)))))
+        in eq/ _ _ (F≤G→G≤F perY perX (composeFuncRel _ _ _ H incFuncRel) F answer , answer)
+
+    opaque
+      unfolding composeRTMorphism
+      unfolding terminalFuncRel
+      G≡H⋆terminal : [ G ] ≡ [ H ] ⋆ [ terminalFuncRel subPer ]
+      G≡H⋆terminal =
+        let
+          answer =
+            do
+              (stHD , stHD⊩isStrictDomainH) ← H .isStrictDomain
+              (a , a⊩idY≤G) ← idY≤G
+              let
+                realizer : ApplStrTerm as 1
+                realizer = ` a ̇ (` stHD ̇ (` pr₁ ̇ # zero))
+              return
+                (λ* realizer ,
+                 (λ { y tt* r r⊩∃x →
+                   equivFun
+                     (propTruncIdempotent≃ (G .relation .isPropValued _ _))
+                     (do
+                       (x , ⊩Hyx , ⊩x~x , ⊩ϕx) ← r⊩∃x
+                       return (subst (λ r' → r' ⊩ ∣ G .relation ∣ (y , tt*)) (sym (λ*ComputationRule realizer r)) (a⊩idY≤G y tt* _ (stHD⊩isStrictDomainH y x _ ⊩Hyx)))) }))
+        in eq/ _ _ (F≤G→G≤F perY terminalPer (composeFuncRel _ _ _ H (terminalFuncRel subPer)) G answer , answer)
+
+    opaque
+      unfolding composeRTMorphism
+      unfolding H
+      unfolding incFuncRel
+      isUniqueH : ∀ (H' : FunctionalRelation perY subPer) → [ F ] ≡ [ H' ] ⋆ [ incFuncRel ] → [ G ] ≡ [ H' ] ⋆ [ terminalFuncRel subPer ] → [_] {R = bientailment perY subPer} H ≡ [ H' ]
+      isUniqueH H' F≡H'⋆inc G≡H'⋆term =
+        let
+          F≤H'⋆inc = [F]≡[G]→F≤G F (composeFuncRel _ _ _ H' incFuncRel) F≡H'⋆inc
+          answer : pointwiseEntailment _ _ H H'
+          answer =
+            do
+              (a , a⊩F≤H'⋆inc) ← F≤H'⋆inc
+              (relH' , relH'⊩isRelationalH) ← isFunctionalRelation.isRelational (H' .isFuncRel)
+              (stDH , stDH⊩isStrictDomainH) ← H .isStrictDomain
+              let
+                realizer : ApplStrTerm as 1
+                realizer = ` relH' ̇ (` stDH ̇ # zero) ̇ (` pr₁ ̇ (` a ̇ # zero)) ̇ (` pr₂ ̇ (` a ̇ # zero))
+              return
+                (λ* realizer ,
+                 (λ y x r r⊩Hyx →
+                   equivFun
+                     (propTruncIdempotent≃ (H' .relation .isPropValued _ _))
+                     (do
+                       (x' , ⊩H'yx' , ⊩x'~x , ⊩ϕx') ← a⊩F≤H'⋆inc y x r r⊩Hyx
+                       return
+                         (subst
+                           (λ r' → r' ⊩ ∣ H' .relation ∣ (y , x))
+                           (sym (λ*ComputationRule realizer r))
+                           (relH'⊩isRelationalH y y x' x _ _ _ (stDH⊩isStrictDomainH y x r r⊩Hyx) ⊩H'yx' (⊩x'~x , ⊩ϕx'))))))
+        in
+        eq/ _ _ (answer , (F≤G→G≤F _ _ H H' answer))
+
+  opaque
+    classifies : isPullback RT (subobjectCospan [ charFuncRel ]) [ incFuncRel ] [ terminalFuncRel subPer ] subobjectSquareCommutes
+    classifies {Y , perY} f g f⋆char≡g⋆true =
+      SQ.elimProp2
+        {P = λ f g → ∀ (commutes : f ⋆ [ charFuncRel ] ≡ g ⋆ [ trueFuncRel ]) → ∃![ hk ∈ RTMorphism perY subPer ] (f ≡ hk ⋆ [ incFuncRel ]) × (g ≡ hk ⋆ [ terminalFuncRel subPer ])}
+        (λ f g → isPropΠ λ _ → isPropIsContr)
+        (λ F G F⋆char≡G⋆true →
+           let
+             entailment = [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G F charFuncRel G trueFuncRel F⋆char≡G⋆true
+           in
+           uniqueExists
+             [ UnivPropWithRepr.H perY F G entailment ]
+             (UnivPropWithRepr.F≡H⋆inc perY F G entailment ,
+             UnivPropWithRepr.G≡H⋆terminal perY F G entailment)
+             (λ hk' → isProp× (squash/ _ _) (squash/ _ _))
+             -- nested eliminator 🤮
+             λ { h' (f≡h'⋆inc , g≡h'⋆term) →
+               SQ.elimProp
+                 {P = λ h' → ∀ (comm1 : [ F ] ≡ h' ⋆ [ incFuncRel ]) (comm2 : [ G ] ≡ h' ⋆ [ terminalFuncRel subPer ]) → [ UnivPropWithRepr.H perY F G entailment ] ≡ h'}
+                 (λ h' → isPropΠ λ _ → isPropΠ λ _ → squash/ _ _)
+                 (λ H' F≡H'⋆inc G≡H'⋆term →
+                   UnivPropWithRepr.isUniqueH perY F G entailment H' F≡H'⋆inc G≡H'⋆term)
+                 h'
+                 f≡h'⋆inc
+                 g≡h'⋆term })
+        f g f⋆char≡g⋆true
+
+  module
+    PullbackHelper
+    (C : FunctionalRelation perX Ωper)
+    (commutes : [ incFuncRel ] ⋆ [ C ] ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ])
+    (classifies : isPullback RT (subobjectCospan [ C ]) [ incFuncRel ] [ terminalFuncRel subPer ] commutes) where
+
+    {-# TERMINATING #-}
+    ψ : StrictRelation perX
+    Predicate.isSetX (predicate ψ) = perX .isSetX
+    Predicate.∣ predicate ψ ∣ x r = r ⊩ ∣ C .relation ∣ (x , ⊤)
+    Predicate.isPropValued (predicate ψ) x r = C .relation .isPropValued _ _
+    isStrictRelation.isStrict (isStrictRelationPredicate ψ) =
+      do
+        (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain
+        return
+          (stDC ,
+           λ x r r⊩Cx⊤ → stDC⊩isStrictDomainC x (fromPredicate truePredicate) r r⊩Cx⊤)
+    isStrictRelation.isRelational (isStrictRelationPredicate ψ) =
+      do
+        (relC , relC⊩isRelationalC) ← isFunctionalRelation.isRelational (C .isFuncRel)
+        (stCC , stCC⊩isStrictCodomainC) ← C .isStrictCodomain
+        let
+          realizer : ApplStrTerm as 2
+          realizer = ` relC ̇ # zero ̇ # one ̇ (` stCC ̇ # one)
+        return
+          (λ*2 realizer ,
+           λ x x' a b a⊩Cx⊤ b⊩x~x' →
+             subst (λ r' → r' ⊩ ∣ C .relation ∣ (x' , ⊤)) (sym (λ*2ComputationRule realizer a b)) (relC⊩isRelationalC x x' ⊤ ⊤ _ _ _ b⊩x~x' a⊩Cx⊤ (stCC⊩isStrictCodomainC x ⊤ a a⊩Cx⊤)))
+
+    perψ = InducedSubobject.subPer perX ψ
+    incFuncRelψ = InducedSubobject.incFuncRel perX ψ
+
+    opaque
+      unfolding composeRTMorphism
+      unfolding InducedSubobject.incFuncRel
+      unfolding terminalFuncRel
+      unfolding trueFuncRel
+      pbSqCommutes : [ incFuncRelψ ] ⋆ [ C ] ≡ [ terminalFuncRel perψ ] ⋆ [ trueFuncRel ]
+      pbSqCommutes =
+        let
+          answer =
+            do
+              (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain
+              (stCC , stCC⊩isStrictCodomainC) ← C .isStrictCodomain
+              (svC , svC⊩isSingleValuedC) ← C .isSingleValued
+              (relC , relC⊩isRelationalC) ← isFunctionalRelation.isRelational (C .isFuncRel)
+              (sX , sX⊩isSymmetricX) ← perX .isSymmetric
+              let
+                closure : ApplStrTerm as 2
+                closure = ` pr₁ ̇ (` svC ̇ (` pr₂ ̇ (` pr₁ ̇ # one)) ̇ (` relC ̇ (` sX ̇ (` pr₁ ̇ (` pr₁ ̇ # one))) ̇ (` pr₂ ̇ # one) ̇ (` stCC ̇ (` pr₂ ̇ # one)))) ̇ ` k
+
+                realizer : ApplStrTerm as 1
+                realizer = ` pair ̇ (` pair ̇ (` stDC ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ (λ*abst closure)
+              return
+                (λ* realizer ,
+                 λ { x p r r⊩∃x' →
+                   do
+                     (x' , (⊩x~x' , ⊩Cx⊤) , ⊩Cx'p) ← r⊩∃x'
+                     let
+                       ⊩Cxp = relC⊩isRelationalC x' x p p _ _ _ (sX⊩isSymmetricX x x' _ ⊩x~x') ⊩Cx'p (stCC⊩isStrictCodomainC x' p _ ⊩Cx'p) 
+                       (⊩⊤≤p , p≤⊤) = svC⊩isSingleValuedC x ⊤ p _ _ ⊩Cx⊤ ⊩Cxp
+                     return
+                       (tt* ,
+                       (subst
+                         (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x))
+                         (sym
+                           (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙
+                            cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙
+                            pr₁pxy≡x _ _ ))
+                         (stDC⊩isStrictDomainC x ⊤ _ ⊩Cx⊤) ,
+                        subst
+                          (λ r' → r' ⊩ ∣ C .relation ∣ (x , ⊤))
+                          (sym
+                            (cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙
+                             cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙
+                             pr₂pxy≡y _ _))
+                          ⊩Cx⊤) ,
+                        λ a →
+                          subst
+                            (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*)
+                            (sym
+                              (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙
+                               cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙
+                               βreduction closure a (r ∷ [])))
+                            (⊩⊤≤p k (subst (λ q → k ⊩ ∣ q ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*))) })
+        in eq/ _ _ (answer , F≤G→G≤F _ _ (composeFuncRel _ _ _ incFuncRelψ C) (composeFuncRel _ _ _ (terminalFuncRel perψ) trueFuncRel) answer)
+
+    opaque
+      unfolding InducedSubobject.incFuncRel
+      unfolding composeFuncRel
+      ⊩Cx⊤≤ϕx : ∃[ ent ∈ A ] (∀ (x : X) (r : A) → r ⊩ ∣ C .relation ∣ (x , ⊤) → (ent ⨾ r) ⊩ ∣ ϕ .predicate ∣ x)
+      ⊩Cx⊤≤ϕx =
+        let
+          ((h , incψ≡h⋆incϕ , termψ≡h⋆termϕ) , isUniqueH) = classifies [ incFuncRelψ ] [ terminalFuncRel perψ ] pbSqCommutes
+        in
+        SQ.elimProp
+          {P = λ h → ∀ (incψ≡h⋆incϕ : [ incFuncRelψ ] ≡ h ⋆ [ incFuncRel ]) → ∃[ ent ∈ A ] (∀ (x : X) (r : A) → r ⊩ ∣ C .relation ∣ (x , ⊤) → (ent ⨾ r) ⊩ ∣ ϕ .predicate ∣ x)}
+          (λ h → isPropΠ λ _ → isPropPropTrunc)
+          (λ H incψ≡H⋆incϕ →
+            do
+              (a , a⊩incψ≤H⋆incϕ) ← [F]≡[G]⋆[H]→F≤G⋆H incFuncRelψ H incFuncRel incψ≡H⋆incϕ
+              (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain
+              (relϕ , relϕ⊩isRelationalϕ) ← isStrictRelation.isRelational (ϕ .isStrictRelationPredicate)
+              let
+                realizer = ` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ (` a ̇ (` pair ̇ (` stDC ̇ # zero) ̇ # zero)))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` a ̇ (` pair ̇ (` stDC ̇ # zero) ̇ # zero)))) 
+              return
+                (λ* realizer ,
+                 (λ x r r⊩Cx⊤ →
+                   equivFun
+                     (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _))
+                     (do
+                       (x' , ⊩Hxx' , ⊩x'~x , ⊩ϕx') ←
+                           a⊩incψ≤H⋆incϕ
+                           x x
+                           (pair ⨾ (stDC ⨾ r) ⨾ r)
+                           (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (pr₁pxy≡x _ _)) (stDC⊩isStrictDomainC x ⊤ r r⊩Cx⊤) ,
+                            subst (λ r' → r' ⊩ ∣ C .relation ∣ (x , ⊤)) (sym (pr₂pxy≡y _ _)) r⊩Cx⊤)
+                       return
+                         (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (λ*ComputationRule realizer r)) (relϕ⊩isRelationalϕ x' x _ _ ⊩ϕx' ⊩x'~x))))))
+          h
+          incψ≡h⋆incϕ
+
+  opaque
+    unfolding trueFuncRel
+    unfolding composeFuncRel
+    unfolding incFuncRel
+    unfolding terminalFuncRel
+    isUniqueCharMorphism :
+      ∀ (char : RTMorphism perX Ωper)
+      → (commutes : [ incFuncRel ] ⋆ char ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ])
+      → (classifies : isPullback RT (subobjectCospan char) [ incFuncRel ] [ terminalFuncRel subPer ] commutes)
+      → char ≡ [ charFuncRel ]
+    isUniqueCharMorphism char commutes classifies =
+      SQ.elimProp
+        {P =
+          λ char →
+          ∀ (commutes : [ incFuncRel ] ⋆ char ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ])
+            (classifies : isPullback RT (subobjectCospan char) [ incFuncRel ] [ terminalFuncRel subPer ] commutes)
+          → char ≡ [ charFuncRel ]}
+        (λ char → isPropΠ λ commutes → isPropΠ λ classifies → squash/ _ _)
+        (λ charFuncRel' commutes classifies →
+          let
+            answer =
+              do
+                (stDX' , stDX'⊩isStrictDomainX') ← charFuncRel' .isStrictDomain
+                (relX' , relX'⊩isRelationalX') ← isFunctionalRelation.isRelational (charFuncRel' .isFuncRel)
+                (a , a⊩inc⋆X'≤term⋆true) ← [F]⋆[G]≡[H]⋆[I]→F⋆G≤H⋆I incFuncRel charFuncRel' (terminalFuncRel subPer) trueFuncRel commutes
+                (b , b⊩term⋆true≤inc⋆X') ← [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G incFuncRel charFuncRel' (terminalFuncRel subPer) trueFuncRel commutes
+                (d , d⊩X'x⊤≤ϕx) ← PullbackHelper.⊩Cx⊤≤ϕx charFuncRel' commutes classifies
+                let
+                  closure1 : ApplStrTerm as 2
+                  closure1 = ` pr₂ ̇ (` a ̇ (` pair ̇ (` pair ̇ (` stDX'  ̇ # one) ̇ # zero) ̇ # one)) ̇ ` k
+                  closure2 : ApplStrTerm as 2
+                  closure2 = ` d ̇ (` relX' ̇ (` stDX' ̇ # one) ̇ # one ̇ (` pair ̇ ` k ̇ (` k ̇ # zero)))
+                  realizer : ApplStrTerm as 1
+                  realizer = ` pair ̇ (` stDX' ̇ # zero) ̇ (` pair ̇ λ*abst closure1 ̇ λ*abst closure2)
+                return
+                  (λ* realizer ,
+                   (λ { x p r r⊩X'xp →
+                     let
+                       ⊩x~x = stDX'⊩isStrictDomainX' x p r r⊩X'xp
+                     in
+                     subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x  _ _)) ⊩x~x ,
+                     (λ b b⊩ϕx →
+                       let
+                         goal =
+                           a⊩inc⋆X'≤term⋆true
+                             x p (pair ⨾ (pair ⨾ (stDX' ⨾ r) ⨾ b) ⨾ r)
+                             (return
+                               (x , (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _)) ⊩x~x ,
+                               subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₂pxy≡y _ _)) b⊩ϕx) ,
+                               subst (λ r' → r' ⊩ ∣ charFuncRel' .relation ∣ (x , p)) (sym (pr₂pxy≡y _ _)) r⊩X'xp))
+
+                         eq : pr₁ ⨾ (pr₂ ⨾ (λ* realizer ⨾ r)) ⨾ b ≡ pr₂ ⨾ (a ⨾ (pair ⨾ (pair ⨾ (stDX' ⨾ r) ⨾ b) ⨾ r)) ⨾ k
+                         eq =
+                           cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙ cong (λ x → x ⨾ b) (pr₁pxy≡x _ _) ∙ βreduction closure1 b (r ∷ [])
+                       in
+                       equivFun
+                         (propTruncIdempotent≃ (toPredicate p .isPropValued _ _))
+                         (do
+                           (tt* , ⊩'x~x , ⊩⊤≤p) ← goal
+                           return (subst (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) (sym eq) (⊩⊤≤p k)))) ,
+                     (λ c c⊩p →
+                       let
+                         ⊩X'x⊤ =
+                           relX'⊩isRelationalX'
+                             x x p ⊤ _ _
+                             (pair ⨾ k ⨾ (k ⨾ c))
+                             ⊩x~x r⊩X'xp
+                             ((λ b b⊩p → subst (λ q → (pr₁ ⨾ (pair ⨾ k ⨾ (k ⨾ c))) ⊩ ∣ q ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*) ,
+                              (λ b b⊩⊤ → subst (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) (sym (cong (λ x → x ⨾ b) (pr₂pxy≡y _ _) ∙ kab≡a _ _)) c⊩p))
+
+                         eq : pr₂ ⨾ (pr₂ ⨾ (λ* realizer ⨾ r)) ⨾ c ≡ d ⨾ (relX' ⨾ (stDX' ⨾ r) ⨾ r ⨾ (pair ⨾ k ⨾ (k ⨾ c)))
+                         eq =
+                           cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ c) (λ*ComputationRule realizer r) ∙
+                           cong (λ x → pr₂ ⨾ x ⨾ c) (pr₂pxy≡y _ _) ∙
+                           cong (λ x → x ⨾ c) (pr₂pxy≡y _ _) ∙
+                           βreduction closure2 c (r ∷ [])
+                       in
+                       subst
+                         (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x)
+                         (sym eq)
+                         (d⊩X'x⊤≤ϕx x _ ⊩X'x⊤)) }))
+          in eq/ _ _ (answer , F≤G→G≤F _ _ charFuncRel' charFuncRel answer))
+        char
+        commutes
+        classifies
+
\ No newline at end of file diff --git a/docs/Realizability.Topos.TerminalObject.html b/docs/Realizability.Topos.TerminalObject.html new file mode 100644 index 0000000..0eb2b9f --- /dev/null +++ b/docs/Realizability.Topos.TerminalObject.html @@ -0,0 +1,112 @@ + +Realizability.Topos.TerminalObject
open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Realizability.CombinatoryAlgebra
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Data.Unit
+open import Cubical.Data.Empty
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.HITs.SetQuotients as SQ
+open import Cubical.Categories.Category
+open import Cubical.Categories.Limits.Terminal
+
+module Realizability.Topos.TerminalObject
+  {ℓ ℓ' ℓ''}
+  {A : Type ℓ}
+  (ca : CombinatoryAlgebra A)
+  (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) where
+
+open CombinatoryAlgebra ca
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Topos.Object {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial
+
+open Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open PartialEquivalenceRelation
+open Predicate renaming (isSetX to isSetPredicateBase)
+
+opaque
+  terminalPer : PartialEquivalenceRelation Unit*
+  isSetPredicateBase (equality terminalPer) = isSet× isSetUnit* isSetUnit*
+  ∣ equality terminalPer ∣ (tt* , tt*) _ = Unit*
+  isPropValued (equality terminalPer) _ _ = isPropUnit*
+  isPartialEquivalenceRelation.isSetX (isPerEquality terminalPer) = isSetUnit*
+  isPartialEquivalenceRelation.isSymmetric (isPerEquality terminalPer) =
+    return (k , (λ { tt* tt* r tt* → tt* }))
+  isPartialEquivalenceRelation.isTransitive (isPerEquality terminalPer) =
+    return (k , (λ { tt* tt* tt* _ _ tt* tt* → tt* }))
+
+open FunctionalRelation
+
+opaque
+  unfolding terminalPer
+  terminalFuncRel : ∀ {Y : Type ℓ'} → (perY : PartialEquivalenceRelation Y) → FunctionalRelation perY terminalPer
+  terminalFuncRel {Y} perY =
+    record
+      { relation =
+        record
+          { isSetX = isSet× (perY .isSetX) isSetUnit*
+          ; ∣_∣ = λ { (y , tt*) r → r ⊩ ∣ perY .equality ∣ (y , y) }
+          ; isPropValued = λ { (y , tt*) r → perY .equality .isPropValued _ _ } }
+      ; isFuncRel =
+        record
+          { isStrictDomain = return (Id , (λ { y tt* r r⊩y~y → subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y)) (sym (Ida≡a _)) r⊩y~y }))
+          ; isStrictCodomain = return (k , (λ { y tt* r r⊩y~y → tt* }))
+          ; isRelational =
+            (do
+            (t , t⊩isTransitive) ← perY .isTransitive
+            (s , s⊩isSymmetric) ← perY .isSymmetric
+            let
+              prover : ApplStrTerm as 3
+              prover = ` t ̇ (` s ̇ # two) ̇ # two
+            return
+              (λ*3 prover ,
+              (λ { y y' tt* tt* a b c a⊩y~y' b⊩y~y tt* →
+                subst
+                  (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y'))
+                  (sym (λ*3ComputationRule prover a b c))
+                  (t⊩isTransitive y' y y' (s ⨾ a) a (s⊩isSymmetric y y' a a⊩y~y') a⊩y~y') })))
+          ; isSingleValued = (return (k , (λ { y tt* tt* r₁ r₂ r₁⊩y~y r₂⊩y~y → tt* })))
+          ; isTotal = return
+                      (Id ,
+                      (λ y r r⊩y~y →
+                        return (tt* , (subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y)) (sym (Ida≡a _)) r⊩y~y))))
+                                    } }
+opaque
+  unfolding terminalPer
+  isTerminalTerminalPer : ∀ {Y : Type ℓ'} → (perY : PartialEquivalenceRelation Y) → isContr (RTMorphism perY terminalPer)
+  isTerminalTerminalPer {Y} perY =
+    inhProp→isContr
+      [ terminalFuncRel perY ]
+      λ f g →
+        SQ.elimProp2
+          (λ f g → squash/ f g)
+          (λ F G →
+            let
+              answer : pointwiseEntailment perY terminalPer F G
+              answer =
+                do
+                  (tlG , tlG⊩isTotalG) ← G .isTotal
+                  (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain
+                  let
+                    prover : ApplStrTerm as 1
+                    prover = ` tlG ̇ (` stFD ̇ # zero)
+                  return
+                    (λ* prover ,
+                    (λ { y tt* r r⊩Fy →
+                      transport
+                        (propTruncIdempotent (G .relation .isPropValued _ _))
+                        (do
+                          (tt* , tlGstFD⊩Gy) ← tlG⊩isTotalG y (stFD ⨾ r) (stFD⊩isStrictDomainF y tt* r r⊩Fy)
+                          return (subst (λ r' → r' ⊩ ∣ G .relation ∣ (y , tt*)) (sym (λ*ComputationRule prover r)) tlGstFD⊩Gy)) }))
+            in
+            eq/ _ _ (answer , F≤G→G≤F perY terminalPer F G answer))
+          f g
+
+TerminalRT : Terminal RT
+TerminalRT =
+  (Unit* , terminalPer) , (λ { (Y , perY) → isTerminalTerminalPer perY})
+
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Logic.Semantics.html b/docs/Realizability.Tripos.Logic.Semantics.html index 59facd9..af8380b 100644 --- a/docs/Realizability.Tripos.Logic.Semantics.html +++ b/docs/Realizability.Tripos.Logic.Semantics.html @@ -1,189 +1,605 @@ Realizability.Tripos.Logic.Semantics
{-# OPTIONS --allow-unsolved-metas #-}
 open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Equiv
-open import Cubical.Foundations.Univalence
-open import Cubical.Foundations.Isomorphism
-open import Cubical.Foundations.Function
-open import Cubical.Foundations.Structure
-open import Cubical.Functions.FunExtEquiv
-open import Cubical.Data.Sigma
-open import Cubical.Data.Empty
-open import Cubical.Data.Unit
-open import Cubical.Data.Sum
-open import Cubical.Data.Vec
-open import Cubical.Data.Nat
-open import Cubical.Data.Fin
-open import Cubical.HITs.PropositionalTruncation
-open import Cubical.HITs.PropositionalTruncation.Monad
-open import Cubical.Relation.Binary.Order.Preorder
-
-module
-  Realizability.Tripos.Logic.Semantics
-  {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A)  where
-open import Realizability.Tripos.Prealgebra.Predicate.Base ca renaming (Predicate to Predicate')
-open import Realizability.Tripos.Prealgebra.Predicate.Properties ca
-open import Realizability.Tripos.Prealgebra.Meets.Identity ca
-open import Realizability.Tripos.Prealgebra.Joins.Identity ca
-open import Realizability.Tripos.Logic.Syntax {ℓ = ℓ'}
-open CombinatoryAlgebra ca
-open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
-open Predicate'
-open PredicateProperties hiding (_≤_ ; isTrans≤)
-open Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''}
-Predicate = Predicate' {ℓ' = ℓ'} {ℓ'' = ℓ''}
-RelationInterpretation : ∀ {n : ℕ} → (Vec Sort n) → Type _
-RelationInterpretation {n} relSym = (∀ i →  Predicate ⟨ ⟦ lookup i relSym ⟧ˢ ⟩)
-module Interpretation
-  {n : ℕ}
-  (relSym : Vec Sort n)
-  (⟦_⟧ʳ : RelationInterpretation relSym) (isNonTrivial : s ≡ k → ⊥) where
-  open Relational relSym
-
-  ⟦_⟧ᶜ : Context → hSet ℓ'
-  ⟦ [] ⟧ᶜ = Unit* , isSetUnit* 
-  ⟦ c ′ x ⟧ᶜ = (⟦ c ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) , isSet× (⟦ c ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)
-
-  ⟦_⟧ⁿ : ∀ {Γ s} → s ∈ Γ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩
-  ⟦_⟧ⁿ {.(_ ′ s)} {s} _∈_.here (⟦Γ⟧ , ⟦s⟧) = ⟦s⟧
-  ⟦_⟧ⁿ {.(_ ′ _)} {s} (_∈_.there s∈Γ) (⟦Γ⟧ , ⟦s⟧) = ⟦ s∈Γ ⟧ⁿ ⟦Γ⟧
-
-  ⟦_⟧ᵗ : ∀ {Γ s} → Term Γ s → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩
-  ⟦_⟧ᵗ {Γ} {s} (var x) ⟦Γ⟧ = ⟦ x ⟧ⁿ ⟦Γ⟧
-  ⟦_⟧ᵗ {Γ} {s} (t `, t₁) ⟦Γ⟧ = (⟦ t ⟧ᵗ ⟦Γ⟧) , (⟦ t₁ ⟧ᵗ ⟦Γ⟧)
-  ⟦_⟧ᵗ {Γ} {s} (π₁ t) ⟦Γ⟧ = fst (⟦ t ⟧ᵗ ⟦Γ⟧)
-  ⟦_⟧ᵗ {Γ} {s} (π₂ t) ⟦Γ⟧ = snd (⟦ t ⟧ᵗ ⟦Γ⟧)
-  ⟦_⟧ᵗ {Γ} {s} (fun x t) ⟦Γ⟧ = x (⟦ t ⟧ᵗ ⟦Γ⟧)
-
-  ⟦_⟧ᶠ : ∀ {Γ} → Formula Γ → Predicate ⟨ ⟦ Γ ⟧ᶜ ⟩
-  ⟦_⟧ᶠ {[]} ⊤ᵗ = pre1 Unit* isSetUnit* isNonTrivial
-  ⟦_⟧ᶠ {[]} ⊥ᵗ = pre0 Unit* isSetUnit* isNonTrivial
-  ⟦_⟧ᶠ {[]} (f `∨ f₁) = _⊔_ Unit* ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (f `∧ f₁) = _⊓_ Unit* ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (f `→ f₁) = _⇒_ Unit* ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (`¬ f) = _⇒_ Unit* ⟦ f ⟧ᶠ ⟦ ⊥ᵗ {Γ = []} ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (`∃ {B = B} f) =
-    `∃[_]
-    {X = Unit* × ⟦ B ⟧ˢ .fst}
-    {Y = Unit*}
-    (isSet× isSetUnit* (⟦ B ⟧ˢ .snd))
-    isSetUnit*
-    fst
-    ⟦ f ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (`∀ {B = B} f) =
-    `∀[_]
-    {X = Unit* × ⟦ B ⟧ˢ .fst}
-    {Y = Unit*}
-    (isSet× isSetUnit* (⟦ B ⟧ˢ .snd))
-    isSetUnit*
-    fst
-    ⟦ f ⟧ᶠ
-  ⟦_⟧ᶠ {[]} (rel R t) = ⋆_ isSetUnit* (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ
-  ⟦_⟧ᶠ {Γ ′ x} ⊤ᵗ = pre1 (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)) isNonTrivial
-  ⟦_⟧ᶠ {Γ ′ x} ⊥ᵗ = pre0 (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)) isNonTrivial
-  ⟦_⟧ᶠ {Γ ′ x} (f `∨ f₁) = _⊔_ (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {Γ ′ x} (f `∧ f₁) = _⊓_ (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {Γ ′ x} (f `→ f₁) = _⇒_ (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ
-  ⟦_⟧ᶠ {Γ ′ x} (`¬ f) = _⇒_ (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) ⟦ f ⟧ᶠ ⟦ ⊥ᵗ {Γ = Γ ′ x} ⟧ᶠ
-  ⟦_⟧ᶠ {Γ ′ x} (`∃ {B = B} f) =
-    `∃[_]
-    {X = (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) × ⟦ B ⟧ˢ .fst}
-    {Y = ⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst}
-    (isSet× (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)) (⟦ B ⟧ˢ .snd))
-    (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd))
-    fst
-    (⟦ f ⟧ᶠ)
-  ⟦_⟧ᶠ {Γ ′ x} (`∀ {B = B} f) =
-    `∀[_]
-    {X = (⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) × ⟦ B ⟧ˢ .fst}
-    {Y = ⟦ Γ ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst}
-    (isSet× (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)) (⟦ B ⟧ˢ .snd))
-    (isSet× (⟦ Γ ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd))
-    fst
-    (⟦ f ⟧ᶠ)
-  ⟦_⟧ᶠ {Γ ′ x} (rel R t) = ⋆_ (str ⟦ Γ ′ x ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ
-
-  -- R for renamings and r for relations
-  ⟦_⟧ᴿ : ∀ {Γ Δ} → Renaming Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩
-  ⟦ id ⟧ᴿ ctx = ctx
-  ⟦ drop ren ⟧ᴿ (ctx , _) = ⟦ ren ⟧ᴿ ctx
-  ⟦ keep ren ⟧ᴿ (ctx , s) = (⟦ ren ⟧ᴿ ctx) , s
-
-  -- B for suBstitution and s for sorts
-  ⟦_⟧ᴮ : ∀ {Γ Δ} → Substitution Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩
-  ⟦ id ⟧ᴮ ctx = ctx
-  ⟦ t , sub ⟧ᴮ ctx = (⟦ sub ⟧ᴮ ctx) , (⟦ t ⟧ᵗ ctx)
-  ⟦ drop sub ⟧ᴮ (ctx , s) = ⟦ sub ⟧ᴮ ctx
-
-  renamingVarSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (v : s ∈ Δ) → ⟦ renamingVar ren v ⟧ⁿ ≡ ⟦ v ⟧ⁿ ∘ ⟦ ren ⟧ᴿ
-  renamingVarSound {Γ} {.Γ} {s} id v = refl
-  renamingVarSound {.(_ ′ _)} {Δ} {s} (drop ren) v = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ }
-  renamingVarSound {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → ⟦s⟧ }
-  renamingVarSound {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there v) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ }
-
-  renamingTermSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (t : Term Δ s) → ⟦ renamingTerm ren t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ ren ⟧ᴿ
-  renamingTermSound {Γ} {.Γ} {s} id t = refl
-  renamingTermSound {.(_ ′ _)} {Δ} {s} (drop ren) (var x) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren x i ⟦Γ⟧ }
-  renamingTermSound {.(_ ′ _)} {Δ} {.(_ `× _)} r@(drop ren) (t `, t₁) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i (⟦Γ⟧ , ⟦s⟧) , renamingTermSound r t₁ i (⟦Γ⟧ , ⟦s⟧) }
-  renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₁ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst }
-  renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₂ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd }
-  renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (fun f t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) }
-  renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (var v) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingVarSound r v i x }
-  renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} r@(keep ren) (t `, t₁) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → (renamingTermSound r t i x) , (renamingTermSound r t₁ i x) }
-  renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₁ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst }
-  renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₂ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd }
-  renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (fun f t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) }
-
-  substitutionVarSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (v : s ∈ Δ) → ⟦ substitutionVar subs v ⟧ᵗ ≡ ⟦ v ⟧ⁿ ∘ ⟦ subs ⟧ᴮ
-  substitutionVarSound {Γ} {.Γ} {s} id t = refl
-  substitutionVarSound {Γ} {.(_ ′ s)} {s} (t' , subs) here = funExt λ ⟦Γ⟧ → refl
-  substitutionVarSound {Γ} {.(_ ′ _)} {s} (t' , subs) (there t) = funExt λ ⟦Γ⟧ i → substitutionVarSound subs t i ⟦Γ⟧
-  substitutionVarSound {.(_ ′ _)} {Δ} {s} r@(drop subs) t =
-    -- TODO : Fix unsolved constraints
-    funExt
-      λ { x@(⟦Γ⟧ , ⟦s⟧) →
-        ⟦ substitutionVar (drop subs) t ⟧ᵗ (⟦Γ⟧ , ⟦s⟧)
-          ≡[ i ]⟨  renamingTermSound (drop id) (substitutionVar subs t) i (⟦Γ⟧ , ⟦s⟧)  ⟩
-        ⟦ substitutionVar subs t ⟧ᵗ (⟦ drop id ⟧ᴿ x)
-          ≡⟨ refl ⟩
-        ⟦ substitutionVar subs t ⟧ᵗ ⟦Γ⟧
-          ≡[ i ]⟨ substitutionVarSound subs t i ⟦Γ⟧ ⟩
-        ⟦ t ⟧ⁿ (⟦ subs ⟧ᴮ ⟦Γ⟧)
-          ∎}
-
-  substitutionTermSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (t : Term Δ s) → ⟦ substitutionTerm subs t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ subs ⟧ᴮ
-  substitutionTermSound {Γ} {Δ} {s} subs (var x) = substitutionVarSound subs x
-  substitutionTermSound {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = funExt λ x i → (substitutionTermSound subs t i x) , (substitutionTermSound subs t₁ i x)
-  substitutionTermSound {Γ} {Δ} {s} subs (π₁ t) = funExt λ x i → substitutionTermSound subs t i x .fst
-  substitutionTermSound {Γ} {Δ} {s} subs (π₂ t) = funExt λ x i → substitutionTermSound subs t i x .snd
-  substitutionTermSound {Γ} {Δ} {s} subs (fun f t) = funExt λ x i → f (substitutionTermSound subs t i x)
-
-module Soundness
-  {n}
-  {relSym : Vec Sort n}
-  (isNonTrivial : s ≡ k → ⊥)
-  (⟦_⟧ʳ : RelationInterpretation relSym) where
-  open Relational relSym
-  open Interpretation relSym ⟦_⟧ʳ isNonTrivial
-
-  infix 24 _⊨_
-
-  module _ {Γ : Context} where
-
-    open PredicateProperties {ℓ'' = ℓ''} ⟨ ⟦ Γ ⟧ᶜ ⟩
-
-    _⊨_ : Formula Γ → Formula Γ → Type _
-    ϕ ⊨ ψ = ⟦ ϕ ⟧ᶠ ≤ ⟦ ψ ⟧ᶠ
-
-    private
-      variable
-        ϕ ψ θ χ : Formula Γ
-
-    cut : ∀ {ϕ ψ θ} → ϕ ⊨ ψ → ψ ⊨ θ → ϕ ⊨ θ
-    cut {ϕ} {ψ} {θ} ϕ⊨ψ ψ⊨θ = isTrans≤ ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ⊨ψ ψ⊨θ
-
-    
+open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm; λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*)
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Structure
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty renaming (elim to ⊥elim ; rec* to ⊥rec*)
+open import Cubical.Data.Unit
+open import Cubical.Data.Sum
+open import Cubical.Data.Vec
+open import Cubical.Data.Nat
+open import Cubical.Data.Fin
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.Relation.Binary.Order.Preorder
+
+module
+  Realizability.Tripos.Logic.Semantics
+  {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A)  where
+open CombinatoryAlgebra ca
+private λ*ComputationRule = `λ*ComputationRule as fefermanStructure
+private λ* = `λ* as fefermanStructure
+
+open import Realizability.Tripos.Prealgebra.Predicate.Base ca renaming (Predicate to Predicate')
+open import Realizability.Tripos.Prealgebra.Predicate.Properties ca
+open import Realizability.Tripos.Prealgebra.Meets.Identity ca
+open import Realizability.Tripos.Prealgebra.Joins.Identity ca
+open import Realizability.Tripos.Prealgebra.Implication ca
+open import Realizability.Tripos.Logic.Syntax {ℓ = ℓ'}
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate'
+open PredicateProperties hiding (_≤_ ; isTrans≤)
+open Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''}
+private
+  Predicate = Predicate' {ℓ' = ℓ'} {ℓ'' = ℓ''}
+RelationInterpretation : ∀ {n : ℕ} → (Vec Sort n) → Type _
+RelationInterpretation {n} relSym = (∀ i →  Predicate ⟨ ⟦ lookup i relSym ⟧ˢ ⟩)
+
+⟦_⟧ᶜ : Context → hSet ℓ'
+⟦ [] ⟧ᶜ = Unit* , isSetUnit* 
+⟦ c ′ x ⟧ᶜ = (⟦ c ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) , isSet× (⟦ c ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd)
+
+⟦_⟧ⁿ : ∀ {Γ s} → s ∈ Γ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩
+⟦_⟧ⁿ {.(_ ′ s)} {s} _∈_.here (⟦Γ⟧ , ⟦s⟧) = ⟦s⟧
+⟦_⟧ⁿ {.(_ ′ _)} {s} (_∈_.there s∈Γ) (⟦Γ⟧ , ⟦s⟧) = ⟦ s∈Γ ⟧ⁿ ⟦Γ⟧
+
+⟦_⟧ᵗ : ∀ {Γ s} → Term Γ s → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩
+⟦_⟧ᵗ {Γ} {s} (var x) ⟦Γ⟧ = ⟦ x ⟧ⁿ ⟦Γ⟧
+⟦_⟧ᵗ {Γ} {s} (t `, t₁) ⟦Γ⟧ = (⟦ t ⟧ᵗ ⟦Γ⟧) , (⟦ t₁ ⟧ᵗ ⟦Γ⟧)
+⟦_⟧ᵗ {Γ} {s} (π₁ t) ⟦Γ⟧ = fst (⟦ t ⟧ᵗ ⟦Γ⟧)
+⟦_⟧ᵗ {Γ} {s} (π₂ t) ⟦Γ⟧ = snd (⟦ t ⟧ᵗ ⟦Γ⟧)
+⟦_⟧ᵗ {Γ} {s} (fun x t) ⟦Γ⟧ = x (⟦ t ⟧ᵗ ⟦Γ⟧)
+
+-- R for renamings and r for relations
+⟦_⟧ᴿ : ∀ {Γ Δ} → Renaming Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩
+⟦ id ⟧ᴿ ctx = ctx
+⟦ drop ren ⟧ᴿ (ctx , _) = ⟦ ren ⟧ᴿ ctx
+⟦ keep ren ⟧ᴿ (ctx , s) = (⟦ ren ⟧ᴿ ctx) , s
+
+-- B for suBstitution and s for sorts
+⟦_⟧ᴮ : ∀ {Γ Δ} → Substitution Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩
+⟦ id ⟧ᴮ ctx = ctx
+⟦ t , sub ⟧ᴮ ctx = (⟦ sub ⟧ᴮ ctx) , (⟦ t ⟧ᵗ ctx)
+⟦ drop sub ⟧ᴮ (ctx , s) = ⟦ sub ⟧ᴮ ctx
+
+renamingVarSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (v : s ∈ Δ) → ⟦ renamingVar ren v ⟧ⁿ ≡ ⟦ v ⟧ⁿ ∘ ⟦ ren ⟧ᴿ
+renamingVarSound {Γ} {.Γ} {s} id v = refl
+renamingVarSound {.(_ ′ _)} {Δ} {s} (drop ren) v = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ }
+renamingVarSound {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → ⟦s⟧ }
+renamingVarSound {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there v) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ }
+
+renamingTermSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (t : Term Δ s) → ⟦ renamingTerm ren t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ ren ⟧ᴿ
+renamingTermSound {Γ} {.Γ} {s} id t = refl
+renamingTermSound {.(_ ′ _)} {Δ} {s} (drop ren) (var x) =
+ funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren x i ⟦Γ⟧ }
+renamingTermSound {.(_ ′ _)} {Δ} {.(_ `× _)} r@(drop ren) (t `, t₁) =
+ funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i (⟦Γ⟧ , ⟦s⟧) , renamingTermSound r t₁ i (⟦Γ⟧ , ⟦s⟧) }
+renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₁ t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst }
+renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₂ t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd }
+renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (fun f t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) }
+renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (var v) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingVarSound r v i x }
+renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} r@(keep ren) (t `, t₁) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → (renamingTermSound r t i x) , (renamingTermSound r t₁ i x) }
+renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₁ t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst }
+renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₂ t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd }
+renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (fun f t) =
+ funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) }
+
+
+substitutionVarSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (v : s ∈ Δ) → ⟦ substitutionVar subs v ⟧ᵗ ≡ ⟦ v ⟧ⁿ ∘ ⟦ subs ⟧ᴮ
+substitutionVarSound {Γ} {.Γ} {s} id t = refl
+substitutionVarSound {Γ} {.(_ ′ s)} {s} (t' , subs) here = funExt λ ⟦Γ⟧ → refl
+substitutionVarSound {Γ} {.(_ ′ _)} {s} (t' , subs) (there t) = funExt λ ⟦Γ⟧ i → substitutionVarSound subs t i ⟦Γ⟧
+substitutionVarSound {.(_ ′ _)} {Δ} {s} r@(drop subs) t =
+ -- TODO : Fix unsolved constraints
+ funExt
+   λ { x@(⟦Γ⟧ , ⟦s⟧) →
+     ⟦ substitutionVar (drop subs) t ⟧ᵗ x
+       ≡[ i ]⟨  renamingTermSound (drop id) (substitutionVar subs t) i x  ⟩
+     ⟦ substitutionVar subs t ⟧ᵗ (⟦ drop id ⟧ᴿ x)
+       ≡⟨ refl ⟩
+     ⟦ substitutionVar subs t ⟧ᵗ ⟦Γ⟧
+       ≡[ i ]⟨ substitutionVarSound subs t i ⟦Γ⟧ ⟩
+     ⟦ t ⟧ⁿ (⟦ subs ⟧ᴮ ⟦Γ⟧)
+       ∎}
+
+substitutionTermSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (t : Term Δ s) → ⟦ substitutionTerm subs t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ subs ⟧ᴮ
+substitutionTermSound {Γ} {Δ} {s} subs (var x) = substitutionVarSound subs x
+substitutionTermSound {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = funExt λ x i → (substitutionTermSound subs t i x) , (substitutionTermSound subs t₁ i x)
+substitutionTermSound {Γ} {Δ} {s} subs (π₁ t) = funExt λ x i → substitutionTermSound subs t i x .fst
+substitutionTermSound {Γ} {Δ} {s} subs (π₂ t) = funExt λ x i → substitutionTermSound subs t i x .snd
+substitutionTermSound {Γ} {Δ} {s} subs (fun f t) = funExt λ x i → f (substitutionTermSound subs t i x)
+
+semanticSubstitution : ∀ {Γ Δ} → (subs : Substitution Γ Δ) → Predicate ⟨ ⟦ Δ ⟧ᶜ ⟩ → Predicate ⟨ ⟦ Γ ⟧ᶜ ⟩
+semanticSubstitution {Γ} {Δ} subs = ⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ
+
+module Interpretation
+  {n : ℕ}
+  (relSym : Vec Sort n)
+  (⟦_⟧ʳ : RelationInterpretation relSym) (isNonTrivial : s ≡ k → ⊥) where
+  open Relational relSym
+  ⟦_⟧ᶠ : ∀ {Γ} → Formula Γ → Predicate ⟨ ⟦ Γ ⟧ᶜ ⟩
+  ⟦_⟧ᶠ {Γ} ⊤ᵗ = pre1 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial
+  ⟦_⟧ᶠ {Γ} ⊥ᵗ = pre0 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial
+  ⟦_⟧ᶠ {Γ} (form `∨ form₁) = _⊔_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ
+  ⟦_⟧ᶠ {Γ} (form `∧ form₁) = _⊓_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ
+  ⟦_⟧ᶠ {Γ} (form `→ form₁) = _⇒_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ
+  ⟦_⟧ᶠ {Γ} (`∃ {B = B} form) = `∃[_] (isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ)) (str ⟦ Γ ⟧ᶜ) (λ { (⟦Γ⟧ , ⟦B⟧) → ⟦Γ⟧ }) ⟦ form ⟧ᶠ
+  ⟦_⟧ᶠ {Γ} (`∀ {B = B} form) = `∀[_] (isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ)) (str ⟦ Γ ⟧ᶜ) (λ { (⟦Γ⟧ , ⟦B⟧) → ⟦Γ⟧ }) ⟦ form ⟧ᶠ
+  ⟦_⟧ᶠ {Γ} (rel R t) = ⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ
+
+  -- Due to a shortcut in the soundness of negation termination checking fails
+  -- TODO : Fix
+  {-# TERMINATING #-}
+  substitutionFormulaSound : ∀ {Γ Δ} → (subs : Substitution Γ Δ) → (f : Formula Δ) → ⟦ substitutionFormula subs f ⟧ᶠ ≡ semanticSubstitution subs ⟦ f ⟧ᶠ
+  substitutionFormulaSound {Γ} {Δ} subs ⊤ᵗ =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (pre1 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial)
+      (semanticSubstitution subs (pre1 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial))
+      (λ γ a a⊩1γ → tt*)
+      λ γ a a⊩1subsγ → tt*
+  substitutionFormulaSound {Γ} {Δ} subs ⊥ᵗ =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (pre0 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial)
+      (semanticSubstitution subs (pre0 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial))
+      (λ _ _ bot → ⊥rec* bot)
+      λ _ _ bot → bot
+  substitutionFormulaSound {Γ} {Δ} subs (f `∨ f₁) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (_⊔_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ)
+      (semanticSubstitution subs (_⊔_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ))
+      (λ γ a a⊩substFormFs →
+        a⊩substFormFs >>=
+          λ { (inl (pr₁a≡k , pr₂a⊩substFormF)) →
+                   ∣ inl (pr₁a≡k , subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f) pr₂a⊩substFormF) ∣₁
+            ; (inr (pr₁a≡k' , pr₂a⊩substFormF₁)) →
+                   ∣ inr (pr₁a≡k' , subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f₁) pr₂a⊩substFormF₁) ∣₁ })
+      λ γ a a⊩semanticSubsFs →
+        a⊩semanticSubsFs >>=
+          λ { (inl (pr₁a≡k , pr₂a⊩semanticSubsF)) →
+                   ∣ inl (pr₁a≡k , (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f)) pr₂a⊩semanticSubsF)) ∣₁
+            ; (inr (pr₁a≡k' , pr₂a⊩semanticSubsF₁)) →
+                   ∣ inr (pr₁a≡k' , (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f₁)) pr₂a⊩semanticSubsF₁)) ∣₁ }
+  substitutionFormulaSound {Γ} {Δ} subs (f `∧ f₁) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (_⊓_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ)
+      (semanticSubstitution subs (_⊓_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ))
+      (λ γ a a⊩substFormulaFs →
+        (subst (λ form → (pr₁ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f) (a⊩substFormulaFs .fst)) ,
+        (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f₁) (a⊩substFormulaFs .snd)))
+      λ γ a a⊩semanticSubstFs →
+        (subst (λ form → (pr₁ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f)) (a⊩semanticSubstFs .fst)) ,
+        (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f₁)) (a⊩semanticSubstFs .snd))
+  substitutionFormulaSound {Γ} {Δ} subs (f `→ f₁) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (_⇒_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ)
+      (semanticSubstitution subs (_⇒_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ))
+      (λ γ a a⊩substFormulaFs →
+        λ b b⊩semanticSubstFs →
+          subst
+            (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ)
+            (substitutionFormulaSound subs f₁)
+            (a⊩substFormulaFs
+              b
+              (subst
+                (λ form → b ⊩ ∣ form ∣ γ)
+                (sym (substitutionFormulaSound subs f))
+                b⊩semanticSubstFs)))
+      λ γ a a⊩semanticSubstFs →
+        λ b b⊩substFormulaFs →
+          subst
+            (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ)
+            (sym (substitutionFormulaSound subs f₁))
+            (a⊩semanticSubstFs
+              b
+              (subst
+                (λ form → b ⊩ ∣ form ∣ γ)
+                (substitutionFormulaSound subs f)
+                b⊩substFormulaFs))
+  substitutionFormulaSound {Γ} {Δ} subs (`∃ {B = B} f) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (`∃[ isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Γ ⟧ᶜ) (λ { (f , s) → f }) ⟦ substitutionFormula (var here , drop subs) f ⟧ᶠ)
+      (semanticSubstitution subs (`∃[ isSet× (str ⟦ Δ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Δ ⟧ᶜ) (λ { (γ , b) → γ }) ⟦ f ⟧ᶠ))
+      (λ γ a a⊩πSubstFormulaF →
+        a⊩πSubstFormulaF >>=
+          λ { ((γ' , b) , γ'≡γ , a⊩substFormFγ') →
+            ∣ ((⟦ subs ⟧ᴮ γ') , b) ,
+              ((cong ⟦ subs ⟧ᴮ γ'≡γ) ,
+                (subst
+                  (λ form → a ⊩ ∣ form ∣ (γ' , b))
+                  (substitutionFormulaSound (var here , drop subs) f)
+                  a⊩substFormFγ' )) ∣₁ })
+      λ γ a a⊩semanticSubstF →
+        a⊩semanticSubstF >>=
+          λ (x@(δ , b) , δ≡subsγ , a⊩fx) →
+            ∣ (γ , b) ,
+              (refl ,
+                (subst
+                  (λ form → a ⊩ ∣ form ∣ (γ , b))
+                  (sym (substitutionFormulaSound (var here , drop subs) f))
+                  (subst (λ x → a ⊩ ∣ ⟦ f ⟧ᶠ ∣ (x , b)) δ≡subsγ a⊩fx))) ∣₁
+  substitutionFormulaSound {Γ} {Δ} subs (`∀ {B = B} f) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (`∀[ isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Γ ⟧ᶜ) (λ { (f , s) → f }) ⟦ substitutionFormula (var here , drop subs) f ⟧ᶠ)
+      (semanticSubstitution subs (`∀[ isSet× (str ⟦ Δ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Δ ⟧ᶜ) (λ { (f , s) → f }) ⟦ f ⟧ᶠ))
+      (λ γ a a⊩substFormF →
+        λ { r x@(δ , b) δ≡subsγ →
+          subst
+            (λ g → (a ⨾ r) ⊩ ∣ ⟦ f ⟧ᶠ ∣ (g , b))
+            (sym δ≡subsγ)
+            (subst
+              (λ form → (a ⨾ r) ⊩ ∣ form ∣ (γ , b))
+              (substitutionFormulaSound (var here , drop subs) f)
+              (a⊩substFormF r (γ , b) refl)) })
+      λ γ a a⊩semanticSubsF →
+        λ { r x@(γ' , b) γ'≡γ →
+          subst
+            (λ form → (a ⨾ r) ⊩ ∣ form ∣ (γ' , b))
+            (sym (substitutionFormulaSound (var here , drop subs) f))
+            (subst
+              (λ g → (a ⨾ r) ⊩ ∣ ⟦ f ⟧ᶠ ∣ (g , b))
+              (cong ⟦ subs ⟧ᴮ (sym γ'≡γ))
+              (a⊩semanticSubsF r (⟦ subs ⟧ᴮ γ , b) refl)) }
+  substitutionFormulaSound {Γ} {Δ} subs (rel R t) =
+    Predicate≡
+      ⟨ ⟦ Γ ⟧ᶜ ⟩
+      (⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ substitutionTerm subs t ⟧ᵗ ⟦ R ⟧ʳ)
+      (semanticSubstitution subs (⋆_ (str ⟦ Δ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ))
+      (λ γ a a⊩substTR →
+        subst (λ transform → a ⊩ ∣ ⟦ R ⟧ʳ ∣ (transform γ)) (substitutionTermSound subs t) a⊩substTR)
+      λ γ a a⊩semSubst →
+        subst (λ transform → a ⊩ ∣ ⟦ R ⟧ʳ ∣ (transform γ)) (sym (substitutionTermSound subs t)) a⊩semSubst
+
+  weakenFormulaMonotonic : ∀ {Γ B} → (γ : ⟨ ⟦ Γ ⟧ᶜ ⟩) → (ϕ : Formula Γ) → (a : A) → (b : ⟨ ⟦ B ⟧ˢ ⟩) → a ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ ≡ a ⊩ ∣ ⟦ weakenFormula {S = B} ϕ ⟧ᶠ ∣ (γ , b)
+  weakenFormulaMonotonic {Γ} {B} γ ϕ a b =
+    hPropExt
+      (⟦ ϕ ⟧ᶠ .isPropValued γ a)
+      (⟦ weakenFormula ϕ ⟧ᶠ .isPropValued (γ , b) a)
+      (λ a⊩ϕγ → subst (λ form → a ⊩ ∣ form ∣ (γ , b)) (sym (substitutionFormulaSound (drop id) ϕ)) a⊩ϕγ)
+      λ a⊩weakenϕγb → subst (λ form → a ⊩ ∣ form ∣ (γ , b)) (substitutionFormulaSound (drop id) ϕ) a⊩weakenϕγb
+module Soundness
+  {n}
+  {relSym : Vec Sort n}
+  (isNonTrivial : s ≡ k → ⊥)
+  (⟦_⟧ʳ : RelationInterpretation relSym) where
+  open Relational relSym
+  open Interpretation relSym ⟦_⟧ʳ isNonTrivial
+  -- Acknowledgements : 1lab's "the internal logic of a regular hyperdoctrine"
+  infix 35 _⊨_
+  
+  module PredProps = PredicateProperties
+  
+  _⊨_ : ∀ {Γ} → Formula Γ → Formula Γ → Type (ℓ-max (ℓ-max ℓ ℓ'') ℓ')
+  _⊨_ {Γ} ϕ ψ = ⟦ ϕ ⟧ᶠ ≤ ⟦ ψ ⟧ᶠ where open PredProps ⟨ ⟦ Γ ⟧ᶜ ⟩
+
+  entails = _⊨_
+
+  holdsInTripos : ∀ {Γ} → Formula Γ → Type (ℓ-max (ℓ-max ℓ ℓ'') ℓ')
+  holdsInTripos {Γ} form = ⊤ᵗ ⊨ form
+
+  private
+    variable
+      Γ Δ : Context
+      ϕ ψ θ : Formula Γ
+      χ μ ν : Formula Δ
+
+  cut : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ψ ⊨ θ → ϕ ⊨ θ
+  cut {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ ψ⊨θ = isTrans≤ ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ⊨ψ ψ⊨θ where open PredProps ⟨ ⟦ Γ ⟧ᶜ ⟩
+
+  substitutionEntailment : ∀ {Γ Δ} (subs : Substitution Γ Δ) → {ϕ ψ : Formula Δ} → ϕ ⊨ ψ → substitutionFormula subs ϕ ⊨ substitutionFormula subs ψ
+  substitutionEntailment {Γ} {Δ} subs {ϕ} {ψ} ϕ⊨ψ =
+    subst2
+      (λ ϕ' ψ' → ϕ' ≤Γ ψ')
+      (sym (substitutionFormulaSound subs ϕ))
+      (sym (substitutionFormulaSound subs ψ))
+      (ϕ⊨ψ >>=
+        λ { (a , a⊩ϕ≤ψ) →
+          ∣ a , (λ γ b b⊩ϕsubsγ → a⊩ϕ≤ψ (⟦ subs ⟧ᴮ γ) b b⊩ϕsubsγ) ∣₁ }) where
+      open PredProps {ℓ'' = ℓ''} ⟨ ⟦ Γ ⟧ᶜ ⟩ renaming (_≤_ to _≤Γ_)
+      open PredProps {ℓ'' = ℓ''} ⟨ ⟦ Δ ⟧ᶜ ⟩ renaming (_≤_ to _≤Δ_)
+
+  `∧intro : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → entails ϕ θ → entails ϕ (ψ `∧ θ)
+  `∧intro {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ ϕ⊨θ =
+    do
+      (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ
+      (b , b⊩ϕ⊨θ) ← ϕ⊨θ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pair ̇ (` a ̇ # fzero) ̇ (` b ̇ # fzero)
+      return
+        (λ* prover ,
+          λ γ r r⊩ϕγ →
+            let
+              proofEq : λ* prover ⨾ r ≡ pair ⨾ (a ⨾ r) ⨾ (b ⨾ r)
+              proofEq = λ*ComputationRule prover (r ∷ [])
+
+              pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ r) ≡ a ⨾ r
+              pr₁proofEq =
+                pr₁ ⨾ (λ* prover ⨾ r)
+                  ≡⟨ cong (λ x → pr₁ ⨾ x) proofEq ⟩
+                pr₁ ⨾ (pair ⨾ (a ⨾ r) ⨾ (b ⨾ r))
+                  ≡⟨ pr₁pxy≡x _ _ ⟩
+                a ⨾ r
+                  ∎
+
+              pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ r) ≡ b ⨾ r
+              pr₂proofEq =
+                pr₂ ⨾ (λ* prover ⨾ r)
+                  ≡⟨ cong (λ x → pr₂ ⨾ x) proofEq ⟩
+                pr₂ ⨾ (pair ⨾ (a ⨾ r) ⨾ (b ⨾ r))
+                  ≡⟨ pr₂pxy≡y _ _ ⟩
+                b ⨾ r
+                  ∎
+            in
+            subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₁proofEq) (a⊩ϕ⊨ψ γ r r⊩ϕγ) ,
+            subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (b⊩ϕ⊨θ γ r r⊩ϕγ))
+
+  `∧elim1 : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `∧ θ) → ϕ ⊨ ψ
+  `∧elim1 {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ∧θ =
+    do
+      (a , a⊩ϕ⊨ψ∧θ) ← ϕ⊨ψ∧θ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pr₁ ̇ (` a ̇ # fzero)
+      return
+        (λ* prover ,
+          λ γ b b⊩ϕγ → subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym (λ*ComputationRule prover (b ∷ []))) (a⊩ϕ⊨ψ∧θ γ b b⊩ϕγ .fst))
+          
+  `∧elim2 : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `∧ θ) → ϕ ⊨ θ
+  `∧elim2 {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ∧θ =
+    do
+      (a , a⊩ϕ⊨ψ∧θ) ← ϕ⊨ψ∧θ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pr₂ ̇ (` a ̇ # fzero)
+      return
+        (λ* prover ,
+          λ γ b b⊩ϕγ → subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym (λ*ComputationRule prover (b ∷ []))) (a⊩ϕ⊨ψ∧θ γ b b⊩ϕγ .snd))
+
+  `∃intro : ∀ {Γ} {ϕ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} {t : Term Γ B} → ϕ ⊨ substitutionFormula (t , id) ψ → ϕ ⊨ `∃ ψ
+  `∃intro {Γ} {ϕ} {B} {ψ} {t} ϕ⊨ψ[t/x] =
+    do
+      (a , a⊩ϕ⊨ψ[t/x]) ← ϕ⊨ψ[t/x]
+      return
+        (a , (λ γ b b⊩ϕγ → ∣ (γ , (⟦ t ⟧ᵗ γ)) ,
+        (refl , (subst (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ) (substitutionFormulaSound (t , id) ψ) (a⊩ϕ⊨ψ[t/x] γ b b⊩ϕγ))) ∣₁))
+
+  `∃elim : ∀ {Γ} {ϕ θ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} → ϕ ⊨ `∃ ψ → (weakenFormula ϕ `∧ ψ) ⊨ weakenFormula θ → ϕ ⊨ θ
+  `∃elim {Γ} {ϕ} {θ} {B} {ψ} ϕ⊨∃ψ ϕ∧ψ⊨θ =
+    do
+      (a , a⊩ϕ⊨∃ψ) ← ϕ⊨∃ψ
+      (b , b⊩ϕ∧ψ⊨θ) ← ϕ∧ψ⊨θ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` b ̇ (` pair ̇ # fzero ̇ (` a ̇ # fzero))
+      return
+        (λ* prover ,
+        (λ γ c c⊩ϕγ →
+          subst
+            (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ)
+            (sym (λ*ComputationRule prover (c ∷ [])))
+            (transport
+              (propTruncIdempotent (⟦ θ ⟧ᶠ .isPropValued γ (b ⨾ (pair ⨾ c ⨾ (a ⨾ c)))))
+              (a⊩ϕ⊨∃ψ γ c c⊩ϕγ >>=
+                λ { (x@(γ' , b') , (γ'≡γ , a⨾c⊩ψx)) →
+                  ∣ transport
+                    (sym
+                      (weakenFormulaMonotonic γ θ (b ⨾ (pair ⨾ c ⨾ (a ⨾ c))) b'))
+                    (b⊩ϕ∧ψ⊨θ
+                      (γ , b')
+                      (pair ⨾ c ⨾ (a ⨾ c))
+                      (subst
+                        (λ r → r ⊩ ∣ ⟦ weakenFormula ϕ ⟧ᶠ ∣ (γ , b'))
+                        (sym (pr₁pxy≡x _ _))
+                        (transport
+                          (weakenFormulaMonotonic γ ϕ c b') c⊩ϕγ) ,
+                      subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ , b')) (sym (pr₂pxy≡y _ _)) (subst (λ g → (a ⨾ c) ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (g , b')) γ'≡γ a⨾c⊩ψx)) ) ∣₁ }))))
+
+  `∀intro : ∀ {Γ} {ϕ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} → weakenFormula ϕ ⊨ ψ → ϕ ⊨ `∀ ψ
+  `∀intro {Γ} {ϕ} {B} {ψ} ϕ⊨ψ =
+    do
+      (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ
+      let
+        prover : ApplStrTerm as 2
+        prover = ` a ̇ # fzero
+      return
+        (λ* prover ,
+        (λ γ b b⊩ϕ → λ { c x@(γ' , b') γ'≡γ →
+          subst
+            (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ' , b'))
+            (sym (λ*ComputationRule prover (b ∷ c ∷ [])))
+            (a⊩ϕ⊨ψ
+              (γ' , b')
+              b
+              (transport (weakenFormulaMonotonic γ' ϕ b b') (subst (λ g → b ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ g) (sym γ'≡γ) b⊩ϕ))) }))
+
+  `∀elim : ∀ {Γ} {B} {ϕ : Formula Γ} {ψ : Formula (Γ ′ B)} → ϕ ⊨ `∀ ψ → (t : Term Γ B) → ϕ ⊨ substitutionFormula (t , id) ψ
+  `∀elim {Γ} {B} {ϕ} {ψ} ϕ⊨∀ψ t =
+    do
+      (a , a⊩ϕ⊨∀ψ) ← ϕ⊨∀ψ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` a ̇ # fzero ̇ ` k
+      return
+        (λ* prover ,
+        (λ γ b b⊩ϕγ →
+          subst
+          (λ form → (λ* prover ⨾ b) ⊩ ∣ form ∣ γ)
+          (sym (substitutionFormulaSound (t , id) ψ))
+          (subst
+            (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ , ⟦ t ⟧ᵗ γ))
+            (sym (λ*ComputationRule prover (b ∷ [])))
+            (a⊩ϕ⊨∀ψ γ b b⊩ϕγ k (γ , ⟦ t ⟧ᵗ γ) refl))))
+
+  `→intro : ∀ {Γ} {ϕ ψ θ : Formula Γ} → (ϕ `∧ ψ) ⊨ θ → ϕ ⊨ (ψ `→ θ)
+  `→intro {Γ} {ϕ} {ψ} {θ} ϕ∧ψ⊨θ = a⊓b≤c→a≤b⇒c ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ∧ψ⊨θ
+
+  `→elim : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `→ θ) → ϕ ⊨ ψ → ϕ ⊨ θ
+  `→elim {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ→θ ϕ⊨ψ =
+    do
+      (a , a⊩ϕ⊨ψ→θ) ← ϕ⊨ψ→θ
+      (b , b⊩ϕ⊨ψ) ← ϕ⊨ψ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` a ̇ (# fzero) ̇ (` b ̇ # fzero)
+      return
+        (λ* prover ,
+        (λ γ c c⊩ϕγ →
+          subst
+            (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ)
+            (sym (λ*ComputationRule prover (c ∷ [])))
+            (a⊩ϕ⊨ψ→θ γ c c⊩ϕγ (b ⨾ c) (b⊩ϕ⊨ψ γ c c⊩ϕγ))))
+
+  `∨introR : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ϕ ⊨ (ψ `∨ θ)
+  `∨introR {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ =
+    do
+      (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pair ̇ ` true ̇ (` a ̇ # fzero)
+      return
+        ((λ* prover) ,
+        (λ γ b b⊩ϕγ →
+          let
+            pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ b) ≡ true
+            pr₁proofEq =
+              pr₁ ⨾ (λ* prover ⨾ b)
+                ≡⟨ cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩
+              pr₁ ⨾ (pair ⨾ true ⨾ (a ⨾ b))
+                ≡⟨ pr₁pxy≡x _ _ ⟩
+              true
+                ∎
+
+            pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ b) ≡ a ⨾ b
+            pr₂proofEq =
+              pr₂ ⨾ (λ* prover ⨾ b)
+                ≡⟨ cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩
+              pr₂ ⨾ (pair ⨾ true ⨾ (a ⨾ b))
+                ≡⟨ pr₂pxy≡y _ _ ⟩
+              a ⨾ b
+                ∎
+          in ∣ inl (pr₁proofEq , subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (a⊩ϕ⊨ψ γ b b⊩ϕγ)) ∣₁))
+
+  `∨introL : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ϕ ⊨ (θ `∨ ψ)
+  `∨introL {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ =
+    do
+      (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ
+      let
+        prover : ApplStrTerm as 1
+        prover = ` pair ̇ ` false ̇ (` a ̇ # fzero)
+      return
+        ((λ* prover) ,
+        (λ γ b b⊩ϕγ →
+          let
+            pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ b) ≡ false
+            pr₁proofEq =
+              pr₁ ⨾ (λ* prover ⨾ b)
+                ≡⟨ cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩
+              pr₁ ⨾ (pair ⨾ false ⨾ (a ⨾ b))
+                ≡⟨ pr₁pxy≡x _ _ ⟩
+              false
+                ∎
+
+            pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ b) ≡ a ⨾ b
+            pr₂proofEq =
+              pr₂ ⨾ (λ* prover ⨾ b)
+                ≡⟨ cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩
+              pr₂ ⨾ (pair ⨾ false ⨾ (a ⨾ b))
+                ≡⟨ pr₂pxy≡y _ _ ⟩
+              a ⨾ b
+                ∎
+          in ∣ inr (pr₁proofEq , subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (a⊩ϕ⊨ψ γ b b⊩ϕγ)) ∣₁))
+
+  -- Pretty sure this is code duplication
+  `if_then_else_ : ∀ {as n} → ApplStrTerm as n → ApplStrTerm as n → ApplStrTerm as n → ApplStrTerm as n
+  `if a then b else c = ` Id ̇ a ̇ b ̇ c
+
+  `∨elim : ∀ {Γ} {ϕ ψ θ χ : Formula Γ} → (ϕ `∧ ψ) ⊨ χ → (ϕ `∧ θ) ⊨ χ → (ϕ `∧ (ψ `∨ θ)) ⊨ χ
+  `∨elim {Γ} {ϕ} {ψ} {θ} {χ} ϕ∧ψ⊨χ ϕ∧θ⊨χ =
+    do
+      (a , a⊩ϕ∧ψ⊨χ) ← ϕ∧ψ⊨χ
+      (b , b⊩ϕ∧θ⊨χ) ← ϕ∧θ⊨χ
+      let
+        prover : ApplStrTerm as 1
+        prover =
+          (`if ` pr₁ ̇ (` pr₂ ̇ # fzero) then ` a else (` b)) ̇ (` pair ̇ (` pr₁ ̇ # fzero) ̇ (` pr₂ ̇ (` pr₂ ̇ # fzero)))
+      return
+        (λ* prover ,
+        (λ
+          { γ c (pr₁⨾c⊩ϕγ , pr₂⨾c⊩ψ∨θ) →
+            transport
+            (propTruncIdempotent (⟦ χ ⟧ᶠ .isPropValued γ (λ* prover ⨾ c)))
+            (pr₂⨾c⊩ψ∨θ >>=
+              λ { (inl (pr₁⨾pr₂⨾c≡true , pr₂⨾pr₂⨾c⊩ψ)) →
+                  let
+                    proofEq : λ* prover ⨾ c ≡ a ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                    proofEq =
+                      λ* prover ⨾ c
+                        ≡⟨ λ*ComputationRule prover (c ∷ []) ⟩
+                      (if (pr₁ ⨾ (pr₂ ⨾ c)) then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ≡⟨ cong (λ x → (if x then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) pr₁⨾pr₂⨾c≡true ⟩
+                      (if true then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ≡⟨ cong (λ x → x ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) (ifTrueThen a b) ⟩
+                      a ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ∎
+                  in
+                  ∣ subst
+                    (λ r → r ⊩ ∣ ⟦ χ ⟧ᶠ ∣ γ)
+                    (sym proofEq)
+                    (a⊩ϕ∧ψ⊨χ
+                      γ
+                      (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                      ((
+                      subst
+                        (λ r → r ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ)
+                        (sym (pr₁pxy≡x _ _))
+                        pr₁⨾c⊩ϕγ) ,
+                      subst
+                        (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ)
+                        (sym (pr₂pxy≡y _ _))
+                        pr₂⨾pr₂⨾c⊩ψ)) ∣₁
+                ; (inr (pr₁pr₂⨾c≡false , pr₂⨾pr₂⨾c⊩θ)) →
+                  let
+                    proofEq : λ* prover ⨾ c ≡ b ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                    proofEq =
+                      λ* prover ⨾ c
+                        ≡⟨ λ*ComputationRule prover (c ∷ []) ⟩
+                      (if (pr₁ ⨾ (pr₂ ⨾ c)) then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ≡⟨ cong (λ x → (if x then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) pr₁pr₂⨾c≡false ⟩
+                      (if false then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ≡⟨ cong (λ x → x ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) (ifFalseElse a b) ⟩
+                      b ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                        ∎
+                  in
+                  ∣ subst
+                    (λ r → r ⊩ ∣ ⟦ χ ⟧ᶠ ∣ γ)
+                    (sym proofEq)
+                    (b⊩ϕ∧θ⊨χ
+                      γ
+                      (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))
+                      ((subst (λ r → r ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ) (sym (pr₁pxy≡x _ _)) pr₁⨾c⊩ϕγ) ,
+                       (subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym (pr₂pxy≡y _ _)) pr₂⨾pr₂⨾c⊩θ))) ∣₁ }) }))
+
+
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Logic.Syntax.html b/docs/Realizability.Tripos.Logic.Syntax.html index 09411b6..218efb7 100644 --- a/docs/Realizability.Tripos.Logic.Syntax.html +++ b/docs/Realizability.Tripos.Logic.Syntax.html @@ -18,85 +18,99 @@ ⟦ ↑ a ⟧ˢ = a ⟦ a `× b ⟧ˢ = ⟦ a ⟧ˢ .fst × ⟦ b ⟧ˢ .fst , isSet× (⟦ a ⟧ˢ .snd) (⟦ b ⟧ˢ .snd) -data Context : Type (ℓ-suc ℓ) where - [] : Context - _′_ : Context → Sort → Context - -data _∈_ : Sort → Context → Type (ℓ-suc ℓ) where - here : ∀ {Γ A} → A ∈ (Γ ′ A) - there : ∀ {Γ A B} → A ∈ Γ → A ∈ (Γ ′ B) - -data Term : Context → Sort → Type (ℓ-suc ℓ) where - var : ∀ {Γ A} → A ∈ Γ → Term Γ A - _`,_ : ∀ {Γ A B} → Term Γ A → Term Γ B → Term Γ (A `× B) - π₁ : ∀ {Γ A B} → Term Γ (A `× B) → Term Γ A - π₂ : ∀ {Γ A B} → Term Γ (A `× B) → Term Γ B - fun : ∀ {Γ A B} → (⟦ A ⟧ˢ .fst → ⟦ B ⟧ˢ .fst) → Term Γ A → Term Γ B - -data Renaming : Context → Context → Type (ℓ-suc ℓ) where - id : ∀ {Γ} → Renaming Γ Γ - drop : ∀ {Γ Δ s} → Renaming Γ Δ → Renaming (Γ ′ s) Δ - keep : ∀ {Γ Δ s} → Renaming Γ Δ → Renaming (Γ ′ s) (Δ ′ s) - -data Substitution : Context → Context → Type (ℓ-suc ℓ) where - id : ∀ {Γ} → Substitution Γ Γ - _,_ : ∀ {Γ Δ s} → (t : Term Γ s) → Substitution Γ Δ → Substitution Γ (Δ ′ s) - drop : ∀ {Γ Δ s} → Substitution Γ Δ → Substitution (Γ ′ s) Δ - -terminatingSubstitution : ∀ {Γ} → Substitution Γ [] -terminatingSubstitution {[]} = id -terminatingSubstitution {Γ ′ x} = drop terminatingSubstitution - -renamingCompose : ∀ {Γ Δ Θ} → Renaming Γ Δ → Renaming Δ Θ → Renaming Γ Θ -renamingCompose {Γ} {.Γ} {Θ} id Δ→Θ = Δ→Θ -renamingCompose {.(_ ′ _)} {Δ} {Θ} (drop Γ→Δ) Δ→Θ = drop (renamingCompose Γ→Δ Δ→Θ) -renamingCompose {.(_ ′ _)} {.(_ ′ _)} {.(_ ′ _)} (keep Γ→Δ) id = keep Γ→Δ -renamingCompose {.(_ ′ _)} {.(_ ′ _)} {Θ} (keep Γ→Δ) (drop Δ→Θ) = drop (renamingCompose Γ→Δ Δ→Θ) -renamingCompose {.(_ ′ _)} {.(_ ′ _)} {.(_ ′ _)} (keep Γ→Δ) (keep Δ→Θ) = keep (renamingCompose Γ→Δ Δ→Θ) - -renamingVar : ∀ {Γ Δ s} → Renaming Γ Δ → s ∈ Δ → s ∈ Γ -renamingVar {Γ} {.Γ} {s} id s∈Δ = s∈Δ -renamingVar {.(_ ′ _)} {Δ} {s} (drop ren) s∈Δ = there (renamingVar ren s∈Δ) -renamingVar {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = here -renamingVar {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there s∈Δ) = there (renamingVar ren s∈Δ) - -renamingTerm : ∀ {Γ Δ s} → Renaming Γ Δ → Term Δ s → Term Γ s -renamingTerm {Γ} {.Γ} {s} id term = term -renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (var x) = var (renamingVar (drop ren) x) -renamingTerm {.(_ ′ _)} {Δ} {.(_ `× _)} (drop ren) (term `, term₁) = renamingTerm (drop ren) term `, renamingTerm (drop ren) term₁ -renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (π₁ term) = π₁ (renamingTerm (drop ren) term) -renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (π₂ term) = π₂ (renamingTerm (drop ren) term) -renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (fun f term) = fun f (renamingTerm (drop ren) term) -renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (var x) = var (renamingVar (keep ren) x) -renamingTerm {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} (keep ren) (term `, term₁) = renamingTerm (keep ren) term `, renamingTerm (keep ren) term₁ -renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (π₁ term) = π₁ (renamingTerm (keep ren) term) -renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (π₂ term) = π₂ (renamingTerm (keep ren) term) -renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (fun f term) = fun f (renamingTerm (keep ren) term) - -substitutionVar : ∀ {Γ Δ s} → Substitution Γ Δ → s ∈ Δ → Term Γ s -substitutionVar {Γ} {.Γ} {s} id s∈Δ = var s∈Δ -substitutionVar {Γ} {.(_ ′ s)} {s} (t , subs) here = t -substitutionVar {Γ} {.(_ ′ _)} {s} (t , subs) (there s∈Δ) = substitutionVar subs s∈Δ -substitutionVar {.(_ ′ _)} {Δ} {s} (drop subs) s∈Δ = renamingTerm (drop id) (substitutionVar subs s∈Δ) - -substitutionTerm : ∀ {Γ Δ s} → Substitution Γ Δ → Term Δ s → Term Γ s -substitutionTerm {Γ} {Δ} {s} subs (var x) = substitutionVar subs x -substitutionTerm {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = substitutionTerm subs t `, substitutionTerm subs t₁ -substitutionTerm {Γ} {Δ} {s} subs (π₁ t) = π₁ (substitutionTerm subs t) -substitutionTerm {Γ} {Δ} {s} subs (π₂ t) = π₂ (substitutionTerm subs t) -substitutionTerm {Γ} {Δ} {s} subs (fun x t) = fun x (substitutionTerm subs t) - -module Relational {n} (relSym : Vec Sort n) where - - data Formula : Context → Type (ℓ-suc ℓ) where - ⊤ᵗ : ∀ {Γ} → Formula Γ - ⊥ᵗ : ∀ {Γ} → Formula Γ - _`∨_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ - _`∧_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ - _`→_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ - `¬_ : ∀ {Γ} → Formula Γ → Formula Γ - `∃ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ - `∀ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ - rel : ∀ {Γ} (k : Fin n) → Term Γ (lookup k relSym) → Formula Γ - +infixl 30 _′_ +data Context : Type (ℓ-suc ℓ) where + [] : Context + _′_ : Context → Sort → Context + +data _∈_ : Sort → Context → Type (ℓ-suc ℓ) where + here : ∀ {Γ A} → A ∈ (Γ ′ A) + there : ∀ {Γ A B} → A ∈ Γ → A ∈ (Γ ′ B) + +data Term : Context → Sort → Type (ℓ-suc ℓ) where + var : ∀ {Γ A} → A ∈ Γ → Term Γ A + _`,_ : ∀ {Γ A B} → Term Γ A → Term Γ B → Term Γ (A `× B) + π₁ : ∀ {Γ A B} → Term Γ (A `× B) → Term Γ A + π₂ : ∀ {Γ A B} → Term Γ (A `× B) → Term Γ B + fun : ∀ {Γ A B} → (⟦ A ⟧ˢ .fst → ⟦ B ⟧ˢ .fst) → Term Γ A → Term Γ B + +data Renaming : Context → Context → Type (ℓ-suc ℓ) where + id : ∀ {Γ} → Renaming Γ Γ + drop : ∀ {Γ Δ s} → Renaming Γ Δ → Renaming (Γ ′ s) Δ + keep : ∀ {Γ Δ s} → Renaming Γ Δ → Renaming (Γ ′ s) (Δ ′ s) + +data Substitution : Context → Context → Type (ℓ-suc ℓ) where + id : ∀ {Γ} → Substitution Γ Γ + _,_ : ∀ {Γ Δ s} → (t : Term Γ s) → Substitution Γ Δ → Substitution Γ (Δ ′ s) + drop : ∀ {Γ Δ s} → Substitution Γ Δ → Substitution (Γ ′ s) Δ + +terminatingSubstitution : ∀ {Γ} → Substitution Γ [] +terminatingSubstitution {[]} = id +terminatingSubstitution {Γ ′ x} = drop terminatingSubstitution + +renamingCompose : ∀ {Γ Δ Θ} → Renaming Γ Δ → Renaming Δ Θ → Renaming Γ Θ +renamingCompose {Γ} {.Γ} {Θ} id Δ→Θ = Δ→Θ +renamingCompose {.(_ ′ _)} {Δ} {Θ} (drop Γ→Δ) Δ→Θ = drop (renamingCompose Γ→Δ Δ→Θ) +renamingCompose {.(_ ′ _)} {.(_ ′ _)} {.(_ ′ _)} (keep Γ→Δ) id = keep Γ→Δ +renamingCompose {.(_ ′ _)} {.(_ ′ _)} {Θ} (keep Γ→Δ) (drop Δ→Θ) = drop (renamingCompose Γ→Δ Δ→Θ) +renamingCompose {.(_ ′ _)} {.(_ ′ _)} {.(_ ′ _)} (keep Γ→Δ) (keep Δ→Θ) = keep (renamingCompose Γ→Δ Δ→Θ) + +renamingVar : ∀ {Γ Δ s} → Renaming Γ Δ → s ∈ Δ → s ∈ Γ +renamingVar {Γ} {.Γ} {s} id s∈Δ = s∈Δ +renamingVar {.(_ ′ _)} {Δ} {s} (drop ren) s∈Δ = there (renamingVar ren s∈Δ) +renamingVar {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = here +renamingVar {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there s∈Δ) = there (renamingVar ren s∈Δ) + +renamingTerm : ∀ {Γ Δ s} → Renaming Γ Δ → Term Δ s → Term Γ s +renamingTerm {Γ} {.Γ} {s} id term = term +renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (var x) = var (renamingVar (drop ren) x) +renamingTerm {.(_ ′ _)} {Δ} {.(_ `× _)} (drop ren) (term `, term₁) = renamingTerm (drop ren) term `, renamingTerm (drop ren) term₁ +renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (π₁ term) = π₁ (renamingTerm (drop ren) term) +renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (π₂ term) = π₂ (renamingTerm (drop ren) term) +renamingTerm {.(_ ′ _)} {Δ} {s} (drop ren) (fun f term) = fun f (renamingTerm (drop ren) term) +renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (var x) = var (renamingVar (keep ren) x) +renamingTerm {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} (keep ren) (term `, term₁) = renamingTerm (keep ren) term `, renamingTerm (keep ren) term₁ +renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (π₁ term) = π₁ (renamingTerm (keep ren) term) +renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (π₂ term) = π₂ (renamingTerm (keep ren) term) +renamingTerm {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (fun f term) = fun f (renamingTerm (keep ren) term) + +substitutionVar : ∀ {Γ Δ s} → Substitution Γ Δ → s ∈ Δ → Term Γ s +substitutionVar {Γ} {.Γ} {s} id s∈Δ = var s∈Δ +substitutionVar {Γ} {.(_ ′ s)} {s} (t , subs) here = t +substitutionVar {Γ} {.(_ ′ _)} {s} (t , subs) (there s∈Δ) = substitutionVar subs s∈Δ +substitutionVar {.(_ ′ _)} {Δ} {s} (drop subs) s∈Δ = renamingTerm (drop id) (substitutionVar subs s∈Δ) + +substitutionTerm : ∀ {Γ Δ s} → Substitution Γ Δ → Term Δ s → Term Γ s +substitutionTerm {Γ} {Δ} {s} subs (var x) = substitutionVar subs x +substitutionTerm {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = substitutionTerm subs t `, substitutionTerm subs t₁ +substitutionTerm {Γ} {Δ} {s} subs (π₁ t) = π₁ (substitutionTerm subs t) +substitutionTerm {Γ} {Δ} {s} subs (π₂ t) = π₂ (substitutionTerm subs t) +substitutionTerm {Γ} {Δ} {s} subs (fun x t) = fun x (substitutionTerm subs t) + +module Relational {n} (relSym : Vec Sort n) where + + data Formula : Context → Type (ℓ-suc ℓ) where + ⊤ᵗ : ∀ {Γ} → Formula Γ + ⊥ᵗ : ∀ {Γ} → Formula Γ + _`∨_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ + _`∧_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ + _`→_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ + `∃ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ + `∀ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ + rel : ∀ {Γ} (k : Fin n) → Term Γ (lookup k relSym) → Formula Γ + + pattern `¬ f = f `→ ⊥ᵗ + + substitutionFormula : ∀ {Γ Δ} → Substitution Γ Δ → Formula Δ → Formula Γ + substitutionFormula {Γ} {Δ} subs ⊤ᵗ = ⊤ᵗ + substitutionFormula {Γ} {Δ} subs ⊥ᵗ = ⊥ᵗ + substitutionFormula {Γ} {Δ} subs (form `∨ form₁) = substitutionFormula subs form `∨ substitutionFormula subs form₁ + substitutionFormula {Γ} {Δ} subs (form `∧ form₁) = substitutionFormula subs form `∧ substitutionFormula subs form₁ + substitutionFormula {Γ} {Δ} subs (form `→ form₁) = substitutionFormula subs form `→ substitutionFormula subs form₁ + substitutionFormula {Γ} {Δ} subs (`∃ form) = `∃ (substitutionFormula (var here , drop subs) form ) + substitutionFormula {Γ} {Δ} subs (`∀ form) = `∀ (substitutionFormula (var here , drop subs) form) + substitutionFormula {Γ} {Δ} subs (rel k x) = rel k (substitutionTerm subs x) + + weakenFormula : ∀ {Γ} {S} → Formula Γ → Formula (Γ ′ S) + weakenFormula {Γ} {S} form = substitutionFormula (drop id) form \ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Implication.html b/docs/Realizability.Tripos.Prealgebra.Implication.html index 846cb4c..968a8e7 100644 --- a/docs/Realizability.Tripos.Prealgebra.Implication.html +++ b/docs/Realizability.Tripos.Prealgebra.Implication.html @@ -15,76 +15,77 @@ open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -λ*ComputationRule = `λ*ComputationRule as fefermanStructure -λ* = `λ* as fefermanStructure +private + λ*ComputationRule = `λ*ComputationRule as fefermanStructure + λ* = `λ* as fefermanStructure -module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where - PredicateX = Predicate {ℓ'' = ℓ''} X - open Predicate - open PredicateProperties {ℓ'' = ℓ''} X - -- ⇒ is Heyting implication - a⊓b≤c→a≤b⇒c : ∀ a b c → (a ⊓ b ≤ c) → a ≤ (b ⇒ c) - a⊓b≤c→a≤b⇒c a b c a⊓b≤c = - do - (a~ , a~proves) ← a⊓b≤c - let prover = (` a~ ̇ (` pair ̇ (# fzero) ̇ (# fone))) - return - (λ* prover , - λ x aₓ aₓ⊩ax bₓ bₓ⊩bx → - subst - (λ r → r ⊩ ∣ c ∣ x) - (sym (λ*ComputationRule prover (aₓ ∷ bₓ ∷ []))) - (a~proves - x - (pair ⨾ aₓ ⨾ bₓ) - ((subst (λ r → r ⊩ ∣ a ∣ x) (sym (pr₁pxy≡x _ _)) aₓ⊩ax) , - (subst (λ r → r ⊩ ∣ b ∣ x) (sym (pr₂pxy≡y _ _)) bₓ⊩bx)))) +module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where + PredicateX = Predicate {ℓ'' = ℓ''} X + open Predicate + open PredicateProperties {ℓ'' = ℓ''} X + -- ⇒ is Heyting implication + a⊓b≤c→a≤b⇒c : ∀ a b c → (a ⊓ b ≤ c) → a ≤ (b ⇒ c) + a⊓b≤c→a≤b⇒c a b c a⊓b≤c = + do + (a~ , a~proves) ← a⊓b≤c + let prover = (` a~ ̇ (` pair ̇ (# fzero) ̇ (# fone))) + return + (λ* prover , + λ x aₓ aₓ⊩ax bₓ bₓ⊩bx → + subst + (λ r → r ⊩ ∣ c ∣ x) + (sym (λ*ComputationRule prover (aₓ ∷ bₓ ∷ []))) + (a~proves + x + (pair ⨾ aₓ ⨾ bₓ) + ((subst (λ r → r ⊩ ∣ a ∣ x) (sym (pr₁pxy≡x _ _)) aₓ⊩ax) , + (subst (λ r → r ⊩ ∣ b ∣ x) (sym (pr₂pxy≡y _ _)) bₓ⊩bx)))) - a≤b⇒c→a⊓b≤c : ∀ a b c → a ≤ (b ⇒ c) → (a ⊓ b ≤ c) - a≤b⇒c→a⊓b≤c a b c a≤b⇒c = - do - (a~ , a~proves) ← a≤b⇒c - let prover = ` a~ ̇ (` pr₁ ̇ (# fzero)) ̇ (` pr₂ ̇ (# fzero)) - return - (λ* prover , - λ { x abₓ (pr₁abₓ⊩ax , pr₂abₓ⊩bx) → - subst - (λ r → r ⊩ ∣ c ∣ x) - (sym (λ*ComputationRule prover (abₓ ∷ []))) - (a~proves x (pr₁ ⨾ abₓ) pr₁abₓ⊩ax (pr₂ ⨾ abₓ) pr₂abₓ⊩bx) }) + a≤b⇒c→a⊓b≤c : ∀ a b c → a ≤ (b ⇒ c) → (a ⊓ b ≤ c) + a≤b⇒c→a⊓b≤c a b c a≤b⇒c = + do + (a~ , a~proves) ← a≤b⇒c + let prover = ` a~ ̇ (` pr₁ ̇ (# fzero)) ̇ (` pr₂ ̇ (# fzero)) + return + (λ* prover , + λ { x abₓ (pr₁abₓ⊩ax , pr₂abₓ⊩bx) → + subst + (λ r → r ⊩ ∣ c ∣ x) + (sym (λ*ComputationRule prover (abₓ ∷ []))) + (a~proves x (pr₁ ⨾ abₓ) pr₁abₓ⊩ax (pr₂ ⨾ abₓ) pr₂abₓ⊩bx) }) - ⇒isRightAdjointOf⊓ : ∀ a b c → (a ⊓ b ≤ c) ≡ (a ≤ b ⇒ c) - ⇒isRightAdjointOf⊓ a b c = hPropExt (isProp≤ (a ⊓ b) c) (isProp≤ a (b ⇒ c)) (a⊓b≤c→a≤b⇒c a b c) (a≤b⇒c→a⊓b≤c a b c) + ⇒isRightAdjointOf⊓ : ∀ a b c → (a ⊓ b ≤ c) ≡ (a ≤ b ⇒ c) + ⇒isRightAdjointOf⊓ a b c = hPropExt (isProp≤ (a ⊓ b) c) (isProp≤ a (b ⇒ c)) (a⊓b≤c→a≤b⇒c a b c) (a≤b⇒c→a⊓b≤c a b c) - antiSym→a⇒c≤b⇒c : ∀ a b c → a ≤ b → b ≤ a → (a ⇒ c) ≤ (b ⇒ c) - antiSym→a⇒c≤b⇒c a b c a≤b b≤a = - do - (α , αProves) ← a≤b - (β , βProves) ← b≤a - let - prover : Term as 2 - prover = (# fzero) ̇ (` β ̇ # fone) - return - (λ* prover , - (λ x r r⊩a⇒c r' r'⊩b → - subst - (λ witness → witness ⊩ ∣ c ∣ x) - (sym (λ*ComputationRule prover (r ∷ r' ∷ []))) - (r⊩a⇒c (β ⨾ r') (βProves x r' r'⊩b)))) + antiSym→a⇒c≤b⇒c : ∀ a b c → a ≤ b → b ≤ a → (a ⇒ c) ≤ (b ⇒ c) + antiSym→a⇒c≤b⇒c a b c a≤b b≤a = + do + (α , αProves) ← a≤b + (β , βProves) ← b≤a + let + prover : Term as 2 + prover = (# fzero) ̇ (` β ̇ # fone) + return + (λ* prover , + (λ x r r⊩a⇒c r' r'⊩b → + subst + (λ witness → witness ⊩ ∣ c ∣ x) + (sym (λ*ComputationRule prover (r ∷ r' ∷ []))) + (r⊩a⇒c (β ⨾ r') (βProves x r' r'⊩b)))) - antiSym→a⇒b≤a⇒c : ∀ a b c → b ≤ c → c ≤ b → (a ⇒ b) ≤ (a ⇒ c) - antiSym→a⇒b≤a⇒c a b c b≤c c≤b = - do - (β , βProves) ← b≤c - (γ , γProves) ← c≤b - let - prover : Term as 2 - prover = ` β ̇ ((# fzero) ̇ (# fone)) - return - (λ* prover , - (λ x α α⊩a⇒b a' a'⊩a → - subst - (λ r → r ⊩ ∣ c ∣ x) - (sym (λ*ComputationRule prover (α ∷ a' ∷ []))) - (βProves x (α ⨾ a') (α⊩a⇒b a' a'⊩a)))) + antiSym→a⇒b≤a⇒c : ∀ a b c → b ≤ c → c ≤ b → (a ⇒ b) ≤ (a ⇒ c) + antiSym→a⇒b≤a⇒c a b c b≤c c≤b = + do + (β , βProves) ← b≤c + (γ , γProves) ← c≤b + let + prover : Term as 2 + prover = ` β ̇ ((# fzero) ̇ (# fone)) + return + (λ* prover , + (λ x α α⊩a⇒b a' a'⊩a → + subst + (λ r → r ⊩ ∣ c ∣ x) + (sym (λ*ComputationRule prover (α ∷ a' ∷ []))) + (βProves x (α ⨾ a') (α⊩a⇒b a' a'⊩a)))) \ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Meets.Commutativity.html b/docs/Realizability.Tripos.Prealgebra.Meets.Commutativity.html index 2f2b484..f96528d 100644 --- a/docs/Realizability.Tripos.Prealgebra.Meets.Commutativity.html +++ b/docs/Realizability.Tripos.Prealgebra.Meets.Commutativity.html @@ -1,79 +1,76 @@ Realizability.Tripos.Prealgebra.Meets.Commutativity
open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure renaming (λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*)
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.Equiv
-open import Cubical.Data.Fin
-open import Cubical.Data.Vec
-open import Cubical.Data.Sum renaming (rec to sumRec)
-open import Cubical.Relation.Binary.Order.Preorder
-open import Cubical.HITs.PropositionalTruncation
-open import Cubical.HITs.PropositionalTruncation.Monad
+open import Realizability.ApplicativeStructure
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Sum renaming (rec to sumRec)
+open import Cubical.Relation.Binary.Order.Preorder
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
 
-module Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+module Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
 
-open import Realizability.Tripos.Prealgebra.Predicate ca
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
 
-open CombinatoryAlgebra ca
-open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
 
-private λ*ComputationRule = `λ*ComputationRule as fefermanStructure
-private λ* = `λ* as fefermanStructure
-
-module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where
+module _ (X : Type ℓ') (isSetX' : isSet X) where
   
-  private PredicateX = Predicate {ℓ'' = ℓ''} X
-  open Predicate
-  open PredicateProperties {ℓ'' = ℓ''} X
-  open PreorderReasoning preorder≤
+  private PredicateX = Predicate  X
+  open Predicate
+  open PredicateProperties  X
+  open PreorderReasoning preorder≤
 
-  x⊓y≤y⊓x : ∀ x y → x ⊓ y ≤ y ⊓ x
-  x⊓y≤y⊓x x y =
-    do
-      let
-        proof : Term as 1
-        proof = ` pair ̇ (` pr₂ ̇ # fzero) ̇ (` pr₁ ̇ # fzero)
-      return
-        (λ* proof ,
-          (λ x' a a⊩x⊓y →
-            subst
-              (λ r → r ⊩ ∣ y ⊓ x ∣ x')
-              (sym (λ*ComputationRule proof (a ∷ []) ))
-              ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (a⊩x⊓y .snd)) ,
-               (subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓y .fst)))))
+  x⊓y≤y⊓x : ∀ x y → x ⊓ y ≤ y ⊓ x
+  x⊓y≤y⊓x x y =
+    do
+      let
+        proof : Term as 1
+        proof = ` pair ̇ (` pr₂ ̇ # zero) ̇ (` pr₁ ̇ # zero)
+      return
+        (λ* proof ,
+          (λ x' a a⊩x⊓y →
+            subst
+              (λ r → r ⊩ ∣ y ⊓ x ∣ x')
+              (sym (λ*ComputationRule proof a))
+              ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (a⊩x⊓y .snd)) ,
+               (subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓y .fst)))))
 
-  antiSym→x⊓z≤y⊓z : ∀ x y z → x ≤ y → y ≤ x → x ⊓ z ≤ y ⊓ z
-  antiSym→x⊓z≤y⊓z x y z x≤y y≤x =
-    do
-      (f , f⊩x≤y) ← x≤y
-      (g , g⊩y≤x) ← y≤x
-      let
-        proof : Term as 1
-        proof = ` pair ̇ (` f ̇ (` pr₁ ̇ # fzero)) ̇ (` pr₂ ̇ # fzero)
-      return
-        ((λ* proof) ,
-          (λ x' a a⊩x⊓z →
-            subst
-              (λ r → r ⊩ ∣ y ⊓ z ∣ x')
-              (sym (λ*ComputationRule proof (a ∷ [])))
-              ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (f⊩x≤y x' (pr₁ ⨾ a) (a⊩x⊓z .fst))) ,
-               (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓z .snd)))))
+  antiSym→x⊓z≤y⊓z : ∀ x y z → x ≤ y → y ≤ x → x ⊓ z ≤ y ⊓ z
+  antiSym→x⊓z≤y⊓z x y z x≤y y≤x =
+    do
+      (f , f⊩x≤y) ← x≤y
+      (g , g⊩y≤x) ← y≤x
+      let
+        proof : Term as 1
+        proof = ` pair ̇ (` f ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero)
+      return
+        ((λ* proof) ,
+          (λ x' a a⊩x⊓z →
+            subst
+              (λ r → r ⊩ ∣ y ⊓ z ∣ x')
+              (sym (λ*ComputationRule proof a))
+              ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (f⊩x≤y x' (pr₁ ⨾ a) (a⊩x⊓z .fst))) ,
+               (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓z .snd)))))
 
 
-  antiSym→x⊓y≤x⊓z : ∀ x y z → y ≤ z → z ≤ y → x ⊓ y ≤ x ⊓ z
-  antiSym→x⊓y≤x⊓z x y z y≤z z≤y =
-    do
-      (f , f⊩y≤z) ← y≤z
-      (g , g⊩z≤y) ← z≤y
-      let
-        proof : Term as 1
-        proof = ` pair ̇ (`  pr₁ ̇ # fzero) ̇ (` f ̇ (` pr₂ ̇ # fzero))
-      return
-        ((λ* proof) ,
-          (λ { x' a (pr₁a⊩x , pr₂a⊩y) →
-            subst
-              (λ r → r ⊩ ∣ x ⊓ z ∣ x')
-              (sym (λ*ComputationRule proof (a ∷ [])))
-              ((subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₁pxy≡x _ _)) pr₁a⊩x) ,
-               (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (f⊩y≤z x' (pr₂ ⨾ a) pr₂a⊩y))) }))
+  antiSym→x⊓y≤x⊓z : ∀ x y z → y ≤ z → z ≤ y → x ⊓ y ≤ x ⊓ z
+  antiSym→x⊓y≤x⊓z x y z y≤z z≤y =
+    do
+      (f , f⊩y≤z) ← y≤z
+      (g , g⊩z≤y) ← z≤y
+      let
+        proof : Term as 1
+        proof = ` pair ̇ (`  pr₁ ̇ # zero) ̇ (` f ̇ (` pr₂ ̇ # zero))
+      return
+        ((λ* proof) ,
+          (λ { x' a (pr₁a⊩x , pr₂a⊩y) →
+            subst
+              (λ r → r ⊩ ∣ x ⊓ z ∣ x')
+              (sym (λ*ComputationRule proof a))
+              ((subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₁pxy≡x _ _)) pr₁a⊩x) ,
+               (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (f⊩y≤z x' (pr₂ ⨾ a) pr₂a⊩y))) }))
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Meets.Identity.html b/docs/Realizability.Tripos.Prealgebra.Meets.Identity.html index 62ba9bd..90b9965 100644 --- a/docs/Realizability.Tripos.Prealgebra.Meets.Identity.html +++ b/docs/Realizability.Tripos.Prealgebra.Meets.Identity.html @@ -1,75 +1,72 @@ Realizability.Tripos.Prealgebra.Meets.Identity
open import Cubical.Foundations.Prelude
 open import Cubical.Data.Unit
-open import Cubical.Data.Fin
-open import Cubical.Data.Vec
-open import Cubical.Data.Sum
-open import Cubical.Data.Empty renaming (rec* to ⊥*rec)
-open import Cubical.Data.Sigma
-open import Cubical.HITs.PropositionalTruncation
-open import Cubical.HITs.PropositionalTruncation.Monad
-open import Cubical.Relation.Binary.Order.Preorder
-open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure renaming (λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*)
+open import Cubical.Data.FinData
+open import Cubical.Data.Vec
+open import Cubical.Data.Sum
+open import Cubical.Data.Empty renaming (rec* to ⊥*rec)
+open import Cubical.Data.Sigma
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.Relation.Binary.Order.Preorder
+open import Realizability.CombinatoryAlgebra
+open import Realizability.ApplicativeStructure 
 
-module Realizability.Tripos.Prealgebra.Meets.Identity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
-open import Realizability.Tripos.Prealgebra.Predicate ca
-open import Realizability.Tripos.Prealgebra.Meets.Commutativity ca
-open CombinatoryAlgebra ca
-open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+module Realizability.Tripos.Prealgebra.Meets.Identity {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open import Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
 
-private λ*ComputationRule = `λ*ComputationRule as fefermanStructure
-private λ* = `λ* as fefermanStructure
+module _ (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where
+  private PredicateX = Predicate X
+  open Predicate
+  open PredicateProperties X
+  open PreorderReasoning preorder≤
 
-module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where
-  private PredicateX = Predicate {ℓ'' = ℓ''} X
-  open Predicate
-  open PredicateProperties {ℓ'' = ℓ''} X
-  open PreorderReasoning preorder≤
+  pre1 : PredicateX
+  Predicate.isSetX pre1 = isSetX'
+  Predicate.∣ pre1 ∣ = λ x a → Unit*
+  Predicate.isPropValued pre1 = λ x a → isPropUnit*
 
-  pre1 : PredicateX
-  Predicate.isSetX pre1 = isSetX'
-  Predicate.∣ pre1 ∣ = λ x a → Unit*
-  Predicate.isPropValued pre1 = λ x a → isPropUnit*
+  x⊓1≤x : ∀ x → x ⊓ pre1 ≤ x
+  x⊓1≤x x = ∣ pr₁ , (λ x' a a⊩x⊓1 → a⊩x⊓1 .fst) ∣₁
 
-  x⊓1≤x : ∀ x → x ⊓ pre1 ≤ x
-  x⊓1≤x x = ∣ pr₁ , (λ x' a a⊩x⊓1 → a⊩x⊓1 .fst) ∣₁
+  x≤x⊓1 : ∀ x → x ≤ x ⊓ pre1
+  x≤x⊓1 x =
+    do
+      let
+        proof : Term as 1
+        proof = ` pair ̇ # zero ̇ ` true
+      return
+        ((λ* proof) ,
+          (λ x' a a⊩x →
+            subst
+              (λ r → ∣ x ⊓ pre1 ∣ x' r)
+              (sym (λ*ComputationRule proof a))
+              (subst
+                (λ r → r ⊩ ∣ x ∣ x')
+                (sym (pr₁pxy≡x _ _))
+                a⊩x , tt*)))
 
-  x≤x⊓1 : ∀ x → x ≤ x ⊓ pre1
-  x≤x⊓1 x =
-    do
-      let
-        proof : Term as 1
-        proof = ` pair ̇ # fzero ̇ ` true
-      return
-        ((λ* proof) ,
-          (λ x' a a⊩x →
-            subst
-              (λ r → ∣ x ⊓ pre1 ∣ x' r)
-              (sym (λ*ComputationRule proof (a ∷ [])))
-              (subst
-                (λ r → r ⊩ ∣ x ∣ x')
-                (sym (pr₁pxy≡x _ _))
-                a⊩x , tt*)))
+  1⊓x≤x : ∀ x → pre1 ⊓ x ≤ x
+  1⊓x≤x x = ∣ pr₂ , (λ x' a a⊩1⊓x → a⊩1⊓x .snd) ∣₁
 
-  1⊓x≤x : ∀ x → pre1 ⊓ x ≤ x
-  1⊓x≤x x = ∣ pr₂ , (λ x' a a⊩1⊓x → a⊩1⊓x .snd) ∣₁
-
-  x≤1⊓x : ∀ x → x ≤ pre1 ⊓ x
-  x≤1⊓x x =
-    do
-      let
-        proof : Term as 1
-        proof = ` pair ̇ ` false ̇ # fzero
-      return
-        ((λ* proof) ,
-          (λ x' a a⊩x →
-            subst
-              (λ r → r ⊩ ∣ pre1 ⊓ x ∣ x')
-              (sym (λ*ComputationRule proof (a ∷ [])))
-              (tt* ,
-              (subst
-                (λ r → r ⊩ ∣ x ∣ x')
-                (sym (pr₂pxy≡y _ _))
-                a⊩x))))
+  x≤1⊓x : ∀ x → x ≤ pre1 ⊓ x
+  x≤1⊓x x =
+    do
+      let
+        proof : Term as 1
+        proof = ` pair ̇ ` false ̇ # zero
+      return
+        ((λ* proof) ,
+          (λ x' a a⊩x →
+            subst
+              (λ r → r ⊩ ∣ pre1 ⊓ x ∣ x')
+              (sym (λ*ComputationRule proof a))
+              (tt* ,
+              (subst
+                (λ r → r ⊩ ∣ x ∣ x')
+                (sym (pr₂pxy≡y _ _))
+                a⊩x))))
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Predicate.Base.html b/docs/Realizability.Tripos.Prealgebra.Predicate.Base.html index b629916..6ff832b 100644 --- a/docs/Realizability.Tripos.Prealgebra.Predicate.Base.html +++ b/docs/Realizability.Tripos.Prealgebra.Predicate.Base.html @@ -1,72 +1,76 @@ Realizability.Tripos.Prealgebra.Predicate.Base
open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure renaming (⟦_⟧ to `⟦_⟧; λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*)
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Univalence
-open import Cubical.Foundations.Isomorphism
-open import Cubical.Data.Sigma
-open import Cubical.Functions.FunExtEquiv
+open import Realizability.ApplicativeStructure
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Equiv
+open import Cubical.Data.Sigma
+open import Cubical.Functions.FunExtEquiv
 
-module Realizability.Tripos.Prealgebra.Predicate.Base {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+module Realizability.Tripos.Prealgebra.Predicate.Base {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
 
-open CombinatoryAlgebra ca
-open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
 
-record Predicate {ℓ' ℓ''} (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
-  field
-    isSetX : isSet X
-    ∣_∣ : X → A → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
-    isPropValued : ∀ x a → isProp (∣_∣ x a)
-  infix 25 ∣_∣
+record Predicate (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where
+  constructor makePredicate
+  field
+    isSetX : isSet X
+    ∣_∣ : X → A → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+    isPropValued : ∀ x a → isProp (∣_∣ x a)
+  infix 25 ∣_∣
 
-open Predicate
-infix 26 _⊩_
-_⊩_ : ∀ {ℓ'} → A → (A → Type ℓ') → Type ℓ'
-a ⊩ ϕ = ϕ a
+open Predicate
+infix 26 _⊩_
+_⊩_ : ∀ {ℓ'} → A → (A → Type ℓ') → Type ℓ'
+a ⊩ ϕ = ϕ a
 
-PredicateΣ : ∀ {ℓ' ℓ''} → (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ''))
-PredicateΣ {ℓ'} {ℓ''} X = Σ[ rel ∈ (X → A → hProp (ℓ-max (ℓ-max ℓ ℓ') ℓ'')) ] (isSet X)
+PredicateΣ : ∀ (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ''))
+PredicateΣ X = Σ[ rel ∈ (X → A → hProp (ℓ-max (ℓ-max ℓ ℓ') ℓ'')) ] (isSet X)
 
-isSetPredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (PredicateΣ {ℓ'' = ℓ''} X)
-isSetPredicateΣ X = isSetΣ (isSetΠ (λ x → isSetΠ λ a → isSetHProp)) λ _ → isProp→isSet isPropIsSet
+isSetPredicateΣ : ∀ (X : Type ℓ') → isSet (PredicateΣ X)
+isSetPredicateΣ X = isSetΣ (isSetΠ (λ x → isSetΠ λ a → isSetHProp)) λ _ → isProp→isSet isPropIsSet
 
-PredicateIsoΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Iso (Predicate {ℓ'' = ℓ''} X) (PredicateΣ {ℓ'' = ℓ''} X)
-PredicateIsoΣ {ℓ'} {ℓ''} X =
-  iso
-    (λ p → (λ x a → (a ⊩ ∣ p ∣ x) , p .isPropValued x a) , p .isSetX)
-    (λ p → record { isSetX = p .snd ; ∣_∣ = λ x a → p .fst x a .fst ; isPropValued = λ x a → p .fst x a .snd })
-    (λ b → refl)
-    λ a → refl
+PredicateIsoΣ : ∀ (X : Type ℓ') → Iso (Predicate  X) (PredicateΣ  X)
+PredicateIsoΣ X =
+  iso
+    (λ p → (λ x a → (a ⊩ ∣ p ∣ x) , p .isPropValued x a) , p .isSetX)
+    (λ p → record { isSetX = p .snd ; ∣_∣ = λ x a → p .fst x a .fst ; isPropValued = λ x a → p .fst x a .snd })
+    (λ b → refl)
+    λ a → refl
 
-Predicate≡PredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Predicate {ℓ'' = ℓ''} X ≡ PredicateΣ {ℓ'' = ℓ''} X
-Predicate≡PredicateΣ {ℓ'} {ℓ''} X = isoToPath (PredicateIsoΣ X)
+Predicate≃PredicateΣ : ∀ (X : Type ℓ') → Predicate X ≃ PredicateΣ X
+Predicate≃PredicateΣ X = isoToEquiv (PredicateIsoΣ X)
 
-isSetPredicate : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (Predicate {ℓ'' = ℓ''} X)
-isSetPredicate {ℓ'} {ℓ''} X = subst (λ predicateType → isSet predicateType) (sym (Predicate≡PredicateΣ X)) (isSetPredicateΣ {ℓ'' = ℓ''} X)
+Predicate≡PredicateΣ : ∀ (X : Type ℓ') → Predicate  X ≡ PredicateΣ  X
+Predicate≡PredicateΣ X = isoToPath (PredicateIsoΣ X)
 
-PredicateΣ≡ : ∀ {ℓ' ℓ''} (X : Type ℓ') → (P Q : PredicateΣ {ℓ'' = ℓ''} X) → (P .fst ≡ Q .fst) → P ≡ Q
-PredicateΣ≡ X P Q ∣P∣≡∣Q∣ = Σ≡Prop (λ _ → isPropIsSet) ∣P∣≡∣Q∣
+isSetPredicate : ∀  (X : Type ℓ') → isSet (Predicate  X)
+isSetPredicate X = subst (λ predicateType → isSet predicateType) (sym (Predicate≡PredicateΣ X)) (isSetPredicateΣ  X)
 
-Predicate≡ :
-  ∀ {ℓ' ℓ''} (X : Type ℓ')
-  → (P Q : Predicate {ℓ'' = ℓ''} X)
-  → (∀ x a → a ⊩ ∣ P ∣ x → a ⊩ ∣ Q ∣ x)
-  → (∀ x a → a ⊩ ∣ Q ∣ x → a ⊩ ∣ P ∣ x)
-  -----------------------------------
-  → P ≡ Q
-Predicate≡ {ℓ'} {ℓ''} X P Q P→Q Q→P i =
-  PredicateIsoΣ X .inv
-    (PredicateΣ≡
-      {ℓ'' = ℓ''}
-      X
-      (PredicateIsoΣ X .fun P)
-      (PredicateIsoΣ X .fun Q)
-      (funExt₂
-        (λ x a → Σ≡Prop (λ A → isPropIsProp)
-        (hPropExt
-          (P .isPropValued x a)
-          (Q .isPropValued x a)
-          (P→Q x a)
-          (Q→P x a)))) i) where open Iso
+PredicateΣ≡ : ∀  (X : Type ℓ') → (P Q : PredicateΣ  X) → (P .fst ≡ Q .fst) → P ≡ Q
+PredicateΣ≡ X P Q ∣P∣≡∣Q∣ = Σ≡Prop (λ _ → isPropIsSet) ∣P∣≡∣Q∣
+
+Predicate≡ :
+  ∀ (X : Type ℓ')
+  → (P Q : Predicate  X)
+  → (∀ x a → a ⊩ ∣ P ∣ x → a ⊩ ∣ Q ∣ x)
+  → (∀ x a → a ⊩ ∣ Q ∣ x → a ⊩ ∣ P ∣ x)
+  -----------------------------------
+  → P ≡ Q
+Predicate≡ X P Q P→Q Q→P i =
+  PredicateIsoΣ X .inv
+    (PredicateΣ≡
+      X
+      (PredicateIsoΣ X .fun P)
+      (PredicateIsoΣ X .fun Q)
+      (funExt₂
+        (λ x a → Σ≡Prop (λ A → isPropIsProp)
+        (hPropExt
+          (P .isPropValued x a)
+          (Q .isPropValued x a)
+          (P→Q x a)
+          (Q→P x a)))) i) where open Iso
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Predicate.Properties.html b/docs/Realizability.Tripos.Prealgebra.Predicate.Properties.html index 8131a20..50a1a61 100644 --- a/docs/Realizability.Tripos.Prealgebra.Predicate.Properties.html +++ b/docs/Realizability.Tripos.Prealgebra.Predicate.Properties.html @@ -1,321 +1,362 @@ Realizability.Tripos.Prealgebra.Predicate.Properties
open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure
-open import Cubical.Foundations.Prelude
-open import Cubical.Foundations.HLevels
-open import Cubical.Foundations.Equiv
-open import Cubical.Foundations.Univalence
-open import Cubical.Foundations.Isomorphism
-open import Cubical.Foundations.Function
-open import Cubical.Functions.FunExtEquiv
-open import Cubical.Data.Sigma
-open import Cubical.Data.Empty
-open import Cubical.Data.Unit
-open import Cubical.Data.Sum
-open import Cubical.HITs.PropositionalTruncation
-open import Cubical.HITs.PropositionalTruncation.Monad
-open import Cubical.Relation.Binary.Order.Preorder
-
-module
-  Realizability.Tripos.Prealgebra.Predicate.Properties
-  {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
-
-open import Realizability.Tripos.Prealgebra.Predicate.Base ca
-
-open CombinatoryAlgebra ca
-open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
-open Predicate
-module PredicateProperties {ℓ' ℓ''} (X : Type ℓ') where
-  private PredicateX = Predicate {ℓ'' = ℓ''} X
-  open Predicate
-  _≤_ : Predicate {ℓ'' = ℓ''} X → Predicate {ℓ'' = ℓ''} X → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
-  ϕ ≤ ψ = ∃[ b ∈ A ] (∀ (x : X) (a : A) → a ⊩ (∣ ϕ ∣ x) → (b ⨾ a) ⊩ ∣ ψ ∣ x)
-
-  isProp≤ : ∀ ϕ ψ → isProp (ϕ ≤ ψ)
-  isProp≤ ϕ ψ = isPropPropTrunc
-
-  isRefl≤ : ∀ ϕ → ϕ ≤ ϕ
-  isRefl≤ ϕ = ∣ Id , (λ x a a⊩ϕx → subst (λ r → r ⊩ ∣ ϕ ∣ x) (sym (Ida≡a a)) a⊩ϕx) ∣₁
-
-  isTrans≤ : ∀ ϕ ψ ξ → ϕ ≤ ψ → ψ ≤ ξ → ϕ ≤ ξ
-  isTrans≤ ϕ ψ ξ ϕ≤ψ ψ≤ξ = do
-                           (a , ϕ≤[a]ψ) ← ϕ≤ψ
-                           (b , ψ≤[b]ξ) ← ψ≤ξ
-                           return
-                             ((B b a) ,
-                             (λ x a' a'⊩ϕx →
-                               subst
-                                 (λ r → r ⊩ ∣ ξ ∣ x)
-                                 (sym (Ba≡gfa b a a'))
-                                 (ψ≤[b]ξ x (a ⨾ a')
-                                 (ϕ≤[a]ψ x a' a'⊩ϕx))))
+open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm)
+open import Cubical.Foundations.Prelude as P
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Univalence
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Function
+open import Cubical.Functions.FunExtEquiv
+open import Cubical.Data.Sigma
+open import Cubical.Data.Empty
+open import Cubical.Data.Unit
+open import Cubical.Data.Sum
+open import Cubical.Data.Vec
+open import Cubical.HITs.PropositionalTruncation
+open import Cubical.HITs.PropositionalTruncation.Monad
+open import Cubical.Relation.Binary.Order.Preorder
+
+module
+  Realizability.Tripos.Prealgebra.Predicate.Properties
+  {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+
+open import Realizability.Tripos.Prealgebra.Predicate.Base {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca
+
+open CombinatoryAlgebra ca
+open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a)
+open Predicate
+
+module PredicateProperties (X : Type ℓ') where
+  private PredicateX = Predicate X
+  open Predicate
+  _≤_ : Predicate  X → Predicate  X → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
+  ϕ ≤ ψ = ∃[ b ∈ A ] (∀ (x : X) (a : A) → a ⊩ (∣ ϕ ∣ x) → (b ⨾ a) ⊩ ∣ ψ ∣ x)
+
+  isProp≤ : ∀ ϕ ψ → isProp (ϕ ≤ ψ)
+  isProp≤ ϕ ψ = isPropPropTrunc
+
+  isRefl≤ : ∀ ϕ → ϕ ≤ ϕ
+  isRefl≤ ϕ = ∣ Id , (λ x a a⊩ϕx → subst (λ r → r ⊩ ∣ ϕ ∣ x) (sym (Ida≡a a)) a⊩ϕx) ∣₁
+
+  isTrans≤ : ∀ ϕ ψ ξ → ϕ ≤ ψ → ψ ≤ ξ → ϕ ≤ ξ
+  isTrans≤ ϕ ψ ξ ϕ≤ψ ψ≤ξ = do
+                           (a , ϕ≤[a]ψ) ← ϕ≤ψ
+                           (b , ψ≤[b]ξ) ← ψ≤ξ
+                           return
+                             ((B b a) ,
+                             (λ x a' a'⊩ϕx →
+                               subst
+                                 (λ r → r ⊩ ∣ ξ ∣ x)
+                                 (sym (Ba≡gfa b a a'))
+                                 (ψ≤[b]ξ x (a ⨾ a')
+                                 (ϕ≤[a]ψ x a' a'⊩ϕx))))
     
 
-  open IsPreorder renaming
-    (is-set to isSet
-    ;is-prop-valued to isPropValued
-    ;is-refl to isRefl
-    ;is-trans to isTrans)
+  open IsPreorder renaming
+    (is-set to isSet
+    ;is-prop-valued to isPropValued
+    ;is-refl to isRefl
+    ;is-trans to isTrans)
 
-  preorder≤ : _
-  preorder≤ = preorder (Predicate X) _≤_ (ispreorder (isSetPredicate X) isProp≤ isRefl≤ isTrans≤)
+  preorder≤ : _
+  preorder≤ = preorder (Predicate X) _≤_ (ispreorder (isSetPredicate X) isProp≤ isRefl≤ isTrans≤)
 
-  {-
+  {-
   It is not necessary to truncate the underlying predicate but it is very convenient.
   We can prove that the underlying type is a proposition if the combinatory algebra
   is non-trivial. This would require some effort to do in Agda, so I have deferred it
   for later.
   -}
-  infix 25 _⊔_
-  _⊔_ : PredicateX → PredicateX → PredicateX
-  (ϕ ⊔ ψ) .isSetX = ϕ .isSetX
-  ∣ ϕ ⊔ ψ ∣ x a = ∥ ((pr₁ ⨾ a ≡ k) × ((pr₂ ⨾ a) ⊩ ∣ ϕ ∣ x)) ⊎ ((pr₁ ⨾ a ≡ k') × ((pr₂ ⨾ a) ⊩ ∣ ψ ∣ x)) ∥₁
-  (ϕ ⊔ ψ) .isPropValued x a = isPropPropTrunc
-
-  infix 25 _⊓_
-  _⊓_ : PredicateX → PredicateX → PredicateX
-  (ϕ ⊓ ψ) .isSetX = ϕ .isSetX
-  ∣ ϕ ⊓ ψ ∣ x a = ((pr₁ ⨾ a) ⊩ ∣ ϕ ∣ x) × ((pr₂ ⨾ a) ⊩ ∣ ψ ∣ x)
-  (ϕ ⊓ ψ) .isPropValued x a = isProp× (ϕ .isPropValued x (pr₁ ⨾ a)) (ψ .isPropValued x (pr₂ ⨾ a))
-
-  infix 25 _⇒_
-  _⇒_ : PredicateX → PredicateX → PredicateX
-  (ϕ ⇒ ψ) .isSetX = ϕ .isSetX
-  ∣ ϕ ⇒ ψ ∣ x a = ∀ b → (b ⊩ ∣ ϕ ∣ x) → (a ⨾ b) ⊩ ∣ ψ ∣ x
-  (ϕ ⇒ ψ) .isPropValued x a = isPropΠ λ a → isPropΠ λ a⊩ϕx → ψ .isPropValued _ _
-
-
-module Morphism {ℓ' ℓ''} {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSet Y)  where
-  PredicateX = Predicate {ℓ'' = ℓ''} X
-  PredicateY = Predicate {ℓ'' = ℓ''} Y
-  module PredicatePropertiesX = PredicateProperties {ℓ'' = ℓ''} X
-  module PredicatePropertiesY = PredicateProperties {ℓ'' = ℓ''} Y
-  open PredicatePropertiesX renaming (_≤_ to _≤X_ ; isProp≤ to isProp≤X)
-  open PredicatePropertiesY renaming (_≤_ to _≤Y_ ; isProp≤ to isProp≤Y)
-  open Predicate hiding (isSetX)
-
-  ⋆_ : (X → Y) → (PredicateY → PredicateX)
-  ⋆ f =
-    λ ϕ →
-      record
-        { isSetX = isSetX
-        ; ∣_∣ = λ x a → a ⊩ ∣ ϕ ∣ (f x)
-        ; isPropValued = λ x a → ϕ .isPropValued (f x) a }
-
-  `∀[_] : (X → Y) → (PredicateX → PredicateY)
-  `∀[ f ] =
-    λ ϕ →
-      record
-        { isSetX = isSetY
-        ; ∣_∣ = λ y a → (∀ b x → f x ≡ y → (a ⨾ b) ⊩ ∣ ϕ ∣ x)
-        ; isPropValued = λ y a → isPropΠ λ a' → isPropΠ λ x → isPropΠ λ fx≡y → ϕ .isPropValued x (a ⨾ a') }
-
-  `∃[_] : (X → Y) → (PredicateX → PredicateY)
-  `∃[ f ] =
-    λ ϕ →
-      record
-        { isSetX = isSetY
-        ; ∣_∣ = λ y a → ∃[ x ∈ X ] (f x ≡ y) × (a ⊩ ∣ ϕ ∣ x)
-        ; isPropValued = λ y a → isPropPropTrunc }
-
-  -- Adjunction proofs
-
-  `∃isLeftAdjoint→ : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ → ϕ ≤X (⋆ f) ψ
-  `∃isLeftAdjoint→ ϕ ψ f p =
-    do
-      (a~ , a~proves) ← p
-      return (a~ , (λ x a a⊩ϕx → a~proves (f x) a ∣ x , refl , a⊩ϕx ∣₁))
-
-
-  `∃isLeftAdjoint← : ∀ ϕ ψ f → ϕ ≤X (⋆ f) ψ → `∃[ f ] ϕ ≤Y ψ
-  `∃isLeftAdjoint← ϕ ψ f p =
-    do
-      (a~ , a~proves) ← p
-      return
-        (a~ ,
-        (λ y b b⊩∃fϕ →
-          equivFun
-            (propTruncIdempotent≃
-              (ψ .isPropValued y (a~ ⨾ b)))
-              (do
-                (x , fx≡y , b⊩ϕx) ← b⊩∃fϕ
-                return (subst (λ y' → (a~ ⨾ b) ⊩ ∣ ψ ∣ y') fx≡y (a~proves x b b⊩ϕx)))))
-
-  `∃isLeftAdjoint : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ ≡ ϕ ≤X (⋆ f) ψ
-  `∃isLeftAdjoint ϕ ψ f =
-    hPropExt
-      (isProp≤Y (`∃[ f ] ϕ) ψ)
-      (isProp≤X ϕ ((⋆ f) ψ))
-      (`∃isLeftAdjoint→ ϕ ψ f)
-      (`∃isLeftAdjoint← ϕ ψ f)
-
-  `∀isRightAdjoint→ : ∀ ϕ ψ f → ψ ≤Y `∀[ f ] ϕ → (⋆ f) ψ ≤X ϕ
-  `∀isRightAdjoint→ ϕ ψ f p =
-    do
-      (a~ , a~proves) ← p
-      let realizer = (s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k))
-      return
-        (realizer ,
-        (λ x a a⊩ψfx →
-          equivFun
-            (propTruncIdempotent≃
-              (ϕ .isPropValued x (realizer ⨾ a) ))
-              (do
-                let ∀prover = a~proves (f x) a a⊩ψfx
-                return
-                  (subst
-                    (λ ϕ~ → ϕ~ ⊩ ∣ ϕ ∣ x)
-                    (sym
-                      (realizer ⨾ a
-                        ≡⟨ refl ⟩
-                       s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k) ⨾ a
-                        ≡⟨ sabc≡ac_bc _ _ _ ⟩
-                       s ⨾ (k ⨾ a~) ⨾ Id ⨾ a ⨾ (k ⨾ k ⨾ a)
-                        ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ a)) (sabc≡ac_bc _ _ _) ⟩
-                       k ⨾ a~ ⨾ a ⨾ (Id ⨾ a) ⨾ (k ⨾ k ⨾ a)
-                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ x ⨾ (k ⨾ k ⨾ a)) (Ida≡a a) ⟩
-                       k ⨾ a~ ⨾ a ⨾ a ⨾ (k ⨾ k ⨾ a)
-                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ a ⨾ x) (kab≡a _ _) ⟩
-                       (k ⨾ a~ ⨾ a) ⨾ a ⨾ k
-                        ≡⟨ cong (λ x → x ⨾ a ⨾ k) (kab≡a _ _) ⟩
-                       a~ ⨾ a ⨾ k
-                         ∎))
-                    (∀prover k x refl)))))
-
-  `∀isRightAdjoint← : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ → ψ ≤Y `∀[ f ] ϕ
-  `∀isRightAdjoint← ϕ ψ f p =
-    do
-      (a~ , a~proves) ← p
-      let realizer = (s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id))
-      return
-        (realizer ,
-        (λ y b b⊩ψy a x fx≡y →
-          subst
-            (λ r → r ⊩ ∣ ϕ ∣ x)
-            (sym
-              (realizer ⨾ b ⨾ a
-                 ≡⟨ refl ⟩
-               s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id) ⨾ b ⨾ a
-                 ≡⟨ cong (λ x → x ⨾ a) (sabc≡ac_bc _ _ _) ⟩
-               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ Id ⨾ b) ⨾ a
-                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ x ⨾ a) (sabc≡ac_bc (k ⨾ k) Id b) ⟩
-               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ ((k ⨾ k ⨾ b) ⨾ (Id ⨾ b)) ⨾ a
-                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (x ⨾ (Id ⨾ b)) ⨾ a) (kab≡a _ _) ⟩
-               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ (Id ⨾ b)) ⨾ a
-                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ x) ⨾ a) (Ida≡a b) ⟩
-               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ b) ⨾ a
-                 ≡⟨ cong (λ x → x ⨾ (k ⨾ b) ⨾ a) (sabc≡ac_bc _ _ _) ⟩
-               k ⨾ s ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
-                 ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a) (kab≡a _ _) ⟩
-               s ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
-                 ≡⟨ sabc≡ac_bc _ _ _ ⟩
-               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ (k ⨾ b ⨾ a)
-                 ≡⟨ cong (λ x → s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ x) (kab≡a b a) ⟩
-               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ b
-                 ≡⟨ cong (λ x → x ⨾ a ⨾ b) (sabc≡ac_bc (k ⨾ k) (k ⨾ a~) b) ⟩
-               k ⨾ k ⨾ b ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
-                 ≡⟨ cong (λ x → x ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b) (kab≡a _ _) ⟩
-               k ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
-                 ≡⟨ cong (λ x → k ⨾ x ⨾ a ⨾ b) (kab≡a _ _) ⟩
-               k ⨾ a~ ⨾ a ⨾ b
-                 ≡⟨ cong (λ x → x ⨾ b) (kab≡a _ _) ⟩
-               a~ ⨾ b
-                   ∎))
-            (a~proves x b (subst (λ x' → b ⊩ ∣ ψ ∣ x') (sym fx≡y) b⊩ψy))))
-
-  `∀isRightAdjoint : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ ≡ ψ ≤Y `∀[ f ] ϕ
-  `∀isRightAdjoint ϕ ψ f =
-    hPropExt
-      (isProp≤X ((⋆ f) ψ) ϕ)
-      (isProp≤Y ψ (`∀[ f ] ϕ))
-      (`∀isRightAdjoint← ϕ ψ f)
-      (`∀isRightAdjoint→ ϕ ψ f)
-
--- The proof is trivial but I am the reader it was left to as an exercise
-module BeckChevalley
-    {ℓ' ℓ'' : Level}
-    (I J K : Type ℓ')
-    (isSetI : isSet I)
-    (isSetJ : isSet J)
-    (isSetK : isSet K)
-    (f : J → I)
-    (g : K → I) where
-
-    module Morphism' = Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''}
-    open Morphism'
+  infix 25 _⊔_
+  _⊔_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⊔ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⊔ ψ ∣ x a = ∥ ((pr₁ ⨾ a ≡ k) × ((pr₂ ⨾ a) ⊩ ∣ ϕ ∣ x)) ⊎ ((pr₁ ⨾ a ≡ k') × ((pr₂ ⨾ a) ⊩ ∣ ψ ∣ x)) ∥₁
+  (ϕ ⊔ ψ) .isPropValued x a = isPropPropTrunc
+
+  infix 25 _⊓_
+  _⊓_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⊓ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⊓ ψ ∣ x a = ((pr₁ ⨾ a) ⊩ ∣ ϕ ∣ x) × ((pr₂ ⨾ a) ⊩ ∣ ψ ∣ x)
+  (ϕ ⊓ ψ) .isPropValued x a = isProp× (ϕ .isPropValued x (pr₁ ⨾ a)) (ψ .isPropValued x (pr₂ ⨾ a))
+
+  infix 25 _⇒_
+  _⇒_ : PredicateX → PredicateX → PredicateX
+  (ϕ ⇒ ψ) .isSetX = ϕ .isSetX
+  ∣ ϕ ⇒ ψ ∣ x a = ∀ b → (b ⊩ ∣ ϕ ∣ x) → (a ⨾ b) ⊩ ∣ ψ ∣ x
+  (ϕ ⇒ ψ) .isPropValued x a = isPropΠ λ a → isPropΠ λ a⊩ϕx → ψ .isPropValued _ _
+
+module _ where
+  open PredicateProperties Unit*
+  private
+    Predicate' = Predicate 
+  module NotAntiSym (antiSym : ∀ (a b : Predicate' Unit*) → (a≤b : a ≤ b) → (b≤a : b ≤ a) → a ≡ b) where
+    Lift' = Lift {i = ℓ} {j = (ℓ-max ℓ' ℓ'')}
+
+    kRealized : Predicate' Unit*
+    kRealized = record { isSetX = isSetUnit* ; ∣_∣ = λ x a → Lift' (a ≡ k) ; isPropValued = λ x a → isOfHLevelRespectEquiv 1 LiftEquiv (isSetA a k) }
+
+    k'Realized : Predicate' Unit*
+    k'Realized = record { isSetX = isSetUnit* ; ∣_∣ = λ x a → Lift' (a ≡ k') ; isPropValued = λ x a → isOfHLevelRespectEquiv 1 LiftEquiv (isSetA a k') }
+
+    kRealized≤k'Realized : kRealized ≤ k'Realized
+    kRealized≤k'Realized =
+      do
+        let
+          prover : ApplStrTerm as 1
+          prover = ` k'
+        return (λ* prover , λ { x a (lift a≡k) → lift (λ*ComputationRule prover a) })
+
+    k'Realized≤kRealized : k'Realized ≤ kRealized
+    k'Realized≤kRealized =
+      do
+        let
+          prover : ApplStrTerm as 1
+          prover = ` k
+        return (λ* prover , λ { x a (lift a≡k') → lift (λ*ComputationRule prover a) })
+
+    kRealized≡k'Realized : kRealized ≡ k'Realized
+    kRealized≡k'Realized = antiSym kRealized k'Realized kRealized≤k'Realized k'Realized≤kRealized
+
+    Lift≡ : Lift' (k ≡ k) ≡ Lift' (k ≡ k')
+    Lift≡ i = ∣ kRealized≡k'Realized i ∣ tt* k
+
+    Liftk≡k' : Lift' (k ≡ k')
+    Liftk≡k' = transport Lift≡ (lift refl)
+
+    k≡k' : k ≡ k'
+    k≡k' = Liftk≡k' .lower
+
+module Morphism {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSet Y)  where
+  PredicateX = Predicate  X
+  PredicateY = Predicate  Y
+  module PredicatePropertiesX = PredicateProperties X
+  module PredicatePropertiesY = PredicateProperties Y
+  open PredicatePropertiesX renaming (_≤_ to _≤X_ ; isProp≤ to isProp≤X)
+  open PredicatePropertiesY renaming (_≤_ to _≤Y_ ; isProp≤ to isProp≤Y)
+  open Predicate hiding (isSetX)
+
+  ⋆_ : (X → Y) → (PredicateY → PredicateX)
+  ⋆ f =
+    λ ϕ →
+      record
+        { isSetX = isSetX
+        ; ∣_∣ = λ x a → a ⊩ ∣ ϕ ∣ (f x)
+        ; isPropValued = λ x a → ϕ .isPropValued (f x) a }
+
+  `∀[_] : (X → Y) → (PredicateX → PredicateY)
+  `∀[ f ] =
+    λ ϕ →
+      record
+        { isSetX = isSetY
+        ; ∣_∣ = λ y a → (∀ b x → f x ≡ y → (a ⨾ b) ⊩ ∣ ϕ ∣ x)
+        ; isPropValued = λ y a → isPropΠ λ a' → isPropΠ λ x → isPropΠ λ fx≡y → ϕ .isPropValued x (a ⨾ a') }
+
+  `∃[_] : (X → Y) → (PredicateX → PredicateY)
+  `∃[ f ] =
+    λ ϕ →
+      record
+        { isSetX = isSetY
+        ; ∣_∣ = λ y a → ∃[ x ∈ X ] (f x ≡ y) × (a ⊩ ∣ ϕ ∣ x)
+        ; isPropValued = λ y a → isPropPropTrunc }
+
+  -- Adjunction proofs
+
+  `∃isLeftAdjoint→ : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ → ϕ ≤X (⋆ f) ψ
+  `∃isLeftAdjoint→ ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      return (a~ , (λ x a a⊩ϕx → a~proves (f x) a ∣ x , refl , a⊩ϕx ∣₁))
+
+
+  `∃isLeftAdjoint← : ∀ ϕ ψ f → ϕ ≤X (⋆ f) ψ → `∃[ f ] ϕ ≤Y ψ
+  `∃isLeftAdjoint← ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      return
+        (a~ ,
+        (λ y b b⊩∃fϕ →
+          equivFun
+            (propTruncIdempotent≃
+              (ψ .isPropValued y (a~ ⨾ b)))
+              (do
+                (x , fx≡y , b⊩ϕx) ← b⊩∃fϕ
+                return (subst (λ y' → (a~ ⨾ b) ⊩ ∣ ψ ∣ y') fx≡y (a~proves x b b⊩ϕx)))))
+
+  `∃isLeftAdjoint : ∀ ϕ ψ f → `∃[ f ] ϕ ≤Y ψ ≡ ϕ ≤X (⋆ f) ψ
+  `∃isLeftAdjoint ϕ ψ f =
+    hPropExt
+      (isProp≤Y (`∃[ f ] ϕ) ψ)
+      (isProp≤X ϕ ((⋆ f) ψ))
+      (`∃isLeftAdjoint→ ϕ ψ f)
+      (`∃isLeftAdjoint← ϕ ψ f)
+
+  `∀isRightAdjoint→ : ∀ ϕ ψ f → ψ ≤Y `∀[ f ] ϕ → (⋆ f) ψ ≤X ϕ
+  `∀isRightAdjoint→ ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      let realizer = (s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k))
+      return
+        (realizer ,
+        (λ x a a⊩ψfx →
+          equivFun
+            (propTruncIdempotent≃
+              (ϕ .isPropValued x (realizer ⨾ a) ))
+              (do
+                let ∀prover = a~proves (f x) a a⊩ψfx
+                return
+                  (subst
+                    (λ ϕ~ → ϕ~ ⊩ ∣ ϕ ∣ x)
+                    (sym
+                      (realizer ⨾ a
+                        ≡⟨ refl ⟩
+                       s ⨾ (s ⨾ (k ⨾ a~) ⨾ Id) ⨾ (k ⨾ k) ⨾ a
+                        ≡⟨ sabc≡ac_bc _ _ _ ⟩
+                       s ⨾ (k ⨾ a~) ⨾ Id ⨾ a ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → x ⨾ (k ⨾ k ⨾ a)) (sabc≡ac_bc _ _ _) ⟩
+                       k ⨾ a~ ⨾ a ⨾ (Id ⨾ a) ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ x ⨾ (k ⨾ k ⨾ a)) (Ida≡a a) ⟩
+                       k ⨾ a~ ⨾ a ⨾ a ⨾ (k ⨾ k ⨾ a)
+                        ≡⟨ cong (λ x → k ⨾ a~ ⨾ a ⨾ a ⨾ x) (kab≡a _ _) ⟩
+                       (k ⨾ a~ ⨾ a) ⨾ a ⨾ k
+                        ≡⟨ cong (λ x → x ⨾ a ⨾ k) (kab≡a _ _) ⟩
+                       a~ ⨾ a ⨾ k
+                         ∎))
+                    (∀prover k x refl)))))
+
+  `∀isRightAdjoint← : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ → ψ ≤Y `∀[ f ] ϕ
+  `∀isRightAdjoint← ϕ ψ f p =
+    do
+      (a~ , a~proves) ← p
+      let realizer = (s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id))
+      return
+        (realizer ,
+        (λ y b b⊩ψy a x fx≡y →
+          subst
+            (λ r → r ⊩ ∣ ϕ ∣ x)
+            (sym
+              (realizer ⨾ b ⨾ a
+                 ≡⟨ refl ⟩
+               s ⨾ (s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~))) ⨾ (s ⨾ (k ⨾ k) ⨾ Id) ⨾ b ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ a) (sabc≡ac_bc _ _ _) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ Id ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ x ⨾ a) (sabc≡ac_bc (k ⨾ k) Id b) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ ((k ⨾ k ⨾ b) ⨾ (Id ⨾ b)) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (x ⨾ (Id ⨾ b)) ⨾ a) (kab≡a _ _) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ (Id ⨾ b)) ⨾ a
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ x) ⨾ a) (Ida≡a b) ⟩
+               s ⨾ (k ⨾ s) ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~)) ⨾ b ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ (k ⨾ b) ⨾ a) (sabc≡ac_bc _ _ _) ⟩
+               k ⨾ s ⨾ b ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ cong (λ x → x ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a) (kab≡a _ _) ⟩
+               s ⨾ (s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b) ⨾ (k ⨾ b) ⨾ a
+                 ≡⟨ sabc≡ac_bc _ _ _ ⟩
+               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ (k ⨾ b ⨾ a)
+                 ≡⟨ cong (λ x → s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ x) (kab≡a b a) ⟩
+               s ⨾ (k ⨾ k) ⨾ (k ⨾ a~) ⨾ b ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ a ⨾ b) (sabc≡ac_bc (k ⨾ k) (k ⨾ a~) b) ⟩
+               k ⨾ k ⨾ b ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b) (kab≡a _ _) ⟩
+               k ⨾ (k ⨾ a~ ⨾ b) ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → k ⨾ x ⨾ a ⨾ b) (kab≡a _ _) ⟩
+               k ⨾ a~ ⨾ a ⨾ b
+                 ≡⟨ cong (λ x → x ⨾ b) (kab≡a _ _) ⟩
+               a~ ⨾ b
+                   ∎))
+            (a~proves x b (subst (λ x' → b ⊩ ∣ ψ ∣ x') (sym fx≡y) b⊩ψy))))
+
+  `∀isRightAdjoint : ∀ ϕ ψ f → (⋆ f) ψ ≤X ϕ ≡ ψ ≤Y `∀[ f ] ϕ
+  `∀isRightAdjoint ϕ ψ f =
+    hPropExt
+      (isProp≤X ((⋆ f) ψ) ϕ)
+      (isProp≤Y ψ (`∀[ f ] ϕ))
+      (`∀isRightAdjoint← ϕ ψ f)
+      (`∀isRightAdjoint→ ϕ ψ f)
+
+-- The proof is trivial but I am the reader it was left to as an exercise
+module BeckChevalley
+    (I J K : Type ℓ')
+    (isSetI : isSet I)
+    (isSetJ : isSet J)
+    (isSetK : isSet K)
+    (f : J → I)
+    (g : K → I) where
+
+    module Morphism' = Morphism
+    open Morphism'
     
-    L = Σ[ k ∈ K ] Σ[ j ∈ J ] (g k ≡ f j)
-
-    isSetL : isSet L
-    isSetL = isSetΣ isSetK λ k → isSetΣ isSetJ λ j → isProp→isSet (isSetI _ _)
-
-    p : L → K
-    p (k , _ , _) = k
-
-    q : L → J
-    q (_ , l , _) = l
-
-    q* = ⋆_ isSetL isSetJ q
-    g* = ⋆_ isSetK isSetI g
-
-    module `f = Morphism' isSetJ isSetI
-    open `f renaming (`∃[_] to `∃[J→I][_]; `∀[_] to `∀[J→I][_])
-
-    module `q = Morphism' isSetL isSetK
-    open `q renaming (`∃[_] to `∃[L→K][_]; `∀[_] to `∀[L→K][_])
-
-    `∃BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k
-    `∃BeckChevalley→ ϕ k a p =
-      do
-        (j , fj≡gk , a⊩ϕj) ← p
-        return ((k , (j , (sym fj≡gk))) , (refl , a⊩ϕj))
-
-    `∃BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k
-    `∃BeckChevalley← ϕ k a p =
-      do
-        (x@(k' , j , gk'≡fj) , k'≡k , a⊩ϕqj) ← p
-        return (j , (subst (λ k → f j ≡ g k) k'≡k (sym gk'≡fj)) , a⊩ϕqj)
-
-    open Iso
-    `∃BeckChevalley : g* ∘ `∃[J→I][ f ] ≡ `∃[L→K][ p ] ∘ q*
-    `∃BeckChevalley =
-      funExt λ ϕ i →
-        PredicateIsoΣ K .inv
-          (PredicateΣ≡ {ℓ'' = ℓ''} K
-            ((λ k a → (∣ (g* ∘ `∃[J→I][ f ]) ϕ ∣ k a) , ((g* ∘ `∃[J→I][ f ]) ϕ .isPropValued k a)) , isSetK)
-            ((λ k a → (∣ (`∃[L→K][ p ] ∘ q*) ϕ ∣ k a) , ((`∃[L→K][ p ] ∘ q*) ϕ .isPropValued k a)) , isSetK)
-            (funExt₂
-              (λ k a →
-                Σ≡Prop
-                  (λ x → isPropIsProp {A = x})
-                  (hPropExt
-                    (g* (`∃[J→I][ f ] ϕ) .isPropValued k a)
-                    (`∃[L→K][ p ] (q* ϕ) .isPropValued k a)
-                    (`∃BeckChevalley→ ϕ k a)
-                    (`∃BeckChevalley← ϕ k a))))
-           i)
-
-    `∀BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k
-    `∀BeckChevalley→ ϕ k a p b (k' , j , gk'≡fj) k'≡k = p b j (sym (subst (λ k'' → g k'' ≡ f j) k'≡k gk'≡fj))
-
-    `∀BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k
-    `∀BeckChevalley← ϕ k a p b j fj≡gk = p b (k , j , sym fj≡gk) refl
-
-    `∀BeckChevalley : g* ∘ `∀[J→I][ f ] ≡ `∀[L→K][ p ] ∘ q*
-    `∀BeckChevalley =
-      funExt λ ϕ i →
-        PredicateIsoΣ K .inv
-          (PredicateΣ≡ {ℓ'' = ℓ''} K
-            ((λ k a → (a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k) , (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)) , isSetK)
-            ((λ k a → (a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k) , (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)) , isSetK)
-            (funExt₂
-              (λ k a →
-                Σ≡Prop
-                  (λ x → isPropIsProp {A = x})
-                  (hPropExt
-                    (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)
-                    (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)
-                    (`∀BeckChevalley→ ϕ k a)
-                    (`∀BeckChevalley← ϕ k a))))
-          i)
+    L = Σ[ k ∈ K ] Σ[ j ∈ J ] (g k ≡ f j)
+
+    isSetL : isSet L
+    isSetL = isSetΣ isSetK λ k → isSetΣ isSetJ λ j → isProp→isSet (isSetI _ _)
+
+    p : L → K
+    p (k , _ , _) = k
+
+    q : L → J
+    q (_ , l , _) = l
+
+    q* = ⋆_ isSetL isSetJ q
+    g* = ⋆_ isSetK isSetI g
+
+    module `f = Morphism' isSetJ isSetI
+    open `f renaming (`∃[_] to `∃[J→I][_]; `∀[_] to `∀[J→I][_])
+
+    module `q = Morphism' isSetL isSetK
+    open `q renaming (`∃[_] to `∃[L→K][_]; `∀[_] to `∀[L→K][_])
+
+    `∃BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k
+    `∃BeckChevalley→ ϕ k a p =
+      do
+        (j , fj≡gk , a⊩ϕj) ← p
+        return ((k , (j , (sym fj≡gk))) , (refl , a⊩ϕj))
+
+    `∃BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∃[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∃[J→I][ f ] ϕ) ∣ k
+    `∃BeckChevalley← ϕ k a p =
+      do
+        (x@(k' , j , gk'≡fj) , k'≡k , a⊩ϕqj) ← p
+        return (j , (subst (λ k → f j ≡ g k) k'≡k (sym gk'≡fj)) , a⊩ϕqj)
+
+    open Iso
+    `∃BeckChevalley : g* ∘ `∃[J→I][ f ] ≡ `∃[L→K][ p ] ∘ q*
+    `∃BeckChevalley =
+      funExt λ ϕ i →
+        PredicateIsoΣ K .inv
+          (PredicateΣ≡  K
+            ((λ k a → (∣ (g* ∘ `∃[J→I][ f ]) ϕ ∣ k a) , ((g* ∘ `∃[J→I][ f ]) ϕ .isPropValued k a)) , isSetK)
+            ((λ k a → (∣ (`∃[L→K][ p ] ∘ q*) ϕ ∣ k a) , ((`∃[L→K][ p ] ∘ q*) ϕ .isPropValued k a)) , isSetK)
+            (funExt₂
+              (λ k a →
+                Σ≡Prop
+                  (λ x → isPropIsProp {A = x})
+                  (hPropExt
+                    (g* (`∃[J→I][ f ] ϕ) .isPropValued k a)
+                    (`∃[L→K][ p ] (q* ϕ) .isPropValued k a)
+                    (`∃BeckChevalley→ ϕ k a)
+                    (`∃BeckChevalley← ϕ k a))))
+           i)
+
+    `∀BeckChevalley→ : ∀ ϕ k a → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k
+    `∀BeckChevalley→ ϕ k a p b (k' , j , gk'≡fj) k'≡k = p b j (sym (subst (λ k'' → g k'' ≡ f j) k'≡k gk'≡fj))
+
+    `∀BeckChevalley← : ∀ ϕ k a → a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k → a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k
+    `∀BeckChevalley← ϕ k a p b j fj≡gk = p b (k , j , sym fj≡gk) refl
+
+    `∀BeckChevalley : g* ∘ `∀[J→I][ f ] ≡ `∀[L→K][ p ] ∘ q*
+    `∀BeckChevalley =
+      funExt λ ϕ i →
+        PredicateIsoΣ K .inv
+          (PredicateΣ≡ K
+            ((λ k a → (a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k) , (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)) , isSetK)
+            ((λ k a → (a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k) , (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)) , isSetK)
+            (funExt₂
+              (λ k a →
+                Σ≡Prop
+                  (λ x → isPropIsProp {A = x})
+                  (hPropExt
+                    (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)
+                    (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)
+                    (`∀BeckChevalley→ ϕ k a)
+                    (`∀BeckChevalley← ϕ k a))))
+          i)
\ No newline at end of file diff --git a/docs/Realizability.Tripos.Prealgebra.Predicate.html b/docs/Realizability.Tripos.Prealgebra.Predicate.html index 1f6df21..88eab61 100644 --- a/docs/Realizability.Tripos.Prealgebra.Predicate.html +++ b/docs/Realizability.Tripos.Prealgebra.Predicate.html @@ -2,8 +2,8 @@ Realizability.Tripos.Prealgebra.Predicate
open import Realizability.CombinatoryAlgebra
 open import Cubical.Foundations.Prelude
 
-module Realizability.Tripos.Prealgebra.Predicate {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
+module Realizability.Tripos.Prealgebra.Predicate {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where
 
-open import Realizability.Tripos.Prealgebra.Predicate.Base ca public
-open import Realizability.Tripos.Prealgebra.Predicate.Properties ca public
+open import Realizability.Tripos.Prealgebra.Predicate.Base {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca public
+open import Realizability.Tripos.Prealgebra.Predicate.Properties {ℓ' = ℓ'} {ℓ'' = ℓ''} ca public
\ No newline at end of file diff --git a/docs/index.html b/docs/index.html index b4c0290..b05e2a9 100644 --- a/docs/index.html +++ b/docs/index.html @@ -2,15 +2,8 @@ index
{-# OPTIONS --cubical #-}
 module index where
 
---open import Realizability.Partiality
---open import Realizability.PartialApplicativeStructure
---open import Realizability.PartialCombinatoryAlgebra
-open import Realizability.CombinatoryAlgebra
-open import Realizability.ApplicativeStructure
-open import Realizability.Assembly.Everything
-open import Realizability.Tripos.Everything
-open import Realizability.Choice
-open import Tripoi.Tripos
-open import Tripoi.HeytingAlgebra
-open import Tripoi.PosetReflection
+open import Realizability.CombinatoryAlgebra
+open import Realizability.ApplicativeStructure
+open import Realizability.Topos.Everything
+open import Realizability.Choice
\ No newline at end of file diff --git a/src/Experiments/Counterexample.agda b/src/Experiments/Counterexample.agda new file mode 100644 index 0000000..e02a410 --- /dev/null +++ b/src/Experiments/Counterexample.agda @@ -0,0 +1,10 @@ +module Experiments.Counterexample where + +open import Cubical.Foundations.Prelude +open import Cubical.HITs.SetQuotients as SQ +open import Cubical.Data.Nat +open import Cubical.Data.Nat.IsEven +open import Cubical.Data.Sigma +open import Cubical.Data.Bool +open import Cubical.Data.Sum as Sum + diff --git a/src/Realizability/ApplicativeStructure.agda b/src/Realizability/ApplicativeStructure.agda index 9bece44..d44bcbc 100644 --- a/src/Realizability/ApplicativeStructure.agda +++ b/src/Realizability/ApplicativeStructure.agda @@ -1,16 +1,34 @@ -{-# OPTIONS --cubical --without-K --allow-unsolved-metas #-} open import Cubical.Core.Everything open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Relation.Nullary open import Cubical.Data.Nat open import Cubical.Data.Nat.Order -open import Cubical.Data.Fin +open import Cubical.Data.FinData open import Cubical.Data.Vec open import Cubical.Data.Empty renaming (elim to ⊥elim) +open import Cubical.Tactics.NatSolver module Realizability.ApplicativeStructure where +private module _ {ℓ} {A : Type ℓ} where + -- Taken from Data.Vec.Base from agda-stdlib + foldlOp : ∀ {ℓ'} (B : ℕ → Type ℓ') → Type _ + foldlOp B = ∀ {n} → B n → A → B (suc n) + + opaque + foldl : ∀ {ℓ'} {n : ℕ} (B : ℕ → Type ℓ') → foldlOp B → B zero → Vec A n → B n + foldl {ℓ'} {.zero} B op acc emptyVec = acc + foldl {ℓ'} {.(suc _)} B op acc (x ∷vec vec) = foldl (λ n → B (suc n)) op (op acc x) vec + + opaque + reverse : ∀ {n} → Vec A n → Vec A n + reverse vec = foldl (λ n → Vec A n) (λ acc curr → curr ∷ acc) [] vec + + opaque + chain : ∀ {n} → Vec A (suc n) → (A → A → A) → A + chain {n} (x ∷vec vec) op = foldl (λ _ → A) (λ acc curr → op acc curr) x vec + record ApplicativeStructure {ℓ} (A : Type ℓ) : Type ℓ where infixl 20 _⨾_ field @@ -26,33 +44,24 @@ module _ {ℓ} {A : Type ℓ} (as : ApplicativeStructure A) where `_ : A → Term n _̇_ : Term n → Term n → Term n - upgrade : ∀ {n m} → n < m → Term n → Term m - upgrade _ (` a) = ` a - upgrade {n} {m} n ∈ₓ + Γ _| Γ + | | + | | + | | + | [ incϕ ] | [ inc∈ ] + | | + | | + | | + (X × Y) - - - - - - - - - -> (X × 𝓟 X) + idₓ × [ F ] + -} + module PowerObjectUnivProp + {Y : Type ℓ} + (perY : PartialEquivalenceRelation Y) + (ϕ : StrictRelation (binProdObRT perX perY)) where + + open InducedSubobject (binProdObRT perX perY) ϕ + renaming + ( subPer to ϕsubPer + ; incFuncRel to ϕincFuncRel + ; isInjectiveIncFuncRel to isInjectiveϕIncFuncRel + ; isMonicInc to isMonicIncϕ) + + opaque + unfolding binProdObRT + unfolding idFuncRel + {-# TERMINATING #-} + topArrowFuncRel : FunctionalRelation ϕsubPer ∈subPer + Predicate.isSetX (relation topArrowFuncRel) = isSet× (isSet× (perX .isSetX) (perY .isSetX)) (isSet× (perX .isSetX) isSetResizedPredicate) + Predicate.∣ relation topArrowFuncRel ∣ ((x , y) , (x' , p)) r = + (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × + (pr₁ ⨾ (pr₂ ⨾ r)) ⊩ ∣ toPredicate p ∣ x × + (pr₂ ⨾ (pr₂ ⨾ r)) ⊩ ∣ ϕ .predicate ∣ (x , y) + Predicate.isPropValued (relation topArrowFuncRel) ((x , y) , (x' , p)) r = + isProp× + (perX .equality .isPropValued _ _) + (isProp× + (toPredicate p .isPropValued _ _) + (ϕ .predicate .isPropValued _ _)) + isFunctionalRelation.isStrictDomain (isFuncRel topArrowFuncRel) = + do + (stX , stX⊩isStrictDomainEqX) ← idFuncRel perX .isStrictDomain + (stY , stY⊩isStrictDomainEqY) ← idFuncRel perY .isStrictDomain + return + ({!!} , + (λ { (x , y) (x' , p) r (⊩x~x' , ⊩ϕxy , ⊩px) → + (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) {!!} (stX⊩isStrictDomainEqX x x' _ ⊩x~x') , + {!subst !}) , + {!!}})) + isFunctionalRelation.isStrictCodomain (isFuncRel topArrowFuncRel) = {!!} + isFunctionalRelation.isRelational (isFuncRel topArrowFuncRel) = {!!} + isFunctionalRelation.isSingleValued (isFuncRel topArrowFuncRel) = {!!} + isFunctionalRelation.isTotal (isFuncRel topArrowFuncRel) = {!!} + + powerObjectCospan : RTMorphism (binProdObRT perX perY) (binProdObRT perX 𝓟) → Cospan RT + Cospan.l (powerObjectCospan f) = X × Y , binProdObRT perX perY + Cospan.m (powerObjectCospan f) = X × ResizedPredicate X , binProdObRT perX 𝓟 + Cospan.r (powerObjectCospan f) = X × ResizedPredicate X , ∈subPer + Cospan.s₁ (powerObjectCospan f) = f + Cospan.s₂ (powerObjectCospan f) = [ ∈incFuncRel ] + + F : FunctionalRelation (binProdObRT perX perY) (binProdObRT perX 𝓟) + Predicate.isSetX (relation F) = isSet× (isSet× (perX .isSetX) (perY .isSetX)) (isSet× (perX .isSetX) isSetResizedPredicate) + Predicate.∣ relation F ∣ ((x , y) , (x' , p)) r = (pr₁ ⨾ (pr₁ ⨾ r)) ⊩ ∣ perY .equality ∣ (y , y) × (pr₂ ⨾ (pr₁ ⨾ r)) ⊩ ∣ 𝓟 .equality ∣ (p , p) × {!∀ !} × {!!} + Predicate.isPropValued (relation F) = {!!} + isFunctionalRelation.isStrictDomain (isFuncRel F) = {!!} + isFunctionalRelation.isStrictCodomain (isFuncRel F) = {!!} + isFunctionalRelation.isRelational (isFuncRel F) = {!!} + isFunctionalRelation.isSingleValued (isFuncRel F) = {!!} + isFunctionalRelation.isTotal (isFuncRel F) = {!!} + + opaque + unfolding composeRTMorphism + unfolding composeFuncRel + pullbackSquareCommutes : [ ϕincFuncRel ] ⋆ [ F ] ≡ [ topArrowFuncRel ] ⋆ [ ∈incFuncRel ] + pullbackSquareCommutes = + eq/ _ _ {!!} + + isPowerObjectUnivProp : Type _ + isPowerObjectUnivProp = + ∃![ f ∈ RTMorphism (binProdObRT perX perY) (binProdObRT perX 𝓟) ] + Σ[ commutes ∈ [ ϕincFuncRel ] ⋆ f ≡ [ topArrowFuncRel ] ⋆ [ ∈incFuncRel ] ] + (isPullback RT (powerObjectCospan f) {c = X × Y , ϕsubPer} [ ϕincFuncRel ] [ topArrowFuncRel ] commutes) + + isPropIsPowerObjectUnivProp : isProp isPowerObjectUnivProp + isPropIsPowerObjectUnivProp = isPropIsContr + + isPowerObject : isPowerObjectUnivProp + isPowerObject = + uniqueExists + [ F ] + (pullbackSquareCommutes , {!!}) + (λ F' → isPropΣ (squash/ _ _) λ commutes → isPropIsPullback RT (powerObjectCospan F') [ ϕincFuncRel ] [ topArrowFuncRel ] commutes) + (λ { f' (commutes , isPullback) → + {!!} }) diff --git a/src/Realizability/Topos/Pullbacks.agda b/src/Realizability/Topos/Pullbacks.agda new file mode 100644 index 0000000..0063c0d --- /dev/null +++ b/src/Realizability/Topos/Pullbacks.agda @@ -0,0 +1,39 @@ +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm; λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) +open import Realizability.CombinatoryAlgebra +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.HLevels +open import Cubical.Foundations.Structure +open import Cubical.Functions.FunExtEquiv +open import Cubical.Data.Unit +open import Cubical.Data.Empty +open import Cubical.Data.Fin +open import Cubical.Data.Vec +open import Cubical.Data.Sigma +open import Cubical.HITs.PropositionalTruncation as PT +open import Cubical.HITs.PropositionalTruncation.Monad +open import Cubical.HITs.SetQuotients as SQ +open import Cubical.Categories.Category +open import Cubical.Categories.Limits.BinProduct + +module Realizability.Topos.Pullbacks + {ℓ ℓ' ℓ''} {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) where + +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial + +open CombinatoryAlgebra ca +open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) +open Predicate renaming (isSetX to isSetPredicateBase) +open PredicateProperties +open Morphism + +private + λ*ComputationRule = `λ*ComputationRule as fefermanStructure + λ* = `λ* as fefermanStructure + +open FunctionalRelation +open PartialEquivalenceRelation + diff --git a/src/Realizability/Topos/ResizedPredicate.agda b/src/Realizability/Topos/ResizedPredicate.agda new file mode 100644 index 0000000..8eb2d7b --- /dev/null +++ b/src/Realizability/Topos/ResizedPredicate.agda @@ -0,0 +1,92 @@ +-- Before we can talk about power objects in RT +-- we need to use propositional resizing to get +-- a copy of A-valued predicates in Type ℓ' + +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.HLevels +open import Cubical.Foundations.Equiv +open import Cubical.Data.Empty +open import Cubical.Data.Sigma +open import Realizability.PropResizing +open import Realizability.CombinatoryAlgebra + +module Realizability.Topos.ResizedPredicate + {ℓ} + {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) + (resizing : hPropResizing ℓ) + where + +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ} {ℓ'' = ℓ} ca +open import Realizability.Topos.Object {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial + +open CombinatoryAlgebra ca +open Predicate renaming (isSetX to isSetPredicateBase) + +smallHProp = resizing .fst +smallHProp≃hProp = resizing .snd + +ResizedPredicate : Type ℓ → Type ℓ +ResizedPredicate X = Σ[ rel ∈ (X → A → smallHProp) ] isSet X + +PredicateΣ≃ResizedPredicate : ∀ X → PredicateΣ X ≃ ResizedPredicate X +PredicateΣ≃ResizedPredicate X = + Σ-cong-equiv-prop + (equivΠ + (idEquiv X) + (λ x → + equivΠ + (idEquiv A) + λ a → + smallHProp≃hProp)) + (λ _ → isPropIsSet) + (λ _ → isPropIsSet) + (λ _ answer → answer) + (λ _ answer → answer) + +Predicate≃ResizedPredicate : ∀ X → Predicate X ≃ ResizedPredicate X +Predicate≃ResizedPredicate X = compEquiv (Predicate≃PredicateΣ X) (PredicateΣ≃ResizedPredicate X) + +isSetResizedPredicate : ∀ {X} → isSet (ResizedPredicate X) +isSetResizedPredicate {X} = isOfHLevelRespectEquiv 2 (Predicate≃ResizedPredicate X) (isSetPredicate X) + +ResizedPredicate≃Predicate : ∀ X → ResizedPredicate X ≃ Predicate X +ResizedPredicate≃Predicate X = invEquiv (Predicate≃ResizedPredicate X) + +toPredicate : ∀ {X} → ResizedPredicate X → Predicate X +toPredicate {X} ϕ = equivFun (ResizedPredicate≃Predicate X) ϕ + +fromPredicate : ∀ {X} → Predicate X → ResizedPredicate X +fromPredicate {X} ϕ = equivFun (Predicate≃ResizedPredicate X) ϕ + +compIsIdEquiv : ∀ X → compEquiv (Predicate≃ResizedPredicate X) (ResizedPredicate≃Predicate X) ≡ idEquiv (Predicate X) +compIsIdEquiv X = invEquiv-is-rinv (Predicate≃ResizedPredicate X) + +compIsIdFunc : ∀ {X} → (p : Predicate X) → toPredicate (fromPredicate p) ≡ p +compIsIdFunc {X} p i = equivFun (compIsIdEquiv X i) p + +module ResizedPredicateProps {X} (perX : PartialEquivalenceRelation X) where + open PartialEquivalenceRelation + + entailmentResizedPredicate : ∀ (ϕ ψ : ResizedPredicate X) → A → Type ℓ + entailmentResizedPredicate ϕ ψ r = ∀ (x : X) (a : A) (⊩ϕx : a ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a) ⊩ ∣ toPredicate ψ ∣ x + + isPropEntailmentResizedPredicate : ∀ ϕ ψ a → isProp (entailmentResizedPredicate ϕ ψ a) + isPropEntailmentResizedPredicate ϕ ψ a = + isPropΠ λ x → isPropΠ λ b → isPropΠ λ _ → (toPredicate ψ) .isPropValued _ _ + + isStrictResizedPredicate : ∀ (ϕ : ResizedPredicate X) → A → Type ℓ + isStrictResizedPredicate ϕ r = ∀ (x : X) (a : A) (⊩ϕx : a ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a) ⊩ ∣ perX .equality ∣ (x , x) + + isPropIsStrictResizedPredicate : ∀ ϕ r → isProp (isStrictResizedPredicate ϕ r) + isPropIsStrictResizedPredicate ϕ r = + isPropΠ λ x → isPropΠ λ a → isPropΠ λ _ → perX .equality .isPropValued _ _ + + isRelationalResizedPredicate : ∀ (ϕ : ResizedPredicate X) → A → Type ℓ + isRelationalResizedPredicate ϕ r = + ∀ (x x' : X) (a b : A) (⊩x~x' : a ⊩ ∣ perX .equality ∣ (x , x')) (⊩ϕx : b ⊩ ∣ toPredicate ϕ ∣ x) → (r ⨾ a ⨾ b) ⊩ ∣ toPredicate ϕ ∣ x' + + isPropIsRelationalResizedPredicate : ∀ ϕ r → isProp (isRelationalResizedPredicate ϕ r) + isPropIsRelationalResizedPredicate ϕ r = + isPropΠ λ x → isPropΠ λ x' → isPropΠ λ a → isPropΠ λ b → isPropΠ λ _ → isPropΠ λ _ → toPredicate ϕ .isPropValued _ _ diff --git a/src/Realizability/Topos/StrictRelation.agda b/src/Realizability/Topos/StrictRelation.agda new file mode 100644 index 0000000..fdd4b2f --- /dev/null +++ b/src/Realizability/Topos/StrictRelation.agda @@ -0,0 +1,632 @@ +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm) +open import Realizability.CombinatoryAlgebra +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.Structure +open import Cubical.Foundations.HLevels +open import Cubical.Foundations.Equiv +open import Cubical.Functions.FunExtEquiv +open import Cubical.Data.Vec +open import Cubical.Data.Nat +open import Cubical.Data.FinData +open import Cubical.Data.Fin hiding (Fin; _/_) +open import Cubical.Data.Sigma +open import Cubical.Data.Empty +open import Cubical.Data.Unit +open import Cubical.HITs.PropositionalTruncation +open import Cubical.HITs.PropositionalTruncation.Monad +open import Cubical.HITs.SetQuotients as SQ +open import Cubical.Categories.Category +open import Cubical.Categories.Morphism +open import Cubical.Categories.Constructions.SubObject +open import Cubical.Categories.Constructions.Slice +open import Cubical.Relation.Binary + +module Realizability.Topos.StrictRelation + {ℓ ℓ' ℓ''} + {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) + where + +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Topos.Object {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.Equalizer {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.BinProducts {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.MonicReprFuncRel {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial + +open CombinatoryAlgebra ca +open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) +open Predicate renaming (isSetX to isSetPredicateBase) +open Morphism +open PartialEquivalenceRelation +open FunctionalRelation +open Category RT + +record isStrictRelation {X : Type ℓ'} (perX : PartialEquivalenceRelation X) (ϕ : Predicate X) : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) where + field + isStrict : ∃[ st ∈ A ] (∀ x r → r ⊩ ∣ ϕ ∣ x → (st ⨾ r) ⊩ ∣ perX .equality ∣ (x , x)) + isRelational : ∃[ rel ∈ A ] (∀ x x' r s → r ⊩ ∣ ϕ ∣ x → s ⊩ ∣ perX .equality ∣ (x , x') → (rel ⨾ r ⨾ s) ⊩ ∣ ϕ ∣ x') + +record StrictRelation {X : Type ℓ'} (perX : PartialEquivalenceRelation X) : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-suc ℓ') (ℓ-suc ℓ''))) where + field + predicate : Predicate X + isStrictRelationPredicate : isStrictRelation perX predicate + open isStrictRelation isStrictRelationPredicate public + +-- Every strict relation induces a subobject +module InducedSubobject {X : Type ℓ'} (perX : PartialEquivalenceRelation X) (ϕ : StrictRelation perX) where + open StrictRelation + -- the subobject induced by ϕ + {-# TERMINATING #-} + subPer : PartialEquivalenceRelation X + Predicate.isSetX (equality subPer) = isSet× (perX .isSetX) (perX .isSetX) + ∣ equality subPer ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ ϕ .predicate ∣ x + isPropValued (equality subPer) (x , x') r = isProp× (perX .equality .isPropValued _ _) (ϕ .predicate .isPropValued _ _) + isPartialEquivalenceRelation.isSetX (isPerEquality subPer) = perX .isSetX + isPartialEquivalenceRelation.isSymmetric (isPerEquality subPer) = + do + -- Trivial : use symmetry of ~X and relationality of ϕ + (s , s⊩isSymmetricX) ← perX .isSymmetric + (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` s ̇ (` pr₁ ̇ # zero)) ̇ (` relϕ ̇ (` pr₂ ̇ # zero) ̇ (` pr₁ ̇ # zero)) + return + (λ* realizer , + (λ { x x' r (pr₁r⊩x~x' , pr₂r⊩ϕx) → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (s⊩isSymmetricX x x' _ pr₁r⊩x~x') , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x') + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + (relϕ⊩isRelationalϕ x x' _ _ pr₂r⊩ϕx pr₁r⊩x~x') })) + isPartialEquivalenceRelation.isTransitive (isPerEquality subPer) = + do + (t , t⊩isTransitiveX) ← perX .isTransitive + (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational + let + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # one) + return + (λ*2 realizer , + (λ { x₁ x₂ x₃ a b (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₂~x₃ , ⊩ϕx₂) → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₃)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer a b) ∙ pr₁pxy≡x _ _)) + (t⊩isTransitiveX x₁ x₂ x₃ _ _ ⊩x₁~x₂ ⊩x₂~x₃) , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₁) + (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer a b) ∙ pr₂pxy≡y _ _)) + ⊩ϕx₁ })) + + opaque + unfolding idFuncRel + {-# TERMINATING #-} + incFuncRel : FunctionalRelation subPer perX + Predicate.isSetX (relation incFuncRel) = isSet× (perX .isSetX) (perX .isSetX) + Predicate.∣ relation incFuncRel ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × (pr₂ ⨾ r) ⊩ ∣ ϕ .predicate ∣ x + Predicate.isPropValued (relation incFuncRel) (x , x') r = isProp× (perX .equality .isPropValued _ _) (ϕ .predicate .isPropValued _ _) + isFunctionalRelation.isStrictDomain (isFuncRel incFuncRel) = + do + (stD , stD⊩isStrictDomain) ← idFuncRel perX .isStrictDomain + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero) + return + (λ* realizer , + (λ { x x' r (⊩x~x' , ⊩ϕx) → + (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) (stD⊩isStrictDomain x x' _ ⊩x~x')) , + (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx) })) + isFunctionalRelation.isStrictCodomain (isFuncRel incFuncRel) = + do + (stC , stC⊩isStrictCodomain) ← idFuncRel perX .isStrictCodomain + let + realizer : ApplStrTerm as 1 + realizer = ` stC ̇ (` pr₁ ̇ # zero) + return + (λ* realizer , + (λ { x x' r (⊩x~x' , ⊩ϕx) → subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x')) (sym (λ*ComputationRule realizer r)) (stC⊩isStrictCodomain x x' _ ⊩x~x')})) + isFunctionalRelation.isRelational (isFuncRel incFuncRel) = + do + (relX , relX⊩isRelationalX) ← idFuncRel perX .isRelational + (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational + let + realizer : ApplStrTerm as 3 + realizer = ` pair ̇ (` relX ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ # zero) ̇ (` relϕ ̇ (` pr₂ ̇ # two) ̇ (` pr₁ ̇ # two)) + return + (λ*3 realizer , + (λ { x₁ x₂ x₃ x₄ a b c (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₁~x₃ , ⊩ϕx₁') c⊩x₃~x₄ → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _)) + (relX⊩isRelationalX x₁ x₂ x₃ x₄ _ _ _ ⊩x₁~x₂ ⊩x₁~x₃ c⊩x₃~x₄) , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₂) + (sym (cong (λ x → pr₂ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₂pxy≡y _ _)) + (relϕ⊩isRelationalϕ x₁ x₂ _ _ ⊩ϕx₁ ⊩x₁~x₂) })) + isFunctionalRelation.isSingleValued (isFuncRel incFuncRel) = + do + (sv , sv⊩isSingleValuedX) ← idFuncRel perX .isSingleValued + let + realizer : ApplStrTerm as 2 + realizer = ` sv ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero) + return + (λ*2 realizer , + (λ { x x' x'' r₁ r₂ (⊩x~x' , ⊩ϕx) (⊩x~x'' , ⊩ϕx') → + subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x'')) (sym (λ*2ComputationRule realizer r₁ r₂)) (sv⊩isSingleValuedX x x' x'' _ _ ⊩x~x' ⊩x~x'') })) + isFunctionalRelation.isTotal (isFuncRel incFuncRel) = + do + return + (Id , + (λ { x r (pr₁r⊩x~x , pr₂r⊩ϕx) → + return + (x , + subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (cong (λ x → pr₁ ⨾ x) (sym (Ida≡a _))) pr₁r⊩x~x , + subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (cong (λ x → pr₂ ⨾ x) (sym (Ida≡a _))) pr₂r⊩ϕx) })) + + opaque + unfolding isInjectiveFuncRel + unfolding incFuncRel + isInjectiveIncFuncRel : isInjectiveFuncRel subPer perX incFuncRel + isInjectiveIncFuncRel = + do + (t , t⊩isTransitiveX) ← perX .isTransitive + (s , s⊩isSymmetricX) ← perX .isSymmetric + let + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ # one) ̇ (` s ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ # one) + return + (λ*2 realizer , + (λ x₁ x₂ x₃ r₁ r₂ (⊩x₁~x₃ , ⊩ϕx₁) (⊩x₂~x₃ , ⊩ϕx₂) → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x₁ , x₂)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _)) + (t⊩isTransitiveX x₁ x₃ x₂ _ _ ⊩x₁~x₃ (s⊩isSymmetricX x₂ x₃ _ ⊩x₂~x₃)) , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₁) + (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _)) + ⊩ϕx₁)) + + isMonicInc : isMonic RT [ incFuncRel ] + isMonicInc = isInjectiveFuncRel→isMonic subPer perX incFuncRel isInjectiveIncFuncRel + +-- Every subobject representing functional relation is isomorphic (as a subobject) to a subobject induced by a strict relation +module SubobjectIsoMonicFuncRel + {X Y : Type ℓ'} + (perX : PartialEquivalenceRelation X) + (perY : PartialEquivalenceRelation Y) + (F : FunctionalRelation perY perX) + (isMonicF : isMonic RT [ F ]) where + + {-# TERMINATING #-} + ψ : StrictRelation perX + Predicate.isSetX (StrictRelation.predicate ψ) = perX .isSetX + Predicate.∣ StrictRelation.predicate ψ ∣ x r = ∃[ y ∈ Y ] r ⊩ ∣ F .relation ∣ (y , x) + Predicate.isPropValued (StrictRelation.predicate ψ) x r = isPropPropTrunc + isStrictRelation.isStrict (StrictRelation.isStrictRelationPredicate ψ) = + do + (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain + return + (stCF , + (λ x r r⊩∃y → + transport + (propTruncIdempotent (perX .equality .isPropValued _ _)) + (do + (y , ⊩Fyx) ← r⊩∃y + return (stCF⊩isStrictCodomainF y x _ ⊩Fyx)))) + isStrictRelation.isRelational (StrictRelation.isStrictRelationPredicate ψ) = + do + (relF , relF⊩isRelationalF) ← F .isRelational + (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain + let + realizer : ApplStrTerm as 2 + realizer = ` relF ̇ (` stDF ̇ # one) ̇ # one ̇ # zero + return + (λ*2 realizer , + (λ x x' r s r⊩∃y s⊩x~x' → + do + (y , ⊩Fyx) ← r⊩∃y + return + (y , + subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x')) + (sym (λ*2ComputationRule realizer r s)) + (relF⊩isRelationalF y y x x' _ _ _ (stDF⊩isStrictDomainF y x _ ⊩Fyx) ⊩Fyx s⊩x~x')))) + + perψ : PartialEquivalenceRelation X + perψ = InducedSubobject.subPer perX ψ + + -- ≤ as subobjects + -- TODO : formalise the preorder category of subobjects + {-# TERMINATING #-} + perY≤perψFuncRel : FunctionalRelation perY perψ + Predicate.isSetX (relation perY≤perψFuncRel) = isSet× (perY .isSetX) (perX .isSetX) + Predicate.∣ relation perY≤perψFuncRel ∣ = ∣ F .relation ∣ + Predicate.isPropValued (relation perY≤perψFuncRel) = F .relation .isPropValued + isFunctionalRelation.isStrictDomain (isFuncRel perY≤perψFuncRel) = + isFunctionalRelation.isStrictDomain (F .isFuncRel) + isFunctionalRelation.isStrictCodomain (isFuncRel perY≤perψFuncRel) = + do + (stCF , stCF⊩isStrictCodomain) ← F .isStrictCodomain + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stCF ̇ # zero) ̇ # zero + return + (λ* realizer , + (λ y x r ⊩Fyx → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (stCF⊩isStrictCodomain y x _ ⊩Fyx) , + ∣ y , + subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + ⊩Fyx ∣₁)) + isFunctionalRelation.isRelational (isFuncRel perY≤perψFuncRel) = + do + (relF , relF⊩isRelationalF) ← F .isRelational + let + realizer : ApplStrTerm as 3 + realizer = ` relF ̇ # two ̇ # one ̇ (` pr₁ ̇ # zero) + return + (λ*3 realizer , + (λ { y y' x x' a b c ⊩y~y' ⊩Fyx (⊩x~x' , ⊩Fy''x) → + subst (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x')) (sym (λ*3ComputationRule realizer a b c)) (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x') })) + isFunctionalRelation.isSingleValued (isFuncRel perY≤perψFuncRel) = + do + (svF , svF⊩isSingleValuedF) ← F .isSingleValued + let + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ (` svF ̇ # one ̇ # zero) ̇ # one + return + (λ*2 realizer , + (λ y x x' r₁ r₂ ⊩Fyx ⊩Fyx' → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _)) + (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') , + ∣ y , + (subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) + (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _)) + ⊩Fyx) ∣₁)) + isFunctionalRelation.isTotal (isFuncRel perY≤perψFuncRel) = + do + (tlF , tlF⊩isTotalF) ← F .isTotal + return + (tlF , + (λ y r ⊩y~y → + do + (x , ⊩Fyx) ← tlF⊩isTotalF y _ ⊩y~y + return (x , ⊩Fyx))) + + -- perY truly is ≤ perψ + opaque + unfolding composeRTMorphism + unfolding InducedSubobject.incFuncRel + perY≤perψCommutes : [ perY≤perψFuncRel ] ⋆ [ InducedSubobject.incFuncRel perX ψ ] ≡ [ F ] + perY≤perψCommutes = + let + answer = + do + (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain + (relF , relF⊩isRelationalF) ← F .isRelational + let + realizer : ApplStrTerm as 1 + realizer = ` relF ̇ (` stDF ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)) + return + (λ* realizer , + (λ y x r r⊩∃x' → + transport + (propTruncIdempotent (F .relation .isPropValued _ _)) + (do + (x' , ⊩Fyx' , ⊩x'~x , ⊩ψx') ← r⊩∃x' + return + (subst + (λ r → r ⊩ ∣ F .relation ∣ (y , x)) + (sym (λ*ComputationRule realizer r)) + (relF⊩isRelationalF y y x' x _ _ _ (stDF⊩isStrictDomainF y x' _ ⊩Fyx') ⊩Fyx' ⊩x'~x))))) + in + eq/ _ _ (answer , F≤G→G≤F perY perX (composeFuncRel _ _ _ perY≤perψFuncRel (InducedSubobject.incFuncRel perX ψ)) F answer) + + opaque + unfolding isInjectiveFuncRel + {-# TERMINATING #-} + perψ≤perYFuncRel : FunctionalRelation perψ perY + Predicate.isSetX (relation perψ≤perYFuncRel) = isSet× (perX .isSetX) (perY .isSetX) + Predicate.∣ relation perψ≤perYFuncRel ∣ (x , y) r = r ⊩ ∣ F .relation ∣ (y , x) + Predicate.isPropValued (relation perψ≤perYFuncRel) (x , y) r = F .relation .isPropValued _ _ + isFunctionalRelation.isStrictDomain (isFuncRel perψ≤perYFuncRel) = + do + (stCF , stCF⊩isStrictCodomainF) ← F .isStrictCodomain + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stCF ̇ # zero) ̇ # zero + return + (λ* realizer , + (λ x y r ⊩Fyx → + (subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (stCF⊩isStrictCodomainF y x _ ⊩Fyx)) , + (return + (y , + (subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + ⊩Fyx))))) + isFunctionalRelation.isStrictCodomain (isFuncRel perψ≤perYFuncRel) = + do + (stDF , stDF⊩isStrictDomainF) ← F .isStrictDomain + return + (stDF , + (λ x y r ⊩Fyx → stDF⊩isStrictDomainF y x _ ⊩Fyx)) + isFunctionalRelation.isRelational (isFuncRel perψ≤perYFuncRel) = + do + (relF , relF⊩isRelationalF) ← F .isRelational + let + realizer : ApplStrTerm as 3 + realizer = ` relF ̇ # zero ̇ # one ̇ (` pr₁ ̇ # two) + return + (λ*3 realizer , + (λ { x x' y y' a b c (⊩x~x' , ⊩ψx) ⊩Fyx ⊩y~y' → + subst (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x')) (sym (λ*3ComputationRule realizer a b c)) (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x') })) + isFunctionalRelation.isSingleValued (isFuncRel perψ≤perYFuncRel) = + let + isInjectiveFuncRelF = isMonic→isInjectiveFuncRel perY perX F isMonicF + in + do + (injF , injF⊩isInjectiveF) ← isInjectiveFuncRelF + return + (injF , + (λ x y y' r₁ r₂ ⊩Fyx ⊩Fy'x → + injF⊩isInjectiveF y y' x _ _ ⊩Fyx ⊩Fy'x)) + isFunctionalRelation.isTotal (isFuncRel perψ≤perYFuncRel) = + return + (pr₂ , + (λ { x r (⊩x~x , ⊩ψx) → ⊩ψx })) + + opaque + unfolding composeRTMorphism + unfolding composeFuncRel + unfolding InducedSubobject.incFuncRel + unfolding perψ≤perYFuncRel + perψ≤perYCommutes : [ perψ≤perYFuncRel ] ⋆ [ F ] ≡ [ InducedSubobject.incFuncRel perX ψ ] + perψ≤perYCommutes = + let + answer = + do + (svF , svF⊩isSingleValuedF) ← F .isSingleValued + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` svF ̇ (` pr₁ ̇ # zero) ̇ (` pr₂ ̇ # zero)) ̇ (` pr₁ ̇ # zero) + return + (λ* realizer , + (λ x x' r r⊩∃y → + transport + (propTruncIdempotent (isProp× (perX .equality .isPropValued _ _) isPropPropTrunc)) + (do + (y , ⊩Fyx , ⊩Fyx') ← r⊩∃y + return + (subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') , + return + (y , + (subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + ⊩Fyx)))))) + in + eq/ _ _ (answer , F≤G→G≤F perψ perX (composeFuncRel _ _ _ perψ≤perYFuncRel F) (InducedSubobject.incFuncRel perX ψ) answer) + +-- For strict relations, subobject inclusion is identified with pointwise entailment +module InclusionEntailment + {X : Type ℓ'} + (perX : PartialEquivalenceRelation X) + (ϕ ψ : StrictRelation perX) where + open StrictRelation + open PredicateProperties X + SubObjX = SubObjCat RT (X , perX) + SubObjHom = Category.Hom[_,_] SubObjX + + perϕ = InducedSubobject.subPer perX ϕ + perψ = InducedSubobject.subPer perX ψ + + incϕ = InducedSubobject.incFuncRel perX ϕ + incψ = InducedSubobject.incFuncRel perX ψ + + ϕsubObject : Category.ob SubObjX + ϕsubObject = sliceob [ InducedSubobject.incFuncRel perX ϕ ] , InducedSubobject.isMonicInc perX ϕ + + ψsubObject : Category.ob SubObjX + ψsubObject = sliceob [ InducedSubobject.incFuncRel perX ψ ] , InducedSubobject.isMonicInc perX ψ + + opaque + unfolding composeRTMorphism + unfolding composeFuncRel + unfolding InducedSubobject.incFuncRel + SubObjHom→ϕ≤ψ : SubObjHom ϕsubObject ψsubObject → (ϕ .predicate ≤ ψ .predicate) + SubObjHom→ϕ≤ψ (slicehom f f⋆incψ≡incϕ) = + SQ.elimProp + {P = λ f → (f ⋆ [ incψ ] ≡ [ incϕ ]) → ϕ .predicate ≤ ψ .predicate} + (λ f → isPropΠ λ f⋆incψ≡incϕ → isProp≤ (ϕ .predicate) (ψ .predicate)) + (λ F F⋆incψ≡incϕ → + let + (p , q) = + SQ.effective + (isPropValuedBientailment (InducedSubobject.subPer perX ϕ) perX) + (isEquivRelBientailment (InducedSubobject.subPer perX ϕ) perX) + (composeFuncRel _ _ _ F incψ) + incϕ + F⋆incψ≡incϕ + in + do + (stϕ , stϕ⊩isStrictϕ) ← ϕ .isStrict + (relψ , relψ⊩isRelationalψ) ← ψ .isRelational + (q , q⊩incϕ≤F⋆incψ) ← q + let + realizer : ApplStrTerm as 1 + realizer = ` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ (` q ̇ (` pair ̇ (` stϕ ̇ # zero) ̇ # zero)))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` q ̇ (` pair ̇ (` stϕ ̇ # zero) ̇ # zero)))) + return + (λ* realizer , + (λ x a a⊩ϕx → + transport + (propTruncIdempotent (ψ .predicate .isPropValued _ _)) + (do + (x' , ⊩Fxx' , ⊩x'~x , ⊩ψx') ← + q⊩incϕ≤F⋆incψ + x x + (pair ⨾ (stϕ ⨾ a) ⨾ a) + ((subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (pr₁pxy≡x _ _)) (stϕ⊩isStrictϕ x a a⊩ϕx)) , + (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (pr₂pxy≡y _ _)) a⊩ϕx)) + return (subst (λ r' → r' ⊩ ∣ ψ .predicate ∣ x) (sym (λ*ComputationRule realizer a)) (relψ⊩isRelationalψ x' x _ _ ⊩ψx' ⊩x'~x)))))) + f + f⋆incψ≡incϕ + + module _ (ϕ≤ψ : ϕ .predicate ≤ ψ .predicate) where opaque + unfolding idFuncRel + unfolding composeRTMorphism + unfolding composeFuncRel + unfolding InducedSubobject.incFuncRel + + {-# TERMINATING #-} + funcRel : FunctionalRelation perϕ perψ + Predicate.isSetX (relation funcRel) = isSet× (perX .isSetX) (perX .isSetX) + Predicate.∣ relation funcRel ∣ (x , x') r = (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x') × ((pr₁ ⨾ (pr₂ ⨾ r)) ⊩ ∣ ϕ .predicate ∣ x) × ((pr₂ ⨾ (pr₂ ⨾ r)) ⊩ ∣ ψ .predicate ∣ x) + Predicate.isPropValued (relation funcRel) (x , x') r = isProp× (perX .equality .isPropValued _ _) (isProp× (ϕ .predicate .isPropValued _ _) (ψ .predicate .isPropValued _ _)) + isFunctionalRelation.isStrictDomain (isFuncRel funcRel) = + do + (stϕ , stϕ⊩isStrictϕ) ← ϕ .isStrict + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stϕ ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)) + return + (λ* realizer , + (λ { x x' r (⊩x~x' , ⊩ϕx , ⊩ψx) → + subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) (stϕ⊩isStrictϕ x _ ⊩ϕx) , + subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx})) + isFunctionalRelation.isStrictCodomain (isFuncRel funcRel) = + do + (stCX , stCX⊩isStrictCodomainX) ← idFuncRel perX .isStrictCodomain + (relψ , relψ⊩isRelationalψ) ← ψ .isRelational + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stCX ̇ (` pr₁ ̇ # zero)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # zero)) ̇ (` pr₁ ̇ # zero)) + return + (λ* realizer , + (λ { x x' r (⊩x~x' , ⊩ϕx , ⊩ψx) → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (stCX⊩isStrictCodomainX x x' _ ⊩x~x') , + subst + (λ r' → r' ⊩ ∣ ψ .predicate ∣ x') + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + (relψ⊩isRelationalψ x x' _ _ ⊩ψx ⊩x~x')})) + isFunctionalRelation.isRelational (isFuncRel funcRel) = + do + (relX , relX⊩isRelationalX) ← idFuncRel perX .isRelational + (relϕ , relϕ⊩isRelationalϕ) ← ϕ .isRelational + (relψ , relψ⊩isRelationalψ) ← ψ .isRelational + let + realizer : ApplStrTerm as 3 + realizer = + ` pair ̇ (` relX ̇ (` pr₁ ̇ # two) ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` pair ̇ (` relϕ ̇ (` pr₂ ̇ # two) ̇ (` pr₁ ̇ # two)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` pr₁ ̇ # two))) + return + (λ*3 realizer , + λ { x₁ x₂ x₃ x₄ a b c (⊩x₁~x₂ , ⊩ϕx₁) (⊩x₁~x₃ , ⊩'ϕx₁ , ⊩ψx₁) (⊩x₃~x₄ , ⊩ψx₃) → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₄)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _)) + (relX⊩isRelationalX x₁ x₂ x₃ x₄ _ _ _ ⊩x₁~x₂ ⊩x₁~x₃ ⊩x₃~x₄) , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x₂) + (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule realizer a b c) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _)) + (relϕ⊩isRelationalϕ x₁ x₂ _ _ ⊩ϕx₁ ⊩x₁~x₂) , + subst + (λ r' → r' ⊩ ∣ ψ .predicate ∣ x₂) + (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*3ComputationRule realizer a b c) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _)) + (relψ⊩isRelationalψ x₁ x₂ _ _ ⊩ψx₁ ⊩x₁~x₂)}) + isFunctionalRelation.isSingleValued (isFuncRel funcRel) = + do + (svX , svX⊩isSingleValuedX) ← idFuncRel perX .isSingleValued + (relψ , relψ⊩isRelationalψ) ← ψ .isRelational + let + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ (` svX ̇ (` pr₁ ̇ # one) ̇ (` pr₁ ̇ # zero)) ̇ (` relψ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` pr₁ ̇ # one)) + return + (λ*2 realizer , + (λ { x₁ x₂ x₃ r₁ r₂ (⊩x₁~x₂ , ⊩ϕx , ⊩ψx) (⊩x₁~x₃ , ⊩'ϕx , ⊩'ψx) → + (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x₂ , x₃)) (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _)) (svX⊩isSingleValuedX x₁ x₂ x₃ _ _ ⊩x₁~x₂ ⊩x₁~x₃)) , + subst (λ r' → r' ⊩ ∣ ψ .predicate ∣ x₂) (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _)) (relψ⊩isRelationalψ x₁ x₂ _ _ ⊩ψx ⊩x₁~x₂)})) + isFunctionalRelation.isTotal (isFuncRel funcRel) = + do + (tl , tl⊩isTotalIncψ) ← incψ .isTotal + (s , s⊩ϕ≤ψ) ← ϕ≤ψ + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` pr₁ ̇ # zero) ̇ (` pair ̇ (` pr₂ ̇ # zero) ̇ (` s ̇ (` pr₂ ̇ # zero))) + return + (λ* realizer , + (λ { x r (⊩x~x , ⊩ϕx) → + return + (x , + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + ⊩x~x , + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) + (sym (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₁pxy≡x _ _)) + ⊩ϕx , + subst + (λ r' → r' ⊩ ∣ ψ .predicate ∣ x) + (sym (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₂ ⨾ x) (pr₂pxy≡y _ _) ∙ pr₂pxy≡y _ _)) + (s⊩ϕ≤ψ x _ ⊩ϕx))})) + + funcRel⋆incψ≡incϕ : [ funcRel ] ⋆ [ incψ ] ≡ [ incϕ ] + funcRel⋆incψ≡incϕ = + let + answer = + do + (t , t⊩isTransitiveX) ← perX .isTransitive + let + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` t ̇ (` pr₁ ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) + return + (λ* realizer , + (λ { x x' r ⊩∃x'' → + transport + (propTruncIdempotent (isPropΣ (perX .equality .isPropValued _ _) λ _ → ϕ .predicate .isPropValued _ _)) + (do + (x'' , (⊩x~x'' , ⊩ϕx , ⊩ψx) , (⊩x''~x' , ⊩'ψx)) ← ⊩∃x'' + return + ((subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (t⊩isTransitiveX x x'' x' _ _ ⊩x~x'' ⊩x''~x')) , + (subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) + (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) + ⊩ϕx)))})) + in + eq/ _ _ (answer , F≤G→G≤F perϕ perX (composeFuncRel _ _ _ funcRel incψ) incϕ answer) + + ϕ≤ψ→SubObjHom : SubObjHom ϕsubObject ψsubObject + ϕ≤ψ→SubObjHom = + slicehom [ funcRel ] funcRel⋆incψ≡incϕ + + SubObjHom≃ϕ≤ψ : SubObjHom ϕsubObject ψsubObject ≃ (ϕ .predicate ≤ ψ .predicate) + SubObjHom≃ϕ≤ψ = + propBiimpl→Equiv + (isPropSubObjMor RT (X , perX) ϕsubObject ψsubObject) + (isProp≤ (ϕ .predicate) (ψ .predicate)) + SubObjHom→ϕ≤ψ + ϕ≤ψ→SubObjHom diff --git a/src/Realizability/Topos/SubobjectClassifier.agda b/src/Realizability/Topos/SubobjectClassifier.agda new file mode 100644 index 0000000..d1d9a56 --- /dev/null +++ b/src/Realizability/Topos/SubobjectClassifier.agda @@ -0,0 +1,938 @@ +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm; ⟦_⟧ to pre⟦_⟧) +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.HLevels +open import Cubical.Foundations.Equiv +open import Cubical.Data.Empty +open import Cubical.Data.Sigma +open import Cubical.Data.FinData +open import Cubical.Data.Vec +open import Cubical.Data.Unit +open import Cubical.HITs.PropositionalTruncation +open import Cubical.HITs.PropositionalTruncation.Monad +open import Cubical.HITs.SetQuotients as SQ +open import Cubical.Categories.Category +open import Cubical.Categories.Limits.Pullback +open import Cubical.Categories.Morphism +open import Realizability.PropResizing +open import Realizability.CombinatoryAlgebra + +module Realizability.Topos.SubobjectClassifier + {ℓ} + {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) + (resizing : hPropResizing ℓ) + where + +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ} {ℓ'' = ℓ} ca +open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ} {ℓ'' = ℓ} ca +open import Realizability.Topos.Object {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.Equalizer {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.BinProducts {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.MonicReprFuncRel {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.ResizedPredicate ca isNonTrivial resizing +open import Realizability.Topos.TerminalObject {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial +open import Realizability.Topos.StrictRelation {ℓ' = ℓ} {ℓ'' = ℓ} ca isNonTrivial + +open CombinatoryAlgebra ca +open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) +open Predicate renaming (isSetX to isSetPredicateBase) +open Morphism +open PartialEquivalenceRelation +open FunctionalRelation +open Category RT + +⟦_⟧ = pre⟦_⟧ as + +Ωper : PartialEquivalenceRelation (ResizedPredicate Unit*) +Predicate.isSetX (equality Ωper) = isSet× isSetResizedPredicate isSetResizedPredicate +Predicate.∣ equality Ωper ∣ (α , β) r = + (∀ (a : A) (⊩α : a ⊩ ∣ toPredicate α ∣ tt*) → ((pr₁ ⨾ r) ⨾ a) ⊩ ∣ toPredicate β ∣ tt*) × + (∀ (a : A) (⊩β : a ⊩ ∣ toPredicate β ∣ tt*) → ((pr₂ ⨾ r) ⨾ a) ⊩ ∣ toPredicate α ∣ tt*) +Predicate.isPropValued (equality Ωper) (α , β) r = + isProp× + (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate β) .isPropValued _ _)) + (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate α) .isPropValued _ _)) +isPartialEquivalenceRelation.isSetX (isPerEquality Ωper) = isSetResizedPredicate +isPartialEquivalenceRelation.isSymmetric (isPerEquality Ωper) = + do + let + ent₁ : ApplStrTerm as 2 + ent₁ = ` pr₂ ̇ # one ̇ # zero + + ent₂ : ApplStrTerm as 2 + ent₂ = ` pr₁ ̇ # one ̇ # zero + + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (λ*abst ent₁) ̇ (λ*abst ent₂) + return + (λ* realizer , + λ { α β r (pr₁r⊩α≤β , pr₂r⊩β≤α) → + (λ a a⊩β → + let + eq : pr₁ ⨾ (λ* realizer ⨾ r) ⨾ a ≡ pr₂ ⨾ r ⨾ a + eq = + pr₁ ⨾ (λ* realizer ⨾ r) ⨾ a + ≡⟨ cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ⟩ + pr₁ ⨾ (pair ⨾ _ ⨾ _) ⨾ a + ≡⟨ cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ⟩ + ⟦ (λ*abst ent₁) ⟧ (r ∷ []) ⨾ a + ≡⟨ βreduction ent₁ a (r ∷ []) ⟩ + pr₂ ⨾ r ⨾ a + ∎ + in + subst (λ r' → r' ⊩ ∣ toPredicate α ∣ tt*) (sym eq) (pr₂r⊩β≤α a a⊩β)) , + (λ a a⊩α → + let + eq : pr₂ ⨾ (λ* realizer ⨾ r) ⨾ a ≡ pr₁ ⨾ r ⨾ a + eq = + pr₂ ⨾ (λ* realizer ⨾ r) ⨾ a + ≡⟨ cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ⟩ + pr₂ ⨾ (pair ⨾ _ ⨾ _) ⨾ a + ≡⟨ cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ⟩ + ⟦ λ*abst ent₂ ⟧ (r ∷ []) ⨾ a + ≡⟨ βreduction ent₂ a (r ∷ []) ⟩ + pr₁ ⨾ r ⨾ a + ∎ + in + subst (λ r' → r' ⊩ ∣ toPredicate β ∣ tt*) (sym eq) (pr₁r⊩α≤β a a⊩α)) }) +isPartialEquivalenceRelation.isTransitive (isPerEquality Ωper) = + do + let + closure1 : ApplStrTerm as 3 + closure1 = ` pr₁ ̇ # one ̇ (` pr₁ ̇ # two ̇ # zero) + + closure2 : ApplStrTerm as 3 + closure2 = ` pr₂ ̇ # two ̇ (` pr₂ ̇ # one ̇ # zero) + + realizer = ` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2) + return + (λ*2 realizer , + (λ { x y z a b (⊩x≤y , ⊩y≤x) (⊩y≤z , ⊩z≤y) → + (λ r r⊩x → + subst + (λ r' → r' ⊩ ∣ toPredicate z ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ x ⨾ r) (λ*2ComputationRule realizer a b) ∙ + cong (λ x → x ⨾ r) (pr₁pxy≡x _ _) ∙ + βreduction closure1 r (b ∷ a ∷ []))) + (⊩y≤z _ (⊩x≤y r r⊩x))) , + (λ r r⊩z → + subst + (λ r' → r' ⊩ ∣ toPredicate x ∣ tt*) + (sym + (cong (λ x → pr₂ ⨾ x ⨾ r) (λ*2ComputationRule realizer a b) ∙ + cong (λ x → x ⨾ r) (pr₂pxy≡y _ _) ∙ + βreduction closure2 r (b ∷ a ∷ []))) + (⊩y≤x _ (⊩z≤y r r⊩z))) })) + +opaque + unfolding terminalPer + trueFuncRel : FunctionalRelation terminalPer Ωper + Predicate.isSetX (relation trueFuncRel) = isSet× isSetUnit* isSetResizedPredicate + Predicate.∣ relation trueFuncRel ∣ (tt* , p) r = ∀ (a : A) → (r ⨾ a) ⊩ ∣ toPredicate p ∣ tt* + Predicate.isPropValued (relation trueFuncRel) (tt* , p) r = isPropΠ λ a → (toPredicate p) .isPropValued _ _ + isFunctionalRelation.isStrictDomain (isFuncRel trueFuncRel) = + do + return + (k , + (λ { tt* y r r⊩⊤≤y → tt*})) + isFunctionalRelation.isStrictCodomain (isFuncRel trueFuncRel) = + do + let + idClosure : ApplStrTerm as 2 + idClosure = # zero + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (λ*abst idClosure) ̇ (λ*abst idClosure) + return + (λ* realizer , + (λ { tt* y r r⊩⊤≤y → + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙ + βreduction idClosure a (r ∷ []))) + a⊩y) , + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym + (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ + βreduction idClosure a (r ∷ []))) + a⊩y)})) + isFunctionalRelation.isRelational (isFuncRel trueFuncRel) = + do + let + realizer : ApplStrTerm as 4 + realizer = ` pr₁ ̇ # one ̇ (# two ̇ ` k) + return + (λ*4 realizer , + (λ { tt* tt* x y a b c tt* b⊩⊤≤x (pr₁c⊩x≤y , pr₂c⊩y≤x) r → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym (λ*4ComputationRule realizer a b c r)) + (pr₁c⊩x≤y (b ⨾ k) (b⊩⊤≤x k))})) + isFunctionalRelation.isSingleValued (isFuncRel trueFuncRel) = + do + let + closure1 : ApplStrTerm as 3 + closure1 = # one ̇ ` k + + closure2 : ApplStrTerm as 3 + closure2 = # two ̇ ` k + + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2) + return + (λ*2 realizer , + (λ { tt* x y r₁ r₂ r₁⊩⊤≤x r₂⊩⊤≤y → + (λ a a⊩x → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ + cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙ + βreduction closure1 a (r₂ ∷ r₁ ∷ []))) + (r₂⊩⊤≤y k)) , + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate x ∣ tt*) + (sym + (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ + cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ + βreduction closure2 a (r₂ ∷ r₁ ∷ []))) + (r₁⊩⊤≤x k))})) + isFunctionalRelation.isTotal (isFuncRel trueFuncRel) = + do + return + (k , + (λ { tt* r tt* → + let + ⊤ = pre1 Unit* isSetUnit* isNonTrivial + in + ∣ + fromPredicate ⊤ , + (λ a → + subst (λ p → (k ⨾ r ⨾ a) ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc ⊤)) tt*) + ∣₁ })) + +opaque + unfolding isInjectiveFuncRel + unfolding terminalPer + isInjectiveTrueFuncRel : isInjectiveFuncRel _ _ trueFuncRel + isInjectiveTrueFuncRel = + do + return + (k , + (λ { tt* tt* p r₁ r₂ r₁⊩⊤≤p r₂⊩⊤≤p → tt* })) + +truePredicate : Predicate Unit* +Predicate.isSetX truePredicate = isSetUnit* +Predicate.∣ truePredicate ∣ tt* r = Unit* +Predicate.isPropValued truePredicate tt* r = isPropUnit* + +⊤ = fromPredicate truePredicate + +-- The subobject classifier classifies subobjects represented by strict relations +module ClassifiesStrictRelations + (X : Type ℓ) + (perX : PartialEquivalenceRelation X) + (ϕ : StrictRelation perX) where + + open InducedSubobject perX ϕ + open StrictRelation + resizedϕ = fromPredicate (ϕ .predicate) + + -- the functional relation that represents the unique indicator map + {-# TERMINATING #-} + charFuncRel : FunctionalRelation perX Ωper + Predicate.isSetX (relation charFuncRel) = isSet× (perX .isSetX) isSetResizedPredicate + Predicate.∣ relation charFuncRel ∣ (x , p) r = + (pr₁ ⨾ r) ⊩ ∣ perX .equality ∣ (x , x) × + (∀ (b : A) (b⊩ϕx : b ⊩ ∣ ϕ .predicate ∣ x) → (pr₁ ⨾ (pr₂ ⨾ r) ⨾ b) ⊩ ∣ toPredicate p ∣ tt*) × + (∀ (b : A) (b⊩px : b ⊩ ∣ toPredicate p ∣ tt*) → (pr₂ ⨾ (pr₂ ⨾ r) ⨾ b) ⊩ ∣ ϕ .predicate ∣ x) + Predicate.isPropValued (relation charFuncRel) (x , p) r = + isProp× + (perX .equality .isPropValued _ _) + (isProp× + (isPropΠ (λ _ → isPropΠ λ _ → (toPredicate p) .isPropValued _ _)) + (isPropΠ λ _ → isPropΠ λ _ → ϕ .predicate .isPropValued _ _)) + isFunctionalRelation.isStrictDomain (isFuncRel charFuncRel) = + do + return + (pr₁ , + (λ { x p r (pr₁r⊩x~x , ⊩ϕx≤p , ⊩p≤ϕx) → pr₁r⊩x~x})) + isFunctionalRelation.isStrictCodomain (isFuncRel charFuncRel) = + do + let + idClosure : ApplStrTerm as 2 + idClosure = # zero + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (λ*abst idClosure) ̇ (λ*abst idClosure) + return + (λ* realizer , + (λ x y r x₁ → + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙ + βreduction idClosure a (r ∷ []))) + a⊩y) , + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym + (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ + βreduction idClosure a (r ∷ []))) + a⊩y))) + isFunctionalRelation.isRelational (isFuncRel charFuncRel) = + do + (sX , sX⊩isSymmetricX) ← perX .isSymmetric + (tX , tX⊩isTransitiveX) ← perX .isTransitive + (relϕ , relϕ⊩isRelationalϕ) ← isStrictRelation.isRelational (ϕ .isStrictRelationPredicate) + let + closure1 : ApplStrTerm as 4 + closure1 = ` pr₁ ̇ # one ̇ (` pr₁ ̇ (` pr₂ ̇ # two) ̇ (` relϕ ̇ # zero ̇ (` sX ̇ # three))) + + closure2 : ApplStrTerm as 4 + closure2 = ` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ # two) ̇ (` pr₂ ̇ # one ̇ # zero)) ̇ # three + + realizer : ApplStrTerm as 3 + realizer = ` pair ̇ (` tX ̇ (` sX ̇ # two) ̇ # two) ̇ (` pair ̇ (λ*abst closure1) ̇ (λ*abst closure2)) + return + (λ*3 realizer , + (λ { x x' p p' a b c a⊩x~x' (⊩x~x , ⊩ϕx≤p , ⊩p≤ϕx) (⊩p≤p' , ⊩p'≤p) → + let + ⊩x'~x = sX⊩isSymmetricX x x' a a⊩x~x' + ⊩x'~x' = tX⊩isTransitiveX x' x x' _ _ ⊩x'~x a⊩x~x' + in + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x' , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*3ComputationRule realizer a b c) ∙ pr₁pxy≡x _ _)) + ⊩x'~x' , + (λ r r⊩ϕx' → + subst + (λ r' → r' ⊩ ∣ toPredicate p' ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ r) (λ*3ComputationRule realizer a b c) ∙ + cong (λ x → pr₁ ⨾ x ⨾ r) (pr₂pxy≡y _ _) ∙ + cong (λ x → x ⨾ r) (pr₁pxy≡x _ _) ∙ + βreduction closure1 r (c ∷ b ∷ a ∷ []))) + (⊩p≤p' _ (⊩ϕx≤p _ (relϕ⊩isRelationalϕ x' x _ _ r⊩ϕx' ⊩x'~x)))) , + λ r r⊩p' → + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x') + (sym + (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ r) (λ*3ComputationRule realizer a b c) ∙ + cong (λ x → pr₂ ⨾ x ⨾ r) (pr₂pxy≡y _ _) ∙ + cong (λ x → x ⨾ r) (pr₂pxy≡y _ _) ∙ + βreduction closure2 r (c ∷ b ∷ a ∷ []))) + (relϕ⊩isRelationalϕ x x' _ _ (⊩p≤ϕx _ (⊩p'≤p r r⊩p')) a⊩x~x') })) + isFunctionalRelation.isSingleValued (isFuncRel charFuncRel) = + do + let + closure1 : ApplStrTerm as 3 + closure1 = ` pr₁ ̇ (` pr₂ ̇ # one) ̇ (` pr₂ ̇ (` pr₂ ̇ # two) ̇ # zero) + + closure2 : ApplStrTerm as 3 + closure2 = ` pr₁ ̇ (` pr₂ ̇ # two) ̇ (` pr₂ ̇ (` pr₂ ̇ # one) ̇ # zero) + + realizer : ApplStrTerm as 2 + realizer = ` pair ̇ λ*abst closure1 ̇ λ*abst closure2 + return + (λ*2 realizer , + (λ { x y y' r₁ r₂ (⊩x~x , ⊩ϕx≤y , ⊩y≤ϕx) (⊩'x~x , ⊩ϕx≤y' , ⊩y'≤ϕx) → + (λ a a⊩y → + subst + (λ r' → r' ⊩ ∣ toPredicate y' ∣ tt*) + (sym (cong (λ x → pr₁ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ cong (λ x → x ⨾ a) (pr₁pxy≡x _ _) ∙ βreduction closure1 a (r₂ ∷ r₁ ∷ []))) + (⊩ϕx≤y' _ (⊩y≤ϕx a a⊩y))) , + (λ a a⊩y' → + subst + (λ r' → r' ⊩ ∣ toPredicate y ∣ tt*) + (sym (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*2ComputationRule realizer r₁ r₂) ∙ cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ βreduction closure2 a (r₂ ∷ r₁ ∷ []))) + (⊩ϕx≤y _ (⊩y'≤ϕx a a⊩y'))) })) + isFunctionalRelation.isTotal (isFuncRel charFuncRel) = + do + let + idClosure : ApplStrTerm as 2 + idClosure = # zero + + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ # zero ̇ (` pair ̇ λ*abst idClosure ̇ λ*abst idClosure) + return + (λ* realizer , + (λ x r r⊩x~x → + let + resultPredicate : Predicate Unit* + resultPredicate = + makePredicate + isSetUnit* + (λ { tt* s → s ⊩ ∣ ϕ .predicate ∣ x }) + (λ { tt* s → ϕ .predicate .isPropValued _ _ }) + in + return + (fromPredicate resultPredicate , + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + r⊩x~x , + (λ b b⊩ϕx → + subst + (λ r → r ⊩ ∣ toPredicate (fromPredicate resultPredicate) ∣ tt*) + (sym + (cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙ + cong (λ x → pr₁ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙ + cong (λ x → x ⨾ b) (pr₁pxy≡x _ _) ∙ + βreduction idClosure b (r ∷ []))) + (subst (λ p → b ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc resultPredicate)) b⊩ϕx)) , + (λ b b⊩'ϕx → + subst + (λ r → r ⊩ ∣ ϕ .predicate ∣ x) + (sym + (cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙ + cong (λ x → pr₂ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙ + cong (λ x → x ⨾ b) (pr₂pxy≡y _ _) ∙ + βreduction idClosure b (r ∷ []))) + let foo = subst (λ p → b ⊩ ∣ p ∣ tt*) (compIsIdFunc resultPredicate) b⊩'ϕx in foo)))) + + subobjectCospan : ∀ char → Cospan RT + Cospan.l (subobjectCospan char) = X , perX + Cospan.m (subobjectCospan char) = ResizedPredicate Unit* , Ωper + Cospan.r (subobjectCospan char) = Unit* , terminalPer + Cospan.s₁ (subobjectCospan char) = char + Cospan.s₂ (subobjectCospan char) = [ trueFuncRel ] + + opaque + unfolding composeRTMorphism + unfolding composeFuncRel + unfolding terminalFuncRel + unfolding trueFuncRel + unfolding incFuncRel + subobjectSquareCommutes : [ incFuncRel ] ⋆ [ charFuncRel ] ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ] + subobjectSquareCommutes = + let + answer = + do + (stX , stX⊩isStrictDomainX) ← idFuncRel perX .isStrictDomain + (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ + let + closure : ApplStrTerm as 2 + closure = (` pr₁ ̇ (` pr₂ ̇ (` pr₂ ̇ # one)) ̇ (` relϕ ̇ (` pr₂ ̇ (` pr₁ ̇ # one)) ̇ (` pr₁ ̇ (` pr₁ ̇ # one)))) + realizer : ApplStrTerm as 1 + realizer = + ` pair ̇ + (` pair ̇ (` stX ̇ (` pr₁ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ + λ*abst closure + return + (λ* realizer , + (λ { x p r r⊩∃x' → + do + (x' , (⊩x~x' , ⊩ϕx) , ⊩x'~x' , ⊩ϕx'≤p , ⊩p≤ϕx') ← r⊩∃x' + return + (tt* , + ((subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _)) + (stX⊩isStrictDomainX x x' _ ⊩x~x')) , + (subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) + (sym (cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₂pxy≡y _ _)) + ⊩ϕx)) , + λ r' → + let + eq : pr₂ ⨾ (λ* realizer ⨾ r) ⨾ r' ≡ pr₁ ⨾ (pr₂ ⨾ (pr₂ ⨾ r)) ⨾ (relϕ ⨾ (pr₂ ⨾ (pr₁ ⨾ r)) ⨾ (pr₁ ⨾ (pr₁ ⨾ r))) + eq = + cong (λ x → pr₂ ⨾ x ⨾ r') (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ r') (pr₂pxy≡y _ _) ∙ + βreduction closure r' (r ∷ []) + in + subst + (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) + (sym eq) + (⊩ϕx'≤p _ (relϕ⊩isRelationalϕ x x' _ _ ⊩ϕx ⊩x~x'))) })) + in + eq/ _ _ (answer , F≤G→G≤F subPer Ωper (composeFuncRel _ _ _ incFuncRel charFuncRel) (composeFuncRel _ _ _ (terminalFuncRel subPer) trueFuncRel) answer) + + module + UnivPropWithRepr + {Y : Type ℓ} + (perY : PartialEquivalenceRelation Y) + (F : FunctionalRelation perY perX) + (G : FunctionalRelation perY terminalPer) + (entailment : pointwiseEntailment perY Ωper (composeFuncRel _ _ _ G trueFuncRel) (composeFuncRel _ _ _ F charFuncRel)) where + + opaque + unfolding terminalFuncRel + G≤idY : pointwiseEntailment perY terminalPer G (terminalFuncRel perY) + G≤idY = + do + (stDG , stDG⊩isStrictDomainG) ← G .isStrictDomain + return + (stDG , + (λ { y tt* r r⊩Gy → stDG⊩isStrictDomainG y tt* r r⊩Gy })) + + opaque + idY≤G : pointwiseEntailment perY terminalPer (terminalFuncRel perY) G + idY≤G = F≤G→G≤F perY terminalPer G (terminalFuncRel perY) G≤idY + + opaque + unfolding trueFuncRel + trueFuncRelTruePredicate : ∀ a → (a ⊩ ∣ trueFuncRel .relation ∣ (tt* , fromPredicate truePredicate)) + trueFuncRelTruePredicate a = λ b → subst (λ p → (a ⨾ b) ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt* + + opaque + unfolding composeFuncRel + unfolding terminalFuncRel + {-# TERMINATING #-} + H : FunctionalRelation perY subPer + Predicate.isSetX (relation H) = isSet× (perY .isSetX) (perX .isSetX) + Predicate.∣ relation H ∣ (y , x) r = r ⊩ ∣ F .relation ∣ (y , x) + Predicate.isPropValued (relation H) (y , x) r = F .relation .isPropValued _ _ + isFunctionalRelation.isStrictDomain (isFuncRel H) = + do + (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain + return + (stFD , + (λ y x r r⊩Hyx → stFD⊩isStrictDomainF y x r r⊩Hyx)) + isFunctionalRelation.isStrictCodomain (isFuncRel H) = + do + (ent , ent⊩entailment) ← entailment + (a , a⊩idY≤G) ← idY≤G + (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain + (stFC , stFC⊩isStrictCodomainF) ← F .isStrictCodomain + (svF , svF⊩isSingleValuedF) ← F .isSingleValued + (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ + let + realizer : ApplStrTerm as 1 + realizer = + ` pair ̇ + (` stFC ̇ # zero) ̇ + (` relϕ ̇ + (` pr₂ ̇ (` pr₂ ̇ (` pr₂ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # zero)) ̇ ` k)))) ̇ ` k) ̇ + (` svF ̇ (` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # zero)) ̇ ` k))) ̇ # zero)) + return + (λ* realizer , + (λ y x r r⊩Hyx → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) + (stFC⊩isStrictCodomainF y x _ r⊩Hyx) , + (equivFun + (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _)) + (do + (x' , ⊩Fyx' , ⊩x'~x' , ⊩ϕx'≤⊤ , ⊩⊤≤ϕx') ← + ent⊩entailment + y + (fromPredicate truePredicate) + (pair ⨾ (a ⨾ (stFD ⨾ r)) ⨾ k) + (return + (tt* , + subst + (λ r → r ⊩ ∣ G .relation ∣ (y , tt*)) + (sym (pr₁pxy≡x _ _)) + (a⊩idY≤G y tt* (stFD ⨾ r) (stFD⊩isStrictDomainF y x _ r⊩Hyx)) , + trueFuncRelTruePredicate _)) + let + ⊩x'~x = svF⊩isSingleValuedF y x' x _ _ ⊩Fyx' r⊩Hyx + ⊩ϕx = relϕ⊩isRelationalϕ x' x _ _ (⊩⊤≤ϕx' k (subst (λ p → k ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*)) ⊩x'~x + return (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₂pxy≡y _ _)) ⊩ϕx))))) + isFunctionalRelation.isRelational (isFuncRel H) = + do + (relF , relF⊩isRelationalF) ← isFunctionalRelation.isRelational (F .isFuncRel) + let + realizer : ApplStrTerm as 3 + realizer = ` relF ̇ # two ̇ # one ̇ (` pr₁ ̇ # zero) + return + (λ*3 realizer , + (λ y y' x x' a b c ⊩y~y' ⊩Fyx (⊩x~x' , ⊩ϕx) → + subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y' , x')) + (sym (λ*3ComputationRule realizer a b c)) + (relF⊩isRelationalF y y' x x' _ _ _ ⊩y~y' ⊩Fyx ⊩x~x'))) + isFunctionalRelation.isSingleValued (isFuncRel H) = + do + (ent , ent⊩entailment) ← entailment + (a , a⊩idY≤G) ← idY≤G + (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain + (svF , svF⊩isSingleValuedF) ← F .isSingleValued + (relϕ , relϕ⊩isRelationalϕ) ← StrictRelation.isRelational ϕ + let + realizer : ApplStrTerm as 2 + realizer = + ` pair ̇ + (` svF ̇ # one ̇ # zero) ̇ + (` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ (` pr₂ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # one)) ̇ ` k)))) ̇ ` k) ̇ (` svF ̇ (` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ (` stFD ̇ # one)) ̇ ` k))) ̇ # one)) + return + (λ*2 realizer , + (λ y x x' r₁ r₂ ⊩Fyx ⊩Fyx' → + subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x')) + (sym (cong (λ x → pr₁ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₁pxy≡x _ _)) + (svF⊩isSingleValuedF y x x' _ _ ⊩Fyx ⊩Fyx') , + (equivFun + (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _)) + (do + (x'' , ⊩Fyx'' , ⊩x''~x'' , ⊩ϕx''≤⊤ , ⊩⊤≤ϕx'') ← + ent⊩entailment + y + (fromPredicate truePredicate) + (pair ⨾ (a ⨾ (stFD ⨾ r₁)) ⨾ k) + (return + (tt* , + subst (λ r → r ⊩ ∣ G .relation ∣ (y , tt*)) (sym (pr₁pxy≡x _ _)) (a⊩idY≤G y tt* _ (stFD⊩isStrictDomainF y x _ ⊩Fyx)) , + trueFuncRelTruePredicate _)) + let + ⊩x''~x = svF⊩isSingleValuedF y x'' x _ _ ⊩Fyx'' ⊩Fyx + ⊩ϕx = relϕ⊩isRelationalϕ x'' x _ _ (⊩⊤≤ϕx'' k (subst (λ p → k ⊩ ∣ p ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*)) ⊩x''~x + return + (subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) + (sym (cong (λ x → pr₂ ⨾ x) (λ*2ComputationRule realizer r₁ r₂) ∙ pr₂pxy≡y _ _)) + ⊩ϕx))))) + isFunctionalRelation.isTotal (isFuncRel H) = + do + (ent , ent⊩entailment) ← entailment + (a , a⊩idY≤G) ← idY≤G + let + realizer : ApplStrTerm as 1 + realizer = ` pr₁ ̇ (` ent ̇ (` pair ̇ (` a ̇ # zero) ̇ ` k)) + return + (λ* realizer , + (λ { y r r⊩y~y → + do + (x , ⊩Fyx , ⊩x~x , ⊩ϕx≤⊤ , ⊩⊤≤ϕx) ← + ent⊩entailment + y + (fromPredicate truePredicate) + (pair ⨾ (a ⨾ r) ⨾ k) + (return + (tt* , + subst (λ r → r ⊩ ∣ G .relation ∣ (y , tt*)) (sym (pr₁pxy≡x _ _)) (a⊩idY≤G y tt* r r⊩y~y) , + trueFuncRelTruePredicate _)) + return (x , subst (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) (sym (λ*ComputationRule realizer r)) ⊩Fyx) })) + + opaque + unfolding composeRTMorphism + unfolding incFuncRel + unfolding H + F≡H⋆inc : [ F ] ≡ [ H ] ⋆ [ incFuncRel ] + F≡H⋆inc = + let + answer = + do + (relF , relF⊩isRelationalF) ← isFunctionalRelation.isRelational (F .isFuncRel) + (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain + let + realizer : ApplStrTerm as 1 + realizer = ` relF ̇ (` stFD ̇ (` pr₁ ̇ # zero)) ̇ (` pr₁ ̇ # zero) ̇ (` pr₁ ̇ (` pr₂ ̇ # zero)) + return + (λ* realizer , + (λ y x r ⊩∃x' → + equivFun + (propTruncIdempotent≃ (F .relation .isPropValued _ _)) + (do + (x' , ⊩Hyx' , ⊩x'~x , ⊩ϕx') ← ⊩∃x' + return + (subst + (λ r' → r' ⊩ ∣ F .relation ∣ (y , x)) + (sym (λ*ComputationRule realizer r)) + (relF⊩isRelationalF y y x' x _ _ _ (stFD⊩isStrictDomainF y x' _ ⊩Hyx') ⊩Hyx' ⊩x'~x))))) + in eq/ _ _ (F≤G→G≤F perY perX (composeFuncRel _ _ _ H incFuncRel) F answer , answer) + + opaque + unfolding composeRTMorphism + unfolding terminalFuncRel + G≡H⋆terminal : [ G ] ≡ [ H ] ⋆ [ terminalFuncRel subPer ] + G≡H⋆terminal = + let + answer = + do + (stHD , stHD⊩isStrictDomainH) ← H .isStrictDomain + (a , a⊩idY≤G) ← idY≤G + let + realizer : ApplStrTerm as 1 + realizer = ` a ̇ (` stHD ̇ (` pr₁ ̇ # zero)) + return + (λ* realizer , + (λ { y tt* r r⊩∃x → + equivFun + (propTruncIdempotent≃ (G .relation .isPropValued _ _)) + (do + (x , ⊩Hyx , ⊩x~x , ⊩ϕx) ← r⊩∃x + return (subst (λ r' → r' ⊩ ∣ G .relation ∣ (y , tt*)) (sym (λ*ComputationRule realizer r)) (a⊩idY≤G y tt* _ (stHD⊩isStrictDomainH y x _ ⊩Hyx)))) })) + in eq/ _ _ (F≤G→G≤F perY terminalPer (composeFuncRel _ _ _ H (terminalFuncRel subPer)) G answer , answer) + + opaque + unfolding composeRTMorphism + unfolding H + unfolding incFuncRel + isUniqueH : ∀ (H' : FunctionalRelation perY subPer) → [ F ] ≡ [ H' ] ⋆ [ incFuncRel ] → [ G ] ≡ [ H' ] ⋆ [ terminalFuncRel subPer ] → [_] {R = bientailment perY subPer} H ≡ [ H' ] + isUniqueH H' F≡H'⋆inc G≡H'⋆term = + let + F≤H'⋆inc = [F]≡[G]→F≤G F (composeFuncRel _ _ _ H' incFuncRel) F≡H'⋆inc + answer : pointwiseEntailment _ _ H H' + answer = + do + (a , a⊩F≤H'⋆inc) ← F≤H'⋆inc + (relH' , relH'⊩isRelationalH) ← isFunctionalRelation.isRelational (H' .isFuncRel) + (stDH , stDH⊩isStrictDomainH) ← H .isStrictDomain + let + realizer : ApplStrTerm as 1 + realizer = ` relH' ̇ (` stDH ̇ # zero) ̇ (` pr₁ ̇ (` a ̇ # zero)) ̇ (` pr₂ ̇ (` a ̇ # zero)) + return + (λ* realizer , + (λ y x r r⊩Hyx → + equivFun + (propTruncIdempotent≃ (H' .relation .isPropValued _ _)) + (do + (x' , ⊩H'yx' , ⊩x'~x , ⊩ϕx') ← a⊩F≤H'⋆inc y x r r⊩Hyx + return + (subst + (λ r' → r' ⊩ ∣ H' .relation ∣ (y , x)) + (sym (λ*ComputationRule realizer r)) + (relH'⊩isRelationalH y y x' x _ _ _ (stDH⊩isStrictDomainH y x r r⊩Hyx) ⊩H'yx' (⊩x'~x , ⊩ϕx')))))) + in + eq/ _ _ (answer , (F≤G→G≤F _ _ H H' answer)) + + opaque + classifies : isPullback RT (subobjectCospan [ charFuncRel ]) [ incFuncRel ] [ terminalFuncRel subPer ] subobjectSquareCommutes + classifies {Y , perY} f g f⋆char≡g⋆true = + SQ.elimProp2 + {P = λ f g → ∀ (commutes : f ⋆ [ charFuncRel ] ≡ g ⋆ [ trueFuncRel ]) → ∃![ hk ∈ RTMorphism perY subPer ] (f ≡ hk ⋆ [ incFuncRel ]) × (g ≡ hk ⋆ [ terminalFuncRel subPer ])} + (λ f g → isPropΠ λ _ → isPropIsContr) + (λ F G F⋆char≡G⋆true → + let + entailment = [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G F charFuncRel G trueFuncRel F⋆char≡G⋆true + in + uniqueExists + [ UnivPropWithRepr.H perY F G entailment ] + (UnivPropWithRepr.F≡H⋆inc perY F G entailment , + UnivPropWithRepr.G≡H⋆terminal perY F G entailment) + (λ hk' → isProp× (squash/ _ _) (squash/ _ _)) + -- nested eliminator 🤮 + λ { h' (f≡h'⋆inc , g≡h'⋆term) → + SQ.elimProp + {P = λ h' → ∀ (comm1 : [ F ] ≡ h' ⋆ [ incFuncRel ]) (comm2 : [ G ] ≡ h' ⋆ [ terminalFuncRel subPer ]) → [ UnivPropWithRepr.H perY F G entailment ] ≡ h'} + (λ h' → isPropΠ λ _ → isPropΠ λ _ → squash/ _ _) + (λ H' F≡H'⋆inc G≡H'⋆term → + UnivPropWithRepr.isUniqueH perY F G entailment H' F≡H'⋆inc G≡H'⋆term) + h' + f≡h'⋆inc + g≡h'⋆term }) + f g f⋆char≡g⋆true + + module + PullbackHelper + (C : FunctionalRelation perX Ωper) + (commutes : [ incFuncRel ] ⋆ [ C ] ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ]) + (classifies : isPullback RT (subobjectCospan [ C ]) [ incFuncRel ] [ terminalFuncRel subPer ] commutes) where + + {-# TERMINATING #-} + ψ : StrictRelation perX + Predicate.isSetX (predicate ψ) = perX .isSetX + Predicate.∣ predicate ψ ∣ x r = r ⊩ ∣ C .relation ∣ (x , ⊤) + Predicate.isPropValued (predicate ψ) x r = C .relation .isPropValued _ _ + isStrictRelation.isStrict (isStrictRelationPredicate ψ) = + do + (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain + return + (stDC , + λ x r r⊩Cx⊤ → stDC⊩isStrictDomainC x (fromPredicate truePredicate) r r⊩Cx⊤) + isStrictRelation.isRelational (isStrictRelationPredicate ψ) = + do + (relC , relC⊩isRelationalC) ← isFunctionalRelation.isRelational (C .isFuncRel) + (stCC , stCC⊩isStrictCodomainC) ← C .isStrictCodomain + let + realizer : ApplStrTerm as 2 + realizer = ` relC ̇ # zero ̇ # one ̇ (` stCC ̇ # one) + return + (λ*2 realizer , + λ x x' a b a⊩Cx⊤ b⊩x~x' → + subst (λ r' → r' ⊩ ∣ C .relation ∣ (x' , ⊤)) (sym (λ*2ComputationRule realizer a b)) (relC⊩isRelationalC x x' ⊤ ⊤ _ _ _ b⊩x~x' a⊩Cx⊤ (stCC⊩isStrictCodomainC x ⊤ a a⊩Cx⊤))) + + perψ = InducedSubobject.subPer perX ψ + incFuncRelψ = InducedSubobject.incFuncRel perX ψ + + opaque + unfolding composeRTMorphism + unfolding InducedSubobject.incFuncRel + unfolding terminalFuncRel + unfolding trueFuncRel + pbSqCommutes : [ incFuncRelψ ] ⋆ [ C ] ≡ [ terminalFuncRel perψ ] ⋆ [ trueFuncRel ] + pbSqCommutes = + let + answer = + do + (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain + (stCC , stCC⊩isStrictCodomainC) ← C .isStrictCodomain + (svC , svC⊩isSingleValuedC) ← C .isSingleValued + (relC , relC⊩isRelationalC) ← isFunctionalRelation.isRelational (C .isFuncRel) + (sX , sX⊩isSymmetricX) ← perX .isSymmetric + let + closure : ApplStrTerm as 2 + closure = ` pr₁ ̇ (` svC ̇ (` pr₂ ̇ (` pr₁ ̇ # one)) ̇ (` relC ̇ (` sX ̇ (` pr₁ ̇ (` pr₁ ̇ # one))) ̇ (` pr₂ ̇ # one) ̇ (` stCC ̇ (` pr₂ ̇ # one)))) ̇ ` k + + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` pair ̇ (` stDC ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ (` pr₂ ̇ (` pr₁ ̇ # zero))) ̇ (λ*abst closure) + return + (λ* realizer , + λ { x p r r⊩∃x' → + do + (x' , (⊩x~x' , ⊩Cx⊤) , ⊩Cx'p) ← r⊩∃x' + let + ⊩Cxp = relC⊩isRelationalC x' x p p _ _ _ (sX⊩isSymmetricX x x' _ ⊩x~x') ⊩Cx'p (stCC⊩isStrictCodomainC x' p _ ⊩Cx'p) + (⊩⊤≤p , p≤⊤) = svC⊩isSingleValuedC x ⊤ p _ _ ⊩Cx⊤ ⊩Cxp + return + (tt* , + (subst + (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) + (sym + (cong (λ x → pr₁ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ + cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ + pr₁pxy≡x _ _ )) + (stDC⊩isStrictDomainC x ⊤ _ ⊩Cx⊤) , + subst + (λ r' → r' ⊩ ∣ C .relation ∣ (x , ⊤)) + (sym + (cong (λ x → pr₂ ⨾ (pr₁ ⨾ x)) (λ*ComputationRule realizer r) ∙ + cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ + pr₂pxy≡y _ _)) + ⊩Cx⊤) , + λ a → + subst + (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) + (sym + (cong (λ x → pr₂ ⨾ x ⨾ a) (λ*ComputationRule realizer r) ∙ + cong (λ x → x ⨾ a) (pr₂pxy≡y _ _) ∙ + βreduction closure a (r ∷ []))) + (⊩⊤≤p k (subst (λ q → k ⊩ ∣ q ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*))) }) + in eq/ _ _ (answer , F≤G→G≤F _ _ (composeFuncRel _ _ _ incFuncRelψ C) (composeFuncRel _ _ _ (terminalFuncRel perψ) trueFuncRel) answer) + + opaque + unfolding InducedSubobject.incFuncRel + unfolding composeFuncRel + ⊩Cx⊤≤ϕx : ∃[ ent ∈ A ] (∀ (x : X) (r : A) → r ⊩ ∣ C .relation ∣ (x , ⊤) → (ent ⨾ r) ⊩ ∣ ϕ .predicate ∣ x) + ⊩Cx⊤≤ϕx = + let + ((h , incψ≡h⋆incϕ , termψ≡h⋆termϕ) , isUniqueH) = classifies [ incFuncRelψ ] [ terminalFuncRel perψ ] pbSqCommutes + in + SQ.elimProp + {P = λ h → ∀ (incψ≡h⋆incϕ : [ incFuncRelψ ] ≡ h ⋆ [ incFuncRel ]) → ∃[ ent ∈ A ] (∀ (x : X) (r : A) → r ⊩ ∣ C .relation ∣ (x , ⊤) → (ent ⨾ r) ⊩ ∣ ϕ .predicate ∣ x)} + (λ h → isPropΠ λ _ → isPropPropTrunc) + (λ H incψ≡H⋆incϕ → + do + (a , a⊩incψ≤H⋆incϕ) ← [F]≡[G]⋆[H]→F≤G⋆H incFuncRelψ H incFuncRel incψ≡H⋆incϕ + (stDC , stDC⊩isStrictDomainC) ← C .isStrictDomain + (relϕ , relϕ⊩isRelationalϕ) ← isStrictRelation.isRelational (ϕ .isStrictRelationPredicate) + let + realizer = ` relϕ ̇ (` pr₂ ̇ (` pr₂ ̇ (` a ̇ (` pair ̇ (` stDC ̇ # zero) ̇ # zero)))) ̇ (` pr₁ ̇ (` pr₂ ̇ (` a ̇ (` pair ̇ (` stDC ̇ # zero) ̇ # zero)))) + return + (λ* realizer , + (λ x r r⊩Cx⊤ → + equivFun + (propTruncIdempotent≃ (ϕ .predicate .isPropValued _ _)) + (do + (x' , ⊩Hxx' , ⊩x'~x , ⊩ϕx') ← + a⊩incψ≤H⋆incϕ + x x + (pair ⨾ (stDC ⨾ r) ⨾ r) + (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (pr₁pxy≡x _ _)) (stDC⊩isStrictDomainC x ⊤ r r⊩Cx⊤) , + subst (λ r' → r' ⊩ ∣ C .relation ∣ (x , ⊤)) (sym (pr₂pxy≡y _ _)) r⊩Cx⊤) + return + (subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (λ*ComputationRule realizer r)) (relϕ⊩isRelationalϕ x' x _ _ ⊩ϕx' ⊩x'~x)))))) + h + incψ≡h⋆incϕ + + opaque + unfolding trueFuncRel + unfolding composeFuncRel + unfolding incFuncRel + unfolding terminalFuncRel + isUniqueCharMorphism : + ∀ (char : RTMorphism perX Ωper) + → (commutes : [ incFuncRel ] ⋆ char ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ]) + → (classifies : isPullback RT (subobjectCospan char) [ incFuncRel ] [ terminalFuncRel subPer ] commutes) + → char ≡ [ charFuncRel ] + isUniqueCharMorphism char commutes classifies = + SQ.elimProp + {P = + λ char → + ∀ (commutes : [ incFuncRel ] ⋆ char ≡ [ terminalFuncRel subPer ] ⋆ [ trueFuncRel ]) + (classifies : isPullback RT (subobjectCospan char) [ incFuncRel ] [ terminalFuncRel subPer ] commutes) + → char ≡ [ charFuncRel ]} + (λ char → isPropΠ λ commutes → isPropΠ λ classifies → squash/ _ _) + (λ charFuncRel' commutes classifies → + let + answer = + do + (stDX' , stDX'⊩isStrictDomainX') ← charFuncRel' .isStrictDomain + (relX' , relX'⊩isRelationalX') ← isFunctionalRelation.isRelational (charFuncRel' .isFuncRel) + (a , a⊩inc⋆X'≤term⋆true) ← [F]⋆[G]≡[H]⋆[I]→F⋆G≤H⋆I incFuncRel charFuncRel' (terminalFuncRel subPer) trueFuncRel commutes + (b , b⊩term⋆true≤inc⋆X') ← [F]⋆[G]≡[H]⋆[I]→H⋆I≤F⋆G incFuncRel charFuncRel' (terminalFuncRel subPer) trueFuncRel commutes + (d , d⊩X'x⊤≤ϕx) ← PullbackHelper.⊩Cx⊤≤ϕx charFuncRel' commutes classifies + let + closure1 : ApplStrTerm as 2 + closure1 = ` pr₂ ̇ (` a ̇ (` pair ̇ (` pair ̇ (` stDX' ̇ # one) ̇ # zero) ̇ # one)) ̇ ` k + closure2 : ApplStrTerm as 2 + closure2 = ` d ̇ (` relX' ̇ (` stDX' ̇ # one) ̇ # one ̇ (` pair ̇ ` k ̇ (` k ̇ # zero))) + realizer : ApplStrTerm as 1 + realizer = ` pair ̇ (` stDX' ̇ # zero) ̇ (` pair ̇ λ*abst closure1 ̇ λ*abst closure2) + return + (λ* realizer , + (λ { x p r r⊩X'xp → + let + ⊩x~x = stDX'⊩isStrictDomainX' x p r r⊩X'xp + in + subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (λ*ComputationRule realizer r) ∙ pr₁pxy≡x _ _)) ⊩x~x , + (λ b b⊩ϕx → + let + goal = + a⊩inc⋆X'≤term⋆true + x p (pair ⨾ (pair ⨾ (stDX' ⨾ r) ⨾ b) ⨾ r) + (return + (x , (subst (λ r' → r' ⊩ ∣ perX .equality ∣ (x , x)) (sym (cong (λ x → pr₁ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₁pxy≡x _ _)) ⊩x~x , + subst (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) (sym (cong (λ x → pr₂ ⨾ x) (pr₁pxy≡x _ _) ∙ pr₂pxy≡y _ _)) b⊩ϕx) , + subst (λ r' → r' ⊩ ∣ charFuncRel' .relation ∣ (x , p)) (sym (pr₂pxy≡y _ _)) r⊩X'xp)) + + eq : pr₁ ⨾ (pr₂ ⨾ (λ* realizer ⨾ r)) ⨾ b ≡ pr₂ ⨾ (a ⨾ (pair ⨾ (pair ⨾ (stDX' ⨾ r) ⨾ b) ⨾ r)) ⨾ k + eq = + cong (λ x → pr₁ ⨾ (pr₂ ⨾ x) ⨾ b) (λ*ComputationRule realizer r) ∙ cong (λ x → pr₁ ⨾ x ⨾ b) (pr₂pxy≡y _ _) ∙ cong (λ x → x ⨾ b) (pr₁pxy≡x _ _) ∙ βreduction closure1 b (r ∷ []) + in + equivFun + (propTruncIdempotent≃ (toPredicate p .isPropValued _ _)) + (do + (tt* , ⊩'x~x , ⊩⊤≤p) ← goal + return (subst (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) (sym eq) (⊩⊤≤p k)))) , + (λ c c⊩p → + let + ⊩X'x⊤ = + relX'⊩isRelationalX' + x x p ⊤ _ _ + (pair ⨾ k ⨾ (k ⨾ c)) + ⊩x~x r⊩X'xp + ((λ b b⊩p → subst (λ q → (pr₁ ⨾ (pair ⨾ k ⨾ (k ⨾ c))) ⊩ ∣ q ∣ tt*) (sym (compIsIdFunc truePredicate)) tt*) , + (λ b b⊩⊤ → subst (λ r' → r' ⊩ ∣ toPredicate p ∣ tt*) (sym (cong (λ x → x ⨾ b) (pr₂pxy≡y _ _) ∙ kab≡a _ _)) c⊩p)) + + eq : pr₂ ⨾ (pr₂ ⨾ (λ* realizer ⨾ r)) ⨾ c ≡ d ⨾ (relX' ⨾ (stDX' ⨾ r) ⨾ r ⨾ (pair ⨾ k ⨾ (k ⨾ c))) + eq = + cong (λ x → pr₂ ⨾ (pr₂ ⨾ x) ⨾ c) (λ*ComputationRule realizer r) ∙ + cong (λ x → pr₂ ⨾ x ⨾ c) (pr₂pxy≡y _ _) ∙ + cong (λ x → x ⨾ c) (pr₂pxy≡y _ _) ∙ + βreduction closure2 c (r ∷ []) + in + subst + (λ r' → r' ⊩ ∣ ϕ .predicate ∣ x) + (sym eq) + (d⊩X'x⊤≤ϕx x _ ⊩X'x⊤)) })) + in eq/ _ _ (answer , F≤G→G≤F _ _ charFuncRel' charFuncRel answer)) + char + commutes + classifies diff --git a/src/Realizability/Topos/TerminalObject.agda b/src/Realizability/Topos/TerminalObject.agda new file mode 100644 index 0000000..b6d3c11 --- /dev/null +++ b/src/Realizability/Topos/TerminalObject.agda @@ -0,0 +1,110 @@ +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm) +open import Realizability.CombinatoryAlgebra +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.HLevels +open import Cubical.Data.Unit +open import Cubical.Data.Empty +open import Cubical.Data.FinData +open import Cubical.Data.Vec +open import Cubical.HITs.PropositionalTruncation +open import Cubical.HITs.PropositionalTruncation.Monad +open import Cubical.HITs.SetQuotients as SQ +open import Cubical.Categories.Category +open import Cubical.Categories.Limits.Terminal + +module Realizability.Topos.TerminalObject + {ℓ ℓ' ℓ''} + {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) where + +open CombinatoryAlgebra ca +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Topos.Object {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial +open import Realizability.Topos.FunctionalRelation {ℓ' = ℓ'} {ℓ'' = ℓ''} ca isNonTrivial + +open Combinators ca renaming (i to Id; ia≡a to Ida≡a) +open PartialEquivalenceRelation +open Predicate renaming (isSetX to isSetPredicateBase) + +opaque + terminalPer : PartialEquivalenceRelation Unit* + isSetPredicateBase (equality terminalPer) = isSet× isSetUnit* isSetUnit* + ∣ equality terminalPer ∣ (tt* , tt*) _ = Unit* + isPropValued (equality terminalPer) _ _ = isPropUnit* + isPartialEquivalenceRelation.isSetX (isPerEquality terminalPer) = isSetUnit* + isPartialEquivalenceRelation.isSymmetric (isPerEquality terminalPer) = + return (k , (λ { tt* tt* r tt* → tt* })) + isPartialEquivalenceRelation.isTransitive (isPerEquality terminalPer) = + return (k , (λ { tt* tt* tt* _ _ tt* tt* → tt* })) + +open FunctionalRelation + +opaque + unfolding terminalPer + terminalFuncRel : ∀ {Y : Type ℓ'} → (perY : PartialEquivalenceRelation Y) → FunctionalRelation perY terminalPer + terminalFuncRel {Y} perY = + record + { relation = + record + { isSetX = isSet× (perY .isSetX) isSetUnit* + ; ∣_∣ = λ { (y , tt*) r → r ⊩ ∣ perY .equality ∣ (y , y) } + ; isPropValued = λ { (y , tt*) r → perY .equality .isPropValued _ _ } } + ; isFuncRel = + record + { isStrictDomain = return (Id , (λ { y tt* r r⊩y~y → subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y)) (sym (Ida≡a _)) r⊩y~y })) + ; isStrictCodomain = return (k , (λ { y tt* r r⊩y~y → tt* })) + ; isRelational = + (do + (t , t⊩isTransitive) ← perY .isTransitive + (s , s⊩isSymmetric) ← perY .isSymmetric + let + prover : ApplStrTerm as 3 + prover = ` t ̇ (` s ̇ # two) ̇ # two + return + (λ*3 prover , + (λ { y y' tt* tt* a b c a⊩y~y' b⊩y~y tt* → + subst + (λ r' → r' ⊩ ∣ perY .equality ∣ (y' , y')) + (sym (λ*3ComputationRule prover a b c)) + (t⊩isTransitive y' y y' (s ⨾ a) a (s⊩isSymmetric y y' a a⊩y~y') a⊩y~y') }))) + ; isSingleValued = (return (k , (λ { y tt* tt* r₁ r₂ r₁⊩y~y r₂⊩y~y → tt* }))) + ; isTotal = return + (Id , + (λ y r r⊩y~y → + return (tt* , (subst (λ r' → r' ⊩ ∣ perY .equality ∣ (y , y)) (sym (Ida≡a _)) r⊩y~y)))) + } } +opaque + unfolding terminalPer + isTerminalTerminalPer : ∀ {Y : Type ℓ'} → (perY : PartialEquivalenceRelation Y) → isContr (RTMorphism perY terminalPer) + isTerminalTerminalPer {Y} perY = + inhProp→isContr + [ terminalFuncRel perY ] + λ f g → + SQ.elimProp2 + (λ f g → squash/ f g) + (λ F G → + let + answer : pointwiseEntailment perY terminalPer F G + answer = + do + (tlG , tlG⊩isTotalG) ← G .isTotal + (stFD , stFD⊩isStrictDomainF) ← F .isStrictDomain + let + prover : ApplStrTerm as 1 + prover = ` tlG ̇ (` stFD ̇ # zero) + return + (λ* prover , + (λ { y tt* r r⊩Fy → + transport + (propTruncIdempotent (G .relation .isPropValued _ _)) + (do + (tt* , tlGstFD⊩Gy) ← tlG⊩isTotalG y (stFD ⨾ r) (stFD⊩isStrictDomainF y tt* r r⊩Fy) + return (subst (λ r' → r' ⊩ ∣ G .relation ∣ (y , tt*)) (sym (λ*ComputationRule prover r)) tlGstFD⊩Gy)) })) + in + eq/ _ _ (answer , F≤G→G≤F perY terminalPer F G answer)) + f g + +TerminalRT : Terminal RT +TerminalRT = + (Unit* , terminalPer) , (λ { (Y , perY) → isTerminalTerminalPer perY}) diff --git a/src/Realizability/Tripos/Algebra/Base.agda b/src/Realizability/Tripos/Algebra/Base.agda index 4287b4a..a1d63ba 100644 --- a/src/Realizability/Tripos/Algebra/Base.agda +++ b/src/Realizability/Tripos/Algebra/Base.agda @@ -8,6 +8,7 @@ open import Cubical.Foundations.Univalence open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.Structure +open import Cubical.Foundations.HLevels open import Cubical.Functions.FunExtEquiv open import Cubical.Data.Fin open import Cubical.Data.Sum renaming (rec to sumRec) @@ -17,7 +18,7 @@ open import Cubical.Data.Empty renaming (elim to ⊥elim) open import Cubical.Data.Unit open import Cubical.HITs.PropositionalTruncation open import Cubical.HITs.PropositionalTruncation.Monad -open import Cubical.HITs.SetQuotients renaming (rec to quotRec; rec2 to quotRec2) +open import Cubical.HITs.SetQuotients as SQ renaming (rec to quotRec; rec2 to quotRec2) open import Cubical.Relation.Binary.Order.Preorder open import Cubical.Relation.Binary.Order.Poset open import Cubical.Algebra.Lattice @@ -26,8 +27,8 @@ open import Cubical.Algebra.CommMonoid open import Cubical.Algebra.Monoid open import Cubical.Algebra.Semigroup -module Realizability.Tripos.Algebra.Base {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca +module Realizability.Tripos.Algebra.Base {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +import Realizability.Tripos.Prealgebra.Predicate ca as Pred open import Realizability.Tripos.Prealgebra.Joins.Commutativity ca open import Realizability.Tripos.Prealgebra.Joins.Identity ca open import Realizability.Tripos.Prealgebra.Joins.Idempotency ca @@ -41,10 +42,60 @@ open import Realizability.Tripos.Prealgebra.Absorbtion ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -λ*ComputationRule = `λ*ComputationRule as fefermanStructure -λ* = `λ* as fefermanStructure +private + λ*ComputationRule = `λ*ComputationRule as fefermanStructure + λ* = `λ* as fefermanStructure -module AlgebraicProperties {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where +AlgebraicPredicate : Type ℓ' → Type _ +AlgebraicPredicate X = PosetReflection (Pred.PredicateProperties._≤_ {ℓ'' = ℓ''} X) + +infixl 50 _⊩[_]_ +opaque + realizes : ∀ {X : Type ℓ'} → A → AlgebraicPredicate X → X → hProp (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) + realizes {X} r ϕ x = + SQ.rec + isSetHProp + (λ Ψ → (∃[ s ∈ A ] Pred.Predicate.∣ Ψ ∣ x (s ⨾ r)) , isPropPropTrunc) + (λ { Ψ Ξ (Ψ≤Ξ , Ξ≤Ψ) → + Σ≡Prop + (λ _ → isPropIsProp) + (hPropExt isPropPropTrunc isPropPropTrunc + (λ Ψholds → + do + (s , s⊩Ψ≤Ξ) ← Ψ≤Ξ + (p , p⊩Ψ) ← Ψholds + let + prover : Term as 1 + prover = ` s ̇ (` p ̇ # fzero) + return (λ* prover , subst (λ r' → Pred.Predicate.∣ Ξ ∣ x r') (sym (λ*ComputationRule prover (r ∷ []))) (s⊩Ψ≤Ξ x (p ⨾ r) p⊩Ψ))) + (λ Ξholds → + do + (s , s⊩Ξ≤Ψ) ← Ξ≤Ψ + (p , p⊩Ξ) ← Ξholds + let + prover : Term as 1 + prover = ` s ̇ (` p ̇ # fzero) + return (λ* prover , subst (λ r' → Pred.Predicate.∣ Ψ ∣ x r') (sym (λ*ComputationRule prover (r ∷ []))) (s⊩Ξ≤Ψ x (p ⨾ r) p⊩Ξ)))) }) + ϕ + + _⊩[_]_ : ∀ {X : Type ℓ'} → A → AlgebraicPredicate X → X → Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) + r ⊩[ ϕ ] x = ⟨ realizes r ϕ x ⟩ + + isProp⊩ : ∀ {X : Type ℓ'} → (a : A) → (ϕ : AlgebraicPredicate X) → (x : X) → isProp (a ⊩[ ϕ ] x) + isProp⊩ {X} a ϕ x = realizes a ϕ x .snd + + transformRealizes : ∀ {X : Type ℓ'} → (r : A) → (ϕ : Pred.Predicate X) → (x : X) → (∃[ s ∈ A ] (s ⨾ r) ⊩[ [ ϕ ] ] x) → r ⊩[ [ ϕ ] ] x + transformRealizes {X} r ϕ x ∃ = + do + (s , s⊩ϕx) ← ∃ + (p , ps⊩ϕx) ← s⊩ϕx + let + prover : Term as 1 + prover = ` p ̇ (` s ̇ # fzero) + return (λ* prover , subst (λ r' → Pred.Predicate.∣ ϕ ∣ x r') (sym (λ*ComputationRule prover (r ∷ []))) ps⊩ϕx) + +module AlgebraicProperties (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where + open Pred private PredicateX = Predicate {ℓ'' = ℓ''} X open Predicate open PredicateProperties {ℓ'' = ℓ''} X diff --git a/src/Realizability/Tripos/Logic/RelContextStructural.agda b/src/Realizability/Tripos/Logic/RelContextStructural.agda new file mode 100644 index 0000000..b520904 --- /dev/null +++ b/src/Realizability/Tripos/Logic/RelContextStructural.agda @@ -0,0 +1,158 @@ +{-# OPTIONS --lossy-unification #-} +open import Cubical.Foundations.Prelude +open import Cubical.Foundations.Structure +open import Cubical.Foundations.Univalence +open import Cubical.Data.Vec +open import Cubical.Data.Nat +open import Cubical.Data.FinData +open import Cubical.Data.Empty +open import Cubical.Data.Sigma +open import Cubical.Data.Sum +open import Cubical.HITs.PropositionalTruncation +open import Cubical.HITs.PropositionalTruncation.Monad +open import Realizability.CombinatoryAlgebra +open import Realizability.ApplicativeStructure +open import Realizability.Tripos.Logic.Syntax +import Realizability.Tripos.Logic.Semantics as Semantics + +module Realizability.Tripos.Logic.RelContextStructural where + +module WeakenSyntax + {n} + {ℓ} + (Ξ : Vec (Sort {ℓ = ℓ}) n) + (R : Sort) where + + private module SyntaxΞ = Relational Ξ + open SyntaxΞ renaming (Formula to ΞFormula) + + private module SyntaxΞR = Relational (R ∷ Ξ) + open SyntaxΞR renaming (Formula to ΞRFormula) + + transportAlongWeakening : ∀ {Γ} → ΞFormula Γ → ΞRFormula Γ + transportAlongWeakening {Γ} Relational.⊤ᵗ = SyntaxΞR.⊤ᵗ + transportAlongWeakening {Γ} Relational.⊥ᵗ = SyntaxΞR.⊥ᵗ + transportAlongWeakening {Γ} (form Relational.`∨ form₁) = transportAlongWeakening form SyntaxΞR.`∨ transportAlongWeakening form₁ + transportAlongWeakening {Γ} (form Relational.`∧ form₁) = transportAlongWeakening form SyntaxΞR.`∧ transportAlongWeakening form₁ + transportAlongWeakening {Γ} (form Relational.`→ form₁) = transportAlongWeakening form SyntaxΞR.`→ transportAlongWeakening form₁ + transportAlongWeakening {Γ} (Relational.`∃ form) = SyntaxΞR.`∃ (transportAlongWeakening form) + transportAlongWeakening {Γ} (Relational.`∀ form) = SyntaxΞR.`∀ (transportAlongWeakening form) + transportAlongWeakening {Γ} (Relational.rel k x) = SyntaxΞR.rel (suc k) x + +module WeakenSemantics + {n} + {ℓ ℓ' ℓ''} + {A : Type ℓ} + (ca : CombinatoryAlgebra A) + (isNonTrivial : CombinatoryAlgebra.s ca ≡ CombinatoryAlgebra.k ca → ⊥) + (Ξ : Vec (Sort {ℓ = ℓ'}) n) + (R : Sort {ℓ = ℓ'}) + (Ξsem : Semantics.RelationInterpretation {ℓ'' = ℓ''} ca Ξ) where + open import Realizability.Tripos.Prealgebra.Predicate.Base ca renaming (Predicate to Predicate') + open import Realizability.Tripos.Prealgebra.Predicate.Properties ca + open CombinatoryAlgebra ca + open Combinators ca + open WeakenSyntax Ξ R + open Predicate' + open Semantics {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca + Predicate = Predicate' {ℓ' = ℓ'} {ℓ'' = ℓ''} + + module SyntaxΞ = Relational Ξ + open SyntaxΞ renaming (Formula to ΞFormula) + + module SyntaxΞR = Relational (R ∷ Ξ) + open SyntaxΞR renaming (Formula to ΞRFormula) + + module _ (Rsem : Predicate ⟨ ⟦ R ⟧ˢ ⟩) where + + RΞsem : Semantics.RelationInterpretation {ℓ'' = ℓ''} ca (R ∷ Ξ) + RΞsem zero = Rsem + RΞsem (suc f) = Ξsem f + + module InterpretationΞ = Interpretation Ξ Ξsem isNonTrivial + module InterpretationΞR = Interpretation (R ∷ Ξ) RΞsem isNonTrivial + module SoundnessΞ = Soundness {relSym = Ξ} isNonTrivial Ξsem + module SoundnessΞR = Soundness {relSym = R ∷ Ξ} isNonTrivial RΞsem + + syntacticTransportPreservesRealizers⁺ : + ∀ {Γ} + → (γ : ⟨ ⟦ Γ ⟧ᶜ ⟩) + → (r : A) + → (f : ΞFormula Γ) + → ∣ InterpretationΞ.⟦ f ⟧ᶠ ∣ γ r + ------------------------------------------------------------- + → r ⊩ ∣ InterpretationΞR.⟦ transportAlongWeakening f ⟧ᶠ ∣ γ + syntacticTransportPreservesRealizers⁻ : + ∀ {Γ} + → (γ : ⟨ ⟦ Γ ⟧ᶜ ⟩) + → (r : A) + → (f : ΞFormula Γ) + → r ⊩ ∣ InterpretationΞR.⟦ transportAlongWeakening f ⟧ᶠ ∣ γ + ------------------------------------------------------------- + → r ⊩ ∣ InterpretationΞ.⟦ f ⟧ᶠ ∣ γ + + syntacticTransportPreservesRealizers⁺ {Γ} γ r Relational.⊤ᵗ r⊩⟦f⟧Ξ = r⊩⟦f⟧Ξ + syntacticTransportPreservesRealizers⁺ {Γ} γ r (f Relational.`∨ f₁) r⊩⟦f⟧Ξ = + r⊩⟦f⟧Ξ >>= + λ { (inl (pr₁r≡k , pr₂r⊩⟦f⟧)) → ∣ inl (pr₁r≡k , syntacticTransportPreservesRealizers⁺ γ (pr₂ ⨾ r) f pr₂r⊩⟦f⟧) ∣₁ + ; (inr (pr₁r≡k' , pr₂r⊩⟦f₁⟧)) → ∣ inr (pr₁r≡k' , (syntacticTransportPreservesRealizers⁺ γ (pr₂ ⨾ r) f₁ pr₂r⊩⟦f₁⟧)) ∣₁ } + syntacticTransportPreservesRealizers⁺ {Γ} γ r (f Relational.`∧ f₁) (pr₁r⊩⟦f⟧ , pr₂r⊩⟦f₁⟧) = + syntacticTransportPreservesRealizers⁺ γ (pr₁ ⨾ r) f pr₁r⊩⟦f⟧ , + syntacticTransportPreservesRealizers⁺ γ (pr₂ ⨾ r) f₁ pr₂r⊩⟦f₁⟧ + syntacticTransportPreservesRealizers⁺ {Γ} γ r (f Relational.`→ f₁) r⊩⟦f⟧Ξ = + λ b b⊩⟦f⟧ΞR → syntacticTransportPreservesRealizers⁺ γ (r ⨾ b) f₁ (r⊩⟦f⟧Ξ b (syntacticTransportPreservesRealizers⁻ γ b f b⊩⟦f⟧ΞR)) + syntacticTransportPreservesRealizers⁺ {Γ} γ r (Relational.`∃ f) r⊩⟦f⟧Ξ = + r⊩⟦f⟧Ξ >>= + λ { ((γ' , b) , γ'≡γ , r⊩⟦f⟧Ξγ'b) → ∣ (γ' , b) , (γ'≡γ , (syntacticTransportPreservesRealizers⁺ (γ' , b) r f r⊩⟦f⟧Ξγ'b)) ∣₁ } + syntacticTransportPreservesRealizers⁺ {Γ} γ r (Relational.`∀ f) r⊩⟦f⟧Ξ = + λ { b (γ' , b') γ'≡γ → syntacticTransportPreservesRealizers⁺ (γ' , b') (r ⨾ b) f (r⊩⟦f⟧Ξ b (γ' , b') γ'≡γ) } + syntacticTransportPreservesRealizers⁺ {Γ} γ r (Relational.rel Rsym t) r⊩⟦f⟧Ξ = + subst + (λ R' → r ⊩ ∣ R' ∣ (⟦ t ⟧ᵗ γ)) + (sym (RΞsem (suc Rsym) ≡⟨ refl ⟩ (Ξsem Rsym ∎))) + r⊩⟦f⟧Ξ + + syntacticTransportPreservesRealizers⁻ {Γ} γ r Relational.⊤ᵗ r⊩⟦f⟧ΞR = r⊩⟦f⟧ΞR + syntacticTransportPreservesRealizers⁻ {Γ} γ r (f Relational.`∨ f₁) r⊩⟦f⟧ΞR = + r⊩⟦f⟧ΞR >>= + λ { (inl (pr₁r≡k , pr₂r⊩⟦f⟧)) → + ∣ inl (pr₁r≡k , (syntacticTransportPreservesRealizers⁻ γ (pr₂ ⨾ r) f pr₂r⊩⟦f⟧)) ∣₁ + ; (inr (pr₁r≡k' , pr₂r⊩⟦f₁⟧)) → + ∣ inr (pr₁r≡k' , (syntacticTransportPreservesRealizers⁻ γ (pr₂ ⨾ r) f₁ pr₂r⊩⟦f₁⟧)) ∣₁ } + syntacticTransportPreservesRealizers⁻ {Γ} γ r (f Relational.`∧ f₁) r⊩⟦f⟧ΞR = + (syntacticTransportPreservesRealizers⁻ γ (pr₁ ⨾ r) f (r⊩⟦f⟧ΞR .fst)) , + (syntacticTransportPreservesRealizers⁻ γ (pr₂ ⨾ r) f₁ (r⊩⟦f⟧ΞR .snd)) + syntacticTransportPreservesRealizers⁻ {Γ} γ r (f Relational.`→ f₁) r⊩⟦f→f₁⟧ΞR = + λ b b⊩⟦f⟧Ξ → syntacticTransportPreservesRealizers⁻ γ (r ⨾ b) f₁ (r⊩⟦f→f₁⟧ΞR b (syntacticTransportPreservesRealizers⁺ γ b f b⊩⟦f⟧Ξ)) + syntacticTransportPreservesRealizers⁻ {Γ} γ r (Relational.`∃ f) r⊩⟦f⟧ΞR = + r⊩⟦f⟧ΞR >>= + λ { ((γ' , b) , γ'≡γ , r⊩⟦f⟧γ'b) → ∣ (γ' , b) , γ'≡γ , (syntacticTransportPreservesRealizers⁻ (γ' , b) r f r⊩⟦f⟧γ'b) ∣₁ } + syntacticTransportPreservesRealizers⁻ {Γ} γ r (Relational.`∀ f) r⊩⟦f⟧ΞR = + λ { b (γ' , b') γ'≡γ → syntacticTransportPreservesRealizers⁻ (γ' , b') (r ⨾ b) f (r⊩⟦f⟧ΞR b (γ' , b') γ'≡γ) } + syntacticTransportPreservesRealizers⁻ {Γ} γ r (Relational.rel Rsym t) r⊩⟦f⟧ΞR = + subst + (λ R' → r ⊩ ∣ R' ∣ (⟦ t ⟧ᵗ γ)) + (sym (RΞsem (suc Rsym) ≡⟨ refl ⟩ (Ξsem Rsym ∎))) + r⊩⟦f⟧ΞR + + syntacticTransportPreservesRealizers : + ∀ {Γ} + → (γ : ⟨ ⟦ Γ ⟧ᶜ ⟩) + → (r : A) + → (f : ΞFormula Γ) + ---------------------------------------------------------- + → r ⊩ ∣ InterpretationΞR.⟦ transportAlongWeakening f ⟧ᶠ ∣ γ + ≡ r ⊩ ∣ InterpretationΞ.⟦ f ⟧ᶠ ∣ γ + syntacticTransportPreservesRealizers {Γ} γ r f = + hPropExt + (InterpretationΞR.⟦ transportAlongWeakening f ⟧ᶠ .isPropValued γ r) + (InterpretationΞ.⟦ f ⟧ᶠ .isPropValued γ r) + (λ r⊩⟦f⟧ΞR → syntacticTransportPreservesRealizers⁻ γ r f r⊩⟦f⟧ΞR) + λ r⊩⟦f⟧Ξ → syntacticTransportPreservesRealizers⁺ γ r f r⊩⟦f⟧Ξ + + transportPreservesHoldsInTripos : ∀ {Γ} → (f : ΞFormula Γ) → SoundnessΞ.holdsInTripos f → SoundnessΞR.holdsInTripos (transportAlongWeakening f) + transportPreservesHoldsInTripos {Γ} f holds = + do + (a , a⊩holds) ← holds + return (a , λ { γ b tt* → syntacticTransportPreservesRealizers⁺ γ (a ⨾ b) f (a⊩holds γ b tt*) }) + diff --git a/src/Realizability/Tripos/Logic/Semantics.agda b/src/Realizability/Tripos/Logic/Semantics.agda index 123d1f0..d19a65a 100644 --- a/src/Realizability/Tripos/Logic/Semantics.agda +++ b/src/Realizability/Tripos/Logic/Semantics.agda @@ -1,6 +1,6 @@ {-# OPTIONS --allow-unsolved-metas #-} open import Realizability.CombinatoryAlgebra -open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm) +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm; λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Foundations.Equiv @@ -23,135 +23,258 @@ open import Cubical.Relation.Binary.Order.Preorder module Realizability.Tripos.Logic.Semantics {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate.Base ca renaming (Predicate to Predicate') -open import Realizability.Tripos.Prealgebra.Predicate.Properties ca -open import Realizability.Tripos.Prealgebra.Meets.Identity ca -open import Realizability.Tripos.Prealgebra.Joins.Identity ca -open import Realizability.Tripos.Logic.Syntax {ℓ = ℓ'} open CombinatoryAlgebra ca +private λ*ComputationRule = `λ*ComputationRule as fefermanStructure +private λ* = `λ* as fefermanStructure + +open import Realizability.Tripos.Prealgebra.Predicate.Base {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Predicate.Properties {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Meets.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Joins.Identity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Implication {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Logic.Syntax {ℓ = ℓ'} open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -open Predicate' +open Predicate open PredicateProperties hiding (_≤_ ; isTrans≤) -open Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''} -Predicate = Predicate' {ℓ' = ℓ'} {ℓ'' = ℓ''} +open Morphism RelationInterpretation : ∀ {n : ℕ} → (Vec Sort n) → Type _ RelationInterpretation {n} relSym = (∀ i → Predicate ⟨ ⟦ lookup i relSym ⟧ˢ ⟩) + +⟦_⟧ᶜ : Context → hSet ℓ' +⟦ [] ⟧ᶜ = Unit* , isSetUnit* +⟦ c ′ x ⟧ᶜ = (⟦ c ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) , isSet× (⟦ c ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd) + +⟦_⟧ⁿ : ∀ {Γ s} → s ∈ Γ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩ +⟦_⟧ⁿ {.(_ ′ s)} {s} _∈_.here (⟦Γ⟧ , ⟦s⟧) = ⟦s⟧ +⟦_⟧ⁿ {.(_ ′ _)} {s} (_∈_.there s∈Γ) (⟦Γ⟧ , ⟦s⟧) = ⟦ s∈Γ ⟧ⁿ ⟦Γ⟧ + +⟦_⟧ᵗ : ∀ {Γ s} → Term Γ s → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩ +⟦_⟧ᵗ {Γ} {s} (var x) ⟦Γ⟧ = ⟦ x ⟧ⁿ ⟦Γ⟧ +⟦_⟧ᵗ {Γ} {s} (t `, t₁) ⟦Γ⟧ = (⟦ t ⟧ᵗ ⟦Γ⟧) , (⟦ t₁ ⟧ᵗ ⟦Γ⟧) +⟦_⟧ᵗ {Γ} {s} (π₁ t) ⟦Γ⟧ = fst (⟦ t ⟧ᵗ ⟦Γ⟧) +⟦_⟧ᵗ {Γ} {s} (π₂ t) ⟦Γ⟧ = snd (⟦ t ⟧ᵗ ⟦Γ⟧) +⟦_⟧ᵗ {Γ} {s} (fun x t) ⟦Γ⟧ = x (⟦ t ⟧ᵗ ⟦Γ⟧) + +-- R for renamings and r for relations +⟦_⟧ᴿ : ∀ {Γ Δ} → Renaming Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩ +⟦ id ⟧ᴿ ctx = ctx +⟦ drop ren ⟧ᴿ (ctx , _) = ⟦ ren ⟧ᴿ ctx +⟦ keep ren ⟧ᴿ (ctx , s) = (⟦ ren ⟧ᴿ ctx) , s + +-- B for suBstitution and s for sorts +⟦_⟧ᴮ : ∀ {Γ Δ} → Substitution Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩ +⟦ id ⟧ᴮ ctx = ctx +⟦ t , sub ⟧ᴮ ctx = (⟦ sub ⟧ᴮ ctx) , (⟦ t ⟧ᵗ ctx) +⟦ drop sub ⟧ᴮ (ctx , s) = ⟦ sub ⟧ᴮ ctx + +renamingVarSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (v : s ∈ Δ) → ⟦ renamingVar ren v ⟧ⁿ ≡ ⟦ v ⟧ⁿ ∘ ⟦ ren ⟧ᴿ +renamingVarSound {Γ} {.Γ} {s} id v = refl +renamingVarSound {.(_ ′ _)} {Δ} {s} (drop ren) v = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ } +renamingVarSound {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → ⟦s⟧ } +renamingVarSound {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there v) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ } + +renamingTermSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (t : Term Δ s) → ⟦ renamingTerm ren t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ ren ⟧ᴿ +renamingTermSound {Γ} {.Γ} {s} id t = refl +renamingTermSound {.(_ ′ _)} {Δ} {s} (drop ren) (var x) = + funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren x i ⟦Γ⟧ } +renamingTermSound {.(_ ′ _)} {Δ} {.(_ `× _)} r@(drop ren) (t `, t₁) = + funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i (⟦Γ⟧ , ⟦s⟧) , renamingTermSound r t₁ i (⟦Γ⟧ , ⟦s⟧) } +renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₁ t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst } +renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₂ t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd } +renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (fun f t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) } +renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (var v) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingVarSound r v i x } +renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} r@(keep ren) (t `, t₁) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → (renamingTermSound r t i x) , (renamingTermSound r t₁ i x) } +renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₁ t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst } +renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₂ t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd } +renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (fun f t) = + funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) } + + +substitutionVarSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (v : s ∈ Δ) → ⟦ substitutionVar subs v ⟧ᵗ ≡ ⟦ v ⟧ⁿ ∘ ⟦ subs ⟧ᴮ +substitutionVarSound {Γ} {.Γ} {s} id t = refl +substitutionVarSound {Γ} {.(_ ′ s)} {s} (t' , subs) here = funExt λ ⟦Γ⟧ → refl +substitutionVarSound {Γ} {.(_ ′ _)} {s} (t' , subs) (there t) = funExt λ ⟦Γ⟧ i → substitutionVarSound subs t i ⟦Γ⟧ +substitutionVarSound {.(_ ′ _)} {Δ} {s} r@(drop subs) t = + -- TODO : Fix unsolved constraints + funExt + λ { x@(⟦Γ⟧ , ⟦s⟧) → + ⟦ substitutionVar (drop subs) t ⟧ᵗ x + ≡[ i ]⟨ renamingTermSound (drop id) (substitutionVar subs t) i x ⟩ + ⟦ substitutionVar subs t ⟧ᵗ (⟦ drop id ⟧ᴿ x) + ≡⟨ refl ⟩ + ⟦ substitutionVar subs t ⟧ᵗ ⟦Γ⟧ + ≡[ i ]⟨ substitutionVarSound subs t i ⟦Γ⟧ ⟩ + ⟦ t ⟧ⁿ (⟦ subs ⟧ᴮ ⟦Γ⟧) + ∎} + +substitutionTermSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (t : Term Δ s) → ⟦ substitutionTerm subs t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ subs ⟧ᴮ +substitutionTermSound {Γ} {Δ} {s} subs (var x) = substitutionVarSound subs x +substitutionTermSound {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = funExt λ x i → (substitutionTermSound subs t i x) , (substitutionTermSound subs t₁ i x) +substitutionTermSound {Γ} {Δ} {s} subs (π₁ t) = funExt λ x i → substitutionTermSound subs t i x .fst +substitutionTermSound {Γ} {Δ} {s} subs (π₂ t) = funExt λ x i → substitutionTermSound subs t i x .snd +substitutionTermSound {Γ} {Δ} {s} subs (fun f t) = funExt λ x i → f (substitutionTermSound subs t i x) + +semanticSubstitution : ∀ {Γ Δ} → (subs : Substitution Γ Δ) → Predicate ⟨ ⟦ Δ ⟧ᶜ ⟩ → Predicate ⟨ ⟦ Γ ⟧ᶜ ⟩ +semanticSubstitution {Γ} {Δ} subs = ⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ + module Interpretation {n : ℕ} (relSym : Vec Sort n) (⟦_⟧ʳ : RelationInterpretation relSym) (isNonTrivial : s ≡ k → ⊥) where open Relational relSym - - ⟦_⟧ᶜ : Context → hSet ℓ' - ⟦ [] ⟧ᶜ = Unit* , isSetUnit* - ⟦ c ′ x ⟧ᶜ = (⟦ c ⟧ᶜ .fst × ⟦ x ⟧ˢ .fst) , isSet× (⟦ c ⟧ᶜ .snd) (⟦ x ⟧ˢ .snd) - - ⟦_⟧ⁿ : ∀ {Γ s} → s ∈ Γ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩ - ⟦_⟧ⁿ {.(_ ′ s)} {s} _∈_.here (⟦Γ⟧ , ⟦s⟧) = ⟦s⟧ - ⟦_⟧ⁿ {.(_ ′ _)} {s} (_∈_.there s∈Γ) (⟦Γ⟧ , ⟦s⟧) = ⟦ s∈Γ ⟧ⁿ ⟦Γ⟧ - - ⟦_⟧ᵗ : ∀ {Γ s} → Term Γ s → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ s ⟧ˢ ⟩ - ⟦_⟧ᵗ {Γ} {s} (var x) ⟦Γ⟧ = ⟦ x ⟧ⁿ ⟦Γ⟧ - ⟦_⟧ᵗ {Γ} {s} (t `, t₁) ⟦Γ⟧ = (⟦ t ⟧ᵗ ⟦Γ⟧) , (⟦ t₁ ⟧ᵗ ⟦Γ⟧) - ⟦_⟧ᵗ {Γ} {s} (π₁ t) ⟦Γ⟧ = fst (⟦ t ⟧ᵗ ⟦Γ⟧) - ⟦_⟧ᵗ {Γ} {s} (π₂ t) ⟦Γ⟧ = snd (⟦ t ⟧ᵗ ⟦Γ⟧) - ⟦_⟧ᵗ {Γ} {s} (fun x t) ⟦Γ⟧ = x (⟦ t ⟧ᵗ ⟦Γ⟧) - ⟦_⟧ᶠ : ∀ {Γ} → Formula Γ → Predicate ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦_⟧ᶠ {Γ} ⊤ᵗ = pre1 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial ⟦_⟧ᶠ {Γ} ⊥ᵗ = pre0 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial ⟦_⟧ᶠ {Γ} (form `∨ form₁) = _⊔_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ ⟦_⟧ᶠ {Γ} (form `∧ form₁) = _⊓_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ ⟦_⟧ᶠ {Γ} (form `→ form₁) = _⇒_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ form₁ ⟧ᶠ - ⟦_⟧ᶠ {Γ} (`¬ form) = _⇒_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ form ⟧ᶠ ⟦ ⊥ᵗ {Γ = Γ} ⟧ᶠ ⟦_⟧ᶠ {Γ} (`∃ {B = B} form) = `∃[_] (isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ)) (str ⟦ Γ ⟧ᶜ) (λ { (⟦Γ⟧ , ⟦B⟧) → ⟦Γ⟧ }) ⟦ form ⟧ᶠ ⟦_⟧ᶠ {Γ} (`∀ {B = B} form) = `∀[_] (isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ)) (str ⟦ Γ ⟧ᶜ) (λ { (⟦Γ⟧ , ⟦B⟧) → ⟦Γ⟧ }) ⟦ form ⟧ᶠ ⟦_⟧ᶠ {Γ} (rel R t) = ⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ - -- R for renamings and r for relations - ⟦_⟧ᴿ : ∀ {Γ Δ} → Renaming Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩ - ⟦ id ⟧ᴿ ctx = ctx - ⟦ drop ren ⟧ᴿ (ctx , _) = ⟦ ren ⟧ᴿ ctx - ⟦ keep ren ⟧ᴿ (ctx , s) = (⟦ ren ⟧ᴿ ctx) , s - - -- B for suBstitution and s for sorts - ⟦_⟧ᴮ : ∀ {Γ Δ} → Substitution Γ Δ → ⟨ ⟦ Γ ⟧ᶜ ⟩ → ⟨ ⟦ Δ ⟧ᶜ ⟩ - ⟦ id ⟧ᴮ ctx = ctx - ⟦ t , sub ⟧ᴮ ctx = (⟦ sub ⟧ᴮ ctx) , (⟦ t ⟧ᵗ ctx) - ⟦ drop sub ⟧ᴮ (ctx , s) = ⟦ sub ⟧ᴮ ctx - - renamingVarSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (v : s ∈ Δ) → ⟦ renamingVar ren v ⟧ⁿ ≡ ⟦ v ⟧ⁿ ∘ ⟦ ren ⟧ᴿ - renamingVarSound {Γ} {.Γ} {s} id v = refl - renamingVarSound {.(_ ′ _)} {Δ} {s} (drop ren) v = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ } - renamingVarSound {.(_ ′ s)} {.(_ ′ s)} {s} (keep ren) here = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → ⟦s⟧ } - renamingVarSound {.(_ ′ _)} {.(_ ′ _)} {s} (keep ren) (there v) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren v i ⟦Γ⟧ } - - renamingTermSound : ∀ {Γ Δ s} → (ren : Renaming Γ Δ) → (t : Term Δ s) → ⟦ renamingTerm ren t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ ren ⟧ᴿ - renamingTermSound {Γ} {.Γ} {s} id t = refl - renamingTermSound {.(_ ′ _)} {Δ} {s} (drop ren) (var x) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingVarSound ren x i ⟦Γ⟧ } - renamingTermSound {.(_ ′ _)} {Δ} {.(_ `× _)} r@(drop ren) (t `, t₁) = funExt λ { (⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i (⟦Γ⟧ , ⟦s⟧) , renamingTermSound r t₁ i (⟦Γ⟧ , ⟦s⟧) } - renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₁ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst } - renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (π₂ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd } - renamingTermSound {.(_ ′ _)} {Δ} {s} r@(drop ren) (fun f t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) } - renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (var v) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingVarSound r v i x } - renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {.(_ `× _)} r@(keep ren) (t `, t₁) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → (renamingTermSound r t i x) , (renamingTermSound r t₁ i x) } - renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₁ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .fst } - renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (π₂ t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → renamingTermSound r t i x .snd } - renamingTermSound {.(_ ′ _)} {.(_ ′ _)} {s} r@(keep ren) (fun f t) = funExt λ { x@(⟦Γ⟧ , ⟦s⟧) i → f (renamingTermSound r t i x) } - - substitutionVarSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (v : s ∈ Δ) → ⟦ substitutionVar subs v ⟧ᵗ ≡ ⟦ v ⟧ⁿ ∘ ⟦ subs ⟧ᴮ - substitutionVarSound {Γ} {.Γ} {s} id t = refl - substitutionVarSound {Γ} {.(_ ′ s)} {s} (t' , subs) here = funExt λ ⟦Γ⟧ → refl - substitutionVarSound {Γ} {.(_ ′ _)} {s} (t' , subs) (there t) = funExt λ ⟦Γ⟧ i → substitutionVarSound subs t i ⟦Γ⟧ - substitutionVarSound {.(_ ′ _)} {Δ} {s} r@(drop subs) t = - -- TODO : Fix unsolved constraints - funExt - λ { x@(⟦Γ⟧ , ⟦s⟧) → - ⟦ substitutionVar (drop subs) t ⟧ᵗ (⟦Γ⟧ , ⟦s⟧) - ≡[ i ]⟨ renamingTermSound (drop id) (substitutionVar subs t) i (⟦Γ⟧ , ⟦s⟧) ⟩ - ⟦ substitutionVar subs t ⟧ᵗ (⟦ drop id ⟧ᴿ x) - ≡⟨ refl ⟩ - ⟦ substitutionVar subs t ⟧ᵗ ⟦Γ⟧ - ≡[ i ]⟨ substitutionVarSound subs t i ⟦Γ⟧ ⟩ - ⟦ t ⟧ⁿ (⟦ subs ⟧ᴮ ⟦Γ⟧) - ∎} - - substitutionTermSound : ∀ {Γ Δ s} → (subs : Substitution Γ Δ) → (t : Term Δ s) → ⟦ substitutionTerm subs t ⟧ᵗ ≡ ⟦ t ⟧ᵗ ∘ ⟦ subs ⟧ᴮ - substitutionTermSound {Γ} {Δ} {s} subs (var x) = substitutionVarSound subs x - substitutionTermSound {Γ} {Δ} {.(_ `× _)} subs (t `, t₁) = funExt λ x i → (substitutionTermSound subs t i x) , (substitutionTermSound subs t₁ i x) - substitutionTermSound {Γ} {Δ} {s} subs (π₁ t) = funExt λ x i → substitutionTermSound subs t i x .fst - substitutionTermSound {Γ} {Δ} {s} subs (π₂ t) = funExt λ x i → substitutionTermSound subs t i x .snd - substitutionTermSound {Γ} {Δ} {s} subs (fun f t) = funExt λ x i → f (substitutionTermSound subs t i x) - - substitutionFormulaSound : ∀ {Γ Δ} → (subs : Substitution Γ Δ) → (f : Formula Δ) → ⟦ substitutionFormula subs f ⟧ᶠ ≡ ⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ ⟦ f ⟧ᶠ + -- Due to a shortcut in the soundness of negation termination checking fails + -- TODO : Fix + {-# TERMINATING #-} + substitutionFormulaSound : ∀ {Γ Δ} → (subs : Substitution Γ Δ) → (f : Formula Δ) → ⟦ substitutionFormula subs f ⟧ᶠ ≡ semanticSubstitution subs ⟦ f ⟧ᶠ substitutionFormulaSound {Γ} {Δ} subs ⊤ᵗ = Predicate≡ ⟨ ⟦ Γ ⟧ᶜ ⟩ (pre1 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial) - (⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ (pre1 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial)) - (λ ⟦Γ⟧ a tt* → tt*) - λ ⟦Γ⟧ a tt* → tt* + (semanticSubstitution subs (pre1 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial)) + (λ γ a a⊩1γ → tt*) + λ γ a a⊩1subsγ → tt* substitutionFormulaSound {Γ} {Δ} subs ⊥ᵗ = Predicate≡ ⟨ ⟦ Γ ⟧ᶜ ⟩ (pre0 ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) isNonTrivial) - (⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ (pre0 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial)) - (λ ⟦Γ⟧ a bot → ⊥rec* bot) - λ ⟦Γ⟧ a bot → bot + (semanticSubstitution subs (pre0 ⟨ ⟦ Δ ⟧ᶜ ⟩ (str ⟦ Δ ⟧ᶜ) isNonTrivial)) + (λ _ _ bot → ⊥rec* bot) + λ _ _ bot → bot substitutionFormulaSound {Γ} {Δ} subs (f `∨ f₁) = Predicate≡ ⟨ ⟦ Γ ⟧ᶜ ⟩ (_⊔_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ) - (⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ Δ ⟧ᶜ) ⟦ subs ⟧ᴮ (_⊔_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ)) - (λ ⟦Γ⟧ a a⊩f'⊔f₁' → {!!}) - {!!} - substitutionFormulaSound {Γ} {Δ} subs (f `∧ f₁) = {!!} - substitutionFormulaSound {Γ} {Δ} subs (f `→ f₁) = {!!} - substitutionFormulaSound {Γ} {Δ} subs (`¬ f) = {!!} - substitutionFormulaSound {Γ} {Δ} subs (`∃ f) = {!!} - substitutionFormulaSound {Γ} {Δ} subs (`∀ f) = {!!} - substitutionFormulaSound {Γ} {Δ} subs (rel k₁ x) = {!!} + (semanticSubstitution subs (_⊔_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ)) + (λ γ a a⊩substFormFs → + a⊩substFormFs >>= + λ { (inl (pr₁a≡k , pr₂a⊩substFormF)) → + ∣ inl (pr₁a≡k , subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f) pr₂a⊩substFormF) ∣₁ + ; (inr (pr₁a≡k' , pr₂a⊩substFormF₁)) → + ∣ inr (pr₁a≡k' , subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f₁) pr₂a⊩substFormF₁) ∣₁ }) + λ γ a a⊩semanticSubsFs → + a⊩semanticSubsFs >>= + λ { (inl (pr₁a≡k , pr₂a⊩semanticSubsF)) → + ∣ inl (pr₁a≡k , (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f)) pr₂a⊩semanticSubsF)) ∣₁ + ; (inr (pr₁a≡k' , pr₂a⊩semanticSubsF₁)) → + ∣ inr (pr₁a≡k' , (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f₁)) pr₂a⊩semanticSubsF₁)) ∣₁ } + substitutionFormulaSound {Γ} {Δ} subs (f `∧ f₁) = + Predicate≡ + ⟨ ⟦ Γ ⟧ᶜ ⟩ + (_⊓_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ) + (semanticSubstitution subs (_⊓_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ)) + (λ γ a a⊩substFormulaFs → + (subst (λ form → (pr₁ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f) (a⊩substFormulaFs .fst)) , + (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (substitutionFormulaSound subs f₁) (a⊩substFormulaFs .snd))) + λ γ a a⊩semanticSubstFs → + (subst (λ form → (pr₁ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f)) (a⊩semanticSubstFs .fst)) , + (subst (λ form → (pr₂ ⨾ a) ⊩ ∣ form ∣ γ) (sym (substitutionFormulaSound subs f₁)) (a⊩semanticSubstFs .snd)) + substitutionFormulaSound {Γ} {Δ} subs (f `→ f₁) = + Predicate≡ + ⟨ ⟦ Γ ⟧ᶜ ⟩ + (_⇒_ ⟨ ⟦ Γ ⟧ᶜ ⟩ ⟦ substitutionFormula subs f ⟧ᶠ ⟦ substitutionFormula subs f₁ ⟧ᶠ) + (semanticSubstitution subs (_⇒_ ⟨ ⟦ Δ ⟧ᶜ ⟩ ⟦ f ⟧ᶠ ⟦ f₁ ⟧ᶠ)) + (λ γ a a⊩substFormulaFs → + λ b b⊩semanticSubstFs → + subst + (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ) + (substitutionFormulaSound subs f₁) + (a⊩substFormulaFs + b + (subst + (λ form → b ⊩ ∣ form ∣ γ) + (sym (substitutionFormulaSound subs f)) + b⊩semanticSubstFs))) + λ γ a a⊩semanticSubstFs → + λ b b⊩substFormulaFs → + subst + (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ) + (sym (substitutionFormulaSound subs f₁)) + (a⊩semanticSubstFs + b + (subst + (λ form → b ⊩ ∣ form ∣ γ) + (substitutionFormulaSound subs f) + b⊩substFormulaFs)) + substitutionFormulaSound {Γ} {Δ} subs (`∃ {B = B} f) = + Predicate≡ + ⟨ ⟦ Γ ⟧ᶜ ⟩ + (`∃[ isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Γ ⟧ᶜ) (λ { (f , s) → f }) ⟦ substitutionFormula (var here , drop subs) f ⟧ᶠ) + (semanticSubstitution subs (`∃[ isSet× (str ⟦ Δ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Δ ⟧ᶜ) (λ { (γ , b) → γ }) ⟦ f ⟧ᶠ)) + (λ γ a a⊩πSubstFormulaF → + a⊩πSubstFormulaF >>= + λ { ((γ' , b) , γ'≡γ , a⊩substFormFγ') → + ∣ ((⟦ subs ⟧ᴮ γ') , b) , + ((cong ⟦ subs ⟧ᴮ γ'≡γ) , + (subst + (λ form → a ⊩ ∣ form ∣ (γ' , b)) + (substitutionFormulaSound (var here , drop subs) f) + a⊩substFormFγ' )) ∣₁ }) + λ γ a a⊩semanticSubstF → + a⊩semanticSubstF >>= + λ (x@(δ , b) , δ≡subsγ , a⊩fx) → + ∣ (γ , b) , + (refl , + (subst + (λ form → a ⊩ ∣ form ∣ (γ , b)) + (sym (substitutionFormulaSound (var here , drop subs) f)) + (subst (λ x → a ⊩ ∣ ⟦ f ⟧ᶠ ∣ (x , b)) δ≡subsγ a⊩fx))) ∣₁ + substitutionFormulaSound {Γ} {Δ} subs (`∀ {B = B} f) = + Predicate≡ + ⟨ ⟦ Γ ⟧ᶜ ⟩ + (`∀[ isSet× (str ⟦ Γ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Γ ⟧ᶜ) (λ { (f , s) → f }) ⟦ substitutionFormula (var here , drop subs) f ⟧ᶠ) + (semanticSubstitution subs (`∀[ isSet× (str ⟦ Δ ⟧ᶜ) (str ⟦ B ⟧ˢ) ] (str ⟦ Δ ⟧ᶜ) (λ { (f , s) → f }) ⟦ f ⟧ᶠ)) + (λ γ a a⊩substFormF → + λ { r x@(δ , b) δ≡subsγ → + subst + (λ g → (a ⨾ r) ⊩ ∣ ⟦ f ⟧ᶠ ∣ (g , b)) + (sym δ≡subsγ) + (subst + (λ form → (a ⨾ r) ⊩ ∣ form ∣ (γ , b)) + (substitutionFormulaSound (var here , drop subs) f) + (a⊩substFormF r (γ , b) refl)) }) + λ γ a a⊩semanticSubsF → + λ { r x@(γ' , b) γ'≡γ → + subst + (λ form → (a ⨾ r) ⊩ ∣ form ∣ (γ' , b)) + (sym (substitutionFormulaSound (var here , drop subs) f)) + (subst + (λ g → (a ⨾ r) ⊩ ∣ ⟦ f ⟧ᶠ ∣ (g , b)) + (cong ⟦ subs ⟧ᴮ (sym γ'≡γ)) + (a⊩semanticSubsF r (⟦ subs ⟧ᴮ γ , b) refl)) } + substitutionFormulaSound {Γ} {Δ} subs (rel R t) = + Predicate≡ + ⟨ ⟦ Γ ⟧ᶜ ⟩ + (⋆_ (str ⟦ Γ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ substitutionTerm subs t ⟧ᵗ ⟦ R ⟧ʳ) + (semanticSubstitution subs (⋆_ (str ⟦ Δ ⟧ᶜ) (str ⟦ lookup R relSym ⟧ˢ) ⟦ t ⟧ᵗ ⟦ R ⟧ʳ)) + (λ γ a a⊩substTR → + subst (λ transform → a ⊩ ∣ ⟦ R ⟧ʳ ∣ (transform γ)) (substitutionTermSound subs t) a⊩substTR) + λ γ a a⊩semSubst → + subst (λ transform → a ⊩ ∣ ⟦ R ⟧ʳ ∣ (transform γ)) (sym (substitutionTermSound subs t)) a⊩semSubst + weakenFormulaMonotonic : ∀ {Γ B} → (γ : ⟨ ⟦ Γ ⟧ᶜ ⟩) → (ϕ : Formula Γ) → (a : A) → (b : ⟨ ⟦ B ⟧ˢ ⟩) → a ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ ≡ a ⊩ ∣ ⟦ weakenFormula {S = B} ϕ ⟧ᶠ ∣ (γ , b) + weakenFormulaMonotonic {Γ} {B} γ ϕ a b = + hPropExt + (⟦ ϕ ⟧ᶠ .isPropValued γ a) + (⟦ weakenFormula ϕ ⟧ᶠ .isPropValued (γ , b) a) + (λ a⊩ϕγ → subst (λ form → a ⊩ ∣ form ∣ (γ , b)) (sym (substitutionFormulaSound (drop id) ϕ)) a⊩ϕγ) + λ a⊩weakenϕγb → subst (λ form → a ⊩ ∣ form ∣ (γ , b)) (substitutionFormulaSound (drop id) ϕ) a⊩weakenϕγb module Soundness {n} {relSym : Vec Sort n} @@ -159,21 +282,320 @@ module Soundness (⟦_⟧ʳ : RelationInterpretation relSym) where open Relational relSym open Interpretation relSym ⟦_⟧ʳ isNonTrivial + -- Acknowledgements : 1lab's "the internal logic of a regular hyperdoctrine" + infix 35 _⊨_ + + module PredProps = PredicateProperties + + _⊨_ : ∀ {Γ} → Formula Γ → Formula Γ → Type (ℓ-max (ℓ-max ℓ ℓ'') ℓ') + _⊨_ {Γ} ϕ ψ = ⟦ ϕ ⟧ᶠ ≤ ⟦ ψ ⟧ᶠ where open PredProps ⟨ ⟦ Γ ⟧ᶜ ⟩ + + entails = _⊨_ + + holdsInTripos : ∀ {Γ} → Formula Γ → Type (ℓ-max (ℓ-max ℓ ℓ'') ℓ') + holdsInTripos {Γ} form = ⊤ᵗ ⊨ form + + private + variable + Γ Δ : Context + ϕ ψ θ : Formula Γ + χ μ ν : Formula Δ + + cut : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ψ ⊨ θ → ϕ ⊨ θ + cut {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ ψ⊨θ = isTrans≤ ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ⊨ψ ψ⊨θ where open PredProps ⟨ ⟦ Γ ⟧ᶜ ⟩ + + substitutionEntailment : ∀ {Γ Δ} (subs : Substitution Γ Δ) → {ϕ ψ : Formula Δ} → ϕ ⊨ ψ → substitutionFormula subs ϕ ⊨ substitutionFormula subs ψ + substitutionEntailment {Γ} {Δ} subs {ϕ} {ψ} ϕ⊨ψ = + subst2 + (λ ϕ' ψ' → ϕ' ≤Γ ψ') + (sym (substitutionFormulaSound subs ϕ)) + (sym (substitutionFormulaSound subs ψ)) + (ϕ⊨ψ >>= + λ { (a , a⊩ϕ≤ψ) → + ∣ a , (λ γ b b⊩ϕsubsγ → a⊩ϕ≤ψ (⟦ subs ⟧ᴮ γ) b b⊩ϕsubsγ) ∣₁ }) where + open PredProps ⟨ ⟦ Γ ⟧ᶜ ⟩ renaming (_≤_ to _≤Γ_) + open PredProps ⟨ ⟦ Δ ⟧ᶜ ⟩ renaming (_≤_ to _≤Δ_) + + `∧intro : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → entails ϕ θ → entails ϕ (ψ `∧ θ) + `∧intro {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ ϕ⊨θ = + do + (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ + (b , b⊩ϕ⊨θ) ← ϕ⊨θ + let + prover : ApplStrTerm as 1 + prover = ` pair ̇ (` a ̇ # fzero) ̇ (` b ̇ # fzero) + return + (λ* prover , + λ γ r r⊩ϕγ → + let + proofEq : λ* prover ⨾ r ≡ pair ⨾ (a ⨾ r) ⨾ (b ⨾ r) + proofEq = λ*ComputationRule prover (r ∷ []) + + pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ r) ≡ a ⨾ r + pr₁proofEq = + pr₁ ⨾ (λ* prover ⨾ r) + ≡⟨ cong (λ x → pr₁ ⨾ x) proofEq ⟩ + pr₁ ⨾ (pair ⨾ (a ⨾ r) ⨾ (b ⨾ r)) + ≡⟨ pr₁pxy≡x _ _ ⟩ + a ⨾ r + ∎ + + pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ r) ≡ b ⨾ r + pr₂proofEq = + pr₂ ⨾ (λ* prover ⨾ r) + ≡⟨ cong (λ x → pr₂ ⨾ x) proofEq ⟩ + pr₂ ⨾ (pair ⨾ (a ⨾ r) ⨾ (b ⨾ r)) + ≡⟨ pr₂pxy≡y _ _ ⟩ + b ⨾ r + ∎ + in + subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₁proofEq) (a⊩ϕ⊨ψ γ r r⊩ϕγ) , + subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (b⊩ϕ⊨θ γ r r⊩ϕγ)) + + `∧elim1 : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `∧ θ) → ϕ ⊨ ψ + `∧elim1 {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ∧θ = + do + (a , a⊩ϕ⊨ψ∧θ) ← ϕ⊨ψ∧θ + let + prover : ApplStrTerm as 1 + prover = ` pr₁ ̇ (` a ̇ # fzero) + return + (λ* prover , + λ γ b b⊩ϕγ → subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym (λ*ComputationRule prover (b ∷ []))) (a⊩ϕ⊨ψ∧θ γ b b⊩ϕγ .fst)) + + `∧elim2 : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `∧ θ) → ϕ ⊨ θ + `∧elim2 {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ∧θ = + do + (a , a⊩ϕ⊨ψ∧θ) ← ϕ⊨ψ∧θ + let + prover : ApplStrTerm as 1 + prover = ` pr₂ ̇ (` a ̇ # fzero) + return + (λ* prover , + λ γ b b⊩ϕγ → subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym (λ*ComputationRule prover (b ∷ []))) (a⊩ϕ⊨ψ∧θ γ b b⊩ϕγ .snd)) + + `∃intro : ∀ {Γ} {ϕ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} {t : Term Γ B} → ϕ ⊨ substitutionFormula (t , id) ψ → ϕ ⊨ `∃ ψ + `∃intro {Γ} {ϕ} {B} {ψ} {t} ϕ⊨ψ[t/x] = + do + (a , a⊩ϕ⊨ψ[t/x]) ← ϕ⊨ψ[t/x] + return + (a , (λ γ b b⊩ϕγ → ∣ (γ , (⟦ t ⟧ᵗ γ)) , + (refl , (subst (λ form → (a ⨾ b) ⊩ ∣ form ∣ γ) (substitutionFormulaSound (t , id) ψ) (a⊩ϕ⊨ψ[t/x] γ b b⊩ϕγ))) ∣₁)) + + `∃elim : ∀ {Γ} {ϕ θ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} → ϕ ⊨ `∃ ψ → (weakenFormula ϕ `∧ ψ) ⊨ weakenFormula θ → ϕ ⊨ θ + `∃elim {Γ} {ϕ} {θ} {B} {ψ} ϕ⊨∃ψ ϕ∧ψ⊨θ = + do + (a , a⊩ϕ⊨∃ψ) ← ϕ⊨∃ψ + (b , b⊩ϕ∧ψ⊨θ) ← ϕ∧ψ⊨θ + let + prover : ApplStrTerm as 1 + prover = ` b ̇ (` pair ̇ # fzero ̇ (` a ̇ # fzero)) + return + (λ* prover , + (λ γ c c⊩ϕγ → + subst + (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) + (sym (λ*ComputationRule prover (c ∷ []))) + (transport + (propTruncIdempotent (⟦ θ ⟧ᶠ .isPropValued γ (b ⨾ (pair ⨾ c ⨾ (a ⨾ c))))) + (a⊩ϕ⊨∃ψ γ c c⊩ϕγ >>= + λ { (x@(γ' , b') , (γ'≡γ , a⨾c⊩ψx)) → + ∣ transport + (sym + (weakenFormulaMonotonic γ θ (b ⨾ (pair ⨾ c ⨾ (a ⨾ c))) b')) + (b⊩ϕ∧ψ⊨θ + (γ , b') + (pair ⨾ c ⨾ (a ⨾ c)) + (subst + (λ r → r ⊩ ∣ ⟦ weakenFormula ϕ ⟧ᶠ ∣ (γ , b')) + (sym (pr₁pxy≡x _ _)) + (transport + (weakenFormulaMonotonic γ ϕ c b') c⊩ϕγ) , + subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ , b')) (sym (pr₂pxy≡y _ _)) (subst (λ g → (a ⨾ c) ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (g , b')) γ'≡γ a⨾c⊩ψx)) ) ∣₁ })))) + + `∀intro : ∀ {Γ} {ϕ : Formula Γ} {B} {ψ : Formula (Γ ′ B)} → weakenFormula ϕ ⊨ ψ → ϕ ⊨ `∀ ψ + `∀intro {Γ} {ϕ} {B} {ψ} ϕ⊨ψ = + do + (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ + let + prover : ApplStrTerm as 2 + prover = ` a ̇ # fzero + return + (λ* prover , + (λ γ b b⊩ϕ → λ { c x@(γ' , b') γ'≡γ → + subst + (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ' , b')) + (sym (λ*ComputationRule prover (b ∷ c ∷ []))) + (a⊩ϕ⊨ψ + (γ' , b') + b + (transport (weakenFormulaMonotonic γ' ϕ b b') (subst (λ g → b ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ g) (sym γ'≡γ) b⊩ϕ))) })) + + `∀elim : ∀ {Γ} {B} {ϕ : Formula Γ} {ψ : Formula (Γ ′ B)} → ϕ ⊨ `∀ ψ → (t : Term Γ B) → ϕ ⊨ substitutionFormula (t , id) ψ + `∀elim {Γ} {B} {ϕ} {ψ} ϕ⊨∀ψ t = + do + (a , a⊩ϕ⊨∀ψ) ← ϕ⊨∀ψ + let + prover : ApplStrTerm as 1 + prover = ` a ̇ # fzero ̇ ` k + return + (λ* prover , + (λ γ b b⊩ϕγ → + subst + (λ form → (λ* prover ⨾ b) ⊩ ∣ form ∣ γ) + (sym (substitutionFormulaSound (t , id) ψ)) + (subst + (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ (γ , ⟦ t ⟧ᵗ γ)) + (sym (λ*ComputationRule prover (b ∷ []))) + (a⊩ϕ⊨∀ψ γ b b⊩ϕγ k (γ , ⟦ t ⟧ᵗ γ) refl)))) + + `→intro : ∀ {Γ} {ϕ ψ θ : Formula Γ} → (ϕ `∧ ψ) ⊨ θ → ϕ ⊨ (ψ `→ θ) + `→intro {Γ} {ϕ} {ψ} {θ} ϕ∧ψ⊨θ = a⊓b≤c→a≤b⇒c ⟨ ⟦ Γ ⟧ᶜ ⟩ (str ⟦ Γ ⟧ᶜ) ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ∧ψ⊨θ + + `→elim : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ (ψ `→ θ) → ϕ ⊨ ψ → ϕ ⊨ θ + `→elim {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ→θ ϕ⊨ψ = + do + (a , a⊩ϕ⊨ψ→θ) ← ϕ⊨ψ→θ + (b , b⊩ϕ⊨ψ) ← ϕ⊨ψ + let + prover : ApplStrTerm as 1 + prover = ` a ̇ (# fzero) ̇ (` b ̇ # fzero) + return + (λ* prover , + (λ γ c c⊩ϕγ → + subst + (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) + (sym (λ*ComputationRule prover (c ∷ []))) + (a⊩ϕ⊨ψ→θ γ c c⊩ϕγ (b ⨾ c) (b⊩ϕ⊨ψ γ c c⊩ϕγ)))) - infix 24 _⊨_ + `∨introR : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ϕ ⊨ (ψ `∨ θ) + `∨introR {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ = + do + (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ + let + prover : ApplStrTerm as 1 + prover = ` pair ̇ ` true ̇ (` a ̇ # fzero) + return + ((λ* prover) , + (λ γ b b⊩ϕγ → + let + pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ b) ≡ true + pr₁proofEq = + pr₁ ⨾ (λ* prover ⨾ b) + ≡⟨ cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩ + pr₁ ⨾ (pair ⨾ true ⨾ (a ⨾ b)) + ≡⟨ pr₁pxy≡x _ _ ⟩ + true + ∎ - module _ {Γ : Context} where + pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ b) ≡ a ⨾ b + pr₂proofEq = + pr₂ ⨾ (λ* prover ⨾ b) + ≡⟨ cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩ + pr₂ ⨾ (pair ⨾ true ⨾ (a ⨾ b)) + ≡⟨ pr₂pxy≡y _ _ ⟩ + a ⨾ b + ∎ + in ∣ inl (pr₁proofEq , subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (a⊩ϕ⊨ψ γ b b⊩ϕγ)) ∣₁)) - open PredicateProperties {ℓ'' = ℓ''} ⟨ ⟦ Γ ⟧ᶜ ⟩ + `∨introL : ∀ {Γ} {ϕ ψ θ : Formula Γ} → ϕ ⊨ ψ → ϕ ⊨ (θ `∨ ψ) + `∨introL {Γ} {ϕ} {ψ} {θ} ϕ⊨ψ = + do + (a , a⊩ϕ⊨ψ) ← ϕ⊨ψ + let + prover : ApplStrTerm as 1 + prover = ` pair ̇ ` false ̇ (` a ̇ # fzero) + return + ((λ* prover) , + (λ γ b b⊩ϕγ → + let + pr₁proofEq : pr₁ ⨾ (λ* prover ⨾ b) ≡ false + pr₁proofEq = + pr₁ ⨾ (λ* prover ⨾ b) + ≡⟨ cong (λ x → pr₁ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩ + pr₁ ⨾ (pair ⨾ false ⨾ (a ⨾ b)) + ≡⟨ pr₁pxy≡x _ _ ⟩ + false + ∎ - _⊨_ : Formula Γ → Formula Γ → Type _ - ϕ ⊨ ψ = ⟦ ϕ ⟧ᶠ ≤ ⟦ ψ ⟧ᶠ + pr₂proofEq : pr₂ ⨾ (λ* prover ⨾ b) ≡ a ⨾ b + pr₂proofEq = + pr₂ ⨾ (λ* prover ⨾ b) + ≡⟨ cong (λ x → pr₂ ⨾ x) (λ*ComputationRule prover (b ∷ [])) ⟩ + pr₂ ⨾ (pair ⨾ false ⨾ (a ⨾ b)) + ≡⟨ pr₂pxy≡y _ _ ⟩ + a ⨾ b + ∎ + in ∣ inr (pr₁proofEq , subst (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) (sym pr₂proofEq) (a⊩ϕ⊨ψ γ b b⊩ϕγ)) ∣₁)) - private - variable - ϕ ψ θ χ : Formula Γ + -- Pretty sure this is code duplication + `if_then_else_ : ∀ {as n} → ApplStrTerm as n → ApplStrTerm as n → ApplStrTerm as n → ApplStrTerm as n + `if a then b else c = ` Id ̇ a ̇ b ̇ c - cut : ∀ {ϕ ψ θ} → ϕ ⊨ ψ → ψ ⊨ θ → ϕ ⊨ θ - cut {ϕ} {ψ} {θ} ϕ⊨ψ ψ⊨θ = isTrans≤ ⟦ ϕ ⟧ᶠ ⟦ ψ ⟧ᶠ ⟦ θ ⟧ᶠ ϕ⊨ψ ψ⊨θ + `∨elim : ∀ {Γ} {ϕ ψ θ χ : Formula Γ} → (ϕ `∧ ψ) ⊨ χ → (ϕ `∧ θ) ⊨ χ → (ϕ `∧ (ψ `∨ θ)) ⊨ χ + `∨elim {Γ} {ϕ} {ψ} {θ} {χ} ϕ∧ψ⊨χ ϕ∧θ⊨χ = + do + (a , a⊩ϕ∧ψ⊨χ) ← ϕ∧ψ⊨χ + (b , b⊩ϕ∧θ⊨χ) ← ϕ∧θ⊨χ + let + prover : ApplStrTerm as 1 + prover = + (`if ` pr₁ ̇ (` pr₂ ̇ # fzero) then ` a else (` b)) ̇ (` pair ̇ (` pr₁ ̇ # fzero) ̇ (` pr₂ ̇ (` pr₂ ̇ # fzero))) + return + (λ* prover , + (λ + { γ c (pr₁⨾c⊩ϕγ , pr₂⨾c⊩ψ∨θ) → + transport + (propTruncIdempotent (⟦ χ ⟧ᶠ .isPropValued γ (λ* prover ⨾ c))) + (pr₂⨾c⊩ψ∨θ >>= + λ { (inl (pr₁⨾pr₂⨾c≡true , pr₂⨾pr₂⨾c⊩ψ)) → + let + proofEq : λ* prover ⨾ c ≡ a ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + proofEq = + λ* prover ⨾ c + ≡⟨ λ*ComputationRule prover (c ∷ []) ⟩ + (if (pr₁ ⨾ (pr₂ ⨾ c)) then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ≡⟨ cong (λ x → (if x then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) pr₁⨾pr₂⨾c≡true ⟩ + (if true then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ≡⟨ cong (λ x → x ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) (ifTrueThen a b) ⟩ + a ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ∎ + in + ∣ subst + (λ r → r ⊩ ∣ ⟦ χ ⟧ᶠ ∣ γ) + (sym proofEq) + (a⊩ϕ∧ψ⊨χ + γ + (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + (( + subst + (λ r → r ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ) + (sym (pr₁pxy≡x _ _)) + pr₁⨾c⊩ϕγ) , + subst + (λ r → r ⊩ ∣ ⟦ ψ ⟧ᶠ ∣ γ) + (sym (pr₂pxy≡y _ _)) + pr₂⨾pr₂⨾c⊩ψ)) ∣₁ + ; (inr (pr₁pr₂⨾c≡false , pr₂⨾pr₂⨾c⊩θ)) → + let + proofEq : λ* prover ⨾ c ≡ b ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + proofEq = + λ* prover ⨾ c + ≡⟨ λ*ComputationRule prover (c ∷ []) ⟩ + (if (pr₁ ⨾ (pr₂ ⨾ c)) then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ≡⟨ cong (λ x → (if x then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) pr₁pr₂⨾c≡false ⟩ + (if false then a else b) ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ≡⟨ cong (λ x → x ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c)))) (ifFalseElse a b) ⟩ + b ⨾ (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ∎ + in + ∣ subst + (λ r → r ⊩ ∣ ⟦ χ ⟧ᶠ ∣ γ) + (sym proofEq) + (b⊩ϕ∧θ⊨χ + γ + (pair ⨾ (pr₁ ⨾ c) ⨾ (pr₂ ⨾ (pr₂ ⨾ c))) + ((subst (λ r → r ⊩ ∣ ⟦ ϕ ⟧ᶠ ∣ γ) (sym (pr₁pxy≡x _ _)) pr₁⨾c⊩ϕγ) , + (subst (λ r → r ⊩ ∣ ⟦ θ ⟧ᶠ ∣ γ) (sym (pr₂pxy≡y _ _)) pr₂⨾pr₂⨾c⊩θ))) ∣₁ }) })) - + diff --git a/src/Realizability/Tripos/Logic/Syntax.agda b/src/Realizability/Tripos/Logic/Syntax.agda index 61f0973..ee80ffc 100644 --- a/src/Realizability/Tripos/Logic/Syntax.agda +++ b/src/Realizability/Tripos/Logic/Syntax.agda @@ -17,6 +17,7 @@ data Sort : Type (ℓ-suc ℓ) where ⟦ ↑ a ⟧ˢ = a ⟦ a `× b ⟧ˢ = ⟦ a ⟧ˢ .fst × ⟦ b ⟧ˢ .fst , isSet× (⟦ a ⟧ˢ .snd) (⟦ b ⟧ˢ .snd) +infixl 30 _′_ data Context : Type (ℓ-suc ℓ) where [] : Context _′_ : Context → Sort → Context @@ -92,20 +93,22 @@ module Relational {n} (relSym : Vec Sort n) where ⊥ᵗ : ∀ {Γ} → Formula Γ _`∨_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ _`∧_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ - _`→_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ - `¬_ : ∀ {Γ} → Formula Γ → Formula Γ + _`→_ : ∀ {Γ} → Formula Γ → Formula Γ → Formula Γ `∃ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ `∀ : ∀ {Γ B} → Formula (Γ ′ B) → Formula Γ rel : ∀ {Γ} (k : Fin n) → Term Γ (lookup k relSym) → Formula Γ + pattern `¬ f = f `→ ⊥ᵗ + substitutionFormula : ∀ {Γ Δ} → Substitution Γ Δ → Formula Δ → Formula Γ substitutionFormula {Γ} {Δ} subs ⊤ᵗ = ⊤ᵗ substitutionFormula {Γ} {Δ} subs ⊥ᵗ = ⊥ᵗ substitutionFormula {Γ} {Δ} subs (form `∨ form₁) = substitutionFormula subs form `∨ substitutionFormula subs form₁ substitutionFormula {Γ} {Δ} subs (form `∧ form₁) = substitutionFormula subs form `∧ substitutionFormula subs form₁ substitutionFormula {Γ} {Δ} subs (form `→ form₁) = substitutionFormula subs form `→ substitutionFormula subs form₁ - substitutionFormula {Γ} {Δ} subs (`¬ form) = `¬ substitutionFormula subs form substitutionFormula {Γ} {Δ} subs (`∃ form) = `∃ (substitutionFormula (var here , drop subs) form ) substitutionFormula {Γ} {Δ} subs (`∀ form) = `∀ (substitutionFormula (var here , drop subs) form) substitutionFormula {Γ} {Δ} subs (rel k x) = rel k (substitutionTerm subs x) + weakenFormula : ∀ {Γ} {S} → Formula Γ → Formula (Γ ′ S) + weakenFormula {Γ} {S} form = substitutionFormula (drop id) form diff --git a/src/Realizability/Tripos/Prealgebra/Implication.agda b/src/Realizability/Tripos/Prealgebra/Implication.agda index 374c42f..f3d53d7 100644 --- a/src/Realizability/Tripos/Prealgebra/Implication.agda +++ b/src/Realizability/Tripos/Prealgebra/Implication.agda @@ -7,20 +7,21 @@ open import Cubical.HITs.PropositionalTruncation.Monad open import Cubical.Data.Fin open import Cubical.Data.Vec -module Realizability.Tripos.Prealgebra.Implication {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +module Realizability.Tripos.Prealgebra.Implication {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -λ*ComputationRule = `λ*ComputationRule as fefermanStructure -λ* = `λ* as fefermanStructure +private + λ*ComputationRule = `λ*ComputationRule as fefermanStructure + λ* = `λ* as fefermanStructure -module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where - PredicateX = Predicate {ℓ'' = ℓ''} X +module _ (X : Type ℓ') (isSetX' : isSet X) where + PredicateX = Predicate X open Predicate - open PredicateProperties {ℓ'' = ℓ''} X + open PredicateProperties X -- ⇒ is Heyting implication a⊓b≤c→a≤b⇒c : ∀ a b c → (a ⊓ b ≤ c) → a ≤ (b ⇒ c) a⊓b≤c→a≤b⇒c a b c a⊓b≤c = diff --git a/src/Realizability/Tripos/Prealgebra/Joins/Commutativity.agda b/src/Realizability/Tripos/Prealgebra/Joins/Commutativity.agda index dac032a..5affaf6 100644 --- a/src/Realizability/Tripos/Prealgebra/Joins/Commutativity.agda +++ b/src/Realizability/Tripos/Prealgebra/Joins/Commutativity.agda @@ -11,8 +11,6 @@ open import Cubical.HITs.PropositionalTruncation.Monad module Realizability.Tripos.Prealgebra.Joins.Commutativity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca - open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) @@ -20,10 +18,10 @@ private λ*ComputationRule = `λ*ComputationRule as fefermanStructure private λ* = `λ* as fefermanStructure module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where - - private PredicateX = Predicate {ℓ'' = ℓ''} X + open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca + private PredicateX = Predicate X open Predicate - open PredicateProperties {ℓ'' = ℓ''} X + open PredicateProperties X open PreorderReasoning preorder≤ -- ⊔ is commutative upto anti-symmetry diff --git a/src/Realizability/Tripos/Prealgebra/Joins/Identity.agda b/src/Realizability/Tripos/Prealgebra/Joins/Identity.agda index 99675ac..f8cb0f1 100644 --- a/src/Realizability/Tripos/Prealgebra/Joins/Identity.agda +++ b/src/Realizability/Tripos/Prealgebra/Joins/Identity.agda @@ -12,8 +12,8 @@ open import Cubical.Relation.Binary.Order.Preorder open import Realizability.CombinatoryAlgebra open import Realizability.ApplicativeStructure renaming (λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) -module Realizability.Tripos.Prealgebra.Joins.Identity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca +module Realizability.Tripos.Prealgebra.Joins.Identity {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca open import Realizability.Tripos.Prealgebra.Joins.Commutativity ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) @@ -21,10 +21,10 @@ open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a t private λ*ComputationRule = `λ*ComputationRule as fefermanStructure private λ* = `λ* as fefermanStructure -module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where - private PredicateX = Predicate {ℓ'' = ℓ''} X +module _ (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where + private PredicateX = Predicate X open Predicate - open PredicateProperties {ℓ'' = ℓ''} X + open PredicateProperties X open PreorderReasoning preorder≤ diff --git a/src/Realizability/Tripos/Prealgebra/Meets/Commutativity.agda b/src/Realizability/Tripos/Prealgebra/Meets/Commutativity.agda index 4e4b22b..722752f 100644 --- a/src/Realizability/Tripos/Prealgebra/Meets/Commutativity.agda +++ b/src/Realizability/Tripos/Prealgebra/Meets/Commutativity.agda @@ -1,29 +1,26 @@ open import Realizability.CombinatoryAlgebra -open import Realizability.ApplicativeStructure renaming (λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) +open import Realizability.ApplicativeStructure open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv -open import Cubical.Data.Fin +open import Cubical.Data.FinData open import Cubical.Data.Vec open import Cubical.Data.Sum renaming (rec to sumRec) open import Cubical.Relation.Binary.Order.Preorder open import Cubical.HITs.PropositionalTruncation open import Cubical.HITs.PropositionalTruncation.Monad -module Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +module Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -private λ*ComputationRule = `λ*ComputationRule as fefermanStructure -private λ* = `λ* as fefermanStructure - -module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where +module _ (X : Type ℓ') (isSetX' : isSet X) where - private PredicateX = Predicate {ℓ'' = ℓ''} X + private PredicateX = Predicate X open Predicate - open PredicateProperties {ℓ'' = ℓ''} X + open PredicateProperties X open PreorderReasoning preorder≤ x⊓y≤y⊓x : ∀ x y → x ⊓ y ≤ y ⊓ x @@ -31,13 +28,13 @@ module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where do let proof : Term as 1 - proof = ` pair ̇ (` pr₂ ̇ # fzero) ̇ (` pr₁ ̇ # fzero) + proof = ` pair ̇ (` pr₂ ̇ # zero) ̇ (` pr₁ ̇ # zero) return (λ* proof , (λ x' a a⊩x⊓y → subst (λ r → r ⊩ ∣ y ⊓ x ∣ x') - (sym (λ*ComputationRule proof (a ∷ []) )) + (sym (λ*ComputationRule proof a)) ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (a⊩x⊓y .snd)) , (subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓y .fst))))) @@ -48,13 +45,13 @@ module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where (g , g⊩y≤x) ← y≤x let proof : Term as 1 - proof = ` pair ̇ (` f ̇ (` pr₁ ̇ # fzero)) ̇ (` pr₂ ̇ # fzero) + proof = ` pair ̇ (` f ̇ (` pr₁ ̇ # zero)) ̇ (` pr₂ ̇ # zero) return ((λ* proof) , (λ x' a a⊩x⊓z → subst (λ r → r ⊩ ∣ y ⊓ z ∣ x') - (sym (λ*ComputationRule proof (a ∷ []))) + (sym (λ*ComputationRule proof a)) ((subst (λ r → r ⊩ ∣ y ∣ x') (sym (pr₁pxy≡x _ _)) (f⊩x≤y x' (pr₁ ⨾ a) (a⊩x⊓z .fst))) , (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (a⊩x⊓z .snd))))) @@ -66,12 +63,12 @@ module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) where (g , g⊩z≤y) ← z≤y let proof : Term as 1 - proof = ` pair ̇ (` pr₁ ̇ # fzero) ̇ (` f ̇ (` pr₂ ̇ # fzero)) + proof = ` pair ̇ (` pr₁ ̇ # zero) ̇ (` f ̇ (` pr₂ ̇ # zero)) return ((λ* proof) , (λ { x' a (pr₁a⊩x , pr₂a⊩y) → subst (λ r → r ⊩ ∣ x ⊓ z ∣ x') - (sym (λ*ComputationRule proof (a ∷ []))) + (sym (λ*ComputationRule proof a)) ((subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₁pxy≡x _ _)) pr₁a⊩x) , (subst (λ r → r ⊩ ∣ z ∣ x') (sym (pr₂pxy≡y _ _)) (f⊩y≤z x' (pr₂ ⨾ a) pr₂a⊩y))) })) diff --git a/src/Realizability/Tripos/Prealgebra/Meets/Identity.agda b/src/Realizability/Tripos/Prealgebra/Meets/Identity.agda index 6d6946a..fabc949 100644 --- a/src/Realizability/Tripos/Prealgebra/Meets/Identity.agda +++ b/src/Realizability/Tripos/Prealgebra/Meets/Identity.agda @@ -1,6 +1,6 @@ open import Cubical.Foundations.Prelude open import Cubical.Data.Unit -open import Cubical.Data.Fin +open import Cubical.Data.FinData open import Cubical.Data.Vec open import Cubical.Data.Sum open import Cubical.Data.Empty renaming (rec* to ⊥*rec) @@ -9,21 +9,18 @@ open import Cubical.HITs.PropositionalTruncation open import Cubical.HITs.PropositionalTruncation.Monad open import Cubical.Relation.Binary.Order.Preorder open import Realizability.CombinatoryAlgebra -open import Realizability.ApplicativeStructure renaming (λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) +open import Realizability.ApplicativeStructure -module Realizability.Tripos.Prealgebra.Meets.Identity {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate ca -open import Realizability.Tripos.Prealgebra.Meets.Commutativity ca +module Realizability.Tripos.Prealgebra.Meets.Identity {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +open import Realizability.Tripos.Prealgebra.Predicate {ℓ' = ℓ'} {ℓ'' = ℓ''} ca +open import Realizability.Tripos.Prealgebra.Meets.Commutativity {ℓ' = ℓ'} {ℓ'' = ℓ''} ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -private λ*ComputationRule = `λ*ComputationRule as fefermanStructure -private λ* = `λ* as fefermanStructure - -module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where - private PredicateX = Predicate {ℓ'' = ℓ''} X +module _ (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ k → ⊥) where + private PredicateX = Predicate X open Predicate - open PredicateProperties {ℓ'' = ℓ''} X + open PredicateProperties X open PreorderReasoning preorder≤ pre1 : PredicateX @@ -39,13 +36,13 @@ module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ do let proof : Term as 1 - proof = ` pair ̇ # fzero ̇ ` true + proof = ` pair ̇ # zero ̇ ` true return ((λ* proof) , (λ x' a a⊩x → subst (λ r → ∣ x ⊓ pre1 ∣ x' r) - (sym (λ*ComputationRule proof (a ∷ []))) + (sym (λ*ComputationRule proof a)) (subst (λ r → r ⊩ ∣ x ∣ x') (sym (pr₁pxy≡x _ _)) @@ -59,13 +56,13 @@ module _ {ℓ' ℓ''} (X : Type ℓ') (isSetX' : isSet X) (isNonTrivial : s ≡ do let proof : Term as 1 - proof = ` pair ̇ ` false ̇ # fzero + proof = ` pair ̇ ` false ̇ # zero return ((λ* proof) , (λ x' a a⊩x → subst (λ r → r ⊩ ∣ pre1 ⊓ x ∣ x') - (sym (λ*ComputationRule proof (a ∷ []))) + (sym (λ*ComputationRule proof a)) (tt* , (subst (λ r → r ⊩ ∣ x ∣ x') diff --git a/src/Realizability/Tripos/Prealgebra/Predicate.agda b/src/Realizability/Tripos/Prealgebra/Predicate.agda index a12e0b6..c99a67d 100644 --- a/src/Realizability/Tripos/Prealgebra/Predicate.agda +++ b/src/Realizability/Tripos/Prealgebra/Predicate.agda @@ -1,7 +1,7 @@ open import Realizability.CombinatoryAlgebra open import Cubical.Foundations.Prelude -module Realizability.Tripos.Prealgebra.Predicate {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +module Realizability.Tripos.Prealgebra.Predicate {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate.Base ca public -open import Realizability.Tripos.Prealgebra.Predicate.Properties ca public +open import Realizability.Tripos.Prealgebra.Predicate.Base {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca public +open import Realizability.Tripos.Prealgebra.Predicate.Properties {ℓ' = ℓ'} {ℓ'' = ℓ''} ca public diff --git a/src/Realizability/Tripos/Prealgebra/Predicate/Base.agda b/src/Realizability/Tripos/Prealgebra/Predicate/Base.agda index 5850d7c..e89afc3 100644 --- a/src/Realizability/Tripos/Prealgebra/Predicate/Base.agda +++ b/src/Realizability/Tripos/Prealgebra/Predicate/Base.agda @@ -1,18 +1,20 @@ open import Realizability.CombinatoryAlgebra -open import Realizability.ApplicativeStructure renaming (⟦_⟧ to `⟦_⟧; λ*-naturality to `λ*ComputationRule; λ*-chain to `λ*) hiding (λ*) +open import Realizability.ApplicativeStructure open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Foundations.Univalence open import Cubical.Foundations.Isomorphism +open import Cubical.Foundations.Equiv open import Cubical.Data.Sigma open import Cubical.Functions.FunExtEquiv -module Realizability.Tripos.Prealgebra.Predicate.Base {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where +module Realizability.Tripos.Prealgebra.Predicate.Base {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) -record Predicate {ℓ' ℓ''} (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where +record Predicate (X : Type ℓ') : Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) where + constructor makePredicate field isSetX : isSet X ∣_∣ : X → A → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'') @@ -24,40 +26,42 @@ infix 26 _⊩_ _⊩_ : ∀ {ℓ'} → A → (A → Type ℓ') → Type ℓ' a ⊩ ϕ = ϕ a -PredicateΣ : ∀ {ℓ' ℓ''} → (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) -PredicateΣ {ℓ'} {ℓ''} X = Σ[ rel ∈ (X → A → hProp (ℓ-max (ℓ-max ℓ ℓ') ℓ'')) ] (isSet X) +PredicateΣ : ∀ (X : Type ℓ') → Type (ℓ-max (ℓ-max (ℓ-suc ℓ) (ℓ-suc ℓ')) (ℓ-suc ℓ'')) +PredicateΣ X = Σ[ rel ∈ (X → A → hProp (ℓ-max (ℓ-max ℓ ℓ') ℓ'')) ] (isSet X) -isSetPredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (PredicateΣ {ℓ'' = ℓ''} X) +isSetPredicateΣ : ∀ (X : Type ℓ') → isSet (PredicateΣ X) isSetPredicateΣ X = isSetΣ (isSetΠ (λ x → isSetΠ λ a → isSetHProp)) λ _ → isProp→isSet isPropIsSet -PredicateIsoΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Iso (Predicate {ℓ'' = ℓ''} X) (PredicateΣ {ℓ'' = ℓ''} X) -PredicateIsoΣ {ℓ'} {ℓ''} X = +PredicateIsoΣ : ∀ (X : Type ℓ') → Iso (Predicate X) (PredicateΣ X) +PredicateIsoΣ X = iso (λ p → (λ x a → (a ⊩ ∣ p ∣ x) , p .isPropValued x a) , p .isSetX) (λ p → record { isSetX = p .snd ; ∣_∣ = λ x a → p .fst x a .fst ; isPropValued = λ x a → p .fst x a .snd }) (λ b → refl) λ a → refl -Predicate≡PredicateΣ : ∀ {ℓ' ℓ''} (X : Type ℓ') → Predicate {ℓ'' = ℓ''} X ≡ PredicateΣ {ℓ'' = ℓ''} X -Predicate≡PredicateΣ {ℓ'} {ℓ''} X = isoToPath (PredicateIsoΣ X) +Predicate≃PredicateΣ : ∀ (X : Type ℓ') → Predicate X ≃ PredicateΣ X +Predicate≃PredicateΣ X = isoToEquiv (PredicateIsoΣ X) -isSetPredicate : ∀ {ℓ' ℓ''} (X : Type ℓ') → isSet (Predicate {ℓ'' = ℓ''} X) -isSetPredicate {ℓ'} {ℓ''} X = subst (λ predicateType → isSet predicateType) (sym (Predicate≡PredicateΣ X)) (isSetPredicateΣ {ℓ'' = ℓ''} X) +Predicate≡PredicateΣ : ∀ (X : Type ℓ') → Predicate X ≡ PredicateΣ X +Predicate≡PredicateΣ X = isoToPath (PredicateIsoΣ X) -PredicateΣ≡ : ∀ {ℓ' ℓ''} (X : Type ℓ') → (P Q : PredicateΣ {ℓ'' = ℓ''} X) → (P .fst ≡ Q .fst) → P ≡ Q +isSetPredicate : ∀ (X : Type ℓ') → isSet (Predicate X) +isSetPredicate X = subst (λ predicateType → isSet predicateType) (sym (Predicate≡PredicateΣ X)) (isSetPredicateΣ X) + +PredicateΣ≡ : ∀ (X : Type ℓ') → (P Q : PredicateΣ X) → (P .fst ≡ Q .fst) → P ≡ Q PredicateΣ≡ X P Q ∣P∣≡∣Q∣ = Σ≡Prop (λ _ → isPropIsSet) ∣P∣≡∣Q∣ Predicate≡ : - ∀ {ℓ' ℓ''} (X : Type ℓ') - → (P Q : Predicate {ℓ'' = ℓ''} X) + ∀ (X : Type ℓ') + → (P Q : Predicate X) → (∀ x a → a ⊩ ∣ P ∣ x → a ⊩ ∣ Q ∣ x) → (∀ x a → a ⊩ ∣ Q ∣ x → a ⊩ ∣ P ∣ x) ----------------------------------- → P ≡ Q -Predicate≡ {ℓ'} {ℓ''} X P Q P→Q Q→P i = +Predicate≡ X P Q P→Q Q→P i = PredicateIsoΣ X .inv (PredicateΣ≡ - {ℓ'' = ℓ''} X (PredicateIsoΣ X .fun P) (PredicateIsoΣ X .fun Q) diff --git a/src/Realizability/Tripos/Prealgebra/Predicate/Properties.agda b/src/Realizability/Tripos/Prealgebra/Predicate/Properties.agda index db3ff90..07ca574 100644 --- a/src/Realizability/Tripos/Prealgebra/Predicate/Properties.agda +++ b/src/Realizability/Tripos/Prealgebra/Predicate/Properties.agda @@ -1,6 +1,6 @@ open import Realizability.CombinatoryAlgebra -open import Realizability.ApplicativeStructure -open import Cubical.Foundations.Prelude +open import Realizability.ApplicativeStructure renaming (Term to ApplStrTerm) +open import Cubical.Foundations.Prelude as P open import Cubical.Foundations.HLevels open import Cubical.Foundations.Equiv open import Cubical.Foundations.Univalence @@ -11,23 +11,25 @@ open import Cubical.Data.Sigma open import Cubical.Data.Empty open import Cubical.Data.Unit open import Cubical.Data.Sum +open import Cubical.Data.Vec open import Cubical.HITs.PropositionalTruncation open import Cubical.HITs.PropositionalTruncation.Monad open import Cubical.Relation.Binary.Order.Preorder module Realizability.Tripos.Prealgebra.Predicate.Properties - {ℓ} {A : Type ℓ} (ca : CombinatoryAlgebra A) where + {ℓ ℓ' ℓ''} {A : Type ℓ} (ca : CombinatoryAlgebra A) where -open import Realizability.Tripos.Prealgebra.Predicate.Base ca +open import Realizability.Tripos.Prealgebra.Predicate.Base {ℓ = ℓ} {ℓ' = ℓ'} {ℓ'' = ℓ''} ca open CombinatoryAlgebra ca open Realizability.CombinatoryAlgebra.Combinators ca renaming (i to Id; ia≡a to Ida≡a) open Predicate -module PredicateProperties {ℓ' ℓ''} (X : Type ℓ') where - private PredicateX = Predicate {ℓ'' = ℓ''} X + +module PredicateProperties (X : Type ℓ') where + private PredicateX = Predicate X open Predicate - _≤_ : Predicate {ℓ'' = ℓ''} X → Predicate {ℓ'' = ℓ''} X → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'') + _≤_ : Predicate X → Predicate X → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'') ϕ ≤ ψ = ∃[ b ∈ A ] (∀ (x : X) (a : A) → a ⊩ (∣ ϕ ∣ x) → (b ⨾ a) ⊩ ∣ ψ ∣ x) isProp≤ : ∀ ϕ ψ → isProp (ϕ ≤ ψ) @@ -83,12 +85,52 @@ module PredicateProperties {ℓ' ℓ''} (X : Type ℓ') where ∣ ϕ ⇒ ψ ∣ x a = ∀ b → (b ⊩ ∣ ϕ ∣ x) → (a ⨾ b) ⊩ ∣ ψ ∣ x (ϕ ⇒ ψ) .isPropValued x a = isPropΠ λ a → isPropΠ λ a⊩ϕx → ψ .isPropValued _ _ +module _ where + open PredicateProperties Unit* + private + Predicate' = Predicate + module NotAntiSym (antiSym : ∀ (a b : Predicate' Unit*) → (a≤b : a ≤ b) → (b≤a : b ≤ a) → a ≡ b) where + Lift' = Lift {i = ℓ} {j = (ℓ-max ℓ' ℓ'')} + + kRealized : Predicate' Unit* + kRealized = record { isSetX = isSetUnit* ; ∣_∣ = λ x a → Lift' (a ≡ k) ; isPropValued = λ x a → isOfHLevelRespectEquiv 1 LiftEquiv (isSetA a k) } + + k'Realized : Predicate' Unit* + k'Realized = record { isSetX = isSetUnit* ; ∣_∣ = λ x a → Lift' (a ≡ k') ; isPropValued = λ x a → isOfHLevelRespectEquiv 1 LiftEquiv (isSetA a k') } + + kRealized≤k'Realized : kRealized ≤ k'Realized + kRealized≤k'Realized = + do + let + prover : ApplStrTerm as 1 + prover = ` k' + return (λ* prover , λ { x a (lift a≡k) → lift (λ*ComputationRule prover a) }) + + k'Realized≤kRealized : k'Realized ≤ kRealized + k'Realized≤kRealized = + do + let + prover : ApplStrTerm as 1 + prover = ` k + return (λ* prover , λ { x a (lift a≡k') → lift (λ*ComputationRule prover a) }) + + kRealized≡k'Realized : kRealized ≡ k'Realized + kRealized≡k'Realized = antiSym kRealized k'Realized kRealized≤k'Realized k'Realized≤kRealized + + Lift≡ : Lift' (k ≡ k) ≡ Lift' (k ≡ k') + Lift≡ i = ∣ kRealized≡k'Realized i ∣ tt* k + + Liftk≡k' : Lift' (k ≡ k') + Liftk≡k' = transport Lift≡ (lift refl) + + k≡k' : k ≡ k' + k≡k' = Liftk≡k' .lower -module Morphism {ℓ' ℓ''} {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSet Y) where - PredicateX = Predicate {ℓ'' = ℓ''} X - PredicateY = Predicate {ℓ'' = ℓ''} Y - module PredicatePropertiesX = PredicateProperties {ℓ'' = ℓ''} X - module PredicatePropertiesY = PredicateProperties {ℓ'' = ℓ''} Y +module Morphism {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSet Y) where + PredicateX = Predicate X + PredicateY = Predicate Y + module PredicatePropertiesX = PredicateProperties X + module PredicatePropertiesY = PredicateProperties Y open PredicatePropertiesX renaming (_≤_ to _≤X_ ; isProp≤ to isProp≤X) open PredicatePropertiesY renaming (_≤_ to _≤Y_ ; isProp≤ to isProp≤Y) open Predicate hiding (isSetX) @@ -232,7 +274,6 @@ module Morphism {ℓ' ℓ''} {X Y : Type ℓ'} (isSetX : isSet X) (isSetY : isSe -- The proof is trivial but I am the reader it was left to as an exercise module BeckChevalley - {ℓ' ℓ'' : Level} (I J K : Type ℓ') (isSetI : isSet I) (isSetJ : isSet J) @@ -240,7 +281,7 @@ module BeckChevalley (f : J → I) (g : K → I) where - module Morphism' = Morphism {ℓ' = ℓ'} {ℓ'' = ℓ''} + module Morphism' = Morphism open Morphism' L = Σ[ k ∈ K ] Σ[ j ∈ J ] (g k ≡ f j) @@ -280,7 +321,7 @@ module BeckChevalley `∃BeckChevalley = funExt λ ϕ i → PredicateIsoΣ K .inv - (PredicateΣ≡ {ℓ'' = ℓ''} K + (PredicateΣ≡ K ((λ k a → (∣ (g* ∘ `∃[J→I][ f ]) ϕ ∣ k a) , ((g* ∘ `∃[J→I][ f ]) ϕ .isPropValued k a)) , isSetK) ((λ k a → (∣ (`∃[L→K][ p ] ∘ q*) ϕ ∣ k a) , ((`∃[L→K][ p ] ∘ q*) ϕ .isPropValued k a)) , isSetK) (funExt₂ @@ -304,7 +345,7 @@ module BeckChevalley `∀BeckChevalley = funExt λ ϕ i → PredicateIsoΣ K .inv - (PredicateΣ≡ {ℓ'' = ℓ''} K + (PredicateΣ≡ K ((λ k a → (a ⊩ ∣ g* (`∀[J→I][ f ] ϕ) ∣ k) , (g* (`∀[J→I][ f ] ϕ) .isPropValued k a)) , isSetK) ((λ k a → (a ⊩ ∣ `∀[L→K][ p ] (q* ϕ) ∣ k) , (`∀[L→K][ p ] (q* ϕ) .isPropValued k a)) , isSetK) (funExt₂ diff --git a/src/index.agda b/src/index.agda index bd6dec1..c30a8cb 100644 --- a/src/index.agda +++ b/src/index.agda @@ -1,14 +1,7 @@ {-# OPTIONS --cubical #-} module index where ---open import Realizability.Partiality ---open import Realizability.PartialApplicativeStructure ---open import Realizability.PartialCombinatoryAlgebra open import Realizability.CombinatoryAlgebra open import Realizability.ApplicativeStructure -open import Realizability.Assembly.Everything -open import Realizability.Tripos.Everything +open import Realizability.Topos.Everything open import Realizability.Choice -open import Tripoi.Tripos -open import Tripoi.HeytingAlgebra -open import Tripoi.PosetReflection