• cubical agda core libraries

#cubical agda core libraries

-- SOURCE URL: `https://agda.github.io/cubical/Agda.Builtin.Cubical.Equiv.html` {-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.Equiv where open import Agda.Primitive open import Agda.Builtin.Sigma open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_; primHComp to hcomp; primTransp to transp; primComp to comp; itIsOne to 1=1) open import Agda.Builtin.Cubical.Path open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]) import Agda.Builtin.Cubical.HCompU as HCompU module Helpers = HCompU.Helpers open Helpers -- We make this a record so that isEquiv can be proved using -- copatterns. This is good because copatterns don't get unfolded -- unless a projection is applied so it should be more efficient. record isEquiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) : Set (ℓ ⊔ ℓ') where no-eta-equality field equiv-proof : (y : B) → isContr (fiber f y) open isEquiv public infix 4 _≃_ _≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ') A ≃ B = Σ (A → B) \ f → (isEquiv f) equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B equivFun e = fst e -- Improved version of equivProof compared to Lemma 5 in CCHM. We put -- the (φ = i0) face in contr' making it be definitionally c in this -- case. This makes the computational behavior better, in particular -- for transp in Glue. equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A) → ∀ ψ (f : Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a [ ψ ↦ f ] equivProof A B w a ψ fb = inS (contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb) where contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i ; (φ = i0) → c }) c {-# BUILTIN EQUIV _≃_ #-} {-# BUILTIN EQUIVFUN equivFun #-} {-# BUILTIN EQUIVPROOF equivProof #-} module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where private E : (i : I) → Set (ℓ i) E = λ i → P i ~E : (i : I) → Set (ℓ (~ i)) ~E = λ i → P (~ i) A = P i0 B = P i1 f : A → B f x = transp E i0 x g : B → A g y = transp ~E i0 y u : ∀ i → A → E i u i x = transp (λ j → E (i ∧ j)) (~ i) x v : ∀ i → B → E i v i y = transp (λ j → ~E ( ~ i ∧ j)) i y fiberPath : (y : B) → (xβ0 xβ1 : fiber f y) → xβ0 ≡ xβ1 fiberPath y (x0 , β0) (x1 , β1) k = ω , λ j → δ (~ j) where module _ (j : I) where private sys : A → ∀ i → PartialP (~ j ∨ j) (λ _ → E (~ i)) sys x i (j = i0) = v (~ i) y sys x i (j = i1) = u (~ i) x ω0 = comp ~E (sys x0) ((β0 (~ j))) ω1 = comp ~E (sys x1) ((β1 (~ j))) θ0 = fill ~E (sys x0) (inS (β0 (~ j))) θ1 = fill ~E (sys x1) (inS (β1 (~ j))) sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j} ω = hcomp sys (g y) θ = hfill sys (inS (g y)) δ = λ (j : I) → comp E (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i) ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) }) (θ j) γ : (y : B) → y ≡ f (g y) γ y j = comp E (λ i → λ { (j = i0) → v i y ; (j = i1) → u i (g y) }) (g y) pathToisEquiv : isEquiv f pathToisEquiv .equiv-proof y .fst .fst = g y pathToisEquiv .equiv-proof y .fst .snd = sym (γ y) pathToisEquiv .equiv-proof y .snd = fiberPath y _ pathToEquiv : A ≃ B pathToEquiv .fst = f pathToEquiv .snd = pathToisEquiv

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Axiom.Omniscience.html` {-# OPTIONS --cubical --no-import-sorts #-} module Cubical.Axiom.Omniscience where open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Prelude open import Cubical.Foundations.Transport open import Cubical.Data.Bool renaming (Bool to 𝟚; Bool→Type to ⟨_⟩) open import Cubical.Data.Empty as Empty open import Cubical.Data.Sum as Sum open import Cubical.HITs.PropositionalTruncation as PT open import Cubical.Relation.Nullary private variable ℓ ℓ' : Level A : Type ℓ -- Lesser limited principle of omniscience -- -- If two decidable predicates cannot both be satisfied, we can -- determine that one predicate cannot be satisfied. LLPO : Type ℓ → Type ℓ LLPO A = ∀(P Q : A → 𝟚) → (∀ x y → ⟨ P x ⟩ → ⟨ Q y ⟩ → ⊥) → ∥ (∀ x → ¬ ⟨ P x ⟩) ⊎ (∀ y → ¬ ⟨ Q y ⟩) ∥₁ isPropLLPO : isProp (LLPO A) isPropLLPO = isPropΠ3 λ _ _ _ → squash₁ -- As above, but without ensuring propositionality LLPO∞ : Type ℓ → Type ℓ LLPO∞ A = ∀(P Q : A → 𝟚) → (∀ x y → ⟨ P x ⟩ → ⟨ Q y ⟩ → ⊥) → (∀ x → ¬ ⟨ P x ⟩) ⊎ (∀ y → ¬ ⟨ Q y ⟩) LLPO∞→LLPO : LLPO∞ A → LLPO A LLPO∞→LLPO llpo' P Q ¬both = ∣ llpo' P Q ¬both ∣₁ -- Weak limited principle of omniscience -- -- It is decidable whether or not a decidable predicate never holds. WLPO : Type ℓ → Type ℓ WLPO A = ∀(P : A → 𝟚) → Dec (∀ x → ¬ ⟨ P x ⟩) WLPO' : Type ℓ → Type ℓ WLPO' A = ∀(P : A → 𝟚) → Dec (P ≡ const false) isPropWLPO : isProp (WLPO A) isPropWLPO = isPropΠ λ P → isPropDec (isPropΠ λ x → isProp¬ ⟨ P x ⟩) isPropWLPO' : isProp (WLPO' A) isPropWLPO' = isPropΠ λ P → isPropDec (isSet→ isSetBool P (const false)) module WLPO≃ where points : (P : A → 𝟚) → P ≡ const false → ∀ x → ¬ ⟨ P x ⟩ points P p x = subst (λ Q → ⟨ Q x ⟩) p total : (P : A → 𝟚) → (∀ x → ¬ ⟨ P x ⟩) → P ≡ const false total P never i x with P x | never x ... | false | _ = false ... | true | ¬⊤ = Empty.rec {A = true ≡ false} (¬⊤ _) i open Iso total≡points : ∀(P : A → 𝟚) → (P ≡ const false) ≡ (∀ x → ¬ ⟨ P x ⟩) total≡points P = isoToPath λ where .fun → points P .inv → total P .sec never → isPropΠ (λ x → isProp¬ ⟨ P x ⟩) _ never .ret α≡f → isSet→ isSetBool P (const false) _ α≡f WLPO≡WLPO' : WLPO A ≡ WLPO' A WLPO≡WLPO' {A = A} i = (P : A → 𝟚) → Dec (WLPO≃.total≡points P (~ i)) WLPO→LLPO∞ : WLPO A → LLPO∞ A WLPO→LLPO∞ {A = A} womn P Q ¬both with womn P ... | yes ∀¬P = inl ∀¬P ... | no ¬∀¬P = inr ∀¬Q where ∀¬Q : ∀ y → ¬ ⟨ Q y ⟩ ∀¬Q y Qy = ¬∀¬P (λ x Px → ¬both x y Px Qy) -- Limited principle of omniscience -- -- Either a decidable predicate never holds, or it does LPO : Type ℓ → Type ℓ LPO A = ∀(P : A → 𝟚) → (∀ x → ¬ ⟨ P x ⟩) ⊎ ∥ Σ[ x ∈ A ] ⟨ P x ⟩ ∥₁ LPO→WLPO : LPO A → WLPO A LPO→WLPO omn P with omn P ... | inl ∀¬P = yes ∀¬P ... | inr ∃P = no λ ∀¬P → PT.rec isProp⊥ (uncurry ∀¬P) ∃P -- As above, but without truncation. LPO∞ : Type ℓ → Type ℓ LPO∞ A = ∀(P : A → 𝟚) → (∀ x → ¬ ⟨ P x ⟩) ⊎ (Σ[ x ∈ A ] ⟨ P x ⟩) LPO∞→LPO : LPO∞ A → LPO A LPO∞→LPO omn P = Sum.map (idfun _) ∣_∣₁ (omn P)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Categories.Category.Base` module Cubical.Categories.Category.Base where open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Foundations.Equiv open import Cubical.Foundations.Powerset open import Cubical.Data.Sigma private variable ℓ ℓ' : Level -- Categories with hom-sets record Category ℓ ℓ' : Type (ℓ-suc (ℓ-max ℓ ℓ')) where -- TODO: document the impetus for this change no-eta-equality field ob : Type ℓ Hom[_,_] : ob → ob → Type ℓ' id : ∀ {x} → Hom[ x , x ] _⋆_ : ∀ {x y z} (f : Hom[ x , y ]) (g : Hom[ y , z ]) → Hom[ x , z ] ⋆IdL : ∀ {x y} (f : Hom[ x , y ]) → id ⋆ f ≡ f ⋆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 ] -- composition: alternative to diagramatic order _∘_ : ∀ {x y z} (g : Hom[ y , z ]) (f : Hom[ x , y ]) → Hom[ x , z ] g ∘ f = f ⋆ g ⟨_⟩⋆⟨_⟩ : {x y z : ob} {f f' : Hom[ x , y ]} {g g' : Hom[ y , z ]} → f ≡ f' → g ≡ g' → f ⋆ g ≡ f' ⋆ g' ⟨ ≡f ⟩⋆⟨ ≡g ⟩ = cong₂ _⋆_ ≡f ≡g infixr 9 _⋆_ infixr 9 _∘_ open Category -- Helpful syntax/notation _[_,_] : (C : Category ℓ ℓ') → (x y : C .ob) → Type ℓ' _[_,_] = Hom[_,_] _End[_] : (C : Category ℓ ℓ') → (x : C .ob) → Type ℓ' C End[ x ] = C [ x , x ] -- 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 -- TODO: move all of this to Constructions.Opposite? _^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

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Cohomology.EilenbergMacLane.Base.html` {-# OPTIONS --lossy-unification #-} module Cubical.Cohomology.EilenbergMacLane.Base where open import Cubical.Homotopy.EilenbergMacLane.GroupStructure open import Cubical.Homotopy.EilenbergMacLane.Base open import Cubical.Homotopy.EilenbergMacLane.Properties open import Cubical.Homotopy.EilenbergMacLane.Order2 open import Cubical.Homotopy.Connected open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Transport open import Cubical.Foundations.HLevels open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Path open import Cubical.Foundations.Pointed open import Cubical.Foundations.Pointed.Homogeneous open import Cubical.Foundations.Isomorphism open import Cubical.HITs.PropositionalTruncation as PT open import Cubical.HITs.Truncation as TR open import Cubical.Data.Nat open import Cubical.Data.Sigma open import Cubical.Algebra.Group.Base open import Cubical.Algebra.Group.MorphismProperties open import Cubical.Algebra.Group.Morphisms open import Cubical.Algebra.AbGroup.Base open import Cubical.Algebra.Monoid open import Cubical.Algebra.Semigroup open import Cubical.Algebra.Group.Instances.IntMod open import Cubical.Algebra.AbGroup.Instances.IntMod open import Cubical.Algebra.AbGroup.Instances.DirectProduct open import Cubical.Algebra.AbGroup.Properties open import Cubical.HITs.SetTruncation as ST hiding (rec ; map ; elim ; elim2 ; elim3) private variable ℓ ℓ' : Level open IsAbGroup open IsGroup open IsSemigroup open IsMonoid open AbGroupStr -- cohomology groups coHom : (n : ℕ) (G : AbGroup ℓ) (A : Type ℓ') → Type _ coHom n G A = ∥ (A → EM G n) ∥₂ module _ {n : ℕ} {G : AbGroup ℓ} {A : Type ℓ'} where _+ₕ_ : coHom n G A → coHom n G A → coHom n G A _+ₕ_ = ST.rec2 squash₂ λ f g → ∣ (λ x → f x +ₖ g x) ∣₂ -ₕ_ : coHom n G A → coHom n G A -ₕ_ = ST.map λ f x → -ₖ f x _-ₕ_ : coHom n G A → coHom n G A → coHom n G A _-ₕ_ = ST.rec2 squash₂ λ f g → ∣ (λ x → f x -ₖ g x) ∣₂ module _ (n : ℕ) {G : AbGroup ℓ} {A : Type ℓ'} where +ₕ-syntax : coHom n G A → coHom n G A → coHom n G A +ₕ-syntax = _+ₕ_ -ₕ-syntax : coHom n G A → coHom n G A -ₕ-syntax = -ₕ_ -'ₕ-syntax : coHom n G A → coHom n G A → coHom n G A -'ₕ-syntax = _-ₕ_ syntax +ₕ-syntax n x y = x +[ n ]ₕ y syntax -ₕ-syntax n x = -[ n ]ₕ x syntax -'ₕ-syntax n x y = x -[ n ]ₕ y module _ (n : ℕ) {G : AbGroup ℓ} {A : Type ℓ'} where 0ₕ : coHom n G A 0ₕ = ∣ (λ _ → 0ₖ n) ∣₂ rUnitₕ : (x : coHom n G A) → x +ₕ 0ₕ ≡ x rUnitₕ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → rUnitₖ n (f x)) lUnitₕ : (x : coHom n G A) → 0ₕ +[ n ]ₕ x ≡ x lUnitₕ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → lUnitₖ n (f x)) commₕ : (x y : coHom n G A) → x +ₕ y ≡ y +ₕ x commₕ = ST.elim2 (λ _ _ → isSetPathImplicit) λ f g → cong ∣_∣₂ (funExt λ x → commₖ n (f x) (g x)) assocₕ : (x y z : coHom n G A) → x +ₕ (y +ₕ z) ≡ (x +ₕ y) +ₕ z assocₕ = ST.elim3 (λ _ _ _ → isSetPathImplicit) λ f g h → cong ∣_∣₂ (funExt λ x → assocₖ n (f x) (g x) (h x)) rCancelₕ : (x : coHom n G A) → x +ₕ (-ₕ x) ≡ 0ₕ rCancelₕ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → rCancelₖ n (f x)) lCancelₕ : (x : coHom n G A) → (-ₕ x) +ₕ x ≡ 0ₕ lCancelₕ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → lCancelₖ n (f x)) coHomGr : (n : ℕ) (G : AbGroup ℓ) (A : Type ℓ') → AbGroup (ℓ-max ℓ ℓ') fst (coHomGr n G A) = coHom n G A 0g (snd (coHomGr n G A)) = 0ₕ n AbGroupStr._+_ (snd (coHomGr n G A)) = _+ₕ_ - snd (coHomGr n G A) = -ₕ_ is-set (isSemigroup (isMonoid (isGroup (isAbGroup (snd (coHomGr n G A)))))) = squash₂ ·Assoc (isSemigroup (isMonoid (isGroup (isAbGroup (snd (coHomGr n G A)))))) = assocₕ n ·IdR (isMonoid (isGroup (isAbGroup (snd (coHomGr n G A))))) = rUnitₕ n ·IdL (isMonoid (isGroup (isAbGroup (snd (coHomGr n G A))))) = lUnitₕ n ·InvR (isGroup (isAbGroup (snd (coHomGr n G A)))) = rCancelₕ n ·InvL (isGroup (isAbGroup (snd (coHomGr n G A)))) = lCancelₕ n +Comm (isAbGroup (snd (coHomGr n G A))) = commₕ n -- reduced cohomology groups coHomRed : (n : ℕ) (G : AbGroup ℓ) (A : Pointed ℓ') → Type _ coHomRed n G A = ∥ (A →∙ EM∙ G n) ∥₂ 0ₕ∙ : (n : ℕ) {G : AbGroup ℓ} {A : Pointed ℓ'} → coHomRed n G A 0ₕ∙ n = ∣ (λ _ → 0ₖ n) , refl ∣₂ -- operations module _ {n : ℕ} {G : AbGroup ℓ} {A : Pointed ℓ'} where _+ₕ∙_ : coHomRed n G A → coHomRed n G A → coHomRed n G A _+ₕ∙_ = ST.rec2 squash₂ λ f g → ∣ (λ x → fst f x +ₖ fst g x) , cong₂ _+ₖ_ (snd f) (snd g) ∙ rUnitₖ n (0ₖ n) ∣₂ -ₕ∙_ : coHomRed n G A → coHomRed n G A -ₕ∙_ = ST.map λ f → (λ x → -ₖ (fst f x)) , cong -ₖ_ (snd f) ∙ -0ₖ n -- group laws -- Note that→∙Homogeneous≡ (in Foundations.Pointed.Homogeneous) is -- purposely avoided to minimise the size of the proof terms module coHomRedAxioms (n : ℕ) {G : AbGroup ℓ} {A : Pointed ℓ'} where commₕ∙ : (x y : coHomRed n G A) → x +ₕ∙ y ≡ y +ₕ∙ x commₕ∙ = ST.elim2 (λ _ _ → isSetPathImplicit) λ f g → cong ∣_∣₂ (ΣPathP (funExt (λ x → commₖ n (fst f x) (fst g x)) , help n _ (sym (snd f)) _ (sym (snd g)))) where help : (n : ℕ) (f0 : EM G n) (f1 : 0ₖ n ≡ f0) (g0 : EM G n) (g1 : 0ₖ n ≡ g0) → PathP (λ i → commₖ n f0 g0 i ≡ 0ₖ n) (sym (cong₂ _+ₖ_ f1 g1) ∙ rUnitₖ n (0ₖ n)) (sym (cong₂ _+ₖ_ g1 f1) ∙ rUnitₖ n (0ₖ n)) help zero _ _ _ _ = isOfHLevelPathP' 0 (is-set (snd G) _ _) _ _ .fst help (suc zero) = J> (J> refl) help (suc (suc n)) = J> (J> refl) rCancelₕ∙ : (x : coHomRed n G A) → (x +ₕ∙ (-ₕ∙ x)) ≡ 0ₕ∙ n rCancelₕ∙ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP ((funExt (λ x → rCancelₖ n (fst f x))) , help n _ (sym (snd f)))) where help : (n : ℕ) (f0 : EM G n) (f1 : 0ₖ n ≡ f0) → PathP (λ i → rCancelₖ n f0 i ≡ 0ₖ n) (cong₂ _+ₖ_ (sym f1) (cong -ₖ_ (sym f1) ∙ -0ₖ n) ∙ rUnitₖ n (0ₖ n)) refl help zero _ _ = isOfHLevelPathP' 0 (is-set (snd G) _ _) _ _ .fst help (suc zero) = J> (sym (rUnit _) ∙ sym (rUnit _)) help (suc (suc n)) = J> (sym (rUnit _) ∙ sym (rUnit _)) lCancelₕ∙ : (x : coHomRed n G A) → ((-ₕ∙ x) +ₕ∙ x) ≡ 0ₕ∙ n lCancelₕ∙ x = commₕ∙ (-ₕ∙ x) x ∙ rCancelₕ∙ x rUnitₕ∙ : (x : coHomRed n G A) → (x +ₕ∙ 0ₕ∙ n) ≡ x rUnitₕ∙ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP ((funExt λ x → rUnitₖ n (fst f x)) , help n _ (sym (snd f)))) where help : (n : ℕ) (f0 : EM G n) (f1 : 0ₖ n ≡ f0) → PathP (λ i → rUnitₖ n f0 i ≡ 0ₖ n) (cong (_+ₖ 0ₖ n) (sym f1) ∙ rUnitₖ n (0ₖ n)) (sym f1) help zero _ _ = isOfHLevelPathP' 0 (is-set (snd G) _ _) _ _ .fst help (suc zero) = J> sym (rUnit refl) help (suc (suc n)) = J> sym (rUnit refl) lUnitₕ∙ : (x : coHomRed n G A) → (0ₕ∙ n +ₕ∙ x) ≡ x lUnitₕ∙ = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP ((funExt (λ x → lUnitₖ n (fst f x))) , help n _ (sym (snd f)))) where help : (n : ℕ) (f0 : EM G n) (f1 : 0ₖ n ≡ f0) → PathP (λ i → lUnitₖ n f0 i ≡ 0ₖ n) (cong (0ₖ n +ₖ_) (sym f1) ∙ rUnitₖ n (0ₖ n)) (sym f1) help zero _ _ = isOfHLevelPathP' 0 (is-set (snd G) _ _) _ _ .fst help (suc zero) = J> sym (rUnit refl) help (suc (suc n)) = J> sym (rUnit refl) assocₕ∙ : (x y z : coHomRed n G A) → x +ₕ∙ (y +ₕ∙ z) ≡ (x +ₕ∙ y) +ₕ∙ z assocₕ∙ = ST.elim3 (λ _ _ _ → isSetPathImplicit) λ f g h → cong ∣_∣₂ (ΣPathP ((funExt (λ x → assocₖ n (fst f x) (fst g x) (fst h x))) , help n _ (sym (snd f)) _ (sym (snd g)) _ (sym (snd h)))) where help : (n : ℕ) (f0 : EM G n) (f1 : 0ₖ n ≡ f0) (g0 : EM G n) (g1 : 0ₖ n ≡ g0) (h0 : EM G n) (h1 : 0ₖ n ≡ h0) → PathP (λ i → assocₖ n f0 g0 h0 i ≡ 0ₖ n) (cong₂ _+ₖ_ (sym f1) (cong₂ _+ₖ_ (sym g1) (sym h1) ∙ rUnitₖ n (0ₖ n)) ∙ rUnitₖ n (0ₖ n)) (cong₂ _+ₖ_ (cong₂ _+ₖ_ (sym f1) (sym g1) ∙ rUnitₖ n (0ₖ n)) (sym h1) ∙ rUnitₖ n (0ₖ n)) help zero _ _ _ _ _ _ = isOfHLevelPathP' 0 (is-set (snd G) _ _) _ _ .fst help (suc zero) = J> (J> (J> cong (_∙ refl) (cong (cong₂ _+ₖ_ refl) (sym (rUnit refl)) ∙ (cong (λ z → cong₂ (+ₖ-syntax {G = G} 1) z (refl {x = 0ₖ {G = G} 1})) (rUnit refl))))) help (suc (suc n)) = J> (J> (J> flipSquare ((sym (rUnit refl)) ◁ flipSquare (cong (_∙ refl) (cong (cong₂ _+ₖ_ refl) (sym (rUnit refl)) ∙ (cong (λ z → cong₂ (+ₖ-syntax {G = G} (suc (suc n))) z (refl {x = 0ₖ {G = G} (suc (suc n))})) (rUnit refl))))))) coHomRedGr : (n : ℕ) (G : AbGroup ℓ) (A : Pointed ℓ') → AbGroup _ fst (coHomRedGr n G A) = coHomRed n G A 0g (snd (coHomRedGr n G A)) = 0ₕ∙ n AbGroupStr._+_ (snd (coHomRedGr n G A)) = _+ₕ∙_ - snd (coHomRedGr n G A) = -ₕ∙_ is-set (isSemigroup (isMonoid (isGroup (isAbGroup (snd (coHomRedGr n G A)))))) = squash₂ ·Assoc (isSemigroup (isMonoid (isGroup (isAbGroup (snd (coHomRedGr n G A)))))) = coHomRedAxioms.assocₕ∙ n ·IdR (isMonoid (isGroup (isAbGroup (snd (coHomRedGr n G A))))) = coHomRedAxioms.rUnitₕ∙ n ·IdL (isMonoid (isGroup (isAbGroup (snd (coHomRedGr n G A))))) = coHomRedAxioms.lUnitₕ∙ n ·InvR (isGroup (isAbGroup (snd (coHomRedGr n G A)))) = coHomRedAxioms.rCancelₕ∙ n ·InvL (isGroup (isAbGroup (snd (coHomRedGr n G A)))) = coHomRedAxioms.lCancelₕ∙ n +Comm (isAbGroup (snd (coHomRedGr n G A))) = coHomRedAxioms.commₕ∙ n coHom≅coHomRed : (n : ℕ) (G : AbGroup ℓ) (A : Pointed ℓ') → AbGroupEquiv (coHomGr (suc n) G (fst A)) (coHomRedGr (suc n) G A) coHom≅coHomRed n G A = GroupIso→GroupEquiv (invGroupIso main) where con-lem : (n : ℕ) (x : EM G (suc n)) → ∥ x ≡ 0ₖ (suc n) ∥₁ con-lem n = EM-raw'-elim G (suc n) (λ _ → isProp→isOfHLevelSuc (suc n) squash₁) (EM-raw'-trivElim G n (λ _ → isProp→isOfHLevelSuc n squash₁) ∣ EM-raw'→EM∙ G (suc n) ∣₁) main : GroupIso _ _ Iso.fun (fst main) = ST.map fst Iso.inv (fst main) = ST.map λ f → (λ x → f x -ₖ f (pt A)) , rCancelₖ (suc n) (f (pt A)) Iso.sec (fst main) = ST.elim (λ _ → isSetPathImplicit) λ f → PT.rec (squash₂ _ _) (λ p → cong ∣_∣₂ (funExt λ x → cong (λ z → f x +ₖ z) (cong -ₖ_ p ∙ -0ₖ (suc n)) ∙ rUnitₖ (suc n) (f x))) (con-lem n (f (pt A))) Iso.ret (fst main) = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousEM (suc n)) (funExt λ x → cong (fst f x +ₖ_) (cong -ₖ_ (snd f) ∙ -0ₖ (suc n)) ∙ rUnitₖ (suc n) (fst f x))) snd main = makeIsGroupHom (ST.elim2 (λ _ _ → isSetPathImplicit) λ _ _ → refl) coHom⁰≅coHomRed⁰ : (G : AbGroup ℓ) (A : Pointed ℓ) → AbGroupEquiv (AbDirProd (coHomRedGr 0 G A) G) (coHomGr 0 G (typ A)) fst (coHom⁰≅coHomRed⁰ G A) = isoToEquiv is where is : Iso _ _ Iso.fun is = uncurry (ST.rec (isSetΠ (λ _ → squash₂)) λ f g → ∣ (λ x → AbGroupStr._+_ (snd G) (fst f x) g) ∣₂) Iso.inv is = ST.rec (isSet× squash₂ (is-set (snd G))) λ f → ∣ (λ x → AbGroupStr._-_ (snd G) (f x) (f (pt A))) , +InvR (snd G) (f (pt A)) ∣₂ , f (pt A) Iso.sec is = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → sym (+Assoc (snd G) _ _ _) ∙∙ cong (AbGroupStr._+_ (snd G) (f x)) (+InvL (snd G) (f (pt A))) ∙∙ +IdR (snd G) (f x)) Iso.ret is = uncurry (ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 (isSet× squash₂ (is-set (snd G))) _ _)) λ f → λ g → ΣPathP (cong ∣_∣₂ (Σ≡Prop (λ _ → is-set (snd G) _ _) (funExt (λ x → cong₂ (AbGroupStr._+_ (snd G)) refl (cong (- (snd G)) (cong₂ (AbGroupStr._+_ (snd G)) (snd f) refl ∙ +IdL (snd G) g)) ∙ sym (+Assoc (snd G) _ _ _) ∙ cong (AbGroupStr._+_ (snd G) (fst f x)) (+InvR (snd G) g) ∙ +IdR (snd G) (f .fst x)))) , (cong (λ x → AbGroupStr._+_ (snd G) x g) (snd f) ∙ +IdL (snd G) g))) snd (coHom⁰≅coHomRed⁰ G A) = makeIsGroupHom (uncurry (ST.elim (λ _ → isSetΠ2 λ _ _ → isSetPathImplicit) λ f1 g1 → uncurry (ST.elim (λ _ → isSetΠ λ _ → isSetPathImplicit) λ f2 g2 → cong ∣_∣₂ (funExt λ a → AbGroupTheory.comm-4 G _ _ _ _)))) -- ℤ/2 lemmas +ₕ≡id-ℤ/2 : ∀ {ℓ} {A : Type ℓ} (n : ℕ) (x : coHom n ℤ/2 A) → x +ₕ x ≡ 0ₕ n +ₕ≡id-ℤ/2 n = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → +ₖ≡id-ℤ/2 n (f x)) -ₕConst-ℤ/2 : (n : ℕ) {A : Type ℓ} (x : coHom n ℤ/2 A) → -ₕ x ≡ x -ₕConst-ℤ/2 zero = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → -Const-ℤ/2 (f x)) -ₕConst-ℤ/2 (suc n) = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (funExt λ x → -ₖConst-ℤ/2 n (f x)) coHomFun : ∀ {ℓ''} {A : Type ℓ} {B : Type ℓ'} {G : AbGroup ℓ''} (n : ℕ) (f : A → B) → coHom n G B → coHom n G A coHomFun n f = ST.map λ g x → g (f x) coHomHom : ∀ {ℓ''} {A : Type ℓ} {B : Type ℓ'} {G : AbGroup ℓ''} (n : ℕ) (f : A → B) → AbGroupHom (coHomGr n G B) (coHomGr n G A) fst (coHomHom n f) = coHomFun n f snd (coHomHom n f) = makeIsGroupHom (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _) λ f g → refl) coHomEquiv : ∀ {ℓ''} {A : Type ℓ} {B : Type ℓ'} {G : AbGroup ℓ''} (n : ℕ) → (Iso A B) → AbGroupEquiv (coHomGr n G B) (coHomGr n G A) fst (coHomEquiv n f) = isoToEquiv is where is : Iso _ _ Iso.fun is = coHomFun n (Iso.fun f) Iso.inv is = coHomFun n (Iso.inv f) Iso.sec is = ST.elim (λ _ → isSetPathImplicit) λ g → cong ∣_∣₂ (funExt λ x → cong g (Iso.ret f x)) Iso.ret is = ST.elim (λ _ → isSetPathImplicit) λ g → cong ∣_∣₂ (funExt λ x → cong g (Iso.sec f x)) snd (coHomEquiv n f) = snd (coHomHom n (Iso.fun f)) coHomFun∙ : ∀ {ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {G : AbGroup ℓ''} (n : ℕ) (f : A →∙ B) → coHomRed n G B → coHomRed n G A coHomFun∙ n f = ST.map λ g → g ∘∙ f coHomHom∙ : ∀ {ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {G : AbGroup ℓ''} (n : ℕ) (f : A →∙ B) → AbGroupHom (coHomRedGr n G B) (coHomRedGr n G A) fst (coHomHom∙ n f) = coHomFun∙ n f snd (coHomHom∙ n f) = makeIsGroupHom (ST.elim2 (λ _ _ → isSetPathImplicit) λ g h → cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousEM n) refl)) substℕ-coHom : {A : Type ℓ} {G : AbGroup ℓ'} {n m : ℕ} → (p : n ≡ m) → AbGroupEquiv (coHomGr n G A) (coHomGr m G A) fst (substℕ-coHom {A = A} {G = G} p) = substEquiv' (λ i → coHom i G A) p snd (substℕ-coHom {A = A} {G = G} p) = makeIsGroupHom λ x y → J (λ m p → subst (λ i → coHom i G A) p (x +ₕ y) ≡ (subst (λ i → coHom i G A) p x +ₕ subst (λ i → coHom i G A) p y)) (transportRefl _ ∙ cong₂ _+ₕ_ (sym (transportRefl x)) (sym (transportRefl y))) p substℕ-coHomRed : {A : Pointed ℓ} {G : AbGroup ℓ'} {n m : ℕ} → (p : n ≡ m) → AbGroupEquiv (coHomRedGr n G A) (coHomRedGr m G A) fst (substℕ-coHomRed {A = A} {G = G} p) = substEquiv' (λ i → coHomRed i G A) p snd (substℕ-coHomRed {A = A} {G = G} p) = makeIsGroupHom λ x y → J (λ m p → subst (λ i → coHomRed i G A) p (x +ₕ∙ y) ≡ (subst (λ i → coHomRed i G A) p x +ₕ∙ subst (λ i → coHomRed i G A) p y)) (transportRefl _ ∙ cong₂ _+ₕ∙_ (sym (transportRefl x)) (sym (transportRefl y))) p subst-EM-0ₖ : ∀{ℓ} {G : AbGroup ℓ} {n m : ℕ} (p : n ≡ m) → subst (EM G) p (0ₖ n) ≡ 0ₖ m subst-EM-0ₖ {G = G} {n = n} = J (λ m p → subst (EM G) p (0ₖ n) ≡ 0ₖ m) (transportRefl _) subst-EM∙ : ∀ {ℓ} {G : AbGroup ℓ} {n m : ℕ} (p : n ≡ m) → EM∙ G n →∙ EM∙ G m fst (subst-EM∙ {G = G} p) = subst (EM G) p snd (subst-EM∙ p) = subst-EM-0ₖ p coHomPointedElim : ∀ {ℓ ℓ' ℓ''} {G : AbGroup ℓ} {A : Type ℓ'} (n : ℕ) (a : A) {B : coHom (suc n) G A → Type ℓ''} → ((x : coHom (suc n) G A) → isProp (B x)) → ((f : A → EM G (suc n)) → f a ≡ 0ₖ (suc n) → B ∣ f ∣₂) → (x : coHom (suc n) G A) → B x coHomPointedElim {ℓ'' = ℓ''} {G = G} {A = A} n a isprop indp = ST.elim (λ _ → isOfHLevelSuc 1 (isprop _)) λ f → helper n isprop indp f where helper : (n : ℕ) {B : coHom (suc n) G A → Type ℓ''} → ((x : coHom (suc n) G A) → isProp (B x)) → ((f : A → EM G (suc n)) → f a ≡ 0ₖ (suc n) → B ∣ f ∣₂) → (f : A → EM G (suc n)) → B ∣ f ∣₂ helper n isprop ind f = TR.rec (isProp→isOfHLevelSuc n (isprop _)) (ind f) (isConnectedPath (suc n) (isConnectedEM (suc n)) (f a) (0ₖ (suc n)) .fst) coHomTruncEquiv : {A : Type ℓ} (G : AbGroup ℓ) (n : ℕ) → AbGroupEquiv (coHomGr n G (∥ A ∥ (suc (suc n)))) (coHomGr n G A) fst (coHomTruncEquiv G n) = isoToEquiv (setTruncIso (univTrunc (suc (suc n)) {B = _ , hLevelEM G n})) snd (coHomTruncEquiv G n) = makeIsGroupHom (ST.elim2 (λ _ _ → isSetPathImplicit) λ _ _ → refl) EM→-charac : ∀ {ℓ ℓ'} {A : Pointed ℓ} {G : AbGroup ℓ'} (n : ℕ) → Iso (fst A → EM G n) ((A →∙ EM∙ G n) × EM G n) Iso.fun (EM→-charac {A = A} n) f = ((λ x → f x -ₖ f (pt A)) , rCancelₖ n (f (pt A))) , f (pt A) Iso.inv (EM→-charac n) (f , a) x = fst f x +ₖ a Iso.sec (EM→-charac {A = A} n) ((f , p) , a) = ΣPathP (→∙Homogeneous≡ (isHomogeneousEM _) (funExt (λ x → (λ i → (f x +ₖ a) -ₖ (cong (_+ₖ a) p ∙ lUnitₖ n a) i) ∙ sym (assocₖ n (f x) a (-ₖ a)) ∙ cong (f x +ₖ_) (rCancelₖ n a) ∙ rUnitₖ n (f x))) , cong (_+ₖ a) p ∙ lUnitₖ n a) Iso.ret (EM→-charac {A = A} n) f = funExt λ x → sym (assocₖ n (f x) (-ₖ f (pt A)) (f (pt A))) ∙∙ cong (f x +ₖ_) (lCancelₖ n (f (pt A))) ∙∙ rUnitₖ n (f x)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Empty.Properties.html` module Cubical.Data.Empty.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Data.Empty.Base isProp⊥ : isProp ⊥ isProp⊥ () isProp⊥* : ∀ {ℓ} → isProp {ℓ} ⊥* isProp⊥* _ () isContr⊥→A : ∀ {ℓ} {A : Type ℓ} → isContr (⊥ → A) fst isContr⊥→A () snd isContr⊥→A f i () isContrΠ⊥ : ∀ {ℓ} {A : ⊥ → Type ℓ} → isContr ((x : ⊥) → A x) fst isContrΠ⊥ () snd isContrΠ⊥ f i () isContrΠ⊥* : ∀ {ℓ ℓ'} {A : ⊥* {ℓ} → Type ℓ'} → isContr ((x : ⊥*) → A x) fst isContrΠ⊥* () snd isContrΠ⊥* f i () uninhabEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → (A → ⊥) → (B → ⊥) → A ≃ B uninhabEquiv ¬a ¬b = isoToEquiv isom where open Iso isom : Iso _ _ isom .fun a = rec (¬a a) isom .inv b = rec (¬b b) isom .sec b = rec (¬b b) isom .ret a = rec (¬a a)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Equality.Conversion.html` {- Conversion between paths and the inductively defined equality type - Path and _≡_ are equal (Path≡Eq) - conversion between dependent paths and PathP (pathOver→PathP and PathP→pathOver) - cong-PathP→apd-pathOver for HIT β rules (see S¹ loop case) -} module Cubical.Data.Equality.Conversion where open import Cubical.Foundations.Prelude hiding (_≡_ ; step-≡ ; _∎ ; isPropIsContr) renaming ( refl to reflPath ; transport to transportPath ; J to JPath ; JRefl to JPathRefl ; sym to symPath ; _∙_ to compPath ; cong to congPath ; subst to substPath ; substRefl to substPathReflPath ; funExt to funExtPath ; isContr to isContrPath ; isProp to isPropPath ) open import Cubical.Foundations.Equiv renaming ( fiber to fiberPath ; isEquiv to isEquivPath ; _≃_ to EquivPath ; equivFun to equivFunPath ; isPropIsEquiv to isPropIsEquivPath ) hiding ( equivCtr ; equivIsEquiv ) open import Cubical.Foundations.Isomorphism using () renaming ( Iso to IsoPath ; iso to isoPath ; isoToPath to isoPathToPath ; isoToEquiv to isoPathToEquivPath ) open import Cubical.Data.Equality.Base private variable a b ℓ ℓ' : Level A : Type a B : Type b x y z : A -------------------------------------------------------------------------------- -- Paths congPathd : {C : A → Type ℓ} (f : (x : A) → C x) {x y : A} (p : Path A x y) → Path (C y) (substPath C p (f x)) (f y) congPathd f p = fromPathP (congPath f p) -- Equality between Path and equality eqToPath : {x y : A} → x ≡ y → Path A x y eqToPath refl = reflPath pathToEq : {x y : A} → Path A x y → x ≡ y pathToEq {x = x} = JPath (λ y _ → x ≡ y) refl pathToEq-reflPath : {x : A} → pathToEq reflPath ≡ refl {x = x} pathToEq-reflPath {x = x} = pathToEq (JPathRefl (λ y _ → x ≡ y) refl) eqToPath-pathToEq : {x y : A} → (p : Path A x y) → Path _ (eqToPath (pathToEq p)) p eqToPath-pathToEq p = JPath (λ _ h → Path _ (eqToPath (pathToEq h)) h) (congPath eqToPath (transportRefl refl)) p pathToEq-eqToPath : {x y : A} → (p : x ≡ y) → Path _ (pathToEq (eqToPath p)) p pathToEq-eqToPath refl = transportRefl refl PathIsoEq : {x y : A} → IsoPath (Path A x y) (x ≡ y) PathIsoEq = isoPath pathToEq eqToPath pathToEq-eqToPath eqToPath-pathToEq PathPathEq : {x y : A} → Path _ (Path A x y) (x ≡ y) PathPathEq = isoPathToPath PathIsoEq Path≡Eq : {x y : A} → (Path A x y) ≡ (x ≡ y) Path≡Eq = pathToEq PathPathEq happly : {B : A → Type ℓ} {f g : (x : A) → B x} → f ≡ g → (x : A) → f x ≡ g x happly refl x = refl -- We get funExt by going back and forth between Path and Eq funExt : {B : A → Type ℓ} {f g : (x : A) → B x} → ((x : A) → f x ≡ g x) → f ≡ g funExt p = pathToEq (λ i x → eqToPath (p x) i) funExtRefl : {B : A → Type ℓ} {f : (x : A) → B x} → funExt (λ x → refl {x = f x}) ≡ refl funExtRefl = pathToEq-reflPath Σ≡Prop : {P : A → Type ℓ} → ((x : A) → isProp (P x)) → {u v : Σ A P} → u .pr₁ ≡ v .pr₁ → u ≡ v Σ≡Prop p {v = (x , y)} refl = ap (x ,_) (p x _ y) -- Some lemmas relating the definitions for Path and ≡ substPath≡transport' : (C : A → Type ℓ) {x y : A} (b : C x) (p : x ≡ y) → substPath C (eqToPath p) b ≡ transport C p b substPath≡transport' C b refl = pathToEq (transportRefl b) substPath≡transport : (C : A → Type ℓ) {x y : A} (b : C x) (p : Path _ x y) → substPath C p b ≡ transport C (pathToEq p) b substPath≡transport C b p = ap (λ x → substPath C x b) (pathToEq (symPath (eqToPath-pathToEq p))) ∙ substPath≡transport' C b (pathToEq p) congPath≡ap : {x y : A} → (f : A → B) (p : x ≡ y) → congPath f (eqToPath p) ≡ eqToPath (ap f p) congPath≡ap f refl = refl ap≡congPath : {x y : A} → (f : A → B) (p : Path A x y) → ap f (pathToEq p) ≡ pathToEq (congPath f p) ap≡congPath {x = x} f p = JPath (λ _ q → ap f (pathToEq q) ≡ pathToEq (congPath f q)) rem p where rem : ap f (transp (λ i → x ≡ x) i0 refl) ≡ transp (λ i → f x ≡ f x) i0 refl rem = pathToEq (compPath (λ i → ap f (transportRefl refl i)) (symPath (transportRefl refl))) -- Functions for going between the various definitions. This could -- also be achieved by making lines in the universe and transporting -- back and forth along them. fiberPathToFiber : {f : A → B} {y : B} → fiberPath f y → fiber f y fiberPathToFiber (x , p) = (x , pathToEq p) fiberToFiberPath : {f : A → B} {y : B} → fiber f y → fiberPath f y fiberToFiberPath (x , p) = (x , eqToPath p) fiberToFiber : {f : A → B} {y : B} (p : fiber f y) → Path _ (fiberPathToFiber (fiberToFiberPath p)) p fiberToFiber (x , p) i = x , pathToEq-eqToPath p i fiberPathToFiberPath : {f : A → B} {y : B} (p : fiberPath f y) → Path _ (fiberToFiberPath (fiberPathToFiber p)) p fiberPathToFiberPath (x , p) i = x , eqToPath-pathToEq p i isContrPathToIsContr : isContrPath A → isContr A isContrPathToIsContr (ctr , p) = (ctr , λ y → pathToEq (p y)) isContrToIsContrPath : isContr A → isContrPath A isContrToIsContrPath (ctr , p) = (ctr , λ y → eqToPath (p y)) isPropPathToIsProp : isPropPath A → isProp A isPropPathToIsProp H x y = pathToEq (H x y) isPropToIsPropPath : isProp A → isPropPath A isPropToIsPropPath H x y = eqToPath (H x y) -- Specialized helper lemmas for going back and forth between -- isContrPath and isContr: private helper1 : {A B : Type ℓ} (f : A → B) (g : B → A) (h : ∀ y → Path _ (f (g y)) y) → isContrPath A → isContr B helper1 f g h (x , p) = (f x , λ y → pathToEq (λ i → hcomp (λ j → λ { (i = i0) → f x ; (i = i1) → h y j }) (f (p (g y) i)))) helper2 : {A B : Type ℓ} (f : A → B) (g : B → A) (h : ∀ y → Path _ (g (f y)) y) → isContr B → isContrPath A helper2 {A = A} f g h (x , p) = (g x , λ y → eqToPath (ap g (p (f y)) ∙ pathToEq (h y))) -- This proof is essentially the one for proving that isContr with -- Path is a proposition, but as we are working with ≡ we have to -- insert a lot of conversion functions. -- TODO: prove this directly following the HoTT proof? isPropIsContr : (p1 p2 : isContr A) → Path (isContr A) p1 p2 isPropIsContr (a0 , p0) (a1 , p1) j = ( eqToPath (p0 a1) j , hcomp (λ i → λ { (j = i0) → λ x → pathToEq-eqToPath (p0 x) i ; (j = i1) → λ x → pathToEq-eqToPath (p1 x) i }) (λ x → pathToEq (λ i → hcomp (λ k → λ { (i = i0) → eqToPath (p0 a1) j ; (i = i1) → eqToPath (p0 x) (j ∨ k) ; (j = i0) → eqToPath (p0 x) (i ∧ k) ; (j = i1) → eqToPath (p1 x) i }) (eqToPath (p0 (eqToPath (p1 x) i)) j)))) -- We now prove that isEquiv is a proposition isPropIsEquiv : {A B : Type ℓ} {f : A → B} (h1 h2 : isEquiv f) → Path _ h1 h2 equiv-proof (isPropIsEquiv h1 h2 i) y = isPropIsContr (h1 .equiv-proof y) (h2 .equiv-proof y) i equivToEquivPath : A ≃ B → EquivPath A B equivToEquivPath (f , p) = (f , λ { .equiv-proof y → helper2 fiberPathToFiber fiberToFiberPath fiberPathToFiberPath (p .equiv-proof y) }) -- Go from a Path equivalence to an ≡ equivalence equivPathToEquiv : EquivPath A B → A ≃ B equivPathToEquiv (f , p) = (f , λ { .equiv-proof y → helper1 fiberPathToFiber fiberToFiberPath fiberToFiber (p .equiv-proof y) }) equivToEquiv : {A B : Type ℓ} (p : A ≃ B) → Path _ (equivPathToEquiv (equivToEquivPath p)) p equivToEquiv (f , p) i = (f , isPropIsEquiv (λ { .equiv-proof y → helper1 fiberPathToFiber fiberToFiberPath fiberToFiber (helper2 fiberPathToFiber fiberToFiberPath fiberPathToFiberPath (p .equiv-proof y)) }) p i) equivPathToEquivPath : {A B : Type ℓ} (p : EquivPath A B) → Path _ (equivToEquivPath (equivPathToEquiv p)) p equivPathToEquivPath (f , p) i = ( f , isPropIsEquivPath f (equivToEquivPath (equivPathToEquiv (f , p)) .snd) p i ) equivPath≡Equiv : {A B : Type ℓ} → Path _ (EquivPath A B) (A ≃ B) equivPath≡Equiv {ℓ} = isoPathToPath (isoPath (equivPathToEquiv {ℓ}) equivToEquivPath equivToEquiv equivPathToEquivPath) path≡Eq : {A B : Type ℓ} → Path _ (Path _ A B) (A ≡ B) path≡Eq = isoPathToPath (isoPath pathToEq eqToPath pathToEq-eqToPath eqToPath-pathToEq) -------------------------------------------------------------------------------- -- Isomorphisms record Iso {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') : Type (ℓ-max ℓ ℓ') where no-eta-equality constructor iso pattern field fun : A → B inv : B → A sec : (b : B) → fun (inv b) ≡ b ret : (a : A) → inv (fun a) ≡ a isoToIsoPath : Iso A B → IsoPath A B isoToIsoPath (iso f g η ε) = isoPath f g (λ b → eqToPath (η b)) (λ a → eqToPath (ε a)) isoToEquiv : Iso A B → A ≃ B isoToEquiv f = equivPathToEquiv (isoPathToEquivPath (isoToIsoPath f)) -------------------------------------------------------------------------------- -- dependent paths and PathP -- similar to https://www.cse.chalmers.se/~nad/listings/equality/Equality.Path.Isomorphisms.html -- used for eliminators and β rules for HITs transportPathToEq→transportPath : (P : A → Type ℓ) (p : Path A x y) (u : P x) → transport P (pathToEq p) u ≡ substPath P p u transportPathToEq→transportPath {x = x} P = JPath (λ y p → (u : P x) → transport P (pathToEq p) u ≡ substPath P p u) λ u → ap (λ t → transport P t u) pathToEq-reflPath ∙ sym (pathToEq (substPathReflPath {B = P} u)) module _ (P : A → Type ℓ) {x y : A} {u : P x} {v : P y} where pathOver→PathP : (p : Path _ x y) → transport P (pathToEq p) u ≡ v → PathP (λ i → P (p i)) u v pathOver→PathP p q = JPath (λ y p → (v : P y) → transport P (pathToEq p) u ≡ v → PathP (λ i → P (p i)) u v) (λ v q → eqToPath (ap (λ r → transport P r u) (sym pathToEq-reflPath) ∙ q)) p v q PathP→pathOver : (p : Path _ x y) → PathP (λ i → P (p i)) u v → transport P (pathToEq p) u ≡ v PathP→pathOver p q = JPath (λ y p → (v : P y) (q : PathP (λ i → P (p i)) u v) → transport P (pathToEq p) u ≡ v) (λ v q → ap (λ t → transport P t u) pathToEq-reflPath ∙ pathToEq q) p _ q module _ (P : A → Type ℓ) {x : A} {u v : P x} where pathOver→PathP-reflPath : (q : transport P (pathToEq reflPath) u ≡ v) → pathOver→PathP P reflPath q ≡ eqToPath (ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q) pathOver→PathP-reflPath q = pathToEq λ i → JPathRefl (λ y p → (v : P y) → transport P (pathToEq p) u ≡ v → PathP (λ i → P (p i)) u v) (λ v q → eqToPath (ap (λ r → transport P r u) (sym pathToEq-reflPath) ∙ q)) i _ q PathP→pathOver-reflPath : (q : PathP (λ i → P x) u v) → PathP→pathOver P reflPath q ≡ ap (λ t → transport P t u) pathToEq-reflPath ∙ pathToEq q PathP→pathOver-reflPath q = pathToEq λ i → JPathRefl (λ y p → (v : P y) (q : PathP (λ i → P (p i)) u v) → transport P (pathToEq p) u ≡ v) (λ v q → ap (λ t → transport P t u) pathToEq-reflPath ∙ pathToEq q) i _ q apd-pathToEq≡PathP→pathOver-cong : {P : A → Type ℓ} {x y : A} (f : (x : A) → P x) (p : Path _ x y) → apd f (pathToEq p) ≡ PathP→pathOver P p (congPath f p) apd-pathToEq≡PathP→pathOver-cong {P = P} {x = x} f = JPath (λ _ p → apd f (pathToEq p) ≡ PathP→pathOver P p (congPath f p)) let step1 = sym (apd (λ (p : x ≡ x) → apd f p) (sym pathToEq-reflPath)) step2 = transport-path (λ p → transport P p (f x)) (λ _ → f x) (sym pathToEq-reflPath) refl step3 = ap (λ t → sym (ap (λ p → transport P p (f x)) (sym pathToEq-reflPath)) ∙ refl ∙ t) (ap-const {A = x ≡ x} (sym pathToEq-reflPath) (f x)) step4 = ap (λ t → sym t ∙ refl) (sym (sym-ap (λ p → transport P p (f x)) pathToEq-reflPath)) step5 = ap (_∙ refl) (sym-invol (ap (λ p → transport P p (f x)) pathToEq-reflPath)) step6 = ap (ap (λ t → transport P t (f x)) pathToEq-reflPath ∙_) (sym pathToEq-reflPath) step7 = sym (PathP→pathOver-reflPath P reflPath) in apd f (pathToEq reflPath) ≡⟨ step1 ⟩ transport (λ p → transport P p (f x) ≡ f x) (sym pathToEq-reflPath) refl ≡⟨ step2 ⟩ sym (ap (λ p → transport P p (f x)) (sym pathToEq-reflPath)) ∙ refl ∙ ap (λ (_ : x ≡ x) → f x) (sym pathToEq-reflPath) ≡⟨ step3 ⟩ sym (ap (λ p → transport P p (f x)) (sym pathToEq-reflPath)) ∙ refl ≡⟨ step4 ⟩ sym (sym (ap (λ p → transport P p (f x)) pathToEq-reflPath)) ∙ refl ≡⟨ step5 ⟩ ap (λ t → transport P t (f x)) pathToEq-reflPath ∙ refl ≡⟨ step6 ⟩ ap (λ t → transport P t (f x)) pathToEq-reflPath ∙ pathToEq reflPath ≡⟨ step7 ⟩ PathP→pathOver P reflPath reflPath ∎ module _ (P : A → Type ℓ) {x y : A} {u : P x} {v : P y} where -- TODO -- PathP→pathOver→PathP : (p : Path _ x y) (q : PathP (λ i → P (p i)) u v) → pathOver→PathP P p (PathP→pathOver P p q) ≡ q -- PathP→pathOver→PathP p q = {!!} pathOver→PathP→pathOver : (p : Path _ x y) (q : transport P (pathToEq p) u ≡ v) → PathP→pathOver P p (pathOver→PathP P p q) ≡ q pathOver→PathP→pathOver p q = JPath (λ y p → {v : P y} (q : transport P (pathToEq p) u ≡ v) → PathP→pathOver P p (pathOver→PathP P p q) ≡ q) (λ q → let step1 = ap (PathP→pathOver P reflPath) (pathOver→PathP-reflPath P q) step2 = PathP→pathOver-reflPath P (eqToPath (ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q)) step3 = ap (ap (λ t → transport P t u) pathToEq-reflPath ∙_) (pathToEq (pathToEq-eqToPath (ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q))) step4 = sym (assoc (ap (λ t → transport P t u) pathToEq-reflPath) (ap (λ t → transport P t u) (sym pathToEq-reflPath)) q) step5 = ap (_∙ q) (sym (ap-∙ (λ t → transport P t u) pathToEq-reflPath (sym pathToEq-reflPath))) step6 = ap (λ t → ap (λ t → transport P t u) t ∙ q) (invR pathToEq-reflPath) in PathP→pathOver P reflPath (pathOver→PathP P reflPath q) ≡⟨ step1 ⟩ PathP→pathOver P reflPath (eqToPath (ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q)) ≡⟨ step2 ⟩ ap (λ t → transport P t u) pathToEq-reflPath ∙ pathToEq (eqToPath (ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q)) ≡⟨ step3 ⟩ ap (λ t → transport P t u) pathToEq-reflPath ∙ ap (λ t → transport P t u) (sym pathToEq-reflPath) ∙ q ≡⟨ step4 ⟩ (ap (λ t → transport P t u) pathToEq-reflPath ∙ ap (λ t → transport P t u) (sym pathToEq-reflPath)) ∙ q ≡⟨ step5 ⟩ ap (λ t → transport P t u) (pathToEq-reflPath ∙ sym pathToEq-reflPath) ∙ q ≡⟨ step6 ⟩ q ∎) p q cong-PathP→apd-pathOver : (P : A → Type ℓ) {x y : A} (f : (x : A) → P x) → (p : Path _ x y) (q : transport P (pathToEq p) (f x) ≡ f y) → congPath f p ≡ pathOver→PathP P p q → apd f (pathToEq p) ≡ q cong-PathP→apd-pathOver {A = A} P {x = x} f p q r = apd f (pathToEq p) ≡⟨ apd-pathToEq≡PathP→pathOver-cong f p ⟩ PathP→pathOver P p (congPath f p) ≡⟨ ap (PathP→pathOver P p) r ⟩ PathP→pathOver P p (pathOver→PathP P p q) ≡⟨ pathOver→PathP→pathOver P p q ⟩ q ∎

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Int.MoreInts.QuoInt.Base.html` -- Define the integers as a HIT by identifying +0 and -0 module Cubical.Data.Int.MoreInts.QuoInt.Base where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Transport open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Univalence open import Cubical.Relation.Nullary open import Cubical.Data.Int using () renaming (ℤ to Int ; discreteℤ to discreteInt ; isSetℤ to isSetInt ; 0≢1-ℤ to 0≢1-Int) open import Cubical.Data.Nat as ℕ using (ℕ; zero; suc) open import Cubical.Data.Bool as Bool using (Bool; not; notnot) variable l : Level Sign : Type₀ Sign = Bool pattern spos = Bool.false pattern sneg = Bool.true _·S_ : Sign → Sign → Sign _·S_ = Bool._⊕_ data ℤ : Type₀ where signed : (s : Sign) (n : ℕ) → ℤ posneg : signed spos 0 ≡ signed sneg 0 pattern pos n = signed spos n pattern neg n = signed sneg n sign : ℤ → Sign sign (signed _ zero) = spos sign (signed s (suc _)) = s sign (posneg i) = spos sign-pos : ∀ n → sign (pos n) ≡ spos sign-pos zero = refl sign-pos (suc n) = refl abs : ℤ → ℕ abs (signed _ n) = n abs (posneg i) = zero signed-inv : ∀ n → signed (sign n) (abs n) ≡ n signed-inv (pos zero) = refl signed-inv (neg zero) = posneg signed-inv (signed s (suc n)) = refl signed-inv (posneg i) j = posneg (i ∧ j) signed-zero : ∀ s₁ s₂ → signed s₁ zero ≡ signed s₂ zero signed-zero spos spos = refl signed-zero sneg sneg = refl signed-zero spos sneg = posneg signed-zero sneg spos = sym posneg rec : ∀ {A : Type l} → (pos' neg' : ℕ → A) → pos' 0 ≡ neg' 0 → ℤ → A rec pos' neg' eq (pos m) = pos' m rec pos' neg' eq (neg m) = neg' m rec pos' neg' eq (posneg i) = eq i elim : ∀ (P : ℤ → Type l) → (pos' : ∀ n → P (pos n)) → (negsuc' : ∀ n → P (neg (suc n))) → ∀ z → P z elim P pos' negsuc' (pos n) = pos' n elim P pos' negsuc' (neg zero) = subst P posneg (pos' zero) elim P pos' negsuc' (neg (suc n)) = negsuc' n elim P pos' negsuc' (posneg i) = subst-filler P posneg (pos' zero) i Int→ℤ : Int → ℤ Int→ℤ (Int.pos n) = pos n Int→ℤ (Int.negsuc n) = neg (suc n) ℤ→Int : ℤ → Int ℤ→Int (pos n) = Int.pos n ℤ→Int (neg zero) = Int.pos 0 ℤ→Int (neg (suc n)) = Int.negsuc n ℤ→Int (posneg _) = Int.pos 0 ℤ→Int→ℤ : ∀ (n : ℤ) → Int→ℤ (ℤ→Int n) ≡ n ℤ→Int→ℤ (pos n) _ = pos n ℤ→Int→ℤ (neg zero) i = posneg i ℤ→Int→ℤ (neg (suc n)) _ = neg (suc n) ℤ→Int→ℤ (posneg j) i = posneg (j ∧ i) Int→ℤ→Int : ∀ (n : Int) → ℤ→Int (Int→ℤ n) ≡ n Int→ℤ→Int (Int.pos n) _ = Int.pos n Int→ℤ→Int (Int.negsuc n) _ = Int.negsuc n isoIntℤ : Iso Int ℤ isoIntℤ = iso Int→ℤ ℤ→Int ℤ→Int→ℤ Int→ℤ→Int Int≡ℤ : Int ≡ ℤ Int≡ℤ = isoToPath isoIntℤ discreteℤ : Discrete ℤ discreteℤ = subst Discrete Int≡ℤ discreteInt isSetℤ : isSet ℤ isSetℤ = subst isSet Int≡ℤ isSetInt -_ : ℤ → ℤ - signed s n = signed (not s) n - posneg i = posneg (~ i) negate-invol : ∀ n → - - n ≡ n negate-invol (signed s n) i = signed (notnot s i) n negate-invol (posneg i) _ = posneg i negateEquiv : ℤ ≃ ℤ negateEquiv = isoToEquiv (iso -_ -_ negate-invol negate-invol) negateEq : ℤ ≡ ℤ negateEq = ua negateEquiv infixl 6 _+_ infixl 7 _·_ sucℤ : ℤ → ℤ sucℤ (pos n) = pos (suc n) sucℤ (neg zero) = pos 1 sucℤ (neg (suc n)) = neg n sucℤ (posneg _) = pos 1 predℤ : ℤ → ℤ predℤ = subst (λ Z → (Z → Z)) negateEq sucℤ -- definitionally equal to λ n → - (sucℤ (- n)) -- strictly more useful than the direct pattern matching version, -- see negateSuc and negatePred sucPredℤ : ∀ n → sucℤ (predℤ n) ≡ n sucPredℤ (pos zero) = sym posneg sucPredℤ (pos (suc _)) = refl sucPredℤ (neg _) = refl sucPredℤ (posneg i) j = posneg (i ∨ ~ j) predSucℤ : ∀ n → predℤ (sucℤ n) ≡ n predSucℤ (pos _) = refl predSucℤ (neg zero) = posneg predSucℤ (neg (suc _)) = refl predSucℤ (posneg i) j = posneg (i ∧ j) _+_ : ℤ → ℤ → ℤ (signed _ zero) + n = n (posneg _) + n = n (pos (suc m)) + n = sucℤ (pos m + n) (neg (suc m)) + n = predℤ (neg m + n) sucPathℤ : ℤ ≡ ℤ sucPathℤ = isoToPath (iso sucℤ predℤ sucPredℤ predSucℤ) -- We do the same trick as in Cubical.Data.Int to prove that addition -- is an equivalence addEqℤ : ℕ → ℤ ≡ ℤ addEqℤ zero = refl addEqℤ (suc n) = addEqℤ n ∙ sucPathℤ predPathℤ : ℤ ≡ ℤ predPathℤ = isoToPath (iso predℤ sucℤ predSucℤ sucPredℤ) subEqℤ : ℕ → ℤ ≡ ℤ subEqℤ zero = refl subEqℤ (suc n) = subEqℤ n ∙ predPathℤ addℤ : ℤ → ℤ → ℤ addℤ (pos m) n = transport (addEqℤ m) n addℤ (neg m) n = transport (subEqℤ m) n addℤ (posneg _) n = n isEquivAddℤ : (m : ℤ) → isEquiv (addℤ m) isEquivAddℤ (pos n) = isEquivTransport (addEqℤ n) isEquivAddℤ (neg n) = isEquivTransport (subEqℤ n) isEquivAddℤ (posneg _) = isEquivTransport refl addℤ≡+ℤ : addℤ ≡ _+_ addℤ≡+ℤ i (pos (suc m)) n = sucℤ (addℤ≡+ℤ i (pos m) n) addℤ≡+ℤ i (neg (suc m)) n = predℤ (addℤ≡+ℤ i (neg m) n) addℤ≡+ℤ i (pos zero) n = n addℤ≡+ℤ i (neg zero) n = n addℤ≡+ℤ _ (posneg _) n = n isEquiv+ℤ : (m : ℤ) → isEquiv (m +_) isEquiv+ℤ = subst (λ _+_ → (m : ℤ) → isEquiv (m +_)) addℤ≡+ℤ isEquivAddℤ _·_ : ℤ → ℤ → ℤ m · n = signed (sign m ·S sign n) (abs m ℕ.· abs n) private ·-abs : ∀ m n → abs (m · n) ≡ abs m ℕ.· abs n ·-abs m n = refl -- Natural number and negative integer literals for ℤ open import Cubical.Data.Nat.Literals public instance fromNatℤ : HasFromNat ℤ fromNatℤ = record { Constraint = λ _ → Unit ; fromNat = λ n → pos n } instance fromNegℤ : HasFromNeg ℤ fromNegℤ = record { Constraint = λ _ → Unit ; fromNeg = λ n → neg n } -- ℤ is non-trivial 0≢1-ℤ : ¬ 0 ≡ 1 0≢1-ℤ p = 0≢1-Int (cong ℤ→Int p)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.List.FinData.html` module Cubical.Data.List.FinData where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Data.List open import Cubical.Data.FinData open import Cubical.Data.Empty as ⊥ open import Cubical.Data.Sigma.Properties open import Cubical.Data.Nat private variable ℓ : Level A B : Type ℓ -- copy-paste from agda-stdlib lookup : ∀ (xs : List A) → Fin (length xs) → A lookup (x ∷ xs) zero = x lookup (x ∷ xs) (suc i) = lookup xs i tabulate : ∀ n → (Fin n → A) → List A tabulate zero ^a = [] tabulate (suc n) ^a = ^a zero ∷ tabulate n (^a ∘ suc) length-tabulate : ∀ n → (^a : Fin n → A) → length (tabulate n ^a) ≡ n length-tabulate zero ^a = refl length-tabulate (suc n) ^a = cong suc (length-tabulate n (^a ∘ suc)) tabulate-lookup : ∀ (xs : List A) → tabulate (length xs) (lookup xs) ≡ xs tabulate-lookup [] = refl tabulate-lookup (x ∷ xs) = cong (x ∷_) (tabulate-lookup xs) lookup-tabulate : ∀ n → (^a : Fin n → A) → PathP (λ i → (Fin (length-tabulate n ^a i) → A)) (lookup (tabulate n ^a)) ^a lookup-tabulate (suc n) ^a i zero = ^a zero lookup-tabulate (suc n) ^a i (suc p) = lookup-tabulate n (^a ∘ suc) i p open Iso lookup-tabulate-iso : (A : Type ℓ) → Iso (List A) (Σ[ n ∈ ℕ ] (Fin n → A)) fun (lookup-tabulate-iso A) xs = (length xs) , lookup xs inv (lookup-tabulate-iso A) (n , f) = tabulate n f ret (lookup-tabulate-iso A) = tabulate-lookup sec (lookup-tabulate-iso A) (n , f) = ΣPathP ((length-tabulate n f) , lookup-tabulate n f) lookup-tabulate-equiv : (A : Type ℓ) → List A ≃ (Σ[ n ∈ ℕ ] (Fin n → A)) lookup-tabulate-equiv A = isoToEquiv (lookup-tabulate-iso A) lookup-map : ∀ (f : A → B) (xs : List A) → (p0 : Fin (length (map f xs))) → (p1 : Fin (length xs)) → (p : PathP (λ i → Fin (length-map f xs i)) p0 p1) → lookup (map f xs) p0 ≡ f (lookup xs p1) lookup-map f (x ∷ xs) zero zero p = refl lookup-map f (x ∷ xs) zero (suc p1) p = ⊥.rec (znotsP p) lookup-map f (x ∷ xs) (suc p0) zero p = ⊥.rec (snotzP p) lookup-map f (x ∷ xs) (suc p0) (suc p1) p = lookup-map f xs p0 p1 (injSucFinP p)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Maybe.Properties.html` module Cubical.Data.Maybe.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Foundations.Equiv open import Cubical.Foundations.Function using (_∘_; idfun) open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Pointed.Base using (Pointed; _→∙_; pt) open import Cubical.Foundations.Structure using (⟨_⟩) open import Cubical.Functions.Embedding using (isEmbedding) open import Cubical.Data.Empty as ⊥ using (⊥; isProp⊥) open import Cubical.Data.Unit open import Cubical.Data.Nat using (suc) open import Cubical.Data.Sum using (_⊎_; inl; inr) open import Cubical.Data.Sigma using (ΣPathP) open import Cubical.Relation.Nullary using (¬_; Discrete; yes; no) open import Cubical.Data.Maybe.Base as Maybe Maybe∙ : ∀ {ℓ} (A : Type ℓ) → Pointed ℓ Maybe∙ A .fst = Maybe A Maybe∙ A .snd = nothing -- Maybe∙ is the "free pointing" functor, that is, left adjoint to the -- forgetful functor forgetting the base point. module _ {ℓ} (A : Type ℓ) {ℓ'} (B : Pointed ℓ') where freelyPointedIso : Iso (Maybe∙ A →∙ B) (A → ⟨ B ⟩) Iso.fun freelyPointedIso f∙ = fst f∙ ∘ just Iso.inv freelyPointedIso f = Maybe.rec (pt B) f , refl Iso.sec freelyPointedIso f = refl Iso.ret freelyPointedIso f∙ = ΣPathP ( funExt (Maybe.elim _ (sym (snd f∙)) (λ a → refl)) , λ i j → snd f∙ (~ i ∨ j)) map-Maybe-id : ∀ {ℓ} {A : Type ℓ} → ∀ m → map-Maybe (idfun A) m ≡ m map-Maybe-id nothing = refl map-Maybe-id (just _) = refl -- 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 (just a) (just a') = a ≡ a' reflCode : (c : Maybe A) → Cover c c 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) encodeRefl : ∀ c → encode c c refl ≡ reflCode c encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c) decode : ∀ c c' → Cover c c' → c ≡ c' decode nothing nothing _ = refl decode (just _) (just _) p = cong just p decodeRefl : ∀ c → decode c c (reflCode c) ≡ refl decodeRefl nothing = refl decodeRefl (just _) = refl 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) (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)) Cover≃Path : ∀ c c' → Cover c c' ≃ (c ≡ c') Cover≃Path c c' = isoToEquiv (iso (decode c c') (encode c c') (decodeEncode c c') (encodeDecode c c')) Cover≡Path : ∀ c c' → Cover c c' ≡ (c ≡ c') Cover≡Path c c' = isoToPath (iso (decode c c') (encode c c') (decodeEncode c c') (encodeDecode c c')) 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 (just a) (just a') = p a a' isOfHLevelMaybe : ∀ {ℓ} (n : HLevel) {A : Type ℓ} → isOfHLevel (suc (suc n)) A → isOfHLevel (suc (suc n)) (Maybe A) isOfHLevelMaybe n lA c c' = isOfHLevelRetract (suc n) (MaybePath.encode c c') (MaybePath.decode c c') (MaybePath.decodeEncode c c') (MaybePath.isOfHLevelCover n lA c c') private variable ℓ : Level A : Type ℓ fromJust-def : A → Maybe A → A fromJust-def a nothing = a fromJust-def _ (just a) = a just-inj : (x y : A) → just x ≡ just y → x ≡ y just-inj x _ eq = cong (fromJust-def x) eq isEmbedding-just : isEmbedding (just {A = A}) 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)) ¬just≡nothing : ∀ {x : A} → ¬ (just x ≡ nothing) ¬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 nothing 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 nothing 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 _) discreteMaybe : Discrete A → Discrete (Maybe A) discreteMaybe eqA nothing nothing = yes refl discreteMaybe eqA nothing (just a') = no ¬nothing≡just discreteMaybe eqA (just a) nothing = no ¬just≡nothing discreteMaybe eqA (just a) (just a') with eqA a a' ... | yes p = yes (cong just p) ... | no ¬p = no (λ p → ¬p (just-inj _ _ p)) module SumUnit where Maybe→SumUnit : Maybe A → Unit ⊎ A Maybe→SumUnit nothing = inl tt Maybe→SumUnit (just a) = inr a SumUnit→Maybe : Unit ⊎ A → Maybe A SumUnit→Maybe (inl _) = nothing SumUnit→Maybe (inr a) = just a Maybe→SumUnit→Maybe : (x : Maybe A) → SumUnit→Maybe (Maybe→SumUnit x) ≡ x Maybe→SumUnit→Maybe nothing = refl Maybe→SumUnit→Maybe (just _) = refl SumUnit→Maybe→SumUnit : (x : Unit ⊎ A) → Maybe→SumUnit (SumUnit→Maybe x) ≡ x SumUnit→Maybe→SumUnit (inl _) = refl SumUnit→Maybe→SumUnit (inr _) = refl Maybe≡SumUnit : Maybe A ≡ Unit ⊎ A Maybe≡SumUnit = isoToPath (iso Maybe→SumUnit SumUnit→Maybe SumUnit→Maybe→SumUnit Maybe→SumUnit→Maybe) where open SumUnit congMaybeEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → A ≃ B → Maybe A ≃ Maybe B congMaybeEquiv e = isoToEquiv isom where open Iso isom : Iso _ _ isom .fun = map-Maybe (equivFun e) isom .inv = map-Maybe (invEq e) isom .sec nothing = refl isom .sec (just b) = cong just (secEq e b) isom .ret nothing = refl isom .ret (just a) = cong just (retEq e a)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.NatPlusOne.MoreNats.AssocNat.Properties.html` module Cubical.Data.NatPlusOne.MoreNats.AssocNat.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Data.Nat open import Cubical.Data.NatPlusOne.MoreNats.AssocNat.Base open import Cubical.Data.NatPlusOne renaming (ℕ₊₁ to Nat; one to one'; _+₁_ to _+₁'_) Nat→ℕ₊₁ : Nat → ℕ₊₁ Nat→ℕ₊₁ one' = 1 Nat→ℕ₊₁ (2+ n) = 1 +₁ Nat→ℕ₊₁ (1+ n) ℕ₊₁→Nat : ℕ₊₁ → Nat ℕ₊₁→Nat one = 1 ℕ₊₁→Nat (a +₁ b) = ℕ₊₁→Nat a +₁' ℕ₊₁→Nat b ℕ₊₁→Nat (assoc a b c i) = +₁-assoc (ℕ₊₁→Nat a) (ℕ₊₁→Nat b) (ℕ₊₁→Nat c) i ℕ₊₁→Nat (trunc m n p q i j) = 1+ (isSetℕ _ _ (λ k → -1+ (ℕ₊₁→Nat (p k))) (λ k → -1+ (ℕ₊₁→Nat (q k))) i j) ℕ₊₁→Nat→ℕ₊₁ : ∀ n → ℕ₊₁→Nat (Nat→ℕ₊₁ n) ≡ n ℕ₊₁→Nat→ℕ₊₁ one' = refl ℕ₊₁→Nat→ℕ₊₁ (2+ n) = cong (1+_ ∘ suc ∘ -1+_) (ℕ₊₁→Nat→ℕ₊₁ (1+ n)) private Nat→ℕ₊₁-+ : ∀ a b → Nat→ℕ₊₁ (a +₁' b) ≡ Nat→ℕ₊₁ a +₁ Nat→ℕ₊₁ b Nat→ℕ₊₁-+ one' b = refl Nat→ℕ₊₁-+ (2+ a) b = cong (one +₁_) (Nat→ℕ₊₁-+ (1+ a) b) ∙ assoc one (Nat→ℕ₊₁ (1+ a)) (Nat→ℕ₊₁ b) Nat→ℕ₊₁→Nat : ∀ n → Nat→ℕ₊₁ (ℕ₊₁→Nat n) ≡ n Nat→ℕ₊₁→Nat = ElimProp.f (trunc _ _) (λ i → one) λ {a} {b} m n → Nat→ℕ₊₁-+ (ℕ₊₁→Nat a) (ℕ₊₁→Nat b) ∙ (λ i → m i +₁ n i) ℕ₊₁≡Nat : ℕ₊₁ ≡ Nat ℕ₊₁≡Nat = isoToPath (iso ℕ₊₁→Nat Nat→ℕ₊₁ ℕ₊₁→Nat→ℕ₊₁ Nat→ℕ₊₁→Nat)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Queue.Truncated2List.html` {-# OPTIONS --no-exact-split #-} module Cubical.Data.Queue.Truncated2List where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.HLevels open import Cubical.Foundations.SIP open import Cubical.Structures.Queue open import Cubical.Data.Maybe open import Cubical.Data.List open import Cubical.Data.Sigma open import Cubical.Data.Queue.1List module Truncated2List {ℓ} (A : Type ℓ) (Aset : isSet A) where open Queues-on A Aset data Q : Type ℓ where Q⟨_,_⟩ : (xs ys : List A) → Q tilt : ∀ xs ys z → Q⟨ xs ++ [ z ] , ys ⟩ ≡ Q⟨ xs , ys ++ [ z ] ⟩ trunc : (q q' : Q) (α β : q ≡ q') → α ≡ β multitilt : (xs ys zs : List A) → Q⟨ xs ++ rev zs , ys ⟩ ≡ Q⟨ xs , ys ++ zs ⟩ multitilt xs ys [] = cong₂ Q⟨_,_⟩ (++-unit-r xs) (sym (++-unit-r ys)) multitilt xs ys (z ∷ zs) = cong (λ ws → Q⟨ ws , ys ⟩) (sym (++-assoc xs (rev zs) [ z ])) ∙ tilt (xs ++ rev zs) ys z ∙ multitilt xs (ys ++ [ z ]) zs ∙ cong (λ ws → Q⟨ xs , ws ⟩) (++-assoc ys [ z ] zs) -- enq into the first list, deq from the second if possible emp : Q emp = Q⟨ [] , [] ⟩ enq : A → Q → Q enq a Q⟨ xs , ys ⟩ = Q⟨ a ∷ xs , ys ⟩ enq a (tilt xs ys z i) = tilt (a ∷ xs) ys z i enq a (trunc q q' α β i j) = trunc _ _ (cong (enq a) α) (cong (enq a) β) i j deqFlush : List A → Maybe (Q × A) deqFlush [] = nothing deqFlush (x ∷ xs) = just (Q⟨ [] , xs ⟩ , x) deq : Q → Maybe (Q × A) deq Q⟨ xs , [] ⟩ = deqFlush (rev xs) deq Q⟨ xs , y ∷ ys ⟩ = just (Q⟨ xs , ys ⟩ , y) deq (tilt xs [] z i) = path i where path : deqFlush (rev (xs ++ [ z ])) ≡ just (Q⟨ xs , [] ⟩ , z) path = cong deqFlush (rev-++ xs [ z ]) ∙ cong (λ q → just (q , z)) (sym (multitilt [] [] (rev xs))) ∙ cong (λ ys → just (Q⟨ ys , [] ⟩ , z)) (rev-rev xs) deq (tilt xs (y ∷ ys) z i) = just (tilt xs ys z i , y) deq (trunc q q' α β i j) = isOfHLevelMaybe 0 (isSetΣ trunc λ _ → Aset) (deq q) (deq q') (cong deq α) (cong deq β) i j Raw : RawQueue Raw = (Q , emp , enq , deq) -- We construct an equivalence to 1Lists and prove this is an equivalence of queue structures private module One = 1List A Aset open One renaming (Q to Q₁; emp to emp₁; enq to enq₁; deq to deq₁) using () quot : Q₁ → Q quot xs = Q⟨ xs , [] ⟩ eval : Q → Q₁ eval Q⟨ xs , ys ⟩ = xs ++ rev ys eval (tilt xs ys z i) = path i where path : (xs ++ [ z ]) ++ rev ys ≡ xs ++ rev (ys ++ [ z ]) path = ++-assoc xs [ z ] (rev ys) ∙ cong (_++_ xs) (sym (rev-++ ys [ z ])) eval (trunc q q' α β i j) = -- truncated case isOfHLevelList 0 Aset (eval q) (eval q') (cong eval α) (cong eval β) i j quot∘eval : ∀ q → quot (eval q) ≡ q quot∘eval Q⟨ xs , ys ⟩ = multitilt xs [] ys quot∘eval (tilt xs ys z i) = -- truncated case isOfHLevelPathP' {A = λ i → quot (eval (tilt xs ys z i)) ≡ tilt xs ys z i} 0 (trunc _ _) (multitilt (xs ++ [ z ]) [] ys) (multitilt xs [] (ys ++ [ z ])) .fst i quot∘eval (trunc q q' α β i j) = -- truncated case isOfHLevelPathP' {A = λ i → PathP (λ j → quot (eval (trunc q q' α β i j)) ≡ trunc q q' α β i j) (quot∘eval q) (quot∘eval q')} 0 (isOfHLevelPathP' 1 (isOfHLevelSuc 2 trunc _ _) _ _) (cong quot∘eval α) (cong quot∘eval β) .fst i j eval∘quot : ∀ xs → eval (quot xs) ≡ xs eval∘quot = ++-unit-r -- We get our desired equivalence quotEquiv : Q₁ ≃ Q quotEquiv = isoToEquiv (iso quot eval quot∘eval eval∘quot) -- Now it only remains to prove that this is an equivalence of queue structures quot∘emp : quot emp₁ ≡ emp quot∘emp = refl quot∘enq : ∀ x xs → quot (enq₁ x xs) ≡ enq x (quot xs) quot∘enq x xs = refl quot∘deq : ∀ xs → deqMap quot (deq₁ xs) ≡ deq (quot xs) quot∘deq [] = refl quot∘deq (x ∷ []) = refl quot∘deq (x ∷ x' ∷ xs) = deqMap-∘ quot (enq₁ x) (deq₁ (x' ∷ xs)) ∙ sym (deqMap-∘ (enq x) quot (deq₁ (x' ∷ xs))) ∙ cong (deqMap (enq x)) (quot∘deq (x' ∷ xs)) ∙ lemma x x' (rev xs) where lemma : ∀ x x' ys → deqMap (enq x) (deqFlush (ys ++ [ x' ])) ≡ deqFlush ((ys ++ [ x' ]) ++ [ x ]) lemma x x' [] i = just (tilt [] [] x i , x') lemma x x' (y ∷ ys) i = just (tilt [] (ys ++ [ x' ]) x i , y) quotEquivHasQueueEquivStr : RawQueueEquivStr One.Raw Raw quotEquiv quotEquivHasQueueEquivStr = quot∘emp , quot∘enq , quot∘deq -- And we get a path between the raw 1Lists and 2Lists Raw-1≡2 : One.Raw ≡ Raw Raw-1≡2 = sip rawQueueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr) -- We derive the axioms for 2List from those for 1List WithLaws : Queue WithLaws = Q , str Raw , subst (uncurry QueueAxioms) Raw-1≡2 (snd (str One.WithLaws)) WithLaws-1≡2 : One.WithLaws ≡ WithLaws WithLaws-1≡2 = sip queueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr) Finite : FiniteQueue Finite = Q , str WithLaws , subst (uncurry FiniteQueueAxioms) WithLaws-1≡2 (snd (str One.Finite))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Sigma.Properties.html` {- Basic properties about Σ-types - Action of Σ on functions ([map-fst], [map-snd]) - Characterization of equality in Σ-types using dependent paths ([ΣPath{Iso,≃,≡}PathΣ], [Σ≡Prop]) - Proof that discrete types are closed under Σ ([discreteΣ]) - Commutativity and associativity ([Σ-swap-*, Σ-assoc-*]) - Distributivity of Π over Σ ([Σ-Π-*]) - Action of Σ on isomorphisms, equivalences, and paths ([Σ-cong-fst], [Σ-cong-snd], ...) - Characterization of equality in Σ-types using transport ([ΣPathTransport{≃,≡}PathΣ]) - Σ with a contractible base is its fiber ([Σ-contractFst, ΣUnit]) -} module Cubical.Data.Sigma.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.Equiv.HalfAdjoint open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Path open import Cubical.Foundations.Transport open import Cubical.Foundations.Univalence open import Cubical.Data.Sigma.Base open import Cubical.Data.Unit.Base open import Cubical.Data.Empty.Base open import Cubical.Relation.Nullary open import Cubical.Reflection.StrictEquiv open Iso private variable ℓ ℓ' ℓ'' : Level A A' : Type ℓ B B' : (a : A) → Type ℓ C : (a : A) (b : B a) → Type ℓ map-fst : {B : Type ℓ} → (f : A → A') → A × B → A' × B map-fst f (a , b) = (f a , b) map-snd : (∀ {a} → B a → B' a) → Σ A B → Σ A B' map-snd f (a , b) = (a , f b) map-× : {B : Type ℓ} {B' : Type ℓ'} → (A → A') → (B → B') → A × B → A' × B' map-× f g (a , b) = (f a , g b) ≡-× : {A : Type ℓ} {B : Type ℓ'} {x y : A × B} → fst x ≡ fst y → snd x ≡ snd y → x ≡ y ≡-× p q i = (p i) , (q i) -- Characterization of paths in Σ using dependent paths module _ {A : I → Type ℓ} {B : (i : I) → A i → Type ℓ'} {x : Σ (A i0) (B i0)} {y : Σ (A i1) (B i1)} where ΣPathP : Σ[ p ∈ PathP A (fst x) (fst y) ] PathP (λ i → B i (p i)) (snd x) (snd y) → PathP (λ i → Σ (A i) (B i)) x y ΣPathP eq i = fst eq i , snd eq i PathPΣ : PathP (λ i → Σ (A i) (B i)) x y → Σ[ p ∈ PathP A (fst x) (fst y) ] PathP (λ i → B i (p i)) (snd x) (snd y) PathPΣ eq = (λ i → fst (eq i)) , (λ i → snd (eq i)) -- allows one to write -- open PathPΣ somePathInΣAB renaming (fst ... ) module PathPΣ (p : PathP (λ i → Σ (A i) (B i)) x y) where open Σ (PathPΣ p) public ΣPathIsoPathΣ : Iso (Σ[ p ∈ PathP A (fst x) (fst y) ] (PathP (λ i → B i (p i)) (snd x) (snd y))) (PathP (λ i → Σ (A i) (B i)) x y) fun ΣPathIsoPathΣ = ΣPathP inv ΣPathIsoPathΣ = PathPΣ sec ΣPathIsoPathΣ _ = refl ret ΣPathIsoPathΣ _ = refl unquoteDecl ΣPath≃PathΣ = declStrictIsoToEquiv ΣPath≃PathΣ ΣPathIsoPathΣ ΣPath≡PathΣ : (Σ[ p ∈ PathP A (fst x) (fst y) ] (PathP (λ i → B i (p i)) (snd x) (snd y))) ≡ (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 pB {u} {v} p i = (p i) , (pB (u .snd) (v .snd) i) ×≡Prop' : isProp A → {u v : A × A'} → u .snd ≡ v .snd → u ≡ v ×≡Prop' pA {u} {v} p i = (pA (u .fst) (v .fst) i) , p 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 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') -- Characterization of dependent paths in Σ module _ {A : I → Type ℓ} {B : (i : I) → (a : A i) → Type ℓ'} {x : Σ (A i0) (B i0)} {y : Σ (A i1) (B i1)} where ΣPathPIsoPathPΣ : Iso (Σ[ p ∈ PathP A (x .fst) (y .fst) ] PathP (λ i → B i (p i)) (x .snd) (y .snd)) (PathP (λ i → Σ (A i) (B i)) x y) ΣPathPIsoPathPΣ .fun (p , q) i = p i , q i ΣPathPIsoPathPΣ .inv pq .fst i = pq i .fst ΣPathPIsoPathPΣ .inv pq .snd i = pq i .snd ΣPathPIsoPathPΣ .sec _ = refl ΣPathPIsoPathPΣ .ret _ = refl unquoteDecl ΣPathP≃PathPΣ = declStrictIsoToEquiv ΣPathP≃PathPΣ ΣPathPIsoPathPΣ ΣPathP≡PathPΣ = ua ΣPathP≃PathPΣ -- Σ of discrete types discreteΣ : Discrete A → ((a : A) → Discrete (B a)) → Discrete (Σ A B) 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 where discreteΣ'' : (b1 : B a0) → Dec ((a0 , b0) ≡ (a0 , b1)) discreteΣ'' b1 with Bdis a0 b0 b1 ... | (yes q) = yes (transport ΣPath≡PathΣ (refl , q)) ... | (no ¬q) = no (λ r → ¬q (subst (λ X → PathP (λ i → B (X i)) b0 b1) (Discrete→isSet Adis a0 a0 (cong fst r) refl) (cong snd r))) discreteΣ' (no ¬p) = no (λ r → ¬p (cong fst r)) lUnit×Iso : Iso (Unit × A) A fun lUnit×Iso = snd inv lUnit×Iso = tt ,_ sec lUnit×Iso _ = refl ret lUnit×Iso _ = refl lUnit*×Iso : ∀{ℓ} → Iso (Unit* {ℓ} × A) A fun lUnit*×Iso = snd inv lUnit*×Iso = tt* ,_ sec lUnit*×Iso _ = refl ret lUnit*×Iso _ = refl rUnit×Iso : Iso (A × Unit) A fun rUnit×Iso = fst inv rUnit×Iso = _, tt sec rUnit×Iso _ = refl ret rUnit×Iso _ = refl rUnit*×Iso : ∀{ℓ} → Iso (A × Unit* {ℓ}) A fun rUnit*×Iso = fst inv rUnit*×Iso = _, tt* sec rUnit*×Iso _ = refl ret rUnit*×Iso _ = refl module _ {A : Type ℓ} {A' : Type ℓ'} where Σ-swap-Iso : Iso (A × A') (A' × A) fun Σ-swap-Iso (x , y) = (y , x) inv Σ-swap-Iso (x , y) = (y , x) sec Σ-swap-Iso _ = refl ret Σ-swap-Iso _ = refl unquoteDecl Σ-swap-≃ = declStrictIsoToEquiv Σ-swap-≃ Σ-swap-Iso module _ {A : Type ℓ} {B : A → Type ℓ'} {C : ∀ a → B a → Type ℓ''} where Σ-assoc-Iso : Iso (Σ[ a ∈ Σ A B ] C (fst a) (snd a)) (Σ[ a ∈ A ] Σ[ b ∈ B a ] C a b) fun Σ-assoc-Iso ((x , y) , z) = (x , (y , z)) inv Σ-assoc-Iso (x , (y , z)) = ((x , y) , z) sec Σ-assoc-Iso _ = refl ret Σ-assoc-Iso _ = refl unquoteDecl Σ-assoc-≃ = declStrictIsoToEquiv Σ-assoc-≃ Σ-assoc-Iso Σ-Π-Iso : Iso ((a : A) → Σ[ b ∈ B a ] C a b) (Σ[ f ∈ ((a : A) → B a) ] ∀ a → C a (f a)) fun Σ-Π-Iso f = (fst ∘ f , snd ∘ f) inv Σ-Π-Iso (f , g) x = (f x , g x) sec Σ-Π-Iso _ = refl ret Σ-Π-Iso _ = refl unquoteDecl Σ-Π-≃ = declStrictIsoToEquiv Σ-Π-≃ Σ-Π-Iso module _ {A : Type ℓ} {B : A → Type ℓ'} {B' : ∀ a → Type ℓ''} where Σ-assoc-swap-Iso : Iso (Σ[ a ∈ Σ A B ] B' (fst a)) (Σ[ a ∈ Σ A B' ] B (fst a)) fun Σ-assoc-swap-Iso ((x , y) , z) = ((x , z) , y) inv Σ-assoc-swap-Iso ((x , z) , y) = ((x , y) , z) sec Σ-assoc-swap-Iso _ = refl ret Σ-assoc-swap-Iso _ = refl unquoteDecl Σ-assoc-swap-≃ = declStrictIsoToEquiv Σ-assoc-swap-≃ Σ-assoc-swap-Iso Σ-cong-iso-fst : (isom : Iso A A') → Iso (Σ A (B ∘ fun isom)) (Σ A' B) fun (Σ-cong-iso-fst isom) x = fun isom (x .fst) , x .snd 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)) sec (Σ-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 ret (Σ-cong-iso-fst {A = A} {B = B} isom) (x , y) = ΣPathP (ret isom x , toPathP goal) where ε = isHAEquiv.rinv (snd (iso→HAEquiv isom)) γ = isHAEquiv.com (snd (iso→HAEquiv isom)) lem : (x : A) → sym (ε (fun isom x)) ∙ cong (fun isom) (ret isom x) ≡ refl lem x = cong (λ a → sym (ε (fun isom x)) ∙ a) (γ x) ∙ lCancel (ε (fun isom x)) goal : subst B (cong (fun isom) (ret isom x)) (subst B (sym (ε (fun isom x))) y) ≡ y goal = sym (substComposite B (sym (ε (fun isom x))) (cong (fun isom) (ret isom x)) y) ∙∙ cong (λ a → subst B a y) (lem x) ∙∙ substRefl {B = B} y Σ-cong-equiv-fst : (e : A ≃ A') → Σ A (B ∘ equivFun e) ≃ Σ A' B -- we could just do this: -- Σ-cong-equiv-fst e = isoToEquiv (Σ-cong-iso-fst (equivToIso e)) -- but the following reduces slightly better Σ-cong-equiv-fst {A = A} {A' = A'} {B = B} e = intro , isEqIntro where intro : Σ A (B ∘ equivFun e) → Σ A' B intro (a , b) = equivFun e a , b isEqIntro : isEquiv intro isEqIntro .equiv-proof x = ctr , isCtr where PB : ∀ {x y} → x ≡ y → B x → B y → Type _ PB p = PathP (λ i → B (p i)) open Σ x renaming (fst to a'; snd to b) open Σ (equivCtr e a') renaming (fst to ctrA; snd to α) ctrB : B (equivFun e ctrA) ctrB = subst B (sym α) b ctrP : PB α ctrB b ctrP = symP (transport-filler (λ i → B (sym α i)) b) ctr : fiber intro x ctr = (ctrA , ctrB) , ΣPathP (α , ctrP) isCtr : ∀ y → ctr ≡ y isCtr ((r , s) , p) = λ i → (a≡r i , b!≡s i) , ΣPathP (α≡ρ i , coh i) where open PathPΣ p renaming (fst to ρ; snd to σ) open PathPΣ (equivCtrPath e a' (r , ρ)) renaming (fst to a≡r; snd to α≡ρ) b!≡s : PB (cong (equivFun e) a≡r) ctrB s b!≡s i = comp (λ k → B (α≡ρ i (~ k))) (λ k → (λ { (i = i0) → ctrP (~ k) ; (i = i1) → σ (~ k) })) b coh : PathP (λ i → PB (α≡ρ i) (b!≡s i) b) ctrP σ coh i j = fill (λ k → B (α≡ρ i (~ k))) (λ k → (λ { (i = i0) → ctrP (~ k) ; (i = i1) → σ (~ k) })) (inS b) (~ j) Σ-cong-fst : (p : A ≡ A') → Σ A (B ∘ transport p) ≡ Σ A' B Σ-cong-fst {B = B} p i = Σ (p i) (B ∘ transp (λ j → p (i ∨ j)) i) Σ-cong-iso-snd : ((x : A) → Iso (B x) (B' x)) → Iso (Σ A B) (Σ A B') fun (Σ-cong-iso-snd isom) (x , y) = x , fun (isom x) y inv (Σ-cong-iso-snd isom) (x , y') = x , inv (isom x) y' sec (Σ-cong-iso-snd isom) (x , y) = ΣPathP (refl , sec (isom x) y) ret (Σ-cong-iso-snd isom) (x , y') = ΣPathP (refl , ret (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-snd : ((x : A) → B x ≡ B' x) → Σ A B ≡ Σ A B' Σ-cong-snd {A = A} p i = Σ[ x ∈ A ] (p x i) Σ-cong-iso : (isom : Iso A A') → ((x : A) → Iso (B x) (B' (fun isom x))) → Iso (Σ A B) (Σ A' B') Σ-cong-iso isom isom' = compIso (Σ-cong-iso-snd isom') (Σ-cong-iso-fst isom) Σ-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' : (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) → 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)) -- Alternative version for path in Σ-types, as in the HoTT book ΣPathTransport : (a b : Σ A B) → Type _ ΣPathTransport {B = B} a b = Σ[ p ∈ (fst a ≡ fst b) ] transport (λ i → B (p i)) (snd a) ≡ snd b IsoΣPathTransportPathΣ : (a b : Σ A B) → Iso (ΣPathTransport a b) (a ≡ b) IsoΣPathTransportPathΣ {B = B} a b = compIso (Σ-cong-iso-snd (λ p → invIso (PathPIsoPath (λ i → B (p i)) _ _))) ΣPathIsoPathΣ ΣPathTransport≃PathΣ : (a b : Σ A B) → ΣPathTransport a b ≃ (a ≡ b) ΣPathTransport≃PathΣ {B = B} a b = isoToEquiv (IsoΣPathTransportPathΣ a b) ΣPathTransport→PathΣ : (a b : Σ A B) → ΣPathTransport a b → (a ≡ b) ΣPathTransport→PathΣ a b = Iso.fun (IsoΣPathTransportPathΣ a b) PathΣ→ΣPathTransport : (a b : Σ A B) → (a ≡ b) → ΣPathTransport a b PathΣ→ΣPathTransport a b = Iso.inv (IsoΣPathTransportPathΣ a b) Σ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)) fun (Σ-contractFstIso {B = B} c) p = subst B (sym (c .snd (fst p))) (snd p) inv (Σ-contractFstIso {B = B} c) b = _ , b sec (Σ-contractFstIso {B = B} c) b = cong (λ p → subst B p b) (isProp→isSet (isContr→isProp c) _ _ _ _) ∙ transportRefl _ fst (ret (Σ-contractFstIso {B = B} c) p j) = c .snd (fst p) j snd (ret (Σ-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 {B = B} c = isoToEquiv (Σ-contractFstIso c) -- a special case of the above module _ (A : Unit → Type ℓ) where ΣUnit : Σ Unit A ≃ A tt unquoteDef ΣUnit = defStrictEquiv {B = A tt} ΣUnit snd (tt ,_) Σ-contractSnd : ((a : A) → isContr (B a)) → Σ A B ≃ A Σ-contractSnd c = isoToEquiv isom where isom : Iso _ _ isom .fun = fst isom .inv a = a , c a .fst isom .sec _ = refl isom .ret (a , b) = cong (a ,_) (c a .snd b) 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 _) _ _) 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) _ _ 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} → (u .fst ≡ v .fst) ≃ (u ≡ v) Σ≡PropEquiv pB = invEquiv (_ , isEmbeddingFstΣProp pB) Σ≡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)) → 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 _ _ _) discreteΣProp : Discrete A → ((x : A) → isProp (B x)) → Discrete (Σ A B) discreteΣProp _≟_ isPropA _ _ = EquivPresDec (Σ≡PropEquiv isPropA) (_ ≟ _) ≃-× : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} → A ≃ C → B ≃ D → A × B ≃ C × D ≃-× eq1 eq2 = map-× (fst eq1) (fst eq2) , record { equiv-proof = λ {(c , d) → ((eq1⁻ c .fst .fst , eq2⁻ d .fst .fst) , ≡-× (eq1⁻ c .fst .snd) (eq2⁻ d .fst .snd)) , λ {((a , b) , p) → ΣPathP (≡-× (cong fst (eq1⁻ c .snd (a , cong fst p))) (cong fst (eq2⁻ d .snd (b , cong snd p))) , λ i → ≡-× (snd ((eq1⁻ c .snd (a , cong fst p)) i)) (snd ((eq2⁻ d .snd (b , cong snd p)) i)))}}} where eq1⁻ = equiv-proof (eq1 .snd) eq2⁻ = equiv-proof (eq2 .snd) {- Some simple ismorphisms -} prodIso : ∀ {ℓ ℓ' ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} → Iso A C → Iso B D → Iso (A × B) (C × D) Iso.fun (prodIso iAC iBD) (a , b) = (Iso.fun iAC a) , Iso.fun iBD b Iso.inv (prodIso iAC iBD) (c , d) = (Iso.inv iAC c) , Iso.inv iBD d Iso.sec (prodIso iAC iBD) (c , d) = ΣPathP ((Iso.sec iAC c) , (Iso.sec iBD d)) Iso.ret (prodIso iAC iBD) (a , b) = ΣPathP ((Iso.ret iAC a) , (Iso.ret iBD b)) 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.sec (prodEquivToIso e e' i) = Iso.sec (equivToIso (≃-× e e')) Iso.ret (prodEquivToIso e e' i) = Iso.ret (equivToIso (≃-× e e')) toProdIso : {B C : A → Type ℓ} → Iso ((a : A) → B a × C a) (((a : A) → B a) × ((a : A) → C a)) Iso.fun toProdIso = λ f → (λ a → fst (f a)) , (λ a → snd (f a)) Iso.inv toProdIso (f , g) = λ a → (f a) , (g a) Iso.sec toProdIso (f , g) = refl Iso.ret toProdIso b = refl module _ {A : Type ℓ} {B : A → Type ℓ'} {C : ∀ a → B a → Type ℓ''} where curryIso : Iso (((a , b) : Σ A B) → C a b) ((a : A) → (b : B a) → C a b) Iso.fun curryIso f a b = f (a , b) Iso.inv curryIso f a = f (fst a) (snd a) Iso.sec curryIso a = refl Iso.ret curryIso f = refl unquoteDecl curryEquiv = declStrictIsoToEquiv curryEquiv curryIso -- Sigma type with empty base module _ (A : ⊥ → Type ℓ) where open Iso ΣEmptyIso : Iso (Σ ⊥ A) ⊥ fun ΣEmptyIso (* , _) = * ΣEmpty : Σ ⊥ A ≃ ⊥ ΣEmpty = isoToEquiv ΣEmptyIso module _ {ℓ : Level} (A : ⊥* {ℓ} → Type ℓ) where open Iso ΣEmpty*Iso : Iso (Σ ⊥* A) ⊥* fun ΣEmpty*Iso (* , _) = * -- fiber of projection map module _ (A : Type ℓ) (B : A → Type ℓ') where private proj : Σ A B → A proj (a , b) = a module _ (a : A) where open Iso fiberProjIso : Iso (B a) (fiber proj a) fiberProjIso .fun b = (a , b) , refl fiberProjIso .inv ((a' , b') , p) = subst B p b' fiberProjIso .ret b i = substRefl {B = B} b i fiberProjIso .sec (_ , p) i .fst .fst = p (~ i) fiberProjIso .sec ((_ , b') , p) i .fst .snd = subst-filler B p b' (~ i) fiberProjIso .sec (_ , p) i .snd j = p (~ i ∨ j) fiberProjEquiv : B a ≃ fiber proj a fiberProjEquiv = isoToEquiv fiberProjIso separatedΣ : Separated A → ((a : A) → Separated (B a)) → Separated (Σ A B) separatedΣ {B = B} sepA sepB (a , b) (a' , b') p = ΣPathTransport→PathΣ _ _ (pA , pB) where pA : a ≡ a' pA = sepA a a' (λ q → p (λ r → q (cong fst r))) pB : subst B pA b ≡ b' pB = sepB _ _ _ (λ q → p (λ r → q (cong (λ r' → subst B r' b) (Separated→isSet sepA _ _ pA (cong fst r)) ∙ snd (PathΣ→ΣPathTransport _ _ r))))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Unit.Properties.html` module Cubical.Data.Unit.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.Univalence open import Cubical.Data.Nat open import Cubical.Data.Unit.Base open import Cubical.Data.Prod.Base open import Cubical.Data.Sigma hiding (_×_) open import Cubical.Reflection.StrictEquiv open Iso private variable ℓ ℓ' : Level terminal : (A : Type ℓ) → A → Unit terminal A x = tt isContrUnit : isContr Unit isContrUnit = tt , λ {tt → refl} isPropUnit : isProp Unit isPropUnit _ _ i = tt -- definitionally equal to: isContr→isProp isContrUnit isSetUnit : isSet Unit isSetUnit = isProp→isSet isPropUnit isOfHLevelUnit : (n : HLevel) → isOfHLevel n Unit isOfHLevelUnit n = isContr→isOfHLevel n isContrUnit module _ (A : Type ℓ) where UnitToType≃ : (Unit → A) ≃ A unquoteDef UnitToType≃ = defStrictEquiv UnitToType≃ (λ f → f _) const UnitToTypePath : ∀ {ℓ} (A : Type ℓ) → (Unit → A) ≡ A UnitToTypePath A = ua (UnitToType≃ A) module _ (A : Unit → Type ℓ) where open Iso ΠUnitIso : Iso ((x : Unit) → A x) (A tt) fun ΠUnitIso f = f tt inv ΠUnitIso a tt = a sec ΠUnitIso a = refl ret ΠUnitIso f = refl ΠUnit : ((x : Unit) → A x) ≃ A tt ΠUnit = isoToEquiv ΠUnitIso module _ (A : Unit* {ℓ} → Type ℓ') where open Iso ΠUnit*Iso : Iso ((x : Unit*) → A x) (A tt*) fun ΠUnit*Iso f = f tt* inv ΠUnit*Iso a tt* = a sec ΠUnit*Iso a = refl ret ΠUnit*Iso f = refl ΠUnit* : ((x : Unit*) → A x) ≃ A tt* ΠUnit* = isoToEquiv ΠUnit*Iso fiberUnitIso : {A : Type ℓ} → Iso (fiber (λ (a : A) → tt) tt) A fun fiberUnitIso = fst inv fiberUnitIso a = a , refl sec fiberUnitIso _ = refl ret fiberUnitIso _ = refl 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 sec (isContr→Iso2 iscontr) _ = refl ret (isContr→Iso2 iscontr) f = funExt λ x → cong f (snd iscontr x) diagonal-unit : Unit ≡ Unit × Unit diagonal-unit = isoToPath (iso (λ x → tt , tt) (λ x → tt) (λ {(tt , tt) i → tt , tt}) λ {tt i → tt}) fibId : (A : Type ℓ) → (fiber (λ (x : A) → tt) tt) ≡ A fibId A = ua e where unquoteDecl e = declStrictEquiv e fst (λ a → a , refl) 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 contr = ua (isContr→≃Unit contr) isContrUnit* : ∀ {ℓ} → isContr (Unit* {ℓ}) isContrUnit* = tt* , λ _ → refl isPropUnit* : ∀ {ℓ} → isProp (Unit* {ℓ}) isPropUnit* _ _ = refl isSetUnit* : ∀ {ℓ} → isSet (Unit* {ℓ}) isSetUnit* _ _ _ _ = refl isOfHLevelUnit* : ∀ {ℓ} (n : HLevel) → isOfHLevel n (Unit* {ℓ}) isOfHLevelUnit* zero = tt* , λ _ → refl isOfHLevelUnit* (suc zero) _ _ = refl isOfHLevelUnit* (suc (suc zero)) _ _ _ _ _ _ = tt* isOfHLevelUnit* (suc (suc (suc n))) = isOfHLevelPlus 3 (isOfHLevelUnit* n) Unit≃Unit* : ∀ {ℓ} → Unit ≃ Unit* {ℓ} 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 = ua (isContr→≃Unit* contr) -- J for pointed propositions JPointedProp : ∀ {ℓ ℓ'} {B : (A : Type ℓ') (a : A) (isPr : isProp A) → Type ℓ} → B Unit* tt* isPropUnit* → (A : Type ℓ') (a : A) (isPr : isProp A) → B A a isPr JPointedProp {ℓ' = ℓ'} {B = B} ind A a isPr = transport (λ i → B (P (~ i) .fst) (coh i) (P (~ i) .snd)) ind where A* : TypeOfHLevel ℓ' 1 A* = A , isPr P : A* ≡ (Unit* , isPropUnit*) P = Σ≡Prop (λ _ → isPropIsProp) (ua (propBiimpl→Equiv isPr isPropUnit* (λ _ → tt*) λ _ → a)) coh : PathP (λ i → (P (~ i) .fst)) tt* a coh = toPathP refl

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Data.Vec.Properties.html` module Cubical.Data.Vec.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.HLevels open import Cubical.Foundations.Univalence import Cubical.Data.Empty as ⊥ open import Cubical.Data.Unit open import Cubical.Data.Nat open import Cubical.Data.Sigma open import Cubical.Data.Sum open import Cubical.Data.Vec.Base open import Cubical.Data.FinData open import Cubical.Relation.Nullary open Iso private variable ℓ : Level A : Type ℓ -- This is really cool! -- Compare with: https://github.com/agda/agda-stdlib/blob/master/src/Data/Vec/Properties/WithK.agda#L32 ++-assoc : ∀ {m n k} (xs : Vec A m) (ys : Vec A n) (zs : Vec A k) → PathP (λ i → Vec A (+-assoc m n k (~ i))) ((xs ++ ys) ++ zs) (xs ++ ys ++ zs) ++-assoc {m = zero} [] ys zs = refl ++-assoc {m = suc m} (x ∷ xs) ys zs i = x ∷ ++-assoc xs ys zs i -- Equivalence between Fin n → A and Vec A n FinVec→Vec : {n : ℕ} → FinVec A n → Vec A n FinVec→Vec {n = zero} xs = [] FinVec→Vec {n = suc _} xs = xs zero ∷ FinVec→Vec (λ x → xs (suc x)) Vec→FinVec : {n : ℕ} → Vec A n → FinVec A n Vec→FinVec xs f = lookup f xs FinVec→Vec→FinVec : {n : ℕ} (xs : FinVec A n) → Vec→FinVec (FinVec→Vec xs) ≡ xs FinVec→Vec→FinVec {n = zero} xs = funExt λ f → ⊥.rec (¬Fin0 f) FinVec→Vec→FinVec {n = suc n} xs = funExt goal where goal : (f : Fin (suc n)) → Vec→FinVec (xs zero ∷ FinVec→Vec (λ x → xs (suc x))) f ≡ xs f goal zero = refl goal (suc f) i = FinVec→Vec→FinVec (λ x → xs (suc x)) i f Vec→FinVec→Vec : {n : ℕ} (xs : Vec A n) → FinVec→Vec (Vec→FinVec xs) ≡ xs Vec→FinVec→Vec {n = zero} [] = refl Vec→FinVec→Vec {n = suc n} (x ∷ xs) i = x ∷ Vec→FinVec→Vec xs i FinVecIsoVec : (n : ℕ) → Iso (FinVec A n) (Vec A n) FinVecIsoVec n = iso FinVec→Vec Vec→FinVec Vec→FinVec→Vec FinVec→Vec→FinVec FinVec≃Vec : (n : ℕ) → FinVec A n ≃ Vec A n FinVec≃Vec n = isoToEquiv (FinVecIsoVec n) FinVec≡Vec : (n : ℕ) → FinVec A n ≡ Vec A n FinVec≡Vec n = ua (FinVec≃Vec n) isContrVec0 : isContr (Vec A 0) isContrVec0 = [] , λ { [] → refl } -- encode - decode Vec module VecPath {A : Type ℓ} where code : {n : ℕ} → (v v' : Vec A n) → Type ℓ code [] [] = Unit* code (a ∷ v) (a' ∷ v') = (a ≡ a') × (v ≡ v') -- encode reflEncode : {n : ℕ} → (v : Vec A n) → code v v reflEncode [] = tt* 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 encodeRefl : {n : ℕ} → (v : Vec A n) → encode v v refl ≡ 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') decode [] [] _ = refl decode (a ∷ v) (a' ∷ v') (p , q) = cong₂ _∷_ p q decodeRefl : {n : ℕ} → (v : Vec A n) → decode v v (reflEncode v) ≡ refl decodeRefl [] = refl decodeRefl (a ∷ v) = refl -- equiv ≡Vec≃codeVec : {n : ℕ} → (v v' : Vec A n) → (v ≡ v') ≃ (code v v') ≡Vec≃codeVec v v' = isoToEquiv is where is : Iso (v ≡ v') (code v v') fun is = encode v v' inv is = decode v v' sec is = sect v v' where 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)) (encodeRefl (a ∷ v)) q) p ret 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) (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 [] [])) (isOfHLevelUnit* (suc h)) 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))) ≢-∷ : {m : ℕ} → (Discrete A) → (a : A) → (v : Vec A m) → (a' : A) → (v' : Vec A m) → (a ∷ v ≡ a' ∷ v' → ⊥.⊥) → (a ≡ a' → ⊥.⊥) ⊎ (v ≡ v' → ⊥.⊥) ≢-∷ {m} discreteA a v a' v' ¬r with (discreteA a a') | (discreteA→discreteVecA discreteA m v v') ... | yes p | yes q = ⊥.rec (¬r (cong₂ _∷_ p q)) ... | yes p | no ¬q = inr ¬q ... | no ¬p | y = inl ¬p

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Displayed.Record.html` {- Generate univalent reflexive graph characterizations for record types from characterizations of the field types using reflection. See end of file for an example. -} {-# OPTIONS --no-exact-split #-} module Cubical.Displayed.Record where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Path open import Cubical.Data.Sigma open import Cubical.Data.List as List open import Cubical.Data.Unit open import Cubical.Data.Bool open import Cubical.Data.Maybe as Maybe open import Cubical.Displayed.Base open import Cubical.Displayed.Properties open import Cubical.Displayed.Prop open import Cubical.Displayed.Sigma open import Cubical.Displayed.Unit open import Cubical.Displayed.Universe open import Cubical.Displayed.Auto import Agda.Builtin.Reflection as R open import Cubical.Reflection.Base import Cubical.Reflection.RecordEquiv as RE {- `DUAFields` A collection of DURG characterizations for fields of a record is described by an element of this inductive family. If you just want to see how to use it, have a look at the end of the file first. An element of `DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅` describes a mapping - from a structure `R : A → Type _` and notion of structured equivalence `_≅R⟨_⟩_`, which are meant to be defined as parameterized record types, - to a DURG `𝒮ᴰ-S`, the underlying structure of which will be an iterated Σ-type, - via projections `πS` and `πS≅`. `𝒮-A`, `R`, and `_≅R⟨_⟩_` are parameters, while `πS`, `𝒮ᴰ-S`, and `πS≅` are indices; the user builds up the Σ-type representation of the record using the DUAFields constructors. A DUAFields representation is _total_ when the projections `πS` and `πS≅` are equivalences, in which case we obtain a DURG on `R` with `_≅R⟨_⟩_` as the notion of structured equivalence---see `𝒮ᴰ-Fields` below. When `R`, and `_≅R⟨_⟩_` are defined by record types, we can use reflection to automatically generate proofs `πS` and `πS≅` are equivalences---see `𝒮ᴰ-Record` below. -} data DUAFields {ℓA ℓ≅A ℓR ℓ≅R} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (R : A → Type ℓR) (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} (πS : ∀ {a} → R a → S a) (𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S) (πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')) → Typeω where -- `fields:` -- Base case, no fields yet recorded in `𝒮ᴰ-S`. fields: : DUAFields 𝒮-A R _≅R⟨_⟩_ (λ _ → tt) (𝒮ᴰ-Unit 𝒮-A) (λ _ → tt) -- `… data[ πF ∣ 𝒮ᴰ-F ∣ πF≅ ]` -- Add a new field with a DURG. `πF` should be the name of the field in the structure record `R` and `πF≅` -- the name of the corresponding field in the equivalence record `_≅R⟨_⟩_`, while `𝒮ᴰ-F` is a DURG for the -- field's type over `𝒮-A`. Data fields that depend on previous fields of the record are not currently -- supported. _data[_∣_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} → DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅ → ∀ {ℓF ℓ≅F} {F : A → Type ℓF} (πF : ∀ {a} → (r : R a) → F a) (𝒮ᴰ-F : DUARel 𝒮-A F ℓ≅F) (πF≅ : ∀ {a} {r : R a} {e} {r' : R a} (p : r ≅R⟨ e ⟩ r') → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-F (πF r) e (πF r')) → DUAFields 𝒮-A R _≅R⟨_⟩_ (λ r → πS r , πF r) (𝒮ᴰ-S ×𝒮ᴰ 𝒮ᴰ-F) (λ p → πS≅ p , πF≅ p) -- `… prop[ πF ∣ propF ]` -- Add a new propositional field. `πF` should be the name of the field in the structure record `R`, while -- propF is a proof that this field is a proposition. _prop[_∣_] : ∀ {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} → 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)) → 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} {ℓR ℓ≅R} {R : A → Type ℓR} (_≅R⟨_⟩_ : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → r ≅R⟨ e ⟩ r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} (fs : DUAFields 𝒮-A R _≅R⟨_⟩_ πS 𝒮ᴰ-S πS≅) where open UARel 𝒮-A open DUARel 𝒮ᴰ-S 𝒮ᴰ-Fields : (e : ∀ a → Iso (R a) (S a)) (e≅ : ∀ a a' (r : R a) p (r' : R a') → Iso (r ≅R⟨ p ⟩ r') ((e a .Iso.fun r ≅ᴰ⟨ p ⟩ e a' .Iso.fun r'))) → DUARel 𝒮-A R ℓ≅R DUARel._≅ᴰ⟨_⟩_ (𝒮ᴰ-Fields e e≅) r p r' = r ≅R⟨ p ⟩ r' DUARel.uaᴰ (𝒮ᴰ-Fields e e≅) r p r' = isoToEquiv (compIso (e≅ _ _ r p r') (compIso (equivToIso (uaᴰ (e _ .Iso.fun r) p (e _ .Iso.fun r'))) (invIso (congPathIso λ i → isoToEquiv (e _))))) module DisplayedRecordMacro where -- Extract a name from a term findName : R.Term → R.TC R.Name findName t = Maybe.rec (R.typeError (R.strErr "Not a name: " ∷ R.termErr t ∷ [])) (λ s → s) (go t) where go : R.Term → Maybe (R.TC R.Name) go (R.meta x _) = just (R.blockOnMeta x) go (R.def name _) = just (R.returnTC name) go (R.lam _ (R.abs _ t)) = go t go t = nothing -- ℓA ℓ≅A ℓR ℓ≅R A 𝒮-A R _≅R⟨_⟩_ pattern family∷ hole = _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ hole -- ℓS ℓ≅S S πS 𝒮ᴰ-S πS≅ pattern indices∷ hole = _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ _ h∷ hole {- Takes a reflected DUAFields term as input and collects lists of structure field names and equivalence field names. (These are returned in reverse order. -} parseFields : R.Term → R.TC (List R.Name × List R.Name) parseFields (R.con (quote fields:) _) = R.returnTC ([] , []) parseFields (R.con (quote _data[_∣_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ ℓ≅F h∷ F h∷ πF v∷ 𝒮ᴰ-F v∷ πF≅ v∷ _)))) = parseFields fs >>= λ (fs , f≅s) → findName πF >>= λ f → findName πF≅ >>= λ f≅ → R.returnTC (f ∷ fs , f≅ ∷ f≅s) parseFields (R.con (quote _prop[_∣_]) (family∷ (indices∷ (fs v∷ ℓF h∷ F h∷ πF v∷ _)))) = parseFields fs >>= λ (fs , f≅s) → findName πF >>= λ f → R.returnTC (f ∷ fs , f≅s) parseFields (R.meta x _) = R.blockOnMeta x parseFields t = R.typeError (R.strErr "Malformed specification: " ∷ R.termErr t ∷ []) {- Given a list of record field names (in reverse order), generates a ΣFormat (in the sense of Cubical.Reflection.RecordEquiv) associating the record fields with the fields of a left-associated iterated Σ-type -} List→LeftAssoc : List R.Name → RE.ΣFormat List→LeftAssoc [] = RE.unit List→LeftAssoc (x ∷ xs) = List→LeftAssoc xs RE., RE.leaf x module _ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {ℓR ℓ≅R} {R : A → Type ℓR} (≅R : {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R) {ℓS ℓ≅S} {S : A → Type ℓS} {πS : ∀ {a} → R a → S a} {𝒮ᴰ-S : DUARel 𝒮-A S ℓ≅S} {πS≅ : ∀ {a} {r : R a} {e} {r' : R a} → ≅R r e r' → DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-S (πS r) e (πS r')} where {- "𝒮ᴰ-Record ... : DUARel 𝒮-A R ℓ≅R" Requires that `R` and `_≅R⟨_⟩_` are defined by records and `πS` and `πS≅` are equivalences. The proofs of equivalence are generated using Cubical.Reflection.RecordEquiv and then `𝒮ᴰ-Fields` is applied. -} 𝒮ᴰ-Record : DUAFields 𝒮-A R ≅R πS 𝒮ᴰ-S πS≅ → R.Term → R.TC Unit 𝒮ᴰ-Record fs hole = R.quoteTC (DUARel 𝒮-A R ℓ≅R) >>= R.checkType hole >>= λ hole → R.quoteωTC fs >>= λ `fs` → parseFields `fs` >>= λ (fields , ≅fields) → R.freshName "fieldsIso" >>= λ fieldsIso → R.freshName "≅fieldsIso" >>= λ ≅fieldsIso → R.quoteTC R >>= R.normalise >>= λ `R` → R.quoteTC {A = {a a' : A} → R a → UARel._≅_ 𝒮-A a a' → R a' → Type ℓ≅R} ≅R >>= R.normalise >>= λ `≅R` → findName `R` >>= RE.declareRecordIsoΣ' fieldsIso (List→LeftAssoc fields) >> findName `≅R` >>= RE.declareRecordIsoΣ' ≅fieldsIso (List→LeftAssoc ≅fields) >> R.unify hole (R.def (quote 𝒮ᴰ-Fields) (`≅R` v∷ `fs` v∷ vlam "_" (R.def fieldsIso []) v∷ vlam "a" (vlam "a'" (vlam "r" (vlam "p" (vlam "r'" (R.def ≅fieldsIso []))))) v∷ [])) macro 𝒮ᴰ-Record = DisplayedRecordMacro.𝒮ᴰ-Record -- Example private module Example where record Example (A : Type) : Type where no-eta-equality -- works with or without eta equality field dog : A → A → A cat : A → A → A mouse : Unit open Example record ExampleEquiv {A B : Type} (x : Example A) (e : A ≃ B) (y : Example B) : Type where no-eta-equality -- works with or without eta equality field dogEq : ∀ a a' → e .fst (x .dog a a') ≡ y .dog (e .fst a) (e .fst a') catEq : ∀ a a' → e .fst (x .cat a a') ≡ y .cat (e .fst a) (e .fst a') open ExampleEquiv example : DUARel (𝒮-Univ ℓ-zero) Example ℓ-zero example = 𝒮ᴰ-Record (𝒮-Univ ℓ-zero) ExampleEquiv (fields: data[ dog ∣ autoDUARel _ _ ∣ dogEq ] data[ cat ∣ autoDUARel _ _ ∣ catEq ] prop[ mouse ∣ (λ _ _ → isPropUnit) ])

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Displayed.Subst` {- Given a type A with a UARel and a family B over A, a SubstRel on B is a family of functions a ≅ a' → B a ≃ B a' path-equal to transport in that family. Any SubstRel gives rise to a DUARel in which b and b' are related over p when the transport of b along p is equial to b'. -} module Cubical.Displayed.Subst where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Path open import Cubical.Foundations.Transport open import Cubical.Foundations.Univalence open import Cubical.Displayed.Base private variable ℓA ℓ≅A ℓB : Level record SubstRel {A : Type ℓA} {ℓ≅A : Level} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) : Type (ℓ-max (ℓ-max ℓA ℓB) ℓ≅A) where no-eta-equality constructor substrel open UARel 𝒮-A field 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ˢ⁻ 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.ret (invEq (act p) b) ⟩ invEq (act p) b ∎ Subst→DUA : {A : Type ℓA} {ℓ≅A : Level} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB} → SubstRel 𝒮-A B → DUARel 𝒮-A B ℓB DUARel._≅ᴰ⟨_⟩_ (Subst→DUA 𝒮ˢ-B) b p b' = 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))) ⟩ subst B (≅→≡ p) b ≡ b' ≃⟨ invEquiv (PathP≃Path (λ i → B (≅→≡ p i)) b b') ⟩ PathP (λ i → B (≅→≡ p i)) b b' ■ where open UARel 𝒮-A

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Cubes.Base.html` {- This file contains: - The definition of the type of n-cubes; - Some basic operations. -} module Cubical.Foundations.Cubes.Base where open import Cubical.Foundations.Prelude hiding (Cube) open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Data.Nat.Base open import Cubical.Data.Sigma.Base private variable ℓ ℓ' : Level A : Type ℓ -- The Type of n-Cubes -- P.S. -- Only the definitions of `∂Cube` and `CubeRel` essentially use mutual recursion. -- The case of `Cube` is designed to gain more definitional equality. interleaved mutual Cube : (n : ℕ) (A : Type ℓ) → Type ℓ ∂Cube₀₁ : (n : ℕ) (A : Type ℓ) (a₀ a₁ : Cube n A) → Type ℓ ∂Cube : (n : ℕ) (A : Type ℓ) → Type ℓ CubeRel : (n : ℕ) (A : Type ℓ) → ∂Cube n A → Type ℓ Cube 0 A = A Cube (suc n) A = Σ[ ∂ ∈ ∂Cube (suc n) A ] CubeRel (suc n) A ∂ ∂Cube₀₁ 0 A _ _ = Unit* ∂Cube₀₁ (suc n) A a₀ a₁ = a₀ .fst ≡ a₁ .fst ∂Cube 0 A = Unit* ∂Cube 1 A = A × A ∂Cube (suc (suc n)) A = Σ[ a₀ ∈ Cube (suc n) A ] Σ[ a₁ ∈ Cube (suc n) A ] ∂Cube₀₁ (suc n) A a₀ a₁ CubeRel 0 A _ = A CubeRel 1 A ∂ = ∂ .fst ≡ ∂ .snd CubeRel (suc (suc n)) A (a₀ , a₁ , ∂₋) = PathP (λ i → CubeRel (suc n) A (∂₋ i)) (a₀ .snd) (a₁ .snd) -- Some basic operations ∂_ : {n : ℕ}{A : Type ℓ} → Cube n A → ∂Cube n A ∂_ {n = 0} _ = tt* ∂_ {n = suc n} = fst ∂₀ : {n : ℕ}{A : Type ℓ} → Cube (suc n) A → Cube n A ∂₀ {n = 0} (_ , p) = p i0 ∂₀ {n = suc n} (_ , p) = _ , p i0 ∂₁ : {n : ℕ}{A : Type ℓ} → Cube (suc n) A → Cube n A ∂₁ {n = 0} (_ , p) = p i1 ∂₁ {n = suc n} (_ , p) = _ , p i1 ∂ᵇ₀ : {n : ℕ}{A : Type ℓ} → ∂Cube (suc n) A → Cube n A ∂ᵇ₀ {n = 0} (a₀ , a₁) = a₀ ∂ᵇ₀ {n = suc n} (a₀ , a₁ , ∂₋) = a₀ ∂ᵇ₁ : {n : ℕ}{A : Type ℓ} → ∂Cube (suc n) A → Cube n A ∂ᵇ₁ {n = 0} (a₀ , a₁) = a₁ ∂ᵇ₁ {n = suc n} (a₀ , a₁ , ∂₋) = a₁ make∂ : {n : ℕ}{A : Type ℓ}{∂₀ ∂₁ : ∂Cube n A} → ∂₀ ≡ ∂₁ → CubeRel n A ∂₀ → CubeRel n A ∂₁ → ∂Cube (suc n) A make∂ {n = 0} _ a b = a , b make∂ {n = suc n} ∂₋ a₀ a₁ = (_ , a₀) , (_ , a₁) , ∂₋ makeCube : {n : ℕ}{A : Type ℓ}{a₀ a₁ : Cube n A} → a₀ ≡ a₁ → Cube (suc n) A makeCube {n = 0} a₋ = _ , a₋ makeCube {n = suc n} a₋ = _ , λ i → a₋ i .snd -- A cube is just a path of cubes of one-lower-dimension. -- Unfortunately the following function cannot begin at 0, -- because Agda doesn't support pattern matching on ℕ towards pre-types. -- P.S. It will be fixed in Agda 2.6.3 when I → A becomes fibrant. pathCube : (n : ℕ) → (I → Cube (suc n) A) → Cube (suc (suc n)) A pathCube n p = _ , λ i → p i .snd ∂Cube₀₁→∂Cube : {n : ℕ}{A : Type ℓ}{a₀ a₁ : Cube n A} → ∂Cube₀₁ n A a₀ a₁ → ∂Cube (suc n) A ∂Cube₀₁→∂Cube {n = 0} {a₀ = a₀} {a₁} _ = a₀ , a₁ ∂Cube₀₁→∂Cube {n = suc n} {a₀ = a₀} {a₁} ∂ = a₀ , a₁ , ∂ CubeRel→Cube : {n : ℕ}{A : Type ℓ}{∂ : ∂Cube n A} → CubeRel n A ∂ → Cube n A CubeRel→Cube {n = 0} a = a CubeRel→Cube {n = suc n} cube = _ , cube -- Composition of internal cubes, with specified boundary hcomp∂ : {n : ℕ} {A : Type ℓ} {∂₀ ∂₁ : ∂Cube n A} (∂₋ : ∂₀ ≡ ∂₁) (a₀ : CubeRel n A ∂₀) → CubeRel n A ∂₁ hcomp∂ ∂₋ = transport (λ i → CubeRel _ _ (∂₋ i)) hfill∂ : {n : ℕ} {A : Type ℓ} {∂₀ ∂₁ : ∂Cube n A} (∂₋ : ∂₀ ≡ ∂₁) (a₀ : CubeRel n A ∂₀) → CubeRel (suc n) A (make∂ ∂₋ a₀ (hcomp∂ ∂₋ a₀)) hfill∂ {n = 0} ∂₋ a₀ i = transportRefl a₀ (~ i) hfill∂ {n = suc n} ∂₋ = transport-filler (λ i → CubeRel _ _ (∂₋ i)) -- Constant path of n-cube as (n+1)-cube constCube : {n : ℕ}{A : Type ℓ} → Cube n A → Cube (suc n) A constCube {n = 0} a = _ , λ i → a constCube {n = suc n} (∂ , cube) = _ , λ i → cube retConst : {n : ℕ}{A : Type ℓ} → (cube : Cube n A) → ∂₀ (constCube {n = n} cube) ≡ cube retConst {n = 0} _ = refl retConst {n = suc n} _ = refl secConst : {n : ℕ}{A : Type ℓ} → (cube : Cube (suc n) A) → constCube (∂₀ cube) ≡ cube secConst {n = 0} (_ , p) i = _ , λ j → p (i ∧ j) secConst {n = suc n} (_ , p) i = _ , λ j → p (i ∧ j) isEquivConstCube : {n : ℕ}{A : Type ℓ} → isEquiv (constCube {n = n} {A = A}) isEquivConstCube {n = n} = isoToEquiv (iso constCube ∂₀ secConst (retConst {n = n})) .snd -- Constant cubes const : (n : ℕ){A : Type ℓ} → A → Cube n A const 0 a = a const (suc n) a = constCube (const n a) isEquivConst : {n : ℕ}{A : Type ℓ} → isEquiv (const n {A = A}) isEquivConst {n = 0} = idIsEquiv _ isEquivConst {n = suc n} = compEquiv (_ , isEquivConst) (_ , isEquivConstCube) .snd cubeEquiv : {n : ℕ}{A : Type ℓ} → A ≃ Cube n A cubeEquiv = _ , isEquivConst makeConst : {n : ℕ}{A : Type ℓ} → (cube : Cube n A) → Σ[ a ∈ A ] cube ≡ const n a makeConst {n = n} cube = invEq cubeEquiv cube , sym (secEq (cubeEquiv {n = n}) cube) makeConstUniq : {n : ℕ}{A : Type ℓ} → (a : A) → makeConst (const n a) ≡ (a , refl) makeConstUniq {n = n} a i .fst = isEquivConst .equiv-proof (const n a) .snd (a , refl) i .fst makeConstUniq {n = n} a i .snd j = isEquivConst .equiv-proof (const n a) .snd (a , refl) i .snd (~ j) -- Cube with constant boundary const∂ : (n : ℕ){A : Type ℓ} → A → ∂Cube n A const∂ n a = ∂ (const n a) -- J-rule for n-cubes, -- in some sense a generalization of the usual (symmetric form of) J-rule, -- which is equivalent to the case n=1. module _ {n : ℕ} {A : Type ℓ} (P : Cube n A → Type ℓ') (d : (a : A) → P (const _ a)) where JCube : (a₋ : Cube n A) → P a₋ JCube a₋ = let c-path = makeConst {n = n} a₋ in transport (λ i → P (c-path .snd (~ i))) (d (c-path .fst)) JCubeβ : (a : A) → JCube (const _ a) ≡ d a JCubeβ a i = let c-square = makeConstUniq {n = n} a in let c-path = transport-filler (λ i → P (c-square i0 .snd (~ i))) (d (c-square i0 .fst)) in comp (λ j → P (c-square j .snd i)) (λ j → λ { (i = i0) → c-path i1 ; (i = i1) → d _ }) (c-path (~ i))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Equiv.html` {- Theory about equivalences Definitions are in Core/Glue.agda but re-exported by this module - isEquiv is a proposition ([isPropIsEquiv]) - Any isomorphism is an equivalence ([isoToEquiv]) There are more statements about equivalences in Equiv/Properties.agda: - if f is an equivalence then (cong f) is an equivalence - if f is an equivalence then precomposition with f is an equivalence - if f is an equivalence then postcomposition with f is an equivalence -} module Cubical.Foundations.Equiv where open import Cubical.Foundations.Function open import Cubical.Foundations.Prelude open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv.Base public open import Cubical.Data.Sigma.Base private variable ℓ ℓ' ℓ'' : Level A B C D : Type ℓ infixr 30 _∙ₑ_ equivIsEquiv : (e : A ≃ B) → isEquiv (equivFun e) equivIsEquiv e = snd e equivCtr : (e : A ≃ B) (y : B) → fiber (equivFun e) y equivCtr e y = e .snd .equiv-proof y .fst equivCtrPath : (e : A ≃ B) (y : B) → (v : fiber (equivFun e) y) → Path _ (equivCtr e y) v equivCtrPath e y = e .snd .equiv-proof y .snd -- Proof using isPropIsContr. This is slow and the direct proof below is better 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 -- 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) equiv-proof (isPropIsEquiv f p q i) y = let p2 = p .equiv-proof y .snd q2 = q .equiv-proof y .snd in p2 (q .equiv-proof y .fst) i , λ w j → hcomp (λ k → λ { (i = i0) → p2 w j ; (i = i1) → q2 w (j ∨ ~ k) ; (j = i0) → p2 (q2 w (~ k)) i ; (j = i1) → w }) (p2 w (i ∨ j)) 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 sec (equivToIso e) = secEq e ret (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 .sec e = equivEq refl isom .ret _ = 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.sec g = funExt λ b → secEq k _ ∙ cong g (secEq h b) equiv→Iso h k .Iso.ret 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 .sec 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 .ret 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.sec g = equivEq (equiv→Iso h k .Iso.sec (equivFun g)) equivCompIso h k .Iso.ret f = equivEq (equiv→Iso h k .Iso.ret (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 .sec q = refl isEquiv-isEquiv'-Iso f .ret 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

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.HLevels.html` {- Basic theory about h-levels/n-types: - Basic properties of isContr, isProp and isSet (definitions are in Prelude) - Hedberg's theorem can be found in Cubical/Relation/Nullary/Properties -} module Cubical.Foundations.HLevels where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Structure open import Cubical.Functions.FunExtEquiv open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Pointed.Base open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Path open import Cubical.Foundations.Transport open import Cubical.Foundations.Univalence using (ua ; univalenceIso) open import Cubical.Data.Sigma open import Cubical.Data.Nat using (ℕ; zero; suc; _+_; +-zero; +-comm) open Iso HLevel : Type₀ HLevel = ℕ private variable ℓ ℓ' ℓ'' ℓ''' ℓ'''' ℓ''''' : Level A A' : Type ℓ B : A → Type ℓ C : (x : A) → B x → Type ℓ D : (x : A) (y : B x) → C x y → Type ℓ E : (x : A) (y : B x) → (z : C x y) → D x y z → Type ℓ F : (x : A) (y : B x) (z : C x y) (w : D x y z) (v : E x y z w) → Type ℓ G : (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) → Type ℓ w x y z : A n : HLevel isOfHLevel : HLevel → Type ℓ → Type ℓ 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 ℓ ℓ') isOfHLevelFun n f = ∀ b → isOfHLevel n (fiber f b) isOfHLevelΩ→isOfHLevel : ∀ {ℓ} {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) isOfHLevelΩ→isOfHLevel (suc n) hΩ x y = J (λ y p → (q : x ≡ y) → isOfHLevel (suc n) (p ≡ q)) (hΩ x refl) TypeOfHLevel : ∀ ℓ → HLevel → Type (ℓ-suc ℓ) TypeOfHLevel ℓ n = TypeWithStr ℓ (isOfHLevel n) hProp hSet hGroupoid h2Groupoid : ∀ ℓ → Type (ℓ-suc ℓ) hProp ℓ = TypeOfHLevel ℓ 1 hSet ℓ = TypeOfHLevel ℓ 2 hGroupoid ℓ = TypeOfHLevel ℓ 3 h2Groupoid ℓ = TypeOfHLevel ℓ 4 -- 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 (suc (suc n)) h a b = isOfHLevelSuc (suc n) (h a b) isSet→isGroupoid : isSet A → isGroupoid A isSet→isGroupoid = isOfHLevelSuc 2 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 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 zero pA = pA isProp→isOfHLevelSuc (suc n) pA = isOfHLevelSuc _ (isProp→isOfHLevelSuc n pA) isOfHLevelPlus' : (m : HLevel) → isOfHLevel m A → isOfHLevel (m + n) A isOfHLevelPlus' {n = n} 0 = isContr→isOfHLevel n isOfHLevelPlus' {n = n} 1 = isProp→isOfHLevelSuc n isOfHLevelPlus' {n = n} (suc (suc m)) hA a₀ a₁ = isOfHLevelPlus' (suc m) (hA a₀ a₁) -- When proving a type has h-level n+1, we can assume it is inhabited. -- To prove a type is a proposition, it suffices to prove it is contractible if inhabited isOfHLevelSucIfInhabited→isOfHLevelSuc : ∀ n → (A → isOfHLevel (suc n) A) → isOfHLevel (suc n) A isOfHLevelSucIfInhabited→isOfHLevelSuc zero hA a = hA a a isOfHLevelSucIfInhabited→isOfHLevelSuc (suc n) hA a = hA a a isContrIfInhabited→isProp : (A → isContr A) → isProp A isContrIfInhabited→isProp hA = isOfHLevelSucIfInhabited→isOfHLevelSuc 0 (isContr→isProp ∘ hA) -- 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 _ 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 isOfHLevelPath' (suc n) h x y = h x y isOfHLevelPath'⁻ : (n : HLevel) → ((x y : A) → isOfHLevel n (x ≡ y)) → isOfHLevel (suc n) A isOfHLevelPath'⁻ zero h x y = h x y .fst isOfHLevelPath'⁻ (suc n) h = h isOfHLevelPath : (n : HLevel) → isOfHLevel n A → (x y : A) → isOfHLevel n (x ≡ y) isOfHLevelPath 0 h x y = isContr→isContrPath h x y isOfHLevelPath (suc n) h x y = isOfHLevelSuc n (isOfHLevelPath' n h x y) -- h-level of isOfHLevel 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 = isPropIsOfHLevel 2 isPropIsGroupoid : isProp (isGroupoid A) isPropIsGroupoid = isPropIsOfHLevel 3 isPropIs2Groupoid : isProp (is2Groupoid A) isPropIs2Groupoid = isPropIsOfHLevel 4 TypeOfHLevel≡ : (n : HLevel) {X Y : TypeOfHLevel ℓ n} → ⟨ X ⟩ ≡ ⟨ Y ⟩ → X ≡ Y TypeOfHLevel≡ n = Σ≡Prop (λ _ → isPropIsOfHLevel n) -- hlevels are preserved by retracts (and consequently equivalences) isContrRetract : ∀ {B : Type ℓ} → (f : A → B) (g : B → A) → (h : retract f g) → (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) isPropRetract : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) → isProp B → isProp A isPropRetract f g h p x y i = hcomp (λ j → λ { (i = i0) → h x j ; (i = i1) → h y j}) (g (p (f x) (f y) i)) isSetRetract : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) → 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 ; (j = i0) → h x k ; (j = i1) → h y k}) (g (set (f x) (f y) (cong f p) (cong f q) i j)) isGroupoidRetract : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) → 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 ; (j = i0) → h (p k) l ; (j = i1) → h (q k) l ; (k = i0) → h x l ; (k = i1) → h y l})) (g (grp (f x) (f y) (cong f p) (cong f q) (cong (cong f) P) (cong (cong f) Q) i j k)) is2GroupoidRetract : {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) → 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 ; (j = i0) → h (P k l) r ; (j = i1) → h (Q k l) r ; (k = i0) → h (p l) r ; (k = i1) → h (q l) r ; (l = i0) → h x r ; (l = i1) → h y r}) (g (grp (f x) (f y) (cong f p) (cong f q) (cong (cong f) P) (cong (cong f) Q) (cong (cong (cong f)) R) (cong (cong (cong f)) S) i j k l)) isOfHLevelRetract : (n : HLevel) {B : Type ℓ} (f : A → B) (g : B → A) (h : (x : A) → g (f x) ≡ x) → isOfHLevel n B → isOfHLevel n A isOfHLevelRetract 0 = isContrRetract isOfHLevelRetract 1 = isPropRetract isOfHLevelRetract 2 = isSetRetract isOfHLevelRetract 3 = isGroupoidRetract isOfHLevelRetract 4 = is2GroupoidRetract isOfHLevelRetract (suc (suc (suc (suc (suc n))))) f g h ofLevel x y p q P Q R S = isOfHLevelRetract (suc n) (cong (cong (cong (cong f)))) (λ s i j k l → hcomp (λ r → λ { (i = i0) → h (R j k l) r ; (i = i1) → h (S j k l) r ; (j = i0) → h (P k l) r ; (j = i1) → h (Q k l) r ; (k = i0) → h (p l) r ; (k = i1) → h (q l) r ; (l = i0) → h x r ; (l = i1) → h y r}) (g (s i j k l))) (λ s i j k l m → hcomp (λ n → λ { (i = i1) → s j k l m ; (j = i0) → h (R k l m) (i ∨ n) ; (j = i1) → h (S k l m) (i ∨ n) ; (k = i0) → h (P l m) (i ∨ n) ; (k = i1) → h (Q l m) (i ∨ n) ; (l = i0) → h (p m) (i ∨ n) ; (l = i1) → h (q m) (i ∨ n) ; (m = i0) → h x (i ∨ n) ; (m = i1) → h y (i ∨ n) }) (h (s j k l m) i)) (ofLevel (f x) (f y) (cong f p) (cong f q) (cong (cong f) P) (cong (cong f) Q) (cong (cong (cong f)) R) (cong (cong (cong f)) S)) isOfHLevelRetractFromIso : {A : Type ℓ} {B : Type ℓ'} (n : HLevel) → Iso A B → isOfHLevel n B → isOfHLevel n A isOfHLevelRetractFromIso n e hlev = isOfHLevelRetract n (Iso.fun e) (Iso.inv e) (Iso.ret 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) isContrRetractOfConstFun : {A : Type ℓ} {B : Type ℓ'} (b₀ : B) → Σ[ f ∈ (B → A) ] ((x : A) → (f ∘ (λ _ → b₀)) x ≡ x) → isContr A fst (isContrRetractOfConstFun b₀ ret) = ret .fst b₀ snd (isContrRetractOfConstFun b₀ ret) y = ret .snd y -- h-level of dependent path types isOfHLevelPathP' : {A : I → Type ℓ} (n : HLevel) → isOfHLevel (suc n) (A i1) → (x : A i0) (y : A i1) → isOfHLevel n (PathP A x y) isOfHLevelPathP' {A = A} n h x y = isOfHLevelRetractFromIso n (PathPIsoPath _ x y) (isOfHLevelPath' n h _ _) isOfHLevelPathP : {A : I → Type ℓ} (n : HLevel) → isOfHLevel n (A i1) → (x : A i0) (y : A i1) → isOfHLevel n (PathP A x y) isOfHLevelPathP {A = A} n h x y = isOfHLevelRetractFromIso n (PathPIsoPath _ x y) (isOfHLevelPath n h _ _) -- Fillers for cubes from h-level isSet→SquareP : {A : I → I → Type ℓ} (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₋₁ isSet→SquareP isset a₀₋ a₁₋ a₋₀ a₋₁ = PathPIsoPath _ _ _ .Iso.inv (isOfHLevelPathP' 1 (isset _ _) _ _ _ _ ) 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 (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₋₁) 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 Agpd' x y p q r s = Agpd' r s refl refl refl refl -- h-level of Σ-types isProp∃! : isProp (∃! A B) isProp∃! = isPropIsContr 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 in (( a , q a .fst) , ( λ 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 cb = isContrΣ ca (λ x → subst _ (snd ca x) cb) section-Σ≡Prop : (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))) (Σ≡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} → 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Σ pA pB t u = Σ≡Prop pB (pA (t .fst) (u .fst)) isOfHLevelΣ : ∀ n → isOfHLevel n A → ((x : A) → isOfHLevel n (B x)) → isOfHLevel n (Σ A B) isOfHLevelΣ 0 = isContrΣ isOfHLevelΣ 1 = isPropΣ isOfHLevelΣ {B = B} (suc (suc n)) h1 h2 x y = isOfHLevelRetractFromIso (suc n) (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Σ = 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)) 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Σ = isOfHLevelΣ 4 -- h-level of × 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×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×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×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×5 pA pB pC pD pE pF = isProp×4 pA pB pC pD (isProp× pE pF) isOfHLevel× : ∀ {A : Type ℓ} {B : Type ℓ'} n → isOfHLevel n A → isOfHLevel n B → 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× = isOfHLevel× 2 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× = isOfHLevel× 4 -- h-level of Π-types isOfHLevelΠ : ∀ n → ((x : A) → isOfHLevel n (B x)) → isOfHLevel n ((x : A) → B x) isOfHLevelΠ 0 h = (λ x → fst (h x)) , λ f i y → snd (h y) (f y) i isOfHLevelΠ 1 h f g i x = (h x) (f x) (g x) i isOfHLevelΠ 2 h f g F G i j z = h z (f z) (g z) (funExt⁻ F z) (funExt⁻ G z) i j isOfHLevelΠ 3 h f g p q P Q i j k z = h z (f z) (g z) (funExt⁻ p z) (funExt⁻ q z) (cong (λ f → funExt⁻ f z) P) (cong (λ f → funExt⁻ f z) Q) i j k isOfHLevelΠ 4 h f g p q P Q R S i j k l z = h z (f z) (g z) (funExt⁻ p z) (funExt⁻ q z) (cong (λ f → funExt⁻ f z) P) (cong (λ f → funExt⁻ f z) Q) (cong (cong (λ f → funExt⁻ f z)) R) (cong (cong (λ f → funExt⁻ f z)) S) i j k l isOfHLevelΠ (suc (suc (suc (suc (suc n))))) h f g p q P Q R S = isOfHLevelRetract (suc n) (cong (cong (cong funExt⁻))) (cong (cong (cong funExt))) (λ _ → refl) (isOfHLevelΠ (suc (suc (suc (suc n)))) (λ x → h x (f x) (g x)) (funExt⁻ p) (funExt⁻ q) (cong funExt⁻ P) (cong funExt⁻ Q) (cong (cong funExt⁻) R) (cong (cong funExt⁻) S)) isOfHLevelΠ2 : (n : HLevel) → ((x : A) → (y : B x) → isOfHLevel n (C x y)) → 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Π = isOfHLevelΠ 0 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 = 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 = 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 = 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 = 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 = isPropΠ λ _ → isPropΠ5 (h _) 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 = isPropImplicitΠ (λ x → isPropImplicitΠ (λ y → h x y)) 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.sec (p₀ i₁) b)) (λ i₁ → (Iso.sec (p₁ i₁) b)) r-p : ∀ a → _ r-p a = isSet→SquareP (λ i j → isProp→isSet (isSet-A _ _)) refl refl (λ i₁ → (Iso.ret (p₀ i₁) a)) (λ i₁ → (Iso.ret (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.sec (h i i₁) b = s-p b i₁ i Iso.ret (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.sec (SetsIso≡-ext {a} {b} fun≡ inv≡ i) b₁ = isSet→SquareP (λ _ _ → isSet-A') (Iso.sec a b₁) (Iso.sec b b₁) (λ i → fun≡ (inv≡ b₁ i) i) refl i Iso.ret (SetsIso≡-ext {a} {b} fun≡ inv≡ i) a₁ = isSet→SquareP (λ _ _ → isSet-A) (Iso.ret a a₁) (Iso.ret 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 sec ww b = equivEq refl ret 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 sec ww b = isInjectiveTransport (funExt λ _ → transportRefl _) ret 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 Π-contractDomIso : (c : isContr A) → Iso ((x : A) → B x) (B (c .fst)) Π-contractDomIso {B = B} c .fun f = f (c .fst) Π-contractDomIso {B = B} c .inv b x = subst B (c .snd x) b Π-contractDomIso {B = B} c .sec b i = transp (λ j → B (isProp→isSet (isContr→isProp c) _ _ (c .snd (c .fst)) refl i j)) i b Π-contractDomIso {B = B} c .ret f = funExt λ x → fromPathP (cong f (c .snd x)) Π-contractDom : (c : isContr A) → ((x : A) → B x) ≃ B (c .fst) Π-contractDom c = isoToEquiv (Π-contractDomIso c)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Isomorphism.html` {- Theory about isomorphisms - Definitions of [section] and [retract] - Definition of isomorphisms ([Iso]) - Any isomorphism is an equivalence ([isoToEquiv]) -} module Cubical.Foundations.Isomorphism where open import Cubical.Core.Glue open import Cubical.Foundations.Prelude open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Function open import Cubical.Foundations.Equiv.Base private variable ℓ ℓ' : Level A B C : Type ℓ -- Section and retract module _ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where section : (f : A → B) → (g : B → A) → Type ℓ' section f g = ∀ b → f (g b) ≡ b -- NB: `g` is the retraction! retract : (f : A → B) → (g : B → A) → Type ℓ retract f g = ∀ a → g (f a) ≡ a record Iso {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') : Type (ℓ-max ℓ ℓ') where no-eta-equality constructor iso field fun : A → B inv : B → A sec : section fun inv ret : retract fun inv isIso : (A → B) → Type _ isIso {A = A} {B = B} f = Σ[ g ∈ (B → A) ] Σ[ _ ∈ section f g ] retract f g isoFunInjective : (f : Iso A B) → (x y : A) → Iso.fun f x ≡ Iso.fun f y → x ≡ y isoFunInjective f x y h = sym (Iso.ret f x) ∙∙ cong (Iso.inv f) h ∙∙ Iso.ret f y isoInvInjective : (f : Iso A B) → (x y : B) → Iso.inv f x ≡ Iso.inv f y → x ≡ y isoInvInjective f x y h = sym (Iso.sec f x) ∙∙ cong (Iso.fun f) h ∙∙ Iso.sec f y -- Any iso is an equivalence module _ (i : Iso A B) where open Iso i renaming ( fun to f ; inv to g ; sec to s ; ret to t) private module _ (y : B) (x0 x1 : A) (p0 : f x0 ≡ y) (p1 : f x1 ≡ y) where fill0 : I → I → A fill0 i = hfill (λ k → λ { (i = i1) → t x0 k ; (i = i0) → g y }) (inS (g (p0 (~ i)))) fill1 : I → I → A fill1 i = hfill (λ k → λ { (i = i1) → t x1 k ; (i = i0) → g y }) (inS (g (p1 (~ i)))) fill2 : I → I → A fill2 i = hfill (λ k → λ { (i = i1) → fill1 k i1 ; (i = i0) → fill0 k i1 }) (inS (g y)) p : x0 ≡ x1 p i = fill2 i i1 sq : I → I → A sq i j = hcomp (λ k → λ { (i = i1) → fill1 j (~ k) ; (i = i0) → fill0 j (~ k) ; (j = i1) → t (fill2 i i1) (~ k) ; (j = i0) → g y }) (fill2 i j) sq1 : I → I → B sq1 i j = hcomp (λ k → λ { (i = i1) → s (p1 (~ j)) k ; (i = i0) → s (p0 (~ j)) k ; (j = i1) → s (f (p i)) k ; (j = i0) → s y k }) (f (sq i j)) lemIso : (x0 , p0) ≡ (x1 , p1) lemIso i .fst = p i lemIso i .snd = λ j → sq1 i (~ j) isoToIsEquiv : isEquiv f isoToIsEquiv .equiv-proof y .fst .fst = g y isoToIsEquiv .equiv-proof y .fst .snd = s y isoToIsEquiv .equiv-proof y .snd z = lemIso y (g y) (fst z) (s y) (snd z) isoToEquiv : Iso A B → A ≃ B isoToEquiv i .fst = i .Iso.fun isoToEquiv i .snd = isoToIsEquiv i IsoToIsIso : (f : Iso A B) → isIso (f .Iso.fun) IsoToIsIso f .fst = f .Iso.inv IsoToIsIso f .snd .fst = f .Iso.sec IsoToIsIso f .snd .snd = f .Iso.ret isIsoToIso : {f : A → B} → isIso f → Iso A B isIsoToIso {f = f} fIsIso .Iso.fun = f isIsoToIso fIsIso .Iso.inv = fIsIso .fst isIsoToIso fIsIso .Iso.sec = fIsIso .snd .fst isIsoToIso fIsIso .Iso.ret = fIsIso .snd .snd isIsoToIsEquiv : {f : A → B} → isIso f → isEquiv f isIsoToIsEquiv fIsIso = isoToIsEquiv (isIsoToIso fIsIso) isoToPath : Iso A B → A ≡ B isoToPath {A = A} {B = B} f i = Glue B (λ { (i = i0) → (A , isoToEquiv f) ; (i = i1) → (B , idEquiv B) }) open Iso invIso : Iso A B → Iso B A fun (invIso f) = inv f inv (invIso f) = fun f sec (invIso f) = ret f ret (invIso f) = sec f compIso : Iso A B → Iso B C → Iso A C fun (compIso i j) = fun j ∘ fun i inv (compIso i j) = inv i ∘ inv j sec (compIso i j) b = cong (fun j) (sec i (inv j b)) ∙ sec j b ret (compIso i j) a = cong (inv i) (ret j (fun i a)) ∙ ret i a composesToId→Iso : (G : Iso A B) (g : B → A) → G .fun ∘ g ≡ idfun B → Iso B A fun (composesToId→Iso _ g _) = g inv (composesToId→Iso j _ _) = fun j sec (composesToId→Iso i g path) b = sym (ret i (g (fun i b))) ∙∙ cong (λ g → inv i (g (fun i b))) path ∙∙ ret i b ret (composesToId→Iso _ _ path) b i = path i b idIso : Iso A A fun idIso = idfun _ inv idIso = idfun _ sec idIso _ = refl ret idIso _ = refl compIsoIdL : (isom : Iso A B) → compIso idIso isom ≡ isom fun (compIsoIdL isom i) = fun isom inv (compIsoIdL isom i) = inv isom sec (compIsoIdL isom i) b = lUnit (isom .sec b) (~ i) ret (compIsoIdL isom i) a = rUnit (isom .ret a) (~ i) compIsoIdR : (isom : Iso A B) → compIso isom idIso ≡ isom fun (compIsoIdR isom i) = fun isom inv (compIsoIdR isom i) = inv isom sec (compIsoIdR isom i) b = rUnit (isom .sec b) (~ i) ret (compIsoIdR isom i) a = lUnit (isom .ret a) (~ i) LiftIso : Iso A (Lift {i = ℓ} {j = ℓ'} A) fun LiftIso = lift inv LiftIso = lower sec LiftIso _ = refl ret LiftIso _ = refl isContr→Iso : isContr A → isContr B → Iso A B fun (isContr→Iso _ Bctr) _ = Bctr .fst inv (isContr→Iso Actr _) _ = Actr .fst sec (isContr→Iso _ Bctr) = Bctr .snd ret (isContr→Iso Actr _) = Actr .snd isContr→Iso' : isContr A → isContr B → (A → B) → Iso A B fun (isContr→Iso' _ Bctr f) = f inv (isContr→Iso' Actr _ _) _ = Actr .fst sec (isContr→Iso' _ Bctr f) = isContr→isProp Bctr _ ret (isContr→Iso' Actr _ _) = Actr .snd 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 sec (isProp→Iso _ Bprop f g) b = Bprop (f (g b)) b ret (isProp→Iso Aprop _ f g) a = Aprop (g (f a)) a domIso : ∀ {ℓ} {C : Type ℓ} → Iso A B → Iso (A → C) (B → C) fun (domIso e) f b = f (inv e b) inv (domIso e) f a = f (fun e a) sec (domIso e) f i x = f (sec e x i) ret (domIso e) f i x = f (ret e x i) -- Helpful notation _Iso⟨_⟩_ : ∀ {ℓ ℓ' ℓ''} {B : Type ℓ'} {C : Type ℓ''} (X : Type ℓ) → Iso X B → Iso B C → Iso X C _ Iso⟨ f ⟩ g = compIso f g _∎Iso : ∀ {ℓ} (A : Type ℓ) → Iso A A A ∎Iso = idIso {A = A} infixr 0 _Iso⟨_⟩_ infix 1 _∎Iso codomainIsoDep : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : A → Type ℓ'} {C : A → Type ℓ''} → ((a : A) → Iso (B a) (C a)) → Iso ((a : A) → B a) ((a : A) → C a) fun (codomainIsoDep is) f a = fun (is a) (f a) inv (codomainIsoDep is) f a = inv (is a) (f a) sec (codomainIsoDep is) f = funExt λ a → sec (is a) (f a) ret (codomainIsoDep is) f = funExt λ a → ret (is a) (f a) codomainIso : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} → Iso B C → Iso (A → B) (A → C) codomainIso z = codomainIsoDep λ _ → z endoIso : Iso A B → Iso (A → A) (B → B) endoIso is = compIso (domIso is) (codomainIso is) 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) → ((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 sec (Iso≡Set hA hB f g hfun hinv i) x j = isSet→isSet' hB (sec f x) (sec g x) (λ i → hfun (hinv x i) i) refl i j ret (Iso≡Set hA hB f g hfun hinv i) x j = isSet→isSet' hA (ret f x) (ret 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 _)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Pointed.Homogeneous.html` {- Definition of a homogeneous pointed type, and proofs that pi, product, path, and discrete types are homogeneous Portions of this file adapted from Nicolai Kraus' code here: https://bitbucket.org/nicolaikraus/agda/src/e30d70c72c6af8e62b72eefabcc57623dd921f04/trunc-inverse.lagda -} module Cubical.Foundations.Pointed.Homogeneous 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.Path open import Cubical.Data.Sigma open import Cubical.Data.Empty as ⊥ open import Cubical.Relation.Nullary open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Pointed.Base open import Cubical.Foundations.Pointed.Properties open import Cubical.Structures.Pointed {- We might say that a type is homogeneous if its automorphism group acts transitively; this could be phrased with a propositional truncation. Here we demand something much stronger, namely that we are given automorphisms that carry the base point to any given point y. If in addition we require this automorphism to be the identity for the base point, then we recover the notion of a left-invertible H-space, and indeed, any homogeneous type in our sense gives rise to such, as shown in: Cubical.Homotopy.HSpace -} isHomogeneous : ∀ {ℓ} → Pointed ℓ → Type (ℓ-suc ℓ) isHomogeneous {ℓ} (A , x) = ∀ y → Path (Pointed ℓ) (A , x) (A , y) -- Pointed functions into a homogeneous type are equal as soon as they are equal -- as unpointed functions →∙Homogeneous≡ : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'} {f∙ g∙ : A∙ →∙ B∙} (h : isHomogeneous B∙) → f∙ .fst ≡ g∙ .fst → f∙ ≡ g∙ →∙Homogeneous≡ {A∙ = A∙@(_ , a₀)} {B∙@(B , _)} {f∙@(_ , f₀)} {g∙@(_ , g₀)} h p = subst (λ Q∙ → PathP (λ i → A∙ →∙ Q∙ i) f∙ g∙) (sym (flipSquare fix)) badPath where badPath : PathP (λ i → A∙ →∙ (B , (sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀) i)) f∙ g∙ badPath i .fst = p i badPath i .snd j = doubleCompPath-filler (sym f₀) (funExt⁻ p a₀) g₀ j i fix : PathP (λ i → B∙ ≡ (B , (sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀) i)) refl refl fix i = hcomp (λ j → λ { (i = i0) → lCancel (h (pt B∙)) j ; (i = i1) → lCancel (h (pt B∙)) j }) (sym (h (pt B∙)) ∙ h ((sym f₀ ∙∙ funExt⁻ p a₀ ∙∙ g₀) i)) →∙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

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Powerset.html` {- This file introduces the "powerset" of a type in the style of Escardó's lecture notes: https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#propositionalextensionality -} module Cubical.Foundations.Powerset where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Structure open import Cubical.Foundations.Function open import Cubical.Foundations.Univalence using (hPropExt) open import Cubical.Data.Sigma private variable ℓ : Level X : Type ℓ ℙ : Type ℓ → Type (ℓ-suc ℓ) ℙ X = X → hProp _ isSetℙ : isSet (ℙ X) isSetℙ = isSetΠ λ x → isSetHProp infix 5 _∈_ _∈_ : {X : Type ℓ} → X → ℙ X → Type ℓ x ∈ A = ⟨ A x ⟩ _⊆_ : {X : Type ℓ} → ℙ X → ℙ X → Type ℓ A ⊆ B = ∀ x → x ∈ A → x ∈ B ∈-isProp : (A : ℙ X) (x : X) → isProp (x ∈ A) ∈-isProp A = snd ∘ A ⊆-isProp : (A B : ℙ X) → isProp (A ⊆ B) ⊆-isProp A B = isPropΠ2 (λ x _ → ∈-isProp B x) ⊆-refl : (A : ℙ X) → A ⊆ A ⊆-refl A x = idfun (x ∈ A) subst-∈ : (A : ℙ X) {x y : X} → x ≡ y → x ∈ A → y ∈ A subst-∈ A = subst (_∈ A) ⊆-refl-consequence : (A B : ℙ X) → A ≡ B → (A ⊆ B) × (B ⊆ A) ⊆-refl-consequence A B p = subst (A ⊆_) p (⊆-refl A) , subst (B ⊆_) (sym p) (⊆-refl B) ⊆-extensionality : (A B : ℙ X) → (A ⊆ B) × (B ⊆ A) → A ≡ B ⊆-extensionality A B (φ , ψ) = funExt (λ x → TypeOfHLevel≡ 1 (hPropExt (A x .snd) (B x .snd) (φ x) (ψ x))) ⊆-trans : (A B C : ℙ X) → A ⊆ B → B ⊆ C → A ⊆ C ⊆-trans A B C φ ψ x = ψ x ∘ φ x ⊆-antisym : (A B : ℙ X) → A ⊆ B → B ⊆ A → A ≡ B ⊆-antisym A B φ ψ = ⊆-extensionality A B (φ , ψ) ⊆-extensionalityEquiv : (A B : ℙ X) → (A ⊆ B) × (B ⊆ A) ≃ (A ≡ B) ⊆-extensionalityEquiv A B = isoToEquiv (iso (⊆-extensionality A B) (⊆-refl-consequence A B) (λ _ → isSetℙ A B _ _) (λ _ → isPropΣ (⊆-isProp A B) (λ _ → ⊆-isProp B A) _ _))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.SIP.html` {- In this file we apply the cubical machinery to Martin Hötzel-Escardó's structure identity principle: https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#sns -} module Cubical.Foundations.SIP where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Univalence renaming (ua-pathToEquiv to ua-pathToEquiv') open import Cubical.Foundations.Transport open import Cubical.Foundations.Function open import Cubical.Foundations.Path open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Data.Sigma open import Cubical.Foundations.Structure public private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ : Level S : Type ℓ₁ → Type ℓ₂ -- Note that for any equivalence (f , e) : X ≃ Y the type ι (X , s) (Y , t) (f , e) need not to be -- a proposition. Indeed this type should correspond to the ways s and t can be identified -- as S-structures. This we call a standard notion of structure or SNS. -- We will use a different definition, but the two definitions are interchangeable. SNS : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃) SNS {ℓ₁} S ι = ∀ {X : Type ℓ₁} (s t : S X) → ι (X , s) (X , t) (idEquiv X) ≃ (s ≡ t) -- We introduce the notation for structure preserving equivalences a -- bit differently, but this definition doesn't actually change from -- Escardó's notes. _≃[_]_ : (A : TypeWithStr ℓ₁ S) (ι : StrEquiv S ℓ₂) (B : TypeWithStr ℓ₁ S) → Type (ℓ-max ℓ₁ ℓ₂) A ≃[ ι ] B = Σ[ e ∈ typ A ≃ typ B ] (ι A B e) -- The following PathP version of SNS is a bit easier to work with -- for the proof of the SIP UnivalentStr : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃) UnivalentStr {ℓ₁} S ι = {A B : TypeWithStr ℓ₁ S} (e : typ A ≃ typ B) → ι A B e ≃ PathP (λ i → S (ua e i)) (str A) (str B) -- A quick sanity-check that our definition is interchangeable with -- Escardó's. The direction SNS→UnivalentStr corresponds more or less -- to a dependent EquivJ formulation of Escardó's homomorphism-lemma. UnivalentStr→SNS : (S : Type ℓ₁ → Type ℓ₂) (ι : StrEquiv S ℓ₃) → UnivalentStr S ι → SNS S ι UnivalentStr→SNS S ι θ {X = X} s t = ι (X , s) (X , t) (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) ⟩ s ≡ t ■ SNS→UnivalentStr : (ι : StrEquiv S ℓ₃) → SNS S ι → UnivalentStr S ι SNS→UnivalentStr {S = S} ι θ {A = A} {B = B} e = EquivJ P C e (str A) (str B) where Y = typ B P : (X : Type _) → X ≃ Y → Type _ P X e' = (s : S X) (t : S Y) → ι (X , s) (Y , t) e' ≃ PathP (λ i → S (ua e' i)) s t 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 ≃⟨ 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} α = {X Y : Type ℓ} (e : X ≃ Y) (s : S X) → equivFun (α e) s ≡ subst S (ua e) s TransportStr→UnivalentStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S) → TransportStr α → UnivalentStr S (EquivAction→StrEquiv α) TransportStr→UnivalentStr {S = S} α τ {X , s} {Y , t} e = equivFun (α e) s ≡ t ≃⟨ pathToEquiv (cong (_≡ t) (τ e s)) ⟩ subst S (ua e) s ≡ t ≃⟨ 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) invTransportStr : {S : Type ℓ → Type ℓ₂} (α : EquivAction S) (τ : TransportStr α) {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) --- We can now define an invertible function --- --- sip : A ≃[ ι ] B → A ≡ B module _ {S : Type ℓ₁ → Type ℓ₂} {ι : StrEquiv S ℓ₃} (θ : UnivalentStr S ι) (A B : TypeWithStr ℓ₁ S) where sip : A ≃[ ι ] B → A ≡ B sip (e , p) i = ua e i , θ e .fst p i SIP : A ≃[ ι ] B ≃ (A ≡ B) SIP = sip , isoToIsEquiv (compIso (Σ-cong-iso (invIso univalenceIso) (equivToIso ∘ θ)) ΣPathIsoPathΣ) sip⁻ : A ≡ B → A ≃[ ι ] B sip⁻ = invEq SIP

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Transport.html` {- Basic theory about transport: - transport is invertible - transport is an equivalence ([pathToEquiv]) -} module Cubical.Foundations.Transport where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv as Equiv hiding (transpEquiv) open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Univalence open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Function using (_∘_) -- Direct definition of transport filler, note that we have to -- explicitly tell Agda that the type is constant (like in CHM) transpFill : ∀ {ℓ} {A : Type ℓ} (φ : I) (A : (i : I) → Type ℓ [ φ ↦ (λ _ → A) ]) (u0 : outS (A i0)) → -------------------------------------- PathP (λ i → outS (A i)) u0 (transp (λ i → outS (A i)) φ u0) transpFill φ A u0 i = transp (λ j → outS (A (i ∧ j))) (~ i ∨ φ) u0 transport⁻ : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → B → A transport⁻ p = transport (λ i → p (~ i)) subst⁻ : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) → B y → B x subst⁻ B p pa = transport⁻ (λ i → B (p i)) pa subst⁻-filler : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) (b : B y) → PathP (λ i → B (p (~ i))) b (subst⁻ B p b) subst⁻-filler B p = subst-filler B (sym p) transport-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → PathP (λ i → A → p i) (λ x → x) (transport p) transport-fillerExt p i x = transport-filler p x i transport⁻-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → PathP (λ i → p i → A) (λ x → x) (transport⁻ p) transport⁻-fillerExt p i x = transp (λ j → p (i ∧ ~ j)) (~ i) x transport-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → PathP (λ i → p i → B) (transport p) (λ x → x) transport-fillerExt⁻ p = symP (transport⁻-fillerExt (sym p)) transport⁻-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → PathP (λ i → B → p i) (transport⁻ p) (λ x → x) transport⁻-fillerExt⁻ p = symP (transport-fillerExt (sym p)) transport⁻-filler : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) (x : B) → PathP (λ i → p (~ i)) x (transport⁻ p x) transport⁻-filler p x = transport-filler (λ i → p (~ i)) x transport⁻Transport : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (a : A) → transport⁻ p (transport p a) ≡ a transport⁻Transport p a j = transport⁻-fillerExt p (~ j) (transport-fillerExt p (~ j) a) transportTransport⁻ : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (b : B) → transport p (transport⁻ p b) ≡ b transportTransport⁻ p b j = transport-fillerExt⁻ p j (transport⁻-fillerExt⁻ p j b) subst⁻Subst : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) → (u : B x) → subst⁻ B p (subst B p u) ≡ u subst⁻Subst {x = x} {y = y} B p u = transport⁻Transport {A = B x} {B = B y} (cong B p) u substSubst⁻ : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) → (v : B y) → subst B p (subst⁻ B p v) ≡ v substSubst⁻ {x = x} {y = y} B p v = transportTransport⁻ {A = B x} {B = B y} (cong B p) v substEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {a a' : A} (P : A → Type ℓ') (p : a ≡ a') → P a ≃ P a' substEquiv P p = (subst P p , isEquivTransport (λ i → P (p i))) subst2Equiv : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {a a' : A} {b b' : B} (P : A → B → Type ℓ'') (p : a ≡ a') (q : b ≡ b') → P a b ≃ P a' b' subst2Equiv P p q = (subst2 P p q , isEquivTransport (λ i → P (p i) (q i))) liftEquiv : ∀ {ℓ ℓ'} {A B : Type ℓ} (P : Type ℓ → Type ℓ') (e : A ≃ B) → P A ≃ P B liftEquiv P e = substEquiv P (ua e) transpEquiv : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → ∀ i → p i ≃ B transpEquiv p = Equiv.transpEquiv (λ i → p i) {-# WARNING_ON_USAGE transpEquiv "Deprecated: Use the more general `transpEquiv` from `Cubical.Foundations.Equiv` instead" #-} uaTransportη : ∀ {ℓ} {A B : Type ℓ} (P : A ≡ B) → ua (pathToEquiv P) ≡ P uaTransportη = uaη {-# WARNING_ON_USAGE uaTransportη "Deprecated: Use `uaη` from `Cubical.Foundations.Univalence` instead of `uaTransportη`" #-} pathToIso : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → Iso A B Iso.fun (pathToIso x) = transport x Iso.inv (pathToIso x) = transport⁻ x Iso.sec (pathToIso x) = transportTransport⁻ x Iso.ret (pathToIso x) = transport⁻Transport x substIso : ∀ {ℓ ℓ'} {A : Type ℓ} (B : A → Type ℓ') {x y : A} (p : x ≡ y) → Iso (B x) (B y) substIso B p = pathToIso (cong B p) -- Redefining substEquiv in terms of substIso gives an explicit inverse substEquiv' : ∀ {ℓ ℓ'} {A : Type ℓ} (B : A → Type ℓ') {x y : A} (p : x ≡ y) → B x ≃ B y substEquiv' B p = isoToEquiv (substIso B p) isInjectiveTransport : ∀ {ℓ : Level} {A B : Type ℓ} {p q : A ≡ B} → transport p ≡ transport q → p ≡ q isInjectiveTransport {p = p} {q} α i = hcomp (λ j → λ { (i = i0) → retEq univalence p j ; (i = i1) → retEq univalence q j }) (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)) _ _ 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) → ∀ {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) -- substituting along a composite path is equivalent to substituting twice substComposite : ∀ {ℓ ℓ'} {A : Type ℓ} → (B : A → Type ℓ') → {x y z : A} (p : x ≡ y) (q : y ≡ z) (u : B x) → subst B (p ∙ q) u ≡ subst B q (subst B p u) substComposite B p q Bx i = transport (cong B (compPath-filler' p q (~ i))) (transport-fillerExt (cong B p) i Bx) -- transporting along a composite path is equivalent to transporting twice transportComposite : ∀ {ℓ} {A B C : Type ℓ} (p : A ≡ B) (q : B ≡ C) (x : A) → transport (p ∙ q) x ≡ transport q (transport p x) transportComposite = substComposite (λ D → D) -- substitution commutes with morphisms in slices substCommSlice : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} → (B : A → Type ℓ') (C : A → Type ℓ'') → (F : ∀ a → B a → C a) → {x y : A} (p : x ≡ y) (u : B x) → subst C p (F x u) ≡ F y (subst B p u) substCommSlice B C F p Bx a = transport-fillerExt⁻ (cong C p) a (F _ (transport-fillerExt (cong B p) a Bx)) constSubstCommSlice : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} → (B : A → Type ℓ') → (C : Type ℓ'') → (F : ∀ a → B a → C) → {x y : A} (p : x ≡ y) (u : B x) → (F x u) ≡ F y (subst B p u) constSubstCommSlice B C F p Bx = (sym (transportRefl (F _ Bx)) ∙ substCommSlice B (λ _ → C) F p Bx) -- transporting over (λ i → B (p i) → C (p i)) divides the transport into -- transports over (λ i → C (p i)) and (λ i → B (p (~ i))) funTypeTransp : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} (B : A → Type ℓ') (C : A → Type ℓ'') {x y : A} (p : x ≡ y) (f : B x → C x) → PathP (λ i → B (p i) → C (p i)) f (subst C p ∘ f ∘ subst B (sym p)) funTypeTransp B C {x = x} p f i b = transp (λ j → C (p (j ∧ i))) (~ i) (f (transp (λ j → B (p (i ∧ ~ j))) (~ i) b)) -- transports between loop spaces preserve path composition overPathFunct : ∀ {ℓ} {A : Type ℓ} {x y : A} (p q : x ≡ x) (P : x ≡ y) → 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) (transportRefl (p ∙ q) ∙ cong₂ _∙_ (sym (transportRefl p)) (sym (transportRefl q))) -- substition over families of paths -- theorem 2.11.3 in The Book substInPaths : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} {a a' : A} → (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')) p=refl p where p=refl : subst (λ y → f y ≡ g y) refl q ≡ refl ∙ q ∙ refl p=refl = subst (λ y → f y ≡ g y) refl q ≡⟨ substRefl {B = (λ y → f y ≡ g y)} q ⟩ q ≡⟨ (rUnit q) ∙ lUnit (q ∙ refl) ⟩ refl ∙ q ∙ refl ∎ flipTransport : ∀ {ℓ} {A : I → Type ℓ} {x : A i0} {y : A i1} → x ≡ transport⁻ (λ i → A i) y → transport (λ i → A i) x ≡ y flipTransport {A = A} {y = y} p = cong (transport (λ i → A i)) p ∙ transportTransport⁻ (λ i → A i) y -- special cases of substInPaths from lemma 2.11.2 in The Book module _ {ℓ : Level} {A : Type ℓ} {a x1 x2 : A} (p : x1 ≡ x2) where substInPathsL : (q : a ≡ x1) → subst (λ x → a ≡ x) p q ≡ q ∙ p substInPathsL q = subst (λ x → a ≡ x) p q ≡⟨ substInPaths (λ _ → a) (λ x → x) p q ⟩ sym (cong (λ _ → a) p) ∙ q ∙ cong (λ x → x) p ≡⟨ assoc (λ _ → a) q p ⟩ (refl ∙ q) ∙ p ≡⟨ cong (_∙ p) (sym (lUnit q)) ⟩ q ∙ p ∎ substInPathsR : (q : x1 ≡ a) → subst (λ x → x ≡ a) p q ≡ sym p ∙ q substInPathsR q = subst (λ x → x ≡ a) p q ≡⟨ substInPaths (λ x → x) (λ _ → a) p q ⟩ sym (cong (λ x → x) p) ∙ q ∙ cong (λ _ → a) p ≡⟨ 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))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Univalence.Dependent.html` {- Dependent Version of Univalence The univalence corresponds to the dependent equivalences/isomorphisms, c.f. `Cubical.Foundations.Equiv.Dependent`. -} module Cubical.Foundations.Univalence.Dependent where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Equiv.HalfAdjoint open import Cubical.Foundations.Equiv.Dependent open import Cubical.Foundations.Univalence private variable ℓ ℓ' : Level -- Dependent Univalence -- -- Given families `P` and `Q` over base types `A` and `B` -- respectively, and given -- * an equivalence of base types `e : A ≃ B`, -- * and and a pointwise equivalence of the families, -- construct a dependent path over `ua e` between the families. module _ {A B : Type ℓ} {P : A → Type ℓ'} {Q : B → Type ℓ'} (e : A ≃ B) (F : mapOver (e .fst) P Q) (equiv : isEquivOver {P = P} {Q = Q} F) where private -- Bundle `F` and `equiv` into a pointwise equivalence of `P` and `Q`: Γ : (a : A) → P a ≃ Q (equivFun e a) Γ a = F a , equiv a -- A quick proof provided by @ecavallo. -- Unfortunately it gives a larger term overall. _ : PathP (λ i → ua e i → Type ℓ') P Q _ = ua→ (λ a → ua (Γ a)) uaOver : PathP (λ i → ua e i → Type ℓ') P Q uaOver i x = Glue Base {φ} equiv-boundary where -- Like `ua`, `uaOver` is obtained from a line of -- Glue-types, except that they are glued -- over a line dependent on `ua e : A ≡ B`. -- `x` is a point along the path `A ≡ B` obtained -- from univalence, i.e. glueing over `B`: -- -- A = = (ua e) = = B -- | | -- (e) (idEquiv B) -- | | -- v v -- B =====(B)====== B _ : Glue B {φ = i ∨ ~ i} (λ { (i = i0) → A , e ; (i = i1) → B , idEquiv B }) _ = x -- We can therefore `unglue` it to obtain a term in the base line of `ua e`, -- i.e. term of type `B`: φ = i ∨ ~ i b : B b = unglue φ x -- This gives us a line `(i : I) ⊢ Base` in the universe of types, -- along which we can glue the equivalences `Γ x` and `idEquiv (Q x)`: -- -- P (e x) = = = = = = Q x -- | | -- (Γ x) (idEquiv (Q x)) -- | | -- v v -- Q x ===(Base)=== Q x Base : Type ℓ' Base = Q b equiv-boundary : Partial φ (Σ[ T ∈ Type ℓ' ] T ≃ Base) equiv-boundary (i = i0) = P x , Γ x equiv-boundary (i = i1) = Q x , idEquiv (Q x) -- Note that above `(i = i0) ⊢ x : A` and `(i = i1) ⊢ x : B`, -- thus `P x` and `Q x` are well-typed. _ : Partial i B _ = λ { (i = i1) → x } _ : Partial (~ i) A _ = λ { (i = i0) → x } -- Dependent `isoToPath` open isHAEquiv isoToPathOver : {A B : Type ℓ} {P : A → Type ℓ'} {Q : B → Type ℓ'} (f : A → B) (hae : isHAEquiv f) (isom : IsoOver (isHAEquiv→Iso hae) P Q) → PathP (λ i → ua (_ , isHAEquiv→isEquiv hae) i → Type ℓ') P Q isoToPathOver f hae isom = uaOver _ _ (isoToEquivOver f hae isom)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Foundations.Univalence.html` {- Proof of the standard formulation of the univalence theorem and various consequences of univalence - Re-exports Glue types from Cubical.Core.Glue - The ua constant and its computation rule (up to a path) - Proof of univalence using that unglue is an equivalence ([EquivContr]) - Equivalence induction ([EquivJ], [elimEquiv]) - Univalence theorem ([univalence]) - The computation rule for ua ([uaβ]) - Isomorphism induction ([elimIso]) -} module Cubical.Foundations.Univalence where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.GroupoidLaws open import Cubical.Data.Sigma.Base open import Cubical.Core.Glue public using (Glue ; glue ; unglue) open import Cubical.Reflection.StrictEquiv private variable ℓ ℓ' : Level -- The ua constant ua : ∀ {A B : Type ℓ} → A ≃ B → A ≡ B ua {A = A} {B = B} e i = Glue B (λ { (i = i0) → (A , e) ; (i = i1) → (B , idEquiv B) }) uaIdEquiv : {A : Type ℓ} → ua (idEquiv A) ≡ refl 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) -- the unglue and glue primitives specialized to the case of ua ua-unglue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : ua e i) → B {- [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → x }) ] -} ua-unglue e i x = unglue (i ∨ ~ i) x ua-glue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : Partial (~ i) A) (y : B [ _ ↦ (λ { (i = i0) → e .fst (x 1=1) }) ]) → ua e i {- [ _ ↦ (λ { (i = i0) → x 1=1 ; (i = i1) → outS y }) ] -} ua-glue e i x y = glue {φ = i ∨ ~ i} (λ { (i = i0) → x 1=1 ; (i = i1) → outS y }) (outS y) module _ {A B : Type ℓ} (e : A ≃ B) {x : A} {y : B} where -- sometimes more useful are versions of these functions with the (i : I) factored in ua-ungluePath : PathP (λ i → ua e i) x y → e .fst x ≡ y ua-ungluePath p i = ua-unglue e i (p i) ua-gluePath : e .fst x ≡ y → PathP (λ i → ua e i) x y ua-gluePath p i = ua-glue e i (λ { (i = i0) → x }) (inS (p i)) -- ua-ungluePath and ua-gluePath are definitional inverses ua-ungluePath-Equiv : (PathP (λ i → ua e i) x y) ≃ (e .fst x ≡ y) unquoteDef ua-ungluePath-Equiv = defStrictEquiv ua-ungluePath-Equiv ua-ungluePath ua-gluePath ua-ungluePathExt : {A B : Type ℓ} (e : A ≃ B) → PathP (λ i → ua e i → B) (fst e) (idfun B) ua-ungluePathExt e i = ua-unglue e i ua-gluePathExt : {A B : Type ℓ} (e : A ≃ B) → PathP (λ i → A → ua e i) (idfun _) (fst e) ua-gluePathExt e i x = ua-glue e i (λ { (i = i0) → x }) (inS (fst e x)) -- ua-unglue and ua-glue are also definitional inverses, in a way -- strengthening the types of ua-unglue and ua-glue gives a nicer formulation of this, see below ua-unglue-glue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : Partial (~ i) A) (y : B [ _ ↦ _ ]) → ua-unglue e i (ua-glue e i x y) ≡ outS y ua-unglue-glue _ _ _ _ = refl ua-glue-unglue : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : ua e i) → ua-glue e i (λ { (i = i0) → x }) (inS (ua-unglue e i x)) ≡ x ua-glue-unglue _ _ _ = refl -- mainly for documentation purposes, ua-unglue and ua-glue wrapped in cubical subtypes ua-unglueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B) → ua e i [ _ ↦ (λ { (i = i0) → x ; (i = i1) → y }) ] → B [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ] ua-unglueS e i x y s = inS (ua-unglue e i (outS s)) ua-glueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B) → B [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ] → ua e i [ _ ↦ (λ { (i = i0) → x ; (i = i1) → y }) ] ua-glueS e i x y s = inS (ua-glue e i (λ { (i = i0) → x }) (inS (outS s))) ua-unglueS-glueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B) (s : B [ _ ↦ (λ { (i = i0) → e .fst x ; (i = i1) → y }) ]) → outS (ua-unglueS e i x y (ua-glueS e i x y s)) ≡ outS s ua-unglueS-glueS _ _ _ _ _ = refl ua-glueS-unglueS : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) (y : B) (s : ua e i [ _ ↦ (λ { (i = i0) → x ; (i = i1) → y }) ]) → outS (ua-glueS e i x y (ua-unglueS e i x y s)) ≡ outS s ua-glueS-unglueS _ _ _ _ _ = refl -- a version of ua-glue with a single endpoint, identical to `ua-gluePath e {x} refl i` ua-gluePt : ∀ {A B : Type ℓ} (e : A ≃ B) (i : I) (x : A) → ua e i {- [ _ ↦ (λ { (i = i0) → x ; (i = i1) → e .fst x }) ] -} ua-gluePt e i x = ua-glue e i (λ { (i = i0) → x }) (inS (e .fst x)) -- Proof of univalence using that unglue is an equivalence: -- unglue is an equivalence unglueIsEquiv : ∀ (A : Type ℓ) (φ : I) (f : PartialP φ (λ o → Σ[ T ∈ Type ℓ ] T ≃ A)) → isEquiv {A = Glue A f} (unglue φ) equiv-proof (unglueIsEquiv A φ f) = λ (b : A) → let u : I → Partial φ A u i = λ{ (φ = i1) → equivCtr (f 1=1 .snd) b .snd (~ i) } ctr : fiber (unglue φ) b ctr = ( glue (λ { (φ = i1) → equivCtr (f 1=1 .snd) b .fst }) (hcomp u b) , λ j → hfill u (inS b) (~ j)) in ( ctr , λ (v : fiber (unglue φ) b) i → let u' : I → Partial (φ ∨ ~ i ∨ i) A u' j = λ { (φ = i1) → equivCtrPath (f 1=1 .snd) b v i .snd (~ j) ; (i = i0) → hfill u (inS b) j ; (i = i1) → v .snd (~ j) } in ( glue (λ { (φ = i1) → equivCtrPath (f 1=1 .snd) b v i .fst }) (hcomp u' b) , λ j → hfill u' (inS b) (~ j))) -- Any partial family of equivalences can be extended to a total one -- from Glue [ φ ↦ (T,f) ] A to A unglueEquiv : ∀ (A : Type ℓ) (φ : I) (f : PartialP φ (λ o → Σ[ T ∈ Type ℓ ] T ≃ A)) → (Glue A f) ≃ A unglueEquiv A φ f = ( unglue φ , unglueIsEquiv A φ f ) ua-unglueEquiv : ∀ {A B : Type ℓ} (e : A ≃ B) → PathP (λ i → ua e i ≃ B) e (idEquiv _) fst (ua-unglueEquiv e i) = ua-unglue e i snd (ua-unglueEquiv e i) = isProp→PathP (λ i → isPropIsEquiv (ua-unglue e i)) (snd e) (idIsEquiv _) i -- The following is a formulation of univalence proposed by Martín Escardó: -- https://groups.google.com/forum/#!msg/homotopytypetheory/HfCB_b-PNEU/Ibb48LvUMeUJ -- See also Theorem 5.8.4 of the HoTT Book. -- -- The reason we have this formulation in the core library and not the -- standard one is that this one is more direct to prove using that -- unglue is an equivalence. The standard formulation can be found in -- Cubical/Basics/Univalence. -- EquivContr : ∀ (A : Type ℓ) → ∃![ T ∈ Type ℓ ] (T ≃ A) EquivContr {ℓ = ℓ} A = ( (A , idEquiv A) , idEquiv≡ ) where idEquiv≡ : (y : Σ (Type ℓ) (λ T → T ≃ A)) → (A , idEquiv A) ≡ y idEquiv≡ w = \ { i .fst → Glue A (f i) ; i .snd .fst → unglueEquiv _ _ (f i) .fst ; i .snd .snd .equiv-proof → unglueEquiv _ _ (f i) .snd .equiv-proof } where f : ∀ i → PartialP (~ i ∨ i) (λ x → Σ[ T ∈ Type ℓ ] T ≃ A) f i = λ { (i = i0) → A , idEquiv A ; (i = i1) → w } 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) -- Equivalence induction EquivJ : {A B : Type ℓ} (P : (A : Type ℓ) → (e : A ≃ B) → Type ℓ') → (r : P B (idEquiv B)) → (e : A ≃ B) → P A e EquivJ P r e = subst (λ x → P (x .fst) (x .snd)) (contrSinglEquiv e) r -- Transport along a path is an equivalence. -- The proof is a special case of isEquivTransp where the line of types is -- given by p, and the extend φ -- where the transport is constant -- is i0. isEquivTransport : {A B : Type ℓ} (p : A ≡ B) → isEquiv (transport p) isEquivTransport p = isEquivTransp A φ where A : I → Type _ A i = p i φ : I φ = i0 pathToEquiv : {A B : Type ℓ} → A ≡ B → A ≃ B pathToEquiv p .fst = transport p pathToEquiv p .snd = isEquivTransport p pathToEquivRefl : {A : Type ℓ} → pathToEquiv refl ≡ idEquiv A 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: -- https://github.com/mortberg/cubicaltt/blob/master/examples/univalence.ctt#L202 uaβ : {A B : Type ℓ} (e : A ≃ B) (x : A) → transport (ua e) x ≡ equivFun e x uaβ e x = transportRefl (equivFun e x) ~uaβ : {A B : Type ℓ} (e : A ≃ B) (x : B) → transport (sym (ua e)) x ≡ invEq e x ~uaβ e x = cong (invEq e) (transportRefl x) uaη : ∀ {A B : Type ℓ} → (P : A ≡ B) → ua (pathToEquiv P) ≡ P uaη {A = A} {B = B} P i j = Glue B {φ = φ} sides where -- Adapted from a proof by @dolio, cf. commit e42a6fa1 φ = i ∨ j ∨ ~ j sides : Partial φ (Σ[ T ∈ Type _ ] T ≃ B) sides (i = i1) = P j , transpEquiv (λ k → P k) j sides (j = i0) = A , pathToEquiv P 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)) ua-pathToEquiv : {A B : Type ℓ} (p : A ≡ B) → ua (pathToEquiv p) ≡ p ua-pathToEquiv = uaη -- Univalence univalenceIso : {A B : Type ℓ} → Iso (A ≡ B) (A ≃ B) univalenceIso .Iso.fun = pathToEquiv univalenceIso .Iso.inv = ua univalenceIso .Iso.sec = pathToEquiv-ua univalenceIso .Iso.ret = ua-pathToEquiv isEquivPathToEquiv : {A B : Type ℓ} → isEquiv (pathToEquiv {A = A} {B = B}) isEquivPathToEquiv = isoToIsEquiv univalenceIso univalence : {A B : Type ℓ} → (A ≡ B) ≃ (A ≃ B) univalence .fst = pathToEquiv univalence .snd = isEquivPathToEquiv -- Assuming that we have an inverse to ua we can easily prove univalence module Univalence (au : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → A ≃ B) (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) (cong ua aurefl ∙ uaIdEquiv) au-ua : {A B : Type ℓ} (e : A ≃ B) → au (ua e) ≡ e au-ua {B = B} = EquivJ (λ _ f → au (ua f) ≡ f) (subst (λ r → au r ≡ idEquiv _) (sym uaIdEquiv) aurefl) isoThm : ∀ {ℓ} {A B : Type ℓ} → Iso (A ≡ B) (A ≃ B) isoThm .Iso.fun = au isoThm .Iso.inv = ua isoThm .Iso.sec = au-ua isoThm .Iso.ret = ua-au thm : ∀ {ℓ} {A B : Type ℓ} → isEquiv au thm {A = A} {B = B} = isoToIsEquiv {B = A ≃ B} isoThm -- 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 eqweqmapid : {A : Type ℓ} → eqweqmap refl ≡ idEquiv A eqweqmapid {A = A} = JRefl (λ X _ → A ≃ X) (idEquiv A) univalenceStatement : {A B : Type ℓ} → isEquiv (eqweqmap {ℓ} {A} {B}) univalenceStatement = Univalence.thm eqweqmap eqweqmapid univalenceUAH : {A B : Type ℓ} → (A ≡ B) ≃ (A ≃ B) univalenceUAH = ( _ , univalenceStatement ) 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 ℓ'} {f₀ : A₀ → B i0} {f₁ : A₁ → B i1} → ((a : A₀) → PathP B (f₀ a) (f₁ (e .fst a))) → PathP (λ i → ua e i → B i) f₀ f₁ ua→ {e = e} {f₀ = f₀} {f₁} h i a = hcomp (λ j → λ { (i = i0) → f₀ a ; (i = i1) → f₁ (lem a j) }) (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 _ ua→⁻ : ∀ {ℓ ℓ'} {A₀ A₁ : Type ℓ} {e : A₀ ≃ A₁} {B : (i : I) → Type ℓ'} {f₀ : A₀ → B i0} {f₁ : A₁ → B i1} → PathP (λ i → ua e i → B i) f₀ f₁ → ((a : A₀) → PathP B (f₀ a) (f₁ (e .fst a))) ua→⁻ {e = e} {f₀ = f₀} {f₁} p a i = hcomp (λ k → λ { (i = i0) → f₀ a ; (i = i1) → f₁ (uaβ e a k) }) (p i (transp (λ j → ua e (j ∧ i)) (~ i) a)) ua→2 : ∀ {ℓ ℓ' ℓ''} {A₀ A₁ : Type ℓ} {e₁ : A₀ ≃ A₁} {B₀ B₁ : Type ℓ'} {e₂ : B₀ ≃ B₁} {C : (i : I) → Type ℓ''} {f₀ : A₀ → B₀ → C i0} {f₁ : A₁ → B₁ → C i1} → (∀ a b → PathP C (f₀ a b) (f₁ (e₁ .fst a) (e₂ .fst b))) → PathP (λ i → ua e₁ i → ua e₂ i → C i) f₀ f₁ ua→2 h = ua→ (ua→ ∘ h) -- 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 -- 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)) transportUAop₂ e f x y 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 ℓ') → (r : P B (idfun B)) → (e : A ≃ B) → P A (e .fst) elimEquivFun P r e = subst (λ x → P (x .fst) (x .snd .fst)) (contrSinglEquiv e) r -- Isomorphism induction elimIso : {B : Type ℓ} → (Q : {A : Type ℓ} → (A → B) → (B → A) → Type ℓ') → (h : Q (idfun B) (idfun B)) → {A : Type ℓ} → (f : A → B) → (g : B → A) → section f g → retract f g → Q f g elimIso {ℓ} {ℓ'} {B} Q h {A} f g sfg rfg = rem1 f g sfg rfg where P : (A : Type ℓ) → (f : A → B) → Type (ℓ-max ℓ' ℓ) P A f = (g : B → A) → section f g → retract f g → Q f g rem : P B (idfun B) rem g sfg rfg = subst (Q (idfun B)) (λ i b → (sfg b) (~ i)) h rem1 : {A : Type ℓ} → (f : A → B) → P A f 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)) 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))))

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.HITs.AssocList.Properties.html` module Cubical.HITs.AssocList.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Function open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.HLevels open import Cubical.Foundations.Univalence open import Cubical.Foundations.SIP open import Cubical.Relation.Nullary open import Cubical.Structures.MultiSet open import Cubical.Data.Nat using (ℕ; zero; suc; _+_; +-assoc; isSetℕ) open import Cubical.HITs.AssocList.Base as AL open import Cubical.HITs.FiniteMultiset as FMS hiding (_++_; unitl-++; unitr-++; assoc-++; cons-++; comm-++) private variable ℓ : Level A : Type ℓ multiPer : (a b : A) (m n : ℕ) (xs : AssocList A) → ⟨ a , m ⟩∷ ⟨ b , n ⟩∷ xs ≡ ⟨ b , n ⟩∷ ⟨ a , m ⟩∷ xs multiPer a b zero n xs = del a (⟨ b , n ⟩∷ xs) ∙ cong (λ ys → ⟨ b , n ⟩∷ ys) (sym (del a xs)) multiPer a b (suc m) zero xs = cong (λ ys → ⟨ a , suc m ⟩∷ ys) (del b xs) ∙ sym (del b (⟨ a , suc m ⟩∷ xs)) multiPer a b (suc m) (suc n) xs = ⟨ a , suc m ⟩∷ ⟨ b , suc n ⟩∷ xs ≡⟨ sym (agg a 1 m (⟨ b , suc n ⟩∷ xs)) ⟩ ⟨ a , 1 ⟩∷ ⟨ a , m ⟩∷ ⟨ b , suc n ⟩∷ xs ≡⟨ cong (λ ys → ⟨ a , 1 ⟩∷ ys) (multiPer a b m (suc n) xs) ⟩ ⟨ a , 1 ⟩∷ ⟨ b , suc n ⟩∷ ⟨ a , m ⟩∷ xs ≡⟨ cong (λ ys → ⟨ a , 1 ⟩∷ ys) (sym (agg b 1 n (⟨ a , m ⟩∷ xs))) ⟩ ⟨ a , 1 ⟩∷ ⟨ b , 1 ⟩∷ ⟨ b , n ⟩∷ ⟨ a , m ⟩∷ xs ≡⟨ per a b (⟨ b , n ⟩∷ ⟨ a , m ⟩∷ xs) ⟩ ⟨ b , 1 ⟩∷ ⟨ a , 1 ⟩∷ ⟨ b , n ⟩∷ ⟨ a , m ⟩∷ xs ≡⟨ cong (λ ys → ⟨ b , 1 ⟩∷ ⟨ a , 1 ⟩∷ ys) (multiPer b a n m xs) ⟩ ⟨ b , 1 ⟩∷ ⟨ a , 1 ⟩∷ ⟨ a , m ⟩∷ ⟨ b , n ⟩∷ xs ≡⟨ cong (λ ys → ⟨ b , 1 ⟩∷ ys) (agg a 1 m (⟨ b , n ⟩∷ xs)) ⟩ ⟨ b , 1 ⟩∷ ⟨ a , suc m ⟩∷ ⟨ b , n ⟩∷ xs ≡⟨ cong (λ ys → ⟨ b , 1 ⟩∷ ys) (multiPer a b (suc m) n xs) ⟩ ⟨ b , 1 ⟩∷ ⟨ b , n ⟩∷ ⟨ a , suc m ⟩∷ xs ≡⟨ agg b 1 n (⟨ a , suc m ⟩∷ xs) ⟩ ⟨ b , suc n ⟩∷ ⟨ a , suc m ⟩∷ xs ∎ -- Show that association lists and finite multisets are equivalent multi-∷ : A → ℕ → FMSet A → FMSet A multi-∷ x zero xs = xs multi-∷ x (suc n) xs = x ∷ multi-∷ x n xs multi-∷-agg : (x : A) (m n : ℕ) (b : FMSet A) → multi-∷ x m (multi-∷ x n b) ≡ multi-∷ x (m + n) b multi-∷-agg x zero n b = refl multi-∷-agg x (suc m) n b i = x ∷ (multi-∷-agg x m n b i) infixr 30 _++_ _++_ : (xs ys : AssocList A) → AssocList A ⟨⟩ ++ ys = ys (⟨ a , n ⟩∷ xs) ++ ys = ⟨ a , n ⟩∷ (xs ++ ys) per a b xs i ++ ys = per a b (xs ++ ys) i agg a m n xs i ++ ys = agg a m n (xs ++ ys) i del a xs i ++ ys = del a (xs ++ ys) i trunc xs ys p q i j ++ zs = trunc (xs ++ zs) (ys ++ zs) (cong (_++ _) p) (cong (_++ _) q) i j unitl-++ : (xs : AssocList A) → ⟨⟩ ++ xs ≡ xs unitl-++ xs = refl unitr-++ : (xs : AssocList A) → xs ++ ⟨⟩ ≡ xs unitr-++ = AL.ElimProp.f (trunc _ _) refl λ _ _ → cong (⟨ _ , _ ⟩∷_) assoc-++ : (xs ys zs : AssocList A) → xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs assoc-++ = AL.ElimProp.f (isPropΠ2 (λ _ _ → trunc _ _)) (λ ys zs → refl) λ x n p ys zs → cong (⟨ _ , _ ⟩∷_) (p ys zs) cons-++ : ∀ x n (xs : AssocList A) → ⟨ x , n ⟩∷ xs ≡ xs ++ (⟨ x , n ⟩∷ ⟨⟩) cons-++ x n = AL.ElimProp.f (trunc _ _) refl λ y m p → multiPer _ _ _ _ _ ∙ cong (⟨ _ , _ ⟩∷_) p comm-++ : (xs ys : AssocList A) → xs ++ ys ≡ ys ++ xs comm-++ = AL.ElimProp.f (isPropΠ (λ _ → trunc _ _)) (sym ∘ unitr-++) λ x n {xs} p ys → cong (⟨ _ , _ ⟩∷_) (p ys) ∙ cong (_++ _) (cons-++ x n ys) ∙ sym (assoc-++ ys _ xs) AL→FMS : AssocList A → FMSet A AL→FMS = AL.Rec.f FMS.trunc [] multi-∷ comm multi-∷-agg λ _ _ → refl FMS→AL : FMSet A → AssocList A FMS→AL = FMS.Rec.f AL.trunc ⟨⟩ (λ x xs → ⟨ x , 1 ⟩∷ xs) per AL→FMS∘FMS→AL≡id : section {A = AssocList A} AL→FMS FMS→AL AL→FMS∘FMS→AL≡id = FMS.ElimProp.f (FMS.trunc _ _) refl (λ x p → cong (λ ys → x ∷ ys) p) -- need a little lemma for other direction multi-∷-id : (x : A) (n : ℕ) (u : FMSet A) → FMS→AL (multi-∷ x n u) ≡ ⟨ x , n ⟩∷ FMS→AL u multi-∷-id x zero u = sym (del x (FMS→AL u)) multi-∷-id x (suc n) u = FMS→AL (multi-∷ x (suc n) u) ≡⟨ cong (λ ys → ⟨ x , 1 ⟩∷ ys) (multi-∷-id x n u) ⟩ ⟨ x , 1 ⟩∷ ⟨ x , n ⟩∷ (FMS→AL u) ≡⟨ agg x 1 n (FMS→AL u) ⟩ ⟨ x , (suc n) ⟩∷ (FMS→AL u) ∎ FMS→AL∘AL→FMS≡id : retract {A = AssocList A} AL→FMS FMS→AL FMS→AL∘AL→FMS≡id = AL.ElimProp.f (AL.trunc _ _) refl (λ x n {xs} p → (multi-∷-id x n (AL→FMS xs)) ∙ cong (λ ys → ⟨ x , n ⟩∷ ys) p) AssocList≃FMSet : AssocList A ≃ FMSet A AssocList≃FMSet = isoToEquiv (iso AL→FMS FMS→AL AL→FMS∘FMS→AL≡id FMS→AL∘AL→FMS≡id) FMSet≃AssocList : FMSet A ≃ AssocList A FMSet≃AssocList = isoToEquiv (iso FMS→AL AL→FMS FMS→AL∘AL→FMS≡id AL→FMS∘FMS→AL≡id) AssocList≡FMSet : AssocList A ≡ FMSet A AssocList≡FMSet = ua AssocList≃FMSet -- We want to define a multiset structure on AssocList A, we use the recursor to define the count-function module _(discA : Discrete A) where setA = Discrete→isSet discA ALcount-⟨,⟩∷* : A → A → ℕ → ℕ → ℕ ALcount-⟨,⟩∷* a x n xs with discA a x ... | yes a≡x = n + xs ... | no a≢x = xs ALcount-per* : (a x y : A) (xs : ℕ) → ALcount-⟨,⟩∷* a x 1 (ALcount-⟨,⟩∷* a y 1 xs) ≡ ALcount-⟨,⟩∷* a y 1 (ALcount-⟨,⟩∷* a x 1 xs) ALcount-per* a x y xs with discA a x | discA a y ALcount-per* a x y xs | yes a≡x | yes a≡y = refl ALcount-per* a x y xs | yes a≡x | no a≢y = refl ALcount-per* a x y xs | no a≢x | yes a≡y = refl ALcount-per* a x y xs | no a≢x | no a≢y = refl ALcount-agg* : (a x : A) (m n xs : ℕ) → ALcount-⟨,⟩∷* a x m (ALcount-⟨,⟩∷* a x n xs) ≡ ALcount-⟨,⟩∷* a x (m + n) xs ALcount-agg* a x m n xs with discA a x ... | yes _ = +-assoc m n xs ... | no _ = refl ALcount-del* : (a x : A) (xs : ℕ) → ALcount-⟨,⟩∷* a x 0 xs ≡ xs ALcount-del* a x xs with discA a x ... | yes _ = refl ... | no _ = refl ALcount : A → AssocList A → ℕ ALcount a = AL.Rec.f isSetℕ 0 (ALcount-⟨,⟩∷* a) (ALcount-per* a) (ALcount-agg* a) (ALcount-del* a) AL-with-str : MultiSet A setA AL-with-str = (AssocList A , ⟨⟩ , ⟨_, 1 ⟩∷_ , ALcount) -- We want to show that Al-with-str ≅ FMS-with-str as multiset-structures FMS→AL-EquivStr : MultiSetEquivStr A setA (FMS-with-str discA) (AL-with-str) FMSet≃AssocList FMS→AL-EquivStr = refl , (λ a xs → refl) , φ where φ : ∀ a xs → FMScount discA a xs ≡ ALcount a (FMS→AL xs) φ a = FMS.ElimProp.f (isSetℕ _ _) refl ψ where ψ : (x : A) {xs : FMSet A} → FMScount discA a xs ≡ ALcount a (FMS→AL xs) → FMScount discA a (x ∷ xs) ≡ ALcount a (FMS→AL (x ∷ xs)) ψ x {xs} p = subst B α θ where B = λ ys → FMScount discA a (x ∷ xs) ≡ ALcount a ys α : ⟨ x , 1 ⟩∷ FMS→AL xs ≡ FMS→AL (x ∷ xs) α = sym (multi-∷-id x 1 xs) θ : FMScount discA a (x ∷ xs) ≡ ALcount a (⟨ x , 1 ⟩∷ (FMS→AL xs)) θ with discA a x ... | yes _ = cong suc p ... | no ¬p = p FMS-with-str≡AL-with-str : FMS-with-str discA ≡ AL-with-str FMS-with-str≡AL-with-str = sip (multiSetUnivalentStr A setA) (FMS-with-str discA) AL-with-str (FMSet≃AssocList , FMS→AL-EquivStr)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.HITs.James.Inductive.Reduced.html` {- This file contains: - Some alternative inductive definitions of James, and they give the same results. The most relevant one is called `𝕁Red` because it is much simpler. It has fewer constructors, among which the 2-dimensional constructor `coh` has a form essentially more clearer, and it avoids indexes. -} module Cubical.HITs.James.Inductive.Reduced where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Pointed open import Cubical.Foundations.Univalence open import Cubical.Data.Nat open import Cubical.HITs.SequentialColimit open import Cubical.HITs.James.Inductive.Base renaming (𝕁ames to 𝕁amesConstruction ; 𝕁ames∞ to 𝕁ames∞Construction) private variable ℓ : Level module _ ((X , x₀) : Pointed ℓ) where infixr 5 _∷_ -- Inductive James with fewer constructors data 𝕁Red : Type ℓ where [] : 𝕁Red _∷_ : X → 𝕁Red → 𝕁Red unit : (x : X)(xs : 𝕁Red) → x₀ ∷ x ∷ xs ≡ x ∷ x₀ ∷ xs coh : (xs : 𝕁Red) → refl ≡ unit x₀ xs data 𝕁Red∞ : Type ℓ where incl : 𝕁Red → 𝕁Red∞ push : (xs : 𝕁Red) → incl xs ≡ incl (x₀ ∷ xs) -- Auxiliary constructions -- The following square of types is defined as HIT over I × I. -- Notice that the constructor `incl∷` can be seen parametrized by i, `coh` by both i j, -- and other constructors are constant. data 𝕁Square (i j : I) : Type ℓ where [] : 𝕁Square i j _∷_ : X → 𝕁Square i j → 𝕁Square i j incl : 𝕁Square i j → 𝕁Square i j unit : (xs : 𝕁Square i j) → incl xs ≡ x₀ ∷ xs incl∷ : (x : X)(xs : 𝕁Square i j) → unit (x ∷ xs) i ≡ x ∷ unit xs i coh : (xs : 𝕁Square i j) → PathP (λ k → unit (unit xs (i ∨ k)) i ≡ unit (unit xs i) (i ∨ j ∨ k)) (λ k → unit (unit xs i) (i ∨ j ∧ k)) (incl∷ x₀ xs) -- What we need actually is its diagonal. 𝕁Path : I → Type ℓ 𝕁Path i = 𝕁Square i (~ i) -- If you expand the very definition at end points, -- you will find that `𝕁Red` is almost a deformation retraction of `𝕁1`, -- and `𝕁0` is almost the same as the original inductive definition of James. -- That explains why the isomorphisms given bellow are mainly of c-c, c-v and refls. 𝕁0 = 𝕁Path i0 𝕁1 = 𝕁Path i1 data 𝕁Path∞ (i : I) : Type ℓ where incl : 𝕁Path i → 𝕁Path∞ i push : (xs : 𝕁Path i) → incl xs ≡ incl (unit xs i) 𝕁0∞ = 𝕁Path∞ i0 𝕁1∞ = 𝕁Path∞ i1 -- The equivalence 𝕁1 ≃ 𝕁Red -- This part reduces the constructors. 𝕁1→𝕁Red : 𝕁1 → 𝕁Red 𝕁1→𝕁Red [] = [] 𝕁1→𝕁Red (x ∷ xs) = x ∷ 𝕁1→𝕁Red xs 𝕁1→𝕁Red (incl xs) = x₀ ∷ 𝕁1→𝕁Red xs 𝕁1→𝕁Red (incl∷ x xs i) = unit x (𝕁1→𝕁Red xs) i 𝕁1→𝕁Red (unit xs i) = x₀ ∷ 𝕁1→𝕁Red xs 𝕁1→𝕁Red (coh xs i j) = coh (𝕁1→𝕁Red xs) i j 𝕁Red→𝕁1 : 𝕁Red → 𝕁1 𝕁Red→𝕁1 [] = [] 𝕁Red→𝕁1 (x ∷ xs) = x ∷ 𝕁Red→𝕁1 xs 𝕁Red→𝕁1 (unit x xs i) = incl∷ x (𝕁Red→𝕁1 xs) i 𝕁Red→𝕁1 (coh xs i j) = coh (𝕁Red→𝕁1 xs) i j 𝕁Red→𝕁1→𝕁Red : (xs : 𝕁Red) → 𝕁1→𝕁Red (𝕁Red→𝕁1 xs) ≡ xs 𝕁Red→𝕁1→𝕁Red [] = refl 𝕁Red→𝕁1→𝕁Red (x ∷ xs) t = x ∷ 𝕁Red→𝕁1→𝕁Red xs t 𝕁Red→𝕁1→𝕁Red (unit x xs i) t = unit x (𝕁Red→𝕁1→𝕁Red xs t) i 𝕁Red→𝕁1→𝕁Red (coh xs i j) t = coh (𝕁Red→𝕁1→𝕁Red xs t) i j 𝕁1→𝕁Red→𝕁1 : (xs : 𝕁1) → 𝕁Red→𝕁1 (𝕁1→𝕁Red xs) ≡ xs 𝕁1→𝕁Red→𝕁1 [] = refl 𝕁1→𝕁Red→𝕁1 (x ∷ xs) t = x ∷ 𝕁1→𝕁Red→𝕁1 xs t 𝕁1→𝕁Red→𝕁1 (incl xs) = (λ t → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs t) ∙ sym (unit xs) 𝕁1→𝕁Red→𝕁1 (incl∷ x xs i) t = incl∷ x (𝕁1→𝕁Red→𝕁1 xs t) i 𝕁1→𝕁Red→𝕁1 (unit xs i) j = hcomp (λ k → λ { (i = i0) → compPath-filler (λ t → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs t) (sym (unit xs)) k j ; (i = i1) → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs j ; (j = i0) → x₀ ∷ 𝕁Red→𝕁1 (𝕁1→𝕁Red xs) ; (j = i1) → unit xs (i ∨ ~ k)}) (x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs j) 𝕁1→𝕁Red→𝕁1 (coh xs i j) t = coh (𝕁1→𝕁Red→𝕁1 xs t) i j 𝕁Red∞→𝕁1∞ : 𝕁Red∞ → 𝕁1∞ 𝕁Red∞→𝕁1∞ (incl xs) = incl (𝕁Red→𝕁1 xs) 𝕁Red∞→𝕁1∞ (push xs i) = push (𝕁Red→𝕁1 xs) i 𝕁1∞→𝕁Red∞ : 𝕁1∞ → 𝕁Red∞ 𝕁1∞→𝕁Red∞ (incl xs) = incl (𝕁1→𝕁Red xs) 𝕁1∞→𝕁Red∞ (push xs i) = push (𝕁1→𝕁Red xs) i 𝕁Red∞→𝕁1∞→𝕁Red∞ : (xs : 𝕁Red∞) → 𝕁1∞→𝕁Red∞ (𝕁Red∞→𝕁1∞ xs) ≡ xs 𝕁Red∞→𝕁1∞→𝕁Red∞ (incl xs) t = incl (𝕁Red→𝕁1→𝕁Red xs t) 𝕁Red∞→𝕁1∞→𝕁Red∞ (push xs i) t = push (𝕁Red→𝕁1→𝕁Red xs t) i 𝕁1∞→𝕁Red∞→𝕁1∞ : (xs : 𝕁1∞) → 𝕁Red∞→𝕁1∞ (𝕁1∞→𝕁Red∞ xs) ≡ xs 𝕁1∞→𝕁Red∞→𝕁1∞ (incl xs) t = incl (𝕁1→𝕁Red→𝕁1 xs t) 𝕁1∞→𝕁Red∞→𝕁1∞ (push xs i) t = push (𝕁1→𝕁Red→𝕁1 xs t) i 𝕁1∞≃𝕁Red∞ : 𝕁1∞ ≃ 𝕁Red∞ 𝕁1∞≃𝕁Red∞ = isoToEquiv (iso 𝕁1∞→𝕁Red∞ 𝕁Red∞→𝕁1∞ 𝕁Red∞→𝕁1∞→𝕁Red∞ 𝕁1∞→𝕁Red∞→𝕁1∞) -- The equivalence 𝕁ames ≃ 𝕁0 -- This part removes the indexes. private 𝕁ames = 𝕁amesConstruction (X , x₀) 𝕁ames∞ = 𝕁ames∞Construction (X , x₀) index : 𝕁0 → ℕ index [] = 0 index (x ∷ xs) = 1 + index xs index (incl xs) = 1 + index xs index (incl∷ x xs i) = 2 + index xs index (unit xs i) = 1 + index xs index (coh xs i j) = 2 + index xs 𝕁ames→𝕁0 : {n : ℕ} → 𝕁ames n → 𝕁0 𝕁ames→𝕁0 [] = [] 𝕁ames→𝕁0 (x ∷ xs) = x ∷ 𝕁ames→𝕁0 xs 𝕁ames→𝕁0 (incl xs) = incl (𝕁ames→𝕁0 xs) 𝕁ames→𝕁0 (incl∷ x xs i) = incl∷ x (𝕁ames→𝕁0 xs) i 𝕁ames→𝕁0 (unit xs i) = unit (𝕁ames→𝕁0 xs) i 𝕁ames→𝕁0 (coh xs i j) = coh (𝕁ames→𝕁0 xs) i j 𝕁0→𝕁ames : (xs : 𝕁0) → 𝕁ames (index xs) 𝕁0→𝕁ames [] = [] 𝕁0→𝕁ames (x ∷ xs) = x ∷ 𝕁0→𝕁ames xs 𝕁0→𝕁ames (incl xs) = incl (𝕁0→𝕁ames xs) 𝕁0→𝕁ames (incl∷ x xs i) = incl∷ x (𝕁0→𝕁ames xs) i 𝕁0→𝕁ames (unit xs i) = unit (𝕁0→𝕁ames xs) i 𝕁0→𝕁ames (coh xs i j) = coh (𝕁0→𝕁ames xs) i j 𝕁0→𝕁ames→𝕁0 : (xs : 𝕁0) → 𝕁ames→𝕁0 (𝕁0→𝕁ames xs) ≡ xs 𝕁0→𝕁ames→𝕁0 [] = refl 𝕁0→𝕁ames→𝕁0 (x ∷ xs) t = x ∷ 𝕁0→𝕁ames→𝕁0 xs t 𝕁0→𝕁ames→𝕁0 (incl xs) t = incl (𝕁0→𝕁ames→𝕁0 xs t) 𝕁0→𝕁ames→𝕁0 (incl∷ x xs i) t = incl∷ x (𝕁0→𝕁ames→𝕁0 xs t) i 𝕁0→𝕁ames→𝕁0 (unit xs i) t = unit (𝕁0→𝕁ames→𝕁0 xs t) i 𝕁0→𝕁ames→𝕁0 (coh xs i j) t = coh (𝕁0→𝕁ames→𝕁0 xs t) i j index-path : {n : ℕ}(xs : 𝕁ames n) → index (𝕁ames→𝕁0 xs) ≡ n index-path [] = refl index-path (x ∷ xs) t = 1 + index-path xs t index-path (incl xs) t = 1 + index-path xs t index-path (incl∷ x xs i) t = 2 + index-path xs t index-path (unit xs i) t = 1 + index-path xs t index-path (coh xs i j) t = 2 + index-path xs t 𝕁ames→𝕁0→𝕁ames : {n : ℕ}(xs : 𝕁ames n) → PathP (λ i → 𝕁ames (index-path xs i)) (𝕁0→𝕁ames (𝕁ames→𝕁0 xs)) xs 𝕁ames→𝕁0→𝕁ames [] = refl 𝕁ames→𝕁0→𝕁ames (x ∷ xs) t = x ∷ 𝕁ames→𝕁0→𝕁ames xs t 𝕁ames→𝕁0→𝕁ames (incl xs) t = incl (𝕁ames→𝕁0→𝕁ames xs t) 𝕁ames→𝕁0→𝕁ames (incl∷ x xs i) t = incl∷ x (𝕁ames→𝕁0→𝕁ames xs t) i 𝕁ames→𝕁0→𝕁ames (unit xs i) t = unit (𝕁ames→𝕁0→𝕁ames xs t) i 𝕁ames→𝕁0→𝕁ames (coh xs i j) t = coh (𝕁ames→𝕁0→𝕁ames xs t) i j 𝕁ames∞→𝕁0∞ : 𝕁ames∞ → 𝕁0∞ 𝕁ames∞→𝕁0∞ (incl xs) = incl (𝕁ames→𝕁0 xs) 𝕁ames∞→𝕁0∞ (push xs i) = push (𝕁ames→𝕁0 xs) i 𝕁0∞→𝕁ames∞ : 𝕁0∞ → 𝕁ames∞ 𝕁0∞→𝕁ames∞ (incl xs) = incl (𝕁0→𝕁ames xs) 𝕁0∞→𝕁ames∞ (push xs i) = push (𝕁0→𝕁ames xs) i 𝕁ames∞→𝕁0∞→𝕁ames∞ : (xs : 𝕁ames∞) → 𝕁0∞→𝕁ames∞ (𝕁ames∞→𝕁0∞ xs) ≡ xs 𝕁ames∞→𝕁0∞→𝕁ames∞ (incl xs) t = incl (𝕁ames→𝕁0→𝕁ames xs t) 𝕁ames∞→𝕁0∞→𝕁ames∞ (push xs i) t = push (𝕁ames→𝕁0→𝕁ames xs t) i 𝕁0∞→𝕁ames∞→𝕁0∞ : (xs : 𝕁0∞) → 𝕁ames∞→𝕁0∞ (𝕁0∞→𝕁ames∞ xs) ≡ xs 𝕁0∞→𝕁ames∞→𝕁0∞ (incl xs) t = incl (𝕁0→𝕁ames→𝕁0 xs t) 𝕁0∞→𝕁ames∞→𝕁0∞ (push xs i) t = push (𝕁0→𝕁ames→𝕁0 xs t) i 𝕁ames∞≃𝕁0∞ : 𝕁ames∞ ≃ 𝕁0∞ 𝕁ames∞≃𝕁0∞ = isoToEquiv (iso 𝕁ames∞→𝕁0∞ 𝕁0∞→𝕁ames∞ 𝕁0∞→𝕁ames∞→𝕁0∞ 𝕁ames∞→𝕁0∞→𝕁ames∞) -- The main equivalence: 𝕁ames∞≃𝕁Red∞ : 𝕁ames∞ ≃ 𝕁Red∞ 𝕁ames∞≃𝕁Red∞ = compEquiv 𝕁ames∞≃𝕁0∞ (compEquiv (pathToEquiv (λ i → 𝕁Path∞ i)) 𝕁1∞≃𝕁Red∞) -- Test of canonicity private -- It's good for []. eq1 : 𝕁ames∞≃𝕁Red∞ .fst (incl []) ≡ incl [] eq1 = refl -- Without regularity, "obvious" equality doesn't hold definitionally. eq2 : (x : X) → 𝕁ames∞≃𝕁Red∞ .fst (incl (x ∷ [])) ≡ incl (x ∷ []) eq2 _ = transportRefl _

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.HITs.James.Properties.html` {- Basic properties of James construction This file contains: - The type James X has h-monoid structure, namely being a monoid in "homotopy category". - The equivalence "James X₊ ≃ List X" for type X, where X₊ denotes the type formed by freely adjoining a base point to X. -} module Cubical.HITs.James.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Pointed open import Cubical.Data.Maybe open import Cubical.Data.List hiding (_++_) open import Cubical.HITs.James.Base private variable ℓ : Level -- The h-monoid structure on James X module _ (X∙@(X , x₀) : Pointed ℓ) where ++lUnit : (xs : James X∙) → xs ≡ [] ++ xs ++lUnit _ = refl ++rUnit : (xs : James X∙) → xs ≡ xs ++ [] ++rUnit [] = refl ++rUnit (x ∷ xs) t = x ∷ ++rUnit xs t ++rUnit (unit xs i) t = unit (++rUnit xs t) i ++Assoc : (xs ys zs : James X∙) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs) ++Assoc [] _ _ = refl ++Assoc (x ∷ xs) ys zs t = x ∷ ++Assoc xs ys zs t ++Assoc (unit xs i) ys zs t = unit (++Assoc xs ys zs t) i -- Freely adjoining a point module _ (X : Type ℓ) where private X₊ = Maybe∙ X J₊→List : James X₊ → List X J₊→List [] = [] J₊→List (just x ∷ xs) = x ∷ J₊→List xs J₊→List (nothing ∷ xs) = J₊→List xs J₊→List (unit xs i) = J₊→List xs List→J₊ : List X → James X₊ List→J₊ [] = [] List→J₊ (x ∷ xs) = just x ∷ List→J₊ xs List→J₊→List : (xs : List X) → J₊→List (List→J₊ xs) ≡ xs List→J₊→List [] = refl List→J₊→List (x ∷ xs) i = x ∷ List→J₊→List xs i J₊→List→J₊ : (xs : James X₊) → List→J₊ (J₊→List xs) ≡ xs J₊→List→J₊ [] = refl J₊→List→J₊ (just x ∷ xs) i = just x ∷ J₊→List→J₊ xs i J₊→List→J₊ (nothing ∷ xs) = J₊→List→J₊ xs ∙ unit xs J₊→List→J₊ (unit xs i) j = hcomp (λ k → λ { (i = i0) → J₊→List→J₊ xs j ; (i = i1) → compPath-filler (J₊→List→J₊ xs) (unit xs) k j ; (j = i0) → List→J₊ (J₊→List xs) ; (j = i1) → unit xs (i ∧ k) }) (J₊→List→J₊ xs j) J₊≃List : James X₊ ≃ List X J₊≃List = isoToEquiv (iso J₊→List List→J₊ List→J₊→List J₊→List→J₊)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.HITs.PropositionalTruncation.Properties.html` {- This file contains: - Eliminator for propositional truncation -} module Cubical.HITs.PropositionalTruncation.Properties where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Univalence open import Cubical.Data.Sigma open import Cubical.Data.Sum hiding (rec ; elim ; map) open import Cubical.Data.Nat using (ℕ ; zero ; suc) open import Cubical.Data.FinData using (Fin ; zero ; suc) open import Cubical.HITs.PropositionalTruncation.Base private variable ℓ ℓ' : Level A B C : Type ℓ A′ : Type ℓ' ∥∥-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 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 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 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 rec3 Pprop f (squash₁ x y i) z w = Pprop (rec3 Pprop f x z w) (rec3 Pprop f y z w) i ∃-rec : {B : A → Type ℓ'} {P : Type ℓ} → isProp P → (∀ x → B x → P) → ∃[ x ∈ A ] B x → P ∃-rec Pprop f = rec Pprop (uncurry f) -- Old version -- rec2 : ∀ {P : Type ℓ} → isProp P → (A → A → P) → ∥ A ∥ → ∥ A ∥ → P -- rec2 Pprop f = rec (isProp→ Pprop) (λ a → rec Pprop (f a)) -- n-ary recursor, stated using a dependent FinVec recFin : {m : ℕ} {P : Fin m → Type ℓ} {B : Type ℓ'} (isPropB : isProp B) → ((∀ i → P i) → B) --------------------- → ((∀ i → ∥ P i ∥₁) → B) recFin {m = zero} _ untruncHyp _ = untruncHyp (λ ()) recFin {m = suc m} {P = P} {B = B} isPropB untruncHyp truncFam = curriedishTrunc (truncFam zero) (truncFam ∘ suc) where curriedish : P zero → (∀ i → ∥ P (suc i) ∥₁) → B curriedish p₀ = recFin isPropB (λ famSuc → untruncHyp (λ { zero → p₀ ; (suc i) → famSuc i })) curriedishTrunc : ∥ P zero ∥₁ → (∀ i → ∥ P (suc i) ∥₁) → B curriedishTrunc = rec (isProp→ isPropB) curriedish recFin2 : {m1 m2 : ℕ} {P : Fin m1 → Fin m2 → Type ℓ} {B : Type ℓ'} (isPropB : isProp B) → ((∀ i j → P i j) → B) -------------------------- → (∀ i j → ∥ P i j ∥₁) → B recFin2 {m1 = zero} _ untruncHyp _ = untruncHyp λ () recFin2 {m1 = suc m1} {P = P} {B = B} isPropB untruncHyp truncFam = curriedishTrunc (truncFam zero) (truncFam ∘ suc) where curriedish : (∀ j → P zero j) → (∀ i j → ∥ P (suc i) j ∥₁) → B curriedish p₀ truncFamSuc = recFin2 isPropB (λ famSuc → untruncHyp λ { zero → p₀ ; (suc i) → famSuc i }) truncFamSuc curriedishTrunc : (∀ j → ∥ P zero j ∥₁) → (∀ i j → ∥ P (suc i) j ∥₁) → B curriedishTrunc = recFin (isProp→ isPropB) curriedish 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 (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)) (f : (a : A) (b : B) → P ∣ a ∣₁ ∣ b ∣₁) (x : ∥ A ∥₁) (y : ∥ B ∥₁) → P x y elim2 Pprop f = elim (λ _ → isPropΠ (λ _ → Pprop _ _)) (λ a → elim (λ _ → Pprop _ _) (f a)) elim3 : {P : ∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁ → Type ℓ} (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 _ _ _)) (λ a b → elim (λ _ → Pprop _ _ _) (g a b)) -- n-ary eliminator, stated using a dependent FinVec elimFin : {m : ℕ} {P : Fin m → Type ℓ} {B : (∀ i → ∥ P i ∥₁) → Type ℓ'} (isPropB : ∀ x → isProp (B x)) → ((x : ∀ i → P i) → B (λ i → ∣ x i ∣₁)) ---------------------------------------- → ((x : ∀ i → ∥ P i ∥₁) → B x) elimFin {m = zero} {B = B} _ untruncHyp _ = subst B (funExt (λ ())) (untruncHyp (λ ())) elimFin {m = suc m} {P = P} {B = B} isPropB untruncHyp x = subst B (funExt (λ { zero → refl ; (suc i) → refl})) (curriedishTrunc (x zero) (x ∘ suc)) where curriedish : (x₀ : P zero) (xₛ : ∀ i → ∥ P (suc i) ∥₁) → B (λ { zero → ∣ x₀ ∣₁ ; (suc i) → xₛ i}) curriedish x₀ xₛ = subst B (funExt (λ { zero → refl ; (suc i) → refl})) (elimFin (λ xₛ → isPropB (λ { zero → ∣ x₀ ∣₁ ; (suc i) → xₛ i})) (λ y → subst B (funExt (λ { zero → refl ; (suc i) → refl})) (untruncHyp (λ { zero → x₀ ; (suc i) → y i }))) xₛ) curriedishTrunc : (x₀ : ∥ P zero ∥₁) (xₛ : ∀ i → ∥ P (suc i) ∥₁) → B (λ { zero → x₀ ; (suc i) → xₛ i}) curriedishTrunc = elim (λ _ → isPropΠ λ _ → isPropB _) λ x₀ xₛ → subst B (funExt (λ { zero → refl ; (suc i) → refl})) (curriedish x₀ xₛ) ∃-elim : {B : A → Type ℓ'} {P : ∃[ x ∈ A ] B x → Type ℓ} (Pprop : ∀ s → isProp (P s)) → (∀ x y → P ∣ x , y ∣₁) → ∀ s → P s ∃-elim Pprop f = elim Pprop (uncurry f) isPropPropTrunc : isProp ∥ A ∥₁ isPropPropTrunc x y = squash₁ x y propTrunc≃ : A ≃ B → ∥ A ∥₁ ≃ ∥ B ∥₁ propTrunc≃ e = propBiimpl→Equiv isPropPropTrunc isPropPropTrunc (rec isPropPropTrunc (λ a → ∣ e .fst a ∣₁)) (rec isPropPropTrunc (λ b → ∣ invEq e b ∣₁)) 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.sec f _ = refl Iso.ret f = elim (λ _ → isProp→isSet isPropPropTrunc _ _) (λ _ → refl) 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)) → ((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 map : (A → B) → (∥ A ∥₁ → ∥ B ∥₁) map f = rec squash₁ (∣_∣₁ ∘ f) map2 : (A → B → C) → (∥ A ∥₁ → ∥ B ∥₁ → ∥ C ∥₁) map2 f = rec (isPropΠ λ _ → squash₁) (map ∘ f) -- The propositional truncation can be eliminated into non-propositional -- types as long as the function used in the eliminator is 'coherently -- 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 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 rec→Set f kf (squash₁ t u i) = helper f kf t u i helper f kf ∣ x ∣₁ ∣ y ∣₁ = kf x y helper f kf (squash₁ t u i) v = Bset' (helper f kf t v) (helper f kf u v) (helper f kf t u) refl i 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 x y = cong f (squash₁ ∣ x ∣₁ ∣ y ∣₁) Fset : isSet (A → B) Fset = isSetΠ (const Bset) Kset : (f : A → B) → isSet (2-Constant f) Kset f = isSetΠ (λ _ → isSetΠ (λ _ → isProp→isSet (Bset _ _))) setRecLemma : (f : ∥ A ∥₁ → B) → rec→Set (f ∘ ∣_∣₁) (kcomp f) ≡ f setRecLemma f i t = 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 f = f ∘ ∣_∣₁ , kcomp f 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 (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≃ .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 = const b , λ _ _ → refl eval : A → (γ : Σ (A → B) 2-Constant) → B eval a₀ (g , _) = g a₀ e-eval : ∀ (a₀ : A) γ → e (eval a₀ γ) ≡ γ e-eval a₀ (g , kg) i .fst a₁ = kg a₀ a₁ i e-eval a₀ (g , kg) i .snd a₁ a₂ = Bset' refl (kg a₁ a₂) (kg a₀ a₁) (kg a₀ a₂) 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) 2-Constant preEquiv₁ t = e , rec (isPropIsEquiv e) e-isEquiv t 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 f .fst x = f ∣ x ∣₁ .fst x to f .snd x y i = f (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) .snd x y i retr : retract to const retr f i t .fst x = f (squash₁ ∣ x ∣₁ t i) .fst x retr f i t .snd x y = Bset' (λ j → f (squash₁ ∣ x ∣₁ ∣ y ∣₁ j) .snd x y j) (f t .snd x y) (λ j → f (squash₁ ∣ x ∣₁ t j) .fst x) (λ j → f (squash₁ ∣ y ∣₁ t j) .fst y) i 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 : ∀ {ℓ'} {A : Type ℓ'} {P : ∥ A ∥₁ → Type ℓ} → (∀ 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 elim→Set {A = A} {P = P} Pset f kf t = main t .fst .fst where main : (t : ∥ A ∥₁) → isContr (Σ[ x ∈ P t ] ((a : A) → PathP (λ i → P (squash₁ t ∣ a ∣₁ i)) x (f a))) main = elim (λ _ → isPropIsContr) λ a → (((f a) , kf a) , λ {(x , p) → Σ≡Prop (λ _ → isPropΠ λ _ → isOfHLevelPathP' 1 (Pset _) _ _) (sym (transport (λ j → PathP (λ i → P (sq a j i)) x (f a)) (p a))) }) where sq : (a : A) → squash₁ ∣ a ∣₁ ∣ a ∣₁ ≡ refl sq a = isProp→isSet squash₁ _ _ _ _ elim2→Set : {P : ∥ A ∥₁ → ∥ B ∥₁ → Type ℓ} → (∀ 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)) (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 where mapHelper : (x : A) (u : ∥ B ∥₁) → P ∣ x ∣₁ u mapHelper x = elim→Set (λ _ → Pset _ _) (f x) (kf₂ x) squareHelper : (x y : A) → PathP (λ i → (u : ∥ B ∥₁) → P (squash₁ ∣ x ∣₁ ∣ y ∣₁ i) u) (mapHelper x) (mapHelper y) 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 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.sec ∥∥-IdempotentL-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-⊎-Iso (Iso.inv ∥∥-IdempotentL-⊎-Iso x)) x Iso.ret ∥∥-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.sec ∥∥-IdempotentR-⊎-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-⊎-Iso (Iso.inv ∥∥-IdempotentR-⊎-Iso x)) x Iso.ret ∥∥-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.sec ∥∥-IdempotentL-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentL-×-Iso (Iso.inv ∥∥-IdempotentL-×-Iso x)) x Iso.ret ∥∥-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.sec ∥∥-IdempotentR-×-Iso x = squash₁ (Iso.fun ∥∥-IdempotentR-×-Iso (Iso.inv ∥∥-IdempotentR-×-Iso x)) x Iso.ret ∥∥-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)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.HITs.Pushout.PushoutProduct.html` {- This file contains: - Pushout-products of two maps; - The connectivity of pushout-product maps. -} module Cubical.HITs.Pushout.PushoutProduct where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Equiv.Properties open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Data.Nat open import Cubical.Data.Sigma open import Cubical.HITs.Pushout.Base open import Cubical.HITs.Pushout.Properties open import Cubical.Homotopy.Connected private variable ℓ ℓ' ℓ'' ℓ''' : Level A : Type ℓ B : Type ℓ' X : Type ℓ'' Y : Type ℓ''' -- The definition of pushout-product PushProd : (f : X → A)(g : Y → B) → Type _ PushProd f g = Pushout (map-× (idfun _) g) (map-× f (idfun _)) _×̂_ : (f : X → A)(g : Y → B) → PushProd f g → A × B (f ×̂ g) (inl (x , b)) = f x , b (f ×̂ g) (inr (a , y)) = a , g y (f ×̂ g) (push (x , y) i) = f x , g y infixr 5 _×̂_ module _ (m n : ℕ)(f : X → A)(g : Y → B) (connf : isConnectedFun m f) (conng : isConnectedFun n g) (P : A × B → TypeOfHLevel ℓ (m + n)) where module _ (sec : (x : PushProd f g) → P ((f ×̂ g) x) .fst) where private fam : A → Type _ fam a = Σ[ k ∈ ((b : B) → P (a , b) .fst) ] ((y : Y) → k (g y) ≡ sec (inr (a , y))) fiberEquiv : (a : A) → fam a ≃ fiber (λ(s : (b : B) → P (a , b) .fst) → s ∘ g) (λ y → sec (inr (a , y))) fiberEquiv a = isoToEquiv (iso (λ (k , p) → k , λ i y → p y i) (λ (k , p) → k , λ y i → p i y) (λ _ → refl) (λ _ → refl)) is-m-trunc-fam : (a : A) → isOfHLevel m (fam a) is-m-trunc-fam a = isOfHLevelRespectEquiv _ (invEquiv (fiberEquiv a)) (isOfHLevelPrecomposeConnected m n (λ b → P (a , b)) g conng _) sec-fam : (x : X) → fam (f x) sec-fam x = (λ b → sec (inl (x , b))) , (λ y i → sec (push (x , y) i)) map-iso = elim.isIsoPrecompose f _ (λ a → fam a , is-m-trunc-fam a) connf k = map-iso .Iso.inv sec-fam ϕ = map-iso .Iso.sec sec-fam ext : (x : A × B) → P x .fst ext (a , b) = k a .fst b ext-path : (x : PushProd f g) → ext ((f ×̂ g) x) ≡ sec x ext-path (inl (x , b)) i = ϕ i x .fst b ext-path (inr (a , y)) i = k a .snd y i ext-path (push (x , y) i) j = hcomp (λ k → λ { (i = i0) → ϕ j x .snd y i0 ; (i = i1) → ϕ i0 x .snd y (j ∨ ~ k) ; (j = i0) → ϕ i0 x .snd y (i ∧ ~ k) ; (j = i1) → ϕ i1 x .snd y i }) (ϕ j x .snd y i) lifting : hasSection (λ(s : (x : A × B) → P x .fst) → s ∘ (f ×̂ g)) lifting .fst sec = ext sec lifting .snd sec i x = ext-path sec x i -- The connectivity of pushout-product isConnected×̂ : {m n : ℕ}{f : A → B}{g : X → Y} → isConnectedFun m f → isConnectedFun n g → isConnectedFun (m + n) (f ×̂ g) isConnected×̂ congf congg = elim.isConnectedPrecompose _ _ (lifting _ _ _ _ congf congg)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Homotopy.Group.Pi4S3.BrunerieNumber.html` {- The goal of this file is to prove the iso π₄S³≅ℤ/β where β is a natural number (aka "the Brunerie number", defined below). -} {-# OPTIONS --lossy-unification #-} module Cubical.Homotopy.Group.Pi4S3.BrunerieNumber where open import Cubical.Homotopy.Loopspace open import Cubical.Homotopy.Group.Base open import Cubical.Homotopy.HopfInvariant.Base open import Cubical.Homotopy.Group.Pi3S2 open import Cubical.Homotopy.Group.PinSn open import Cubical.Homotopy.BlakersMassey open import Cubical.Homotopy.Whitehead open import Cubical.Homotopy.Connected open import Cubical.Homotopy.Group.LES open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2 open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso open import Cubical.Foundations.Prelude open import Cubical.Foundations.Pointed open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.GroupoidLaws open import Cubical.Foundations.Path open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Data.Unit open import Cubical.Data.Sigma open import Cubical.Data.Nat open import Cubical.Data.Int renaming (ℤ to Z ; _·_ to _·Z_ ; _+_ to _+Z_) open import Cubical.HITs.S1 open import Cubical.HITs.Sn open import Cubical.HITs.Sn.Multiplication open import Cubical.HITs.Join open import Cubical.HITs.Susp open import Cubical.HITs.Wedge open import Cubical.HITs.Pushout open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; map to pMap) open import Cubical.HITs.SetTruncation renaming (rec to sRec ; rec2 to sRec2 ; elim to sElim ; elim2 to sElim2 ; elim3 to sElim3 ; map to sMap) open import Cubical.HITs.Truncation renaming (rec to trRec ; elim to trElim ; elim2 to trElim2 ; map to trMap) open import Cubical.Algebra.Group open import Cubical.Algebra.Group.Exact open import Cubical.Algebra.Group.ZAction open import Cubical.Algebra.Group.Instances.IntMod open import Cubical.Algebra.Group.Morphisms open import Cubical.Algebra.Group.MorphismProperties open import Cubical.Algebra.Group.Instances.Unit open import Cubical.Algebra.Group.GroupPath open Iso open Exact4 -- The Brunerie number (see Corollary 3.4.5 in Brunerie's PhD thesis) Brunerie : ℕ Brunerie = abs (HopfInvariant-π' 0 [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π') -- First we need to define the following maps. W : S₊ 3 → (S₊∙ 2 ⋁ S₊∙ 2) W = joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1} ∘ Iso.inv (IsoSphereJoin 1 1) fold∘W : S₊ 3 → S₊ 2 fold∘W = fold⋁ ∘ W {- We will now instantiate Blakers Massey to get a square: fold∘W S³ --------------> S² |\ ↗ | | \ ↗ | | \ ↗ | | X | inr | / | | / | | / | v / v 1 -----------> coFib fold∘W inl where X is the pullback of inl and inr and the map S³ → X is surjective on π₃. This will give us a sequence π₃ S³ --ᶠ→ π₃ S² → π₃ (coFib fold∘W) → π₂ X ≅ 0, where f is the function induced by fold∘W. From this, we can deduce that π₃ (coFib fold∘W) ≅ ℤ/ f(1) where f(1) is interpreted as an integer via the isos π₃ S³ ≅ π₃ S² ≅ ℤ (Recall that π₃(coFib fold∘W) ≅ π₄S³) For clarity: X, above will have two names (via a trivial iso) below: TotalPushoutPath× (the version the falls out of BM) P = fiber inr (Same name as in Brunerie's prop 4.3.4.) -} -- Before instantiating, we need to show that -- any map S³ → S² is 0-connected isConnectedS3→S2 : (f : S₊ 3 → S₊ 2) → isConnectedFun 2 f isConnectedS3→S2 f p = trRec (isProp→isOfHLevelSuc 1 isPropIsContr) (J (λ p _ → isConnected 2 (fiber f p)) (∣ north , refl ∣ , (trElim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _) (uncurry (sphereElim 2 (λ _ → isOfHLevelΠ 3 λ _ → isOfHLevelPath 3 (isOfHLevelSuc 2 (isOfHLevelTrunc 2)) _ _) λ p → trRec (isOfHLevelTrunc 2 _ _) (λ r → cong ∣_∣ₕ (ΣPathP (refl , r))) (fun (PathIdTruncIso 1) (isContr→isProp (isConnectedPath 2 (sphereConnected 2) (f north) (f north)) ∣ refl ∣ ∣ p ∣))))))) (fun (PathIdTruncIso 2) (isContr→isProp (sphereConnected 2) ∣ f north ∣ ∣ p ∣)) -- We get our square module BM-inst = BlakersMassey□ (λ _ → tt) fold∘W 3 1 (λ _ → subst (isConnected 4) (isoToPath (invIso fiberUnitIso)) (sphereConnected 3)) (isConnectedS3→S2 fold∘W) open BM-inst -- The central types coFib-fold∘W : Type coFib-fold∘W = Pushout (λ _ → tt) fold∘W coFib-fold∘W∙ : Pointed₀ coFib-fold∘W∙ = coFib-fold∘W , inl tt TotalPushoutPath×∙ : Pointed ℓ-zero fst TotalPushoutPath×∙ = Σ (Unit × S₊ 2) PushoutPath× snd TotalPushoutPath×∙ = (tt , north) , push north S³→TotalPushoutPath× : S₊ 3 → Σ (Unit × S₊ 2) PushoutPath× S³→TotalPushoutPath× = toPullback private inr' : S₊ 2 → coFib-fold∘W inr' = inr inr∙ : S₊∙ 2 →∙ coFib-fold∘W∙ fst inr∙ = inr' snd inr∙ = sym (push north) fiberinr'Iso' : Iso (fiber inr' (inl tt)) (Σ (Unit × S₊ 2) PushoutPath×) fiberinr'Iso' = compIso (Σ-cong-iso-snd (λ x → symIso)) (Σ-cong-iso-fst (invIso lUnit×Iso)) fiberinr'Iso : Iso (fiber inr' (inl tt)) (Σ (Unit × S₊ 2) PushoutPath×) fun fiberinr'Iso (x , p) = (tt , x) , (sym p) inv fiberinr'Iso ((tt , x) , p) = x , (sym p) sec fiberinr'Iso _ = refl ret fiberinr'Iso _ = refl P : Pointed₀ P = (fiber inr' (inl tt) , north , (sym (push north))) π'P→π'TotalPath× : (n : ℕ) → GroupEquiv (π'Gr n TotalPushoutPath×∙) (π'Gr n P) fst (fst (π'P→π'TotalPath× n)) = π'eqFun n ((invEquiv (isoToEquiv fiberinr'Iso)) , refl) snd (fst (π'P→π'TotalPath× n)) = π'eqFunIsEquiv n _ snd (π'P→π'TotalPath× n) = π'eqFunIsHom n _ -- Time to invoke the long exact sequence of homotopy groups on -- inr : S² → coFib-fold∘W module LESinst = πLES {A = S₊∙ 2} {B = coFib-fold∘W∙} inr∙ -- We instantiate the sequence -- π₃ P → π₃ S² → π₃ coFib-fold∘W∙ → π₂ P P→S²→Pushout : Exact4 (πGr 2 P) (πGr 2 (S₊∙ 2)) (πGr 2 coFib-fold∘W∙) (πGr 1 P) (LESinst.fib→A 2) (LESinst.A→B 2) (LESinst.B→fib 1) Exact4.ImG→H⊂KerH→L P→S²→Pushout = LESinst.Im-fib→A⊂Ker-A→B 2 Exact4.KerH→L⊂ImG→H P→S²→Pushout = LESinst.Ker-A→B⊂Im-fib→A 2 Exact4.ImH→L⊂KerL→R P→S²→Pushout = LESinst.Im-A→B⊂Ker-B→fib 1 Exact4.KerL→R⊂ImH→L P→S²→Pushout = LESinst.Ker-B→fib⊂Im-A→B 1 -- The goal now is to rewrite it as -- π₃ S³ → π₃ S² → π₃ coFib-fold∘W∙ → Unit using the -- "functions from spheres"-definition of πₙ. -- Here, the first map is the one induced by fold∘W. We do this by: -- (1) showing that π₂ P is trivial -- (2) extending the sequence by appending surjections -- π₃ S³ → π₃ TotalPushoutPath×∙ → π₃ P on the left. -- (3) proving that this new composition is indeed the appropriate map -- Step 1: π₂ P is trivial π₂P≅0 : GroupEquiv (πGr 1 P) UnitGroup₀ π₂P≅0 = compGroupEquiv (πIso (isoToEquiv fiberinr'Iso , refl) 1) (GroupIso→GroupEquiv (contrGroupIsoUnit (isOfHLevelRetractFromIso 0 (invIso iso₂) isContrπ₂S³))) where iso₁ : Iso (hLevelTrunc 4 (S₊ 3)) (hLevelTrunc 4 (Σ (Unit × S₊ 2) PushoutPath×)) iso₁ = connectedTruncIso 4 S³→TotalPushoutPath× isConnected-toPullback iso₂ : Iso (π 2 (hLevelTrunc∙ 4 (S₊∙ 3))) (π 2 TotalPushoutPath×∙) iso₂ = (compIso (setTruncIso (equivToIso (_ , (isEquivΩ^→ 2 (fun iso₁ , refl) (isoToIsEquiv iso₁))))) (invIso (πTruncIso 2))) isContrπ₂S³ : isContr (π 2 (hLevelTrunc∙ 4 (S₊∙ 3))) isContrπ₂S³ = subst (λ x → isContr (π 2 x)) (λ i → ((sym (isContr→≡Unit (sphereConnected 3))) i) , transp (λ j → isContr→≡Unit (sphereConnected 3) (~ i ∧ j)) i ∣ north ∣) (∣ refl ∣₂ , sElim (λ _ → isSetPathImplicit) λ p → cong ∣_∣₂ (isProp→isSet (isOfHLevelPath 1 isPropUnit _ _) _ _ _ p)) -- Step 2. We transform our original sequence to one for the -- the "maps from spheres" definition of πₙ and where π₂ P is -- replaced by the trivial group: -- π₃ P → π₃ S² → π₃ coFib-fold∘W∙ → 0 P→S²→Pushout→P' : Exact4 (π'Gr 2 P) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀ (π'∘∙Hom 2 (fst , refl)) (π'∘∙Hom 2 inr∙) (→UnitHom _) P→S²→Pushout→P' = transportExact4 (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 P))))) (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 (S₊∙ 2)))))) (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 coFib-fold∘W∙))))) (sym (GroupPath _ _ .fst π₂P≅0)) _ _ _ _ _ P→S²→Pushout (ΣPathPProp (λ _ → isPropIsGroupHom _ _) λ i → fst (π∘∙fib→A-PathP 2 inr∙ i)) (ΣPathPProp (λ _ → isPropIsGroupHom _ _) λ i → fst (π∘∙A→B-PathP 2 inr∙ i)) -- The two surjections in question π₃S³→π₃P : GroupHom (π'Gr 2 (S₊∙ 3)) (π'Gr 2 TotalPushoutPath×∙) π₃S³→π₃P = π'∘∙Hom 2 (S³→TotalPushoutPath× , refl) TotalPushoutPath×∙→P : TotalPushoutPath×∙ →∙ P -- Surjective, and in particular on π₃ fst TotalPushoutPath×∙→P x = (snd (fst x)) , (sym (snd x)) snd TotalPushoutPath×∙→P = refl -- This surjectivity is where Blakers-Massey is used -- In particular, it uses isConnected-toPullback isSurjective-π₃S³→π₃TotalPushoutPath× : isSurjective π₃S³→π₃P isSurjective-π₃S³→π₃TotalPushoutPath× = transport (λ i → isSurjective (transportLem i)) isSurjective-π₃S³→π₃TotalPushoutPath×' where π₃S³→π₃TotalPushoutPath× : GroupHom (πGr 2 (S₊∙ 3)) (πGr 2 TotalPushoutPath×∙) π₃S³→π₃TotalPushoutPath× = πHom 2 (S³→TotalPushoutPath× , refl) isSurjective-π₃S³→π₃TotalPushoutPath×' : isSurjective π₃S³→π₃TotalPushoutPath× isSurjective-π₃S³→π₃TotalPushoutPath×' = sElim (λ _ → isProp→isSet squash₁) λ p → trRec squash₁ (λ s → ∣ ∣ fst s ∣₂ , (cong ∣_∣₂ (snd s)) ∣₁) (((isConnectedΩ^→ 3 3 (S³→TotalPushoutPath× , refl) isConnected-toPullback) p) .fst) transportLem : PathP (λ i → GroupHomπ≅π'PathP (S₊∙ 3) TotalPushoutPath×∙ 2 2 i) π₃S³→π₃TotalPushoutPath× π₃S³→π₃P transportLem = toPathP (Σ≡Prop (λ _ → isPropIsGroupHom _ _) (π'∘∙Hom'≡π'∘∙fun {A = S₊∙ 3} {B = TotalPushoutPath×∙} 2 (S³→TotalPushoutPath× , refl))) -- We get a sequence on the right form π₃S³ → π₃S² → π₃ Pushout → Unit S³→S²→Pushout→Unit'' : Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀ (compGroupHom π₃S³→π₃P (compGroupHom (π'∘∙Hom 2 TotalPushoutPath×∙→P) (π'∘∙Hom 2 (fst , refl)))) (π'∘∙Hom 2 inr∙) (→UnitHom (π'Gr 2 coFib-fold∘W∙)) S³→S²→Pushout→Unit'' = extendExact4Surjective _ _ _ _ _ _ _ _ _ isSurjective-π₃S³→π₃TotalPushoutPath× (extendExact4Surjective _ _ _ _ _ _ _ _ _ ((sElim (λ _ → isProp→isSet squash₁) (λ f → ∣ ∣ (λ x → (tt , fst f x .fst) , sym (fst f x .snd)) , ΣPathP ((ΣPathP (refl , cong fst (snd f))) , λ j i → snd f j .snd (~ i)) ∣₂ , cong ∣_∣₂ (ΣPathP (refl , sym (rUnit _))) ∣₁))) P→S²→Pushout→P') -- Step 3: We need to show that the map π₃S³ → π₃S² in the above sequence -- indeed comes from fold∘W tripleComp≡ : (compGroupHom π₃S³→π₃P (compGroupHom (π'∘∙Hom 2 TotalPushoutPath×∙→P) (π'∘∙Hom 2 (fst , refl)))) ≡ π'∘∙Hom 2 (fold∘W , refl) tripleComp≡ = Σ≡Prop (λ _ → isPropIsGroupHom _ _) (funExt (sElim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP (refl , (cong (_∙ refl) (λ j → cong fst (rUnit (cong (fst TotalPushoutPath×∙→P) (rUnit (cong S³→TotalPushoutPath× (snd f)) (~ j))) (~ j)))))))) -- We finally get the correct sequence S³→S²→Pushout→Unit : Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀ (π'∘∙Hom 2 (fold∘W , refl)) (π'∘∙Hom 2 inr∙) (→UnitHom (π'Gr 2 coFib-fold∘W∙)) S³→S²→Pushout→Unit = subst (λ F → Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀ F (π'∘∙Hom 2 inr∙) (→UnitHom (π'Gr 2 coFib-fold∘W∙))) tripleComp≡ S³→S²→Pushout→Unit'' -- We need to throw around some pushouts module _ where Pushout-coFibW-fold⋁≃coFib-fold∘W : Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁ ≃ fst coFib-fold∘W∙ Pushout-coFibW-fold⋁≃coFib-fold∘W = compEquiv (compEquiv pushoutSwitchEquiv (isoToEquiv (PushoutDistr.PushoutDistrIso fold⋁ W λ _ → tt))) pushoutSwitchEquiv coFibW≅coFibW' : Pushout W (λ _ → tt) ≃ cofibW S¹ S¹ base base coFibW≅coFibW' = pushoutEquiv W (λ _ → tt) joinTo⋁ (λ _ → tt) (isoToEquiv (invIso (IsoSphereJoin 1 1))) (idEquiv _) (idEquiv _) refl refl Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ : Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁ ≃ fst (Pushout⋁↪fold⋁∙ (S₊∙ 2)) Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ = pushoutEquiv inl _ ⋁↪ fold⋁ (idEquiv _) (compEquiv coFibW≅coFibW' (isoToEquiv (invIso (Iso-Susp×Susp-cofibJoinTo⋁ S¹ S¹ base base)))) (idEquiv _) (Susp×Susp→cofibW≡ S¹ S¹ base base) refl Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ : (Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁ , inr north) ≃∙ (Pushout⋁↪fold⋁∙ (S₊∙ 2)) fst Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ = Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ snd Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ = sym (push (inl north)) π₄S³≅π₃coFib-fold∘W∙ : GroupEquiv (π'Gr 3 (S₊∙ 3)) (π'Gr 2 coFib-fold∘W∙) π₄S³≅π₃coFib-fold∘W∙ = compGroupEquiv (GroupIso→GroupEquiv (compGroupIso (π'Gr≅πGr 3 (S₊∙ 3)) (compGroupIso π₄S³≅π₃PushS² (invGroupIso (π'Gr≅πGr 2 (Pushout⋁↪fold⋁∙ (S₊∙ 2))))))) (compGroupEquiv (invGroupEquiv (π'Iso 2 Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙)) (π'Iso 2 (Pushout-coFibW-fold⋁≃coFib-fold∘W , sym (push north)))) -- We get the iso -- For type checking reasons, let's first prove it for the abstract -- definition of ℤ/_ -- To get everything on the same form as in Brunerie's thesis, we -- first need the following: fold∘W≡Whitehead : fst (π'∘∙Hom 2 (fold∘W , refl)) ∣ idfun∙ (S₊∙ 3) ∣₂ ≡ ∣ [ idfun∙ (S₊∙ 2) ∣ idfun∙ (S₊∙ 2) ] ∣₂ fold∘W≡Whitehead = cong ∣_∣₂ (ΣPathP (funExt (main ∘ sphere→Join 1 1) , refl)) where main : (x : _) → fold⋁ (joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1} x) ≡ fst [ idfun∙ (Susp S¹ , north) ∣ idfun∙ (Susp S¹ , north) ]-pre x main (inl x) = refl main (inr x) = refl main (push a b i) j = help j i where help : cong (fold⋁ ∘ joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1}) (push a b) ≡ (σS b ∙ refl) ∙ σS a ∙ refl help = cong-∙∙ fold⋁ _ _ _ ∙ doubleCompPath≡compPath _ _ _ ∙ cong₂ _∙_ (rUnit _) (sym (lUnit (σS a)) ∙ rUnit (σS a)) BrunerieIsoAbstract : GroupEquiv (π'Gr 3 (S₊∙ 3)) (abstractℤGroup/ Brunerie) BrunerieIsoAbstract = compGroupEquiv π₄S³≅π₃coFib-fold∘W∙ (invGroupEquiv (GroupEquiv-abstractℤ/abs-gen (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) (GroupIso→GroupEquiv (invGroupIso (πₙ'Sⁿ≅ℤ 2))) (invGroupEquiv hopfInvariantEquiv) (π'∘∙Hom 2 (fold∘W , refl)) _ S³→S²→Pushout→Unit Brunerie main)) where mainPath : fst (π'∘∙Hom 2 (fold∘W , refl)) (Iso.inv (fst (πₙ'Sⁿ≅ℤ 2)) 1) ≡ [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π' mainPath = cong (fst (π'∘∙Hom 2 (fold∘W , refl))) (cong (Iso.inv (fst (πₙ'Sⁿ≅ℤ 2))) (sym (πₙ'Sⁿ≅ℤ-idfun∙ 2)) ∙ (Iso.ret (fst (πₙ'Sⁿ≅ℤ 2)) ∣ idfun∙ (S₊∙ 3) ∣₂)) ∙ fold∘W≡Whitehead main : _ ≡ Brunerie main i = abs (HopfInvariant-π' 0 (mainPath i)) -- And, finally, we get the actual iso -- (as in Corollary 3.4.5 in Brunerie's thesis) BrunerieIso : GroupEquiv (π'Gr 3 (S₊∙ 3)) (ℤGroup/ Brunerie) BrunerieIso = compGroupEquiv BrunerieIsoAbstract (abstractℤ/≅ℤ Brunerie)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Papers.Pi4S3.html` {- Please do not move this file. Changes should only be made if necessary. This file contains pointers to the code examples and main results from the paper: Formalizing π₄(S³) ≅ ℤ/2ℤ and Computing a Brunerie Number in Cubical Agda -} -- The "--safe" flag ensures that there are no postulates or -- unfinished goals {-# OPTIONS --cubical #-} module Cubical.Papers.Pi4S3 where -- Misc. open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Univalence open import Cubical.Foundations.Pointed open import Cubical.Foundations.HLevels open import Cubical.Data.Int hiding (_+_) open import Cubical.Data.Nat open import Cubical.Data.Nat.Order open import Cubical.Data.Sum open import Cubical.Data.Sigma -- 2 open import Cubical.Data.Bool as Boolean open import Cubical.HITs.S1 as Circle open import Cubical.Foundations.Prelude as Prelude open import Cubical.HITs.Susp as Suspensions open import Cubical.HITs.Sn as Spheres hiding (S) renaming (S₊ to S) open import Cubical.HITs.Sn.Multiplication as SMult open import Cubical.HITs.Pushout as Pushouts open import Cubical.HITs.Wedge as Wedges open import Cubical.HITs.Join as Joins open import Cubical.HITs.Susp as Suspension open import Cubical.HITs.PropositionalTruncation as PT open import Cubical.HITs.Truncation as Trunc open import Cubical.Homotopy.HSpace as H-Spaces open import Cubical.Homotopy.Group.Base as HomotopyGroups open import Cubical.Homotopy.Group.LES as LES open import Cubical.Homotopy.HopfInvariant.HopfMap as HopfMap open import Cubical.Homotopy.Hopf as HopfFibration open import Cubical.Homotopy.Connected as Connectedness open S¹Hopf open import Cubical.Homotopy.Freudenthal as Freudenthal open import Cubical.Homotopy.Group.PinSn as Stable open import Cubical.Homotopy.Group.Pi3S2 as π₃S² -- 3 open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso as James₁ open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2 as James₂ open import Cubical.HITs.S2 as Sphere open import Cubical.Homotopy.Whitehead as Whitehead open import Cubical.Homotopy.BlakersMassey module BM = BlakersMassey□ open BM open import Cubical.Homotopy.Group.Pi4S3.BrunerieNumber as BNumber hiding (W) -- 5 open import Cubical.ZCohomology.Base as cohom open import Cubical.ZCohomology.GroupStructure as cohomGr open import Cubical.ZCohomology.Properties as cohomProps open import Cubical.ZCohomology.RingStructure.CupProduct as cup open import Cubical.ZCohomology.MayerVietorisUnreduced as MayerVietoris open import Cubical.Homotopy.HopfInvariant.Base as HI open import Cubical.Homotopy.HopfInvariant.Homomorphism as HI-hom open import Cubical.Homotopy.HopfInvariant.Brunerie as HI-β open import Cubical.ZCohomology.Gysin as GysinSeq open import Cubical.Homotopy.Group.Pi4S3.Summary as π₄S³ hiding (π) open import Cubical.ZCohomology.RingStructure.RingLaws as cupLaws -- 6 open import Cubical.Homotopy.Group.Pi4S3.DirectProof as Direct -- II. HOMOTOPY TYPE THEORY IN Cubical Agda -- Booleans open Boolean using (Bool) -- S¹ open Circle using (S¹) -- Non-dependent paths and refl open Prelude using (_≡_ ; refl) -- funExt, funExt⁻, cong open Prelude using (funExt; funExt⁻; cong) -- transport and dependent paths open Prelude using (transport ; PathP) -- cirlce-indution open Circle using (elim) -- suspension open Suspensions using (Susp) -- spheres open Spheres using (S₊) -- pushouts open Pushouts using (Pushout) -- wedge sums open Wedges using (_⋁_) -- joins open Joins using (join) -- cofibres open Pushouts using (cofib) -- ∇ and i∨ open Wedges using (fold⋁ ; ⋁↪) ∇ = fold⋁ i∨ = ⋁↪ -- propositional and general truncation -- note that the indexing is off by 2! open PT using (∥_∥₁) open Trunc using (∥_∥_) -- h-spaces open H-Spaces using (HSpace) -- homotopy groups (function and loop space definition, respectively) -- Note that the indexing is off by 1. open HomotopyGroups using (π'Gr ; πGr) -- πLES (Proposition 1) module ExactSeq = πLES -- σ (definition 3) open Suspensions using (toSusp) σ = toSusp -- Definition 4 and Proposition (Hopf map), -- Phrased somewhat differently in the paper. open HopfMap using (HopfMap) open S¹Hopf using (IsoS³TotalHopf) -- Lemma 1 (connectedness of spheres) -- Note that the indexing is off by 2. open Spheres using (sphereConnected) -- Proposition 3 (πₙSᵐ vanishishing for n < m) isContr-πₙSᵐ-low : (n m : ℕ) → n < m → isContr (π n (S₊∙ m)) isContr-πₙSᵐ-low n m l = transport (cong isContr (sym (ua h))) (∣ const∙ (S₊∙ n) _ ∣₂ , ST.elim (λ _ → isOfHLevelPath 2 squash₂ _ _) λ f → refl) where open import Cubical.HITs.SetTruncation as ST isContrUnit : isContr Unit isContrUnit = tt , λ _ → refl con-lem : isConnected (2 + n) (S₊ m) con-lem = isConnectedSubtr (suc (suc n)) (fst l) (subst (λ n → isConnected n (S₊ m)) (sym (+-suc (fst l) (suc n) ∙ cong suc (snd l))) (sphereConnected m)) h : π n (S₊∙ m) ≃ π' n (Unit , tt) h = compEquiv (isoToEquiv (πTruncIso n)) (compEquiv (pathToEquiv (cong (π n) (ua∙ (isoToEquiv (isContr→Iso (con-lem) isContrUnit)) refl))) (pathToEquiv (cong ∥_∥₂ (isoToPath (IsoΩSphereMap n))))) -- Theorem 1 (Freudenthal Suspension Theorem) open Freudenthal using (isConnectedσ) -- formalized by Evan Cavallo -- Corollary 1 (πₙSⁿ≅ℤ with identity as generator) open Stable using (πₙ'Sⁿ≅ℤ ; πₙ'Sⁿ≅ℤ-idfun∙) -- Proposition 4 and Corollary 2 (πₙSⁿ≅ℤ with identity as generator) open π₃S² using (π₃S²≅ℤ ; π₂S³-gen-by-HopfMap) ------ IV. THE BRUNERIE NUMBER ------ {- The formalization of this part does not follow the paper exactly. For instance, Lemma 2 is baked into a more specific elimination principle for J₂. For this reason, we only give the crucial results here -} ---- A. The James construction ---- -- Lemma 3 (the family of automorphisms on ∥J₂S²∥₃ open James₁ using (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅) ---- B. Formalization of the James construction ---- -- S²-HIT open Sphere using (S²) -- Definition 5: J₂S² open James₁ using (Pushout⋁↪fold⋁S₊2) -- encode, decode open James₁ using (encode ; decode) -- Proposition 7: Ω ∥S³∥₄ ≃ ∥J₂S²∥₃ open James₁ using (IsoΩ∥SuspS²∥₅∥Pushout⋁↪fold⋁S²∥₅) ---- C. Formalization of the James construction ---- -- Proposition 8: Sⁿ * Sᵐ ≃ Sⁿ⁺ᵐ⁺¹ open SMult using (IsoSphereJoin) -- Definition 6: W + whitehead product W = joinTo⋁ open Whitehead using ([_∣_]) -- Theorem 3 is omitted as it is used implicitly in the proof of the main result -- Blakers-Massey open BM using (isConnected-toPullback) -- formalized primarily (in a different form) by Kang Rongji -- Definition 7: The Brunerie number (note that, in the formalization -- we have worked defined β as the image of the Hopf Invariant -- directly) open BNumber using (Brunerie) -- Corollary 3: π₄S³ ≅ ℤ/βℤ open BNumber using (BrunerieIso) --- ------ V. BRUNERIE'S PROOF PART 2 ------ ---- A. Cohomology Theory / B. Formalization of Chapter 5---- -- All formalizations marked with (BLM22) are borrowed from Brunerie, -- Ljungström, and Mörtberg, “Synthetic Integral Cohomology in Cubical -- Agda" -- Eilenberg-MacLane spaces and cohomology groups (BLM22) open cohom using (coHomK) open cohomGr using (coHomGr) -- addition (BLM22) open cohomGr using (_+ₖ_) -- the cup product (BLM22) open cup using (_⌣ₖ_ ; _⌣_) -- Kₙ ≃ ΩKₙ₊₁ (BLM22) open cohomProps using (Kn≃ΩKn+1) -- Mayer Vietoris (BLM22) open MV using ( Ker-i⊂Im-d ; Im-d⊂Ker-i ; Ker-Δ⊂Im-i ; Im-i⊂Ker-Δ ; Ker-d⊂Im-Δ ; Im-Δ⊂Ker-d) -- Lemma 4 (cohomology of cofibers S³ → S²) open HI using (Hopfβ-Iso) -- Definition 8 (Hopf Invariant) open HI using (HopfInvariant-π') -- Proposition 9 (The Hopf invariant is a homomorphism) open HI-hom using (GroupHom-HopfInvariant-π') -- Proposition 10 (The Hopf invariant of the Brunerie element is ±2) open HI-β using (Brunerie'≡2) -- Lemma 5 -- only included for presentation, omitted from frmalization ---- C. The Gysin Sequence / B. Formalization of the Gysin Sequence -- Proposition 11 (Gysin sequence) open Gysin using (Im-⌣e⊂Ker-p ; Ker-p⊂Im-⌣e ; Im-Susp∘ϕ⊂Ker-⌣e ; Ker-⌣e⊂Im-Susp∘ϕ ; Im-ϕ∘j⊂Ker-p ; Ker-p⊂Im-ϕ∘j) -- Proposition 12 : CP² fibration -- Indirect, but see in particular open HopfMap using (fibr) -- Proposition 13 : Iterated Hopf Construction. -- Indirect, but see in particular: open Hopf using (joinIso₂) -- Proposition 14 : ∣ HI hopf ∣ ≡ 1 open HopfMap using (HopfInvariant-HopfMap) -- Theorem 5: π₄S³≅ℤ/2ℤ open π₄S³ using (π₄S³≃ℤ/2ℤ) -- Lemma 6: (BLM22) open cupLaws using (assoc-helper) -- proof that e₂ : H²(CP²) is a generator by computation -- (the field with refl is where the computation happens) open HopfMap using (isGenerator≃ℤ-e) ------ VI. SIMPLIFIED NEW PROOF AND COMPUTATION OF A BRUNERIE NUMBER ------ -- A relatively detailed accound of the proof is given in the formalization: open Direct -- Note that the numbering of the ηs is shifted, with -- η₁ being ∣ ∇ ∘ W ∣, η₂ being η₁ and η₃ being η₂. open Direct using (η₁ ; η₂ ; η₃) -- computation of η₂: the alternative definition and the computation open Direct using (η₃' ; computerIsoη₃)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Papers.Synthetic.html` module Cubical.Papers.Synthetic where -- Cubical synthetic homotopy theory -- Mörtberg and Pujet, „Cubical synthetic homotopy theory“. -- https://dl.acm.org/doi/abs/10.1145/3372885.3373825 -- 2.1 import Agda.Builtin.Cubical.Path as Path import Cubical.Foundations.Prelude as Prelude -- 2.2 import Agda.Primitive.Cubical as PrimitiveCubical import Cubical.Data.Bool as Bool import Cubical.Core.Primitives as CorePrimitives -- 2.3 import Cubical.HITs.S1 as S1 -- 2.4 import Cubical.Foundations.Equiv as Equiv import Cubical.Core.Glue as CoreGlue import Cubical.Foundations.Univalence as Univalence -- 3. import Cubical.HITs.Torus as T2 -- 3.1 import Cubical.Data.Int as Int import Cubical.Data.Int.Properties as IntProp import Cubical.Foundations.Isomorphism as Isomorphism -- 4.1 import Cubical.HITs.Susp as Suspension import Cubical.HITs.Sn as Sn import Agda.Builtin.Nat as BNat import Agda.Builtin.Bool as BBool import Cubical.Foundations.GroupoidLaws as GroupoidLaws import Cubical.HITs.S2 as S2 import Cubical.HITs.S3 as S3 -- 4.2 import Cubical.HITs.Pushout as Push import Cubical.HITs.Pushout.Properties as PushProp -- 4.3 import Cubical.HITs.Join as Join import Cubical.HITs.Join.Properties as JoinProp -- 5. import Cubical.Homotopy.Hopf as Hopf -------------------------------------------------------------------------------- -- 2. Cubical Agda -- 2.1 The Interval and Path Types -- 2.2 Transport and Composition -- 2.3 Higher Inductive Types -- 2.4 Glue Types and Univalence -------------------------------------------------------------------------------- -- 2.1 The Interval and Path Types open Path using (PathP) public open Prelude using (_≡_ ; refl ; funExt) public open Prelude renaming (sym to _⁻¹) public -- 2.2 Transport and Composition open Prelude using (transport ; subst ; J ; JRefl) public open PrimitiveCubical using (Partial) public open Bool using (Bool ; true ; false) public partialBool : ∀ i → Partial (i ∨ ~ i) Bool partialBool i = λ {(i = i1) → true ; (i = i0) → false} open CorePrimitives using (inS ; outS ; hcomp) public open Prelude using (_∙_) public -- 2.3 Higher Inductive Types open S1 using (S¹ ; base ; loop) public double : S¹ → S¹ double base = base double (loop i) = (loop ∙ loop) i -- 2.4 Glue Types and Univalence open Equiv using (idEquiv) public open CoreGlue using (Glue) public open Univalence using (ua) public -------------------------------------------------------------------------------- -- 3. The Circle and Torus -- 3.1 The Loop Spaces of the Circle and Torus -------------------------------------------------------------------------------- open T2 using ( Torus ; point ; line1 ; line2 ; square ; t2c ; c2t ; c2t-t2c ; t2c-c2t ; Torus≡S¹×S¹) -- 3.1 The Loop Spaces of the Circle and Torus open S1 using (ΩS¹) public open T2 using (ΩTorus) public open Int using (pos ; negsuc) renaming (ℤ to Int) public open IntProp using (sucPathℤ) public open S1 using (helix ; winding) public -- Examples computing the winding numbers of the circle _ : winding (loop ∙ loop ∙ loop) ≡ pos 3 _ = refl _ : winding ((loop ⁻¹) ∙ loop ∙ (loop ⁻¹)) ≡ negsuc 0 _ = refl open S1 renaming (intLoop to loopn) public open S1 renaming (windingℤLoop to winding-loopn) public open S1 using (encode ; decode ; decodeEncode ; ΩS¹≡ℤ) public open Isomorphism using (isoToPath ; iso) public -- Notation of the paper, current notation under ΩS¹≡Int ΩS¹≡Int' : ΩS¹ ≡ Int ΩS¹≡Int' = isoToPath (iso winding loopn winding-loopn (decodeEncode base)) open T2 using (ΩTorus≡ℤ×ℤ ; windingTorus) public -- Examples at the end of section 3. _ : windingTorus (line1 ∙ line2) ≡ (pos 1 , pos 1) _ = refl _ : windingTorus ((line1 ⁻¹) ∙ line2 ∙ line1) ≡ (pos 0 , pos 1) _ = refl -------------------------------------------------------------------------------- -- 4. Suspension, Spheres and Pushouts -- 4.1 Suspension -- 4.2 Pushouts and the 3 × 3 Lemma -- 4.3 The Join and S³ -------------------------------------------------------------------------------- -- 4.1 Suspension open Suspension using (Susp ; north ; south ; merid) public open Sn using (S₊) public open Suspension using ( SuspBool→S¹ ; S¹→SuspBool ; SuspBool→S¹→SuspBool ; S¹→SuspBool→S¹) public -- Deprecated version of S₊ open BNat renaming (Nat to ℕ) hiding (_*_) public open CorePrimitives renaming (Type to Set) public open BBool using (Bool) public -- At the time the paper was published, Set was used instead of Type _-sphere : ℕ → Set 0 -sphere = Bool (suc n) -sphere = Susp (n -sphere) -- Lemma 4.1. The (1)-sphere is equal to the circle S1. open BBool using (true ; false) public -- Deprecated version of SuspBool→S¹ s2c : 1 -sphere → S¹ s2c north = base s2c south = base s2c (merid true i) = loop i s2c (merid false i) = base -- (loop ⁻¹) i -- Deprecated version of S¹→SuspBool c2s : S¹ → 1 -sphere c2s base = north c2s (loop i) = (merid true ∙ (merid false ⁻¹)) i open GroupoidLaws using (rUnit) public -- Deprecated version of SuspBool→S¹→SuspBool s2c-c2s : ∀ (p : S¹) → s2c (c2s p) ≡ p s2c-c2s base = refl s2c-c2s (loop i) j = rUnit loop (~ j) i h1 : I → I → 1 -sphere h1 i j = merid false (i ∧ j) h2 : I → I → 1 -sphere h2 i j = hcomp (λ k → λ { (i = i0) → north ; (i = i1) → merid false (j ∨ ~ k) ; (j = i1) → merid true i }) (merid true i) -- Deprecated version of S¹→SuspBool→S¹ c2s-s2c : ∀ (t : 1 -sphere) → c2s (s2c t) ≡ t c2s-s2c north j = north c2s-s2c south j = merid false j c2s-s2c (merid true i) j = h2 i j c2s-s2c (merid false i) j = merid false (i ∧ j) -- Notation of the paper, current notation under S¹≡SuspBool -- Proof of Lemma 4.1 1-sphere≡S¹ : 1 -sphere ≡ S¹ 1-sphere≡S¹ = isoToPath (iso s2c c2s s2c-c2s c2s-s2c) -- Definitions of S2 and S3 open S2 using (S²) public open S3 using (S³) public -- 4.2 Pushouts and the 3 × 3 Lemma open Push using (Pushout) public -- 3x3-span is implemented as a record open PushProp using (3x3-span) public open 3x3-span using (f□1) public -- The rest of the definitions inside the 3x3-lemma -- A□0-A○□ , A□○-A○□ ... open 3x3-span using (3x3-lemma) public -- 4.3 The Join and S³ open Join renaming (join to Join) using (S³≡joinS¹S¹) public open JoinProp using (join-assoc) public -------------------------------------------------------------------------------- -- 5. The Hopf Fibration -------------------------------------------------------------------------------- -- rot (denoted by _·_ here) in the paper is substituted by a rot and rotLoop in S1 open S1 using (_·_ ; rotLoop) public open Hopf.S¹Hopf renaming ( HopfSuspS¹ to Hopf ; JoinS¹S¹→TotalHopf to j2h ; TotalHopf→JoinS¹S¹ to h2j) using (HopfS²) public open S1 renaming (rotInv-1 to lem-rot-inv) public

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Relation.Binary.Base.html` module Cubical.Relation.Binary.Base where open import Cubical.Foundations.Prelude open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.Equiv open import Cubical.Foundations.Equiv.Fiberwise open import Cubical.Functions.Embedding open import Cubical.Functions.Logic using (_⊔′_) open import Cubical.Data.Empty as ⊥ open import Cubical.Data.Sigma open import Cubical.Data.Sum.Base as ⊎ open import Cubical.HITs.SetQuotients.Base open import Cubical.HITs.PropositionalTruncation as ∥₁ open import Cubical.Relation.Nullary.Base open import Cubical.Induction.WellFounded private variable ℓA ℓ≅A ℓA' ℓ≅A' : Level Rel : ∀ {ℓa ℓb} (A : Type ℓa) (B : Type ℓb) (ℓ' : Level) → Type (ℓ-max (ℓ-max ℓa ℓb) (ℓ-suc ℓ')) Rel A B ℓ' = A → B → Type ℓ' PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ')) PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b) idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ idPropRel A .fst a a' = ∥ a ≡ a' ∥₁ idPropRel A .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 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₁ graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ graphRel f a b = f a ≡ b module HeterogenousRelation {ℓ ℓ' : Level} {A B : Type ℓ} (R : Rel A B ℓ') where isUniversalRel : Type (ℓ-max ℓ ℓ') isUniversalRel = (a : A) (b : B) → R a b module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where isRefl : Type (ℓ-max ℓ ℓ') isRefl = (a : A) → R a a isRefl' : Type (ℓ-max ℓ ℓ') isRefl' = {a : A} → R a a isIrrefl : Type (ℓ-max ℓ ℓ') isIrrefl = (a : A) → ¬ R a a isSym : Type (ℓ-max ℓ ℓ') isSym = (a b : A) → R a b → R b a isAsym : Type (ℓ-max ℓ ℓ') isAsym = (a b : A) → R a b → ¬ R b a isAntisym : Type (ℓ-max ℓ ℓ') isAntisym = (a b : A) → R a b → R b a → a ≡ b isTrans : Type (ℓ-max ℓ ℓ') isTrans = (a b c : A) → R a b → R b c → R a c isTrans' : Type (ℓ-max ℓ ℓ') isTrans' = {a b c : A} → R a b → R b c → R a c -- 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 isWeaklyLinear : Type (ℓ-max ℓ ℓ') isWeaklyLinear = (a b c : A) → R a b → R a c ⊔′ R c b isConnected : Type (ℓ-max ℓ ℓ') isConnected = (a b : A) → (¬ R a b) × (¬ R b a) → a ≡ b isTotal : Type (ℓ-max ℓ ℓ') isTotal = (a b : A) → 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₀) WellFounded→isIrrefl : WellFounded R → isIrrefl WellFounded→isIrrefl well = WFI.induction well λ a f Raa → f a Raa Raa isAsym→isIrrefl : isAsym → isIrrefl isAsym→isIrrefl asym a Raa = asym a a Raa Raa IrreflKernel : Rel A A (ℓ-max ℓ ℓ') IrreflKernel a b = R a b × (¬ a ≡ b) ReflClosure : Rel A A (ℓ-max ℓ ℓ') ReflClosure a b = R a b ⊎ (a ≡ b) SymKernel : Rel A A ℓ' SymKernel a b = R a b × R b a SymClosure : Rel A A ℓ' SymClosure a b = R a b ⊎ R b a AsymKernel : Rel A A ℓ' AsymKernel a b = R a b × (¬ R b a) NegationRel : Rel A A ℓ' NegationRel a b = ¬ (R a b) Dual : Rel A A ℓ' Dual a b = R b a module _ {ℓ'' : Level} (P : Embedding A ℓ'') 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) isDecidable : Type (ℓ-max ℓ ℓ') isDecidable = (a b : A) → Dec (R a b) impliesIdentity : Type _ impliesIdentity = {a a' : A} → (R a a') → (a ≡ a') isTight : Type _ isTight = (a b : A) → ¬ R a b → a ≡ b 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.sec 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.ret 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 sec : (a' : A') → fun (inv a') ≅' a' ret : (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.sec (RelIso→Iso _ _ uni uni' f) a' = uni' (RelIso.sec f a') Iso.ret (RelIso→Iso _ _ uni uni' f) a = uni (RelIso.ret 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 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

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Structures.Maybe.html` {- Maybe structure: X ↦ Maybe (S X) -} {-# OPTIONS --no-exact-split #-} module Cubical.Structures.Maybe where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Function open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.HLevels open import Cubical.Foundations.SIP open import Cubical.Functions.FunExtEquiv open import Cubical.Data.Unit open import Cubical.Data.Empty open import Cubical.Data.Maybe private variable ℓ ℓ₁ ℓ₁' : Level MaybeRel : {A B : Type ℓ} (R : A → B → Type ℓ₁) → Maybe A → Maybe B → Type ℓ₁ MaybeRel R nothing nothing = Lift Unit MaybeRel R nothing (just _) = Lift ⊥ MaybeRel R (just _) nothing = Lift ⊥ MaybeRel R (just x) (just y) = R x y congMaybeRel : {A B : Type ℓ} {R : A → B → Type ℓ₁} {S : A → B → Type ℓ₁'} → (∀ x y → R x y ≃ S x y) → ∀ ox oy → MaybeRel R ox oy ≃ MaybeRel S ox oy congMaybeRel e nothing nothing = Lift≃Lift (idEquiv _) congMaybeRel e nothing (just _) = Lift≃Lift (idEquiv _) congMaybeRel e (just _) nothing = Lift≃Lift (idEquiv _) congMaybeRel e (just x) (just y) = e x y module MaybePathP where Code : (A : I → Type ℓ) → Maybe (A i0) → Maybe (A i1) → Type ℓ Code A = MaybeRel (PathP A) encodeRefl : {A : Type ℓ} → ∀ ox → Code (λ _ → A) ox ox encodeRefl nothing = lift tt encodeRefl (just _) = refl encode : (A : I → Type ℓ) → ∀ ox oy → PathP (λ i → Maybe (A i)) ox oy → Code A ox oy encode A ox oy p = transport (λ j → Code (λ i → A (i ∧ j)) ox (p j)) (encodeRefl ox) decode : {A : I → Type ℓ} → ∀ ox oy → Code A ox oy → PathP (λ i → Maybe (A i)) ox oy decode nothing nothing p i = nothing decode (just _) (just _) p i = just (p i) decodeEncodeRefl : {A : Type ℓ} (ox : Maybe A) → decode ox ox (encodeRefl ox) ≡ refl decodeEncodeRefl nothing = refl decodeEncodeRefl (just _) = refl decodeEncode : {A : I → Type ℓ} → ∀ ox oy p → decode ox oy (encode A ox oy p) ≡ p decodeEncode {A = A} ox oy p = transport (λ k → decode _ _ (transp (λ j → Code (λ i → A (i ∧ j ∧ k)) ox (p (j ∧ k))) (~ k) (encodeRefl ox)) ≡ (λ i → p (i ∧ k))) (decodeEncodeRefl ox) encodeDecode : (A : I → Type ℓ) → ∀ ox oy c → encode A ox oy (decode ox oy c) ≡ c encodeDecode A nothing nothing c = refl encodeDecode A (just x) (just y) c = transport (λ k → encode (λ i → A (i ∧ k)) _ _ (decode (just x) (just (c k)) (λ i → c (i ∧ k))) ≡ (λ i → c (i ∧ k))) (transportRefl _) Code≃PathP : {A : I → Type ℓ} → ∀ ox oy → Code A ox oy ≃ PathP (λ i → Maybe (A i)) ox oy Code≃PathP {A = A} ox oy = isoToEquiv isom where isom : Iso _ _ isom .Iso.fun = decode ox oy isom .Iso.inv = encode _ ox oy isom .Iso.sec = decodeEncode ox oy isom .Iso.ret = encodeDecode A ox oy -- Structured isomorphisms MaybeStructure : (S : Type ℓ → Type ℓ₁) → Type ℓ → Type ℓ₁ MaybeStructure S X = Maybe (S X) MaybeEquivStr : {S : Type ℓ → Type ℓ₁} → StrEquiv S ℓ₁' → StrEquiv (MaybeStructure S) ℓ₁' MaybeEquivStr ι (X , ox) (Y , oy) e = MaybeRel (λ x y → ι (X , x) (Y , y) e) ox oy maybeUnivalentStr : {S : Type ℓ → Type ℓ₁} (ι : StrEquiv S ℓ₁') → UnivalentStr S ι → UnivalentStr (MaybeStructure S) (MaybeEquivStr ι) maybeUnivalentStr ι θ {X , ox} {Y , oy} e = compEquiv (congMaybeRel (λ x y → θ {X , x} {Y , y} e) ox oy) (MaybePathP.Code≃PathP ox oy) maybeEquivAction : {S : Type ℓ → Type ℓ₁} → EquivAction S → EquivAction (MaybeStructure S) maybeEquivAction α e = congMaybeEquiv (α e) maybeTransportStr : {S : Type ℓ → Type ℓ₁} (α : EquivAction S) → TransportStr α → TransportStr (maybeEquivAction α) maybeTransportStr _ τ e nothing = refl maybeTransportStr _ τ e (just x) = cong just (τ e x)

-- SOURCE URL: `https://agda.github.io/cubical/Cubical.Structures.Record.html` {- Automatically generating proofs of UnivalentStr for records -} {-# OPTIONS --no-exact-split #-} module Cubical.Structures.Record where open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Function open import Cubical.Foundations.HLevels open import Cubical.Foundations.Isomorphism open import Cubical.Foundations.SIP open import Cubical.Foundations.Structure open import Cubical.Foundations.Univalence open import Cubical.Data.Sigma open import Cubical.Data.Nat open import Cubical.Data.List as List open import Cubical.Data.Vec as Vec open import Cubical.Data.Bool open import Cubical.Data.Maybe open import Cubical.Data.Sum open import Cubical.Structures.Auto import Cubical.Structures.Macro as M import Agda.Builtin.Reflection as R open import Cubical.Reflection.Base -- Magic number private FUEL = 10000 -- Types for specifying inputs to the tactics data AutoFieldSpec : Typeω where autoFieldSpec : ∀ {ℓ ℓ₁ ℓ₂} (R : Type ℓ → Type ℓ₁) {S : Type ℓ → Type ℓ₂} → ({X : Type ℓ} → R X → S X) → AutoFieldSpec module _ {ℓ ℓ₁ ℓ₁'} where mutual data AutoFields (R : Type ℓ → Type ℓ₁) (ι : StrEquiv R ℓ₁') : Typeω where fields: : AutoFields R ι _data[_∣_] : (fs : AutoFields R ι) → ∀ {ℓ₂ ℓ₂'} {S : Type ℓ → Type ℓ₂} {ι' : StrEquiv S ℓ₂'} → (f : {X : Type ℓ} → R X → S X) → ({A B : TypeWithStr ℓ R} {e : typ A ≃ typ B} → ι A B e → ι' (map-snd f A) (map-snd f B) e) → AutoFields R ι _prop[_∣_] : (fs : AutoFields R ι) → ∀ {ℓ₂} {P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂} → ({X : Type ℓ} (r : R X) → P X (projectFields fs r)) → isPropProperty R ι fs P → AutoFields R ι GatherFieldsLevel : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'} → AutoFields R ι → Level GatherFieldsLevel fields: = ℓ-zero GatherFieldsLevel (_data[_∣_] fs {ℓ₂ = ℓ₂} _ _) = ℓ-max (GatherFieldsLevel fs) ℓ₂ GatherFieldsLevel (_prop[_∣_] fs {ℓ₂ = ℓ₂} _ _) = ℓ-max (GatherFieldsLevel fs) ℓ₂ GatherFields : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'} (dat : AutoFields R ι) → Type ℓ → Type (GatherFieldsLevel dat) GatherFields fields: X = Unit GatherFields (_data[_∣_] fs {S = S} _ _) X = GatherFields fs X × S X GatherFields (_prop[_∣_] fs {P = P} _ _) X = Σ[ s ∈ GatherFields fs X ] (P X s) projectFields : {R : Type ℓ → Type ℓ₁} {ι : StrEquiv R ℓ₁'} (fs : AutoFields R ι) → {X : Type ℓ} → R X → GatherFields fs X projectFields fields: = _ projectFields (fs data[ f ∣ _ ]) r = projectFields fs r , f r projectFields (fs prop[ f ∣ _ ]) r = projectFields fs r , f r isPropProperty : ∀ {ℓ₂} (R : Type ℓ → Type ℓ₁) (ι : StrEquiv R ℓ₁') (fs : AutoFields R ι) (P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂) → Type (ℓ-max (ℓ-suc ℓ) (ℓ-max ℓ₁ ℓ₂)) isPropProperty R ι fs P = {X : Type ℓ} (r : R X) → isProp (P X (projectFields fs r)) data AutoRecordSpec : Typeω where autoRecordSpec : (R : Type ℓ → Type ℓ₁) (ι : StrEquiv R ℓ₁') → AutoFields R ι → AutoRecordSpec -- Some reflection utilities private tApply : R.Term → List (R.Arg R.Term) → R.Term tApply t l = R.def (quote idfun) (R.unknown v∷ t v∷ l) tStrMap : R.Term → R.Term → R.Term tStrMap A f = R.def (quote map-snd) (f v∷ A v∷ []) tStrProj : R.Term → R.Name → R.Term tStrProj A sfield = tStrMap A (R.def sfield []) Fun : ∀ {ℓ ℓ'} → Type ℓ → Type ℓ' → Type (ℓ-max ℓ ℓ') Fun A B = A → B -- Helper functions used in the generated univalence proof private pathMap : ∀ {ℓ ℓ'} {S : I → Type ℓ} {T : I → Type ℓ'} (f : {i : I} → S i → T i) {x : S i0} {y : S i1} → PathP S x y → PathP T (f x) (f y) pathMap f p i = f (p i) -- Property field helper functions module _ {ℓ ℓ₁ ℓ₁' ℓ₂} (R : Type ℓ → Type ℓ₁) -- Structure record (ι : StrEquiv R ℓ₁') -- Equivalence record (fs : AutoFields R ι) -- Prior fields (P : (X : Type ℓ) → GatherFields fs X → Type ℓ₂) -- Property type (f : {X : Type ℓ} (r : R X) → P X (projectFields fs r)) -- Property projection where prev = projectFields fs Prev = GatherFields fs PropHelperCenterType : Type _ PropHelperCenterType = (A B : TypeWithStr ℓ R) (e : A .fst ≃ B .fst) (p : PathP (λ i → Prev (ua e i)) (prev (A .snd)) (prev (B .snd))) → PathP (λ i → P (ua e i) (p i)) (f (A .snd)) (f (B .snd)) PropHelperContractType : PropHelperCenterType → Type _ PropHelperContractType c = (A B : TypeWithStr ℓ R) (e : A .fst ≃ B .fst) {p₀ : PathP (λ i → Prev (ua e i)) (prev (A .snd)) (prev (B .snd))} (q : PathP (λ i → R (ua e i)) (A .snd) (B .snd)) (p : p₀ ≡ (λ i → prev (q i))) → PathP (λ k → PathP (λ i → P (ua e i) (p k i)) (f (A .snd)) (f (B .snd))) (c A B e p₀) (λ i → f (q i)) PropHelperType : Type _ PropHelperType = Σ PropHelperCenterType PropHelperContractType derivePropHelper : isPropProperty R ι fs P → PropHelperType derivePropHelper propP .fst A B e p = isOfHLevelPathP' 0 (propP _) (f (A .snd)) (f (B .snd)) .fst derivePropHelper propP .snd A B e q p = isOfHLevelPathP' 0 (isOfHLevelPathP 1 (propP _) _ _) _ _ .fst -- Build proof of univalence from an isomorphism module _ {ℓ ℓ₁ ℓ₁'} (S : Type ℓ → Type ℓ₁) (ι : StrEquiv S ℓ₁') where fwdShape : Type _ fwdShape = (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ι A B e → PathP (λ i → S (ua e i)) (str A) (str B) bwdShape : Type _ bwdShape = (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → PathP (λ i → S (ua e i)) (str A) (str B) → ι A B e fwdBwdShape : fwdShape → bwdShape → Type _ fwdBwdShape fwd bwd = (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ∀ p → fwd A B e (bwd A B e p) ≡ p bwdFwdShape : fwdShape → bwdShape → Type _ bwdFwdShape fwd bwd = (A B : TypeWithStr ℓ S) (e : typ A ≃ typ B) → ∀ r → bwd A B e (fwd A B e r) ≡ r -- The implicit arguments A,B in UnivalentStr make some things annoying so let's avoid them ExplicitUnivalentStr : Type _ ExplicitUnivalentStr = (A B : TypeWithStr _ S) (e : typ A ≃ typ B) → ι A B e ≃ PathP (λ i → S (ua e i)) (str A) (str B) explicitUnivalentStr : (fwd : fwdShape) (bwd : bwdShape) → fwdBwdShape fwd bwd → bwdFwdShape fwd bwd → ExplicitUnivalentStr explicitUnivalentStr fwd bwd fwdBwd bwdFwd A B e = isoToEquiv isom where open Iso isom : Iso _ _ isom .fun = fwd A B e isom .inv = bwd A B e isom .sec = fwdBwd A B e isom .ret = bwdFwd A B e ExplicitUnivalentDesc : ∀ ℓ {ℓ₁ ℓ₁'} → (d : M.Desc ℓ ℓ₁ ℓ₁') → Type _ ExplicitUnivalentDesc _ d = ExplicitUnivalentStr (M.MacroStructure d) (M.MacroEquivStr d) explicitUnivalentDesc : ∀ ℓ {ℓ₁ ℓ₁'} → (d : M.Desc ℓ ℓ₁ ℓ₁') → ExplicitUnivalentDesc ℓ d explicitUnivalentDesc _ d A B e = M.MacroUnivalentStr d e -- Internal record specification type private record TypedTerm : Type where field type : R.Term term : R.Term record InternalDatumField : Type where field sfield : R.Name -- name of structure field efield : R.Name -- name of equivalence field record InternalPropField : Type where field sfield : R.Name -- name of structure field InternalField : Type InternalField = InternalDatumField ⊎ InternalPropField record InternalSpec (A : Type) : Type where field srec : R.Term -- structure record type erec : R.Term -- equivalence record type fields : List (InternalField × A) -- in reverse order open TypedTerm open InternalDatumField open InternalPropField -- Parse a field and record specifications private findName : R.Term → R.TC R.Name findName (R.def name _) = R.returnTC name findName (R.lam R.hidden (R.abs _ t)) = findName t findName t = R.typeError (R.strErr "Not a name + spine: " ∷ R.termErr t ∷ []) parseFieldSpec : R.Term → R.TC (R.Term × R.Term × R.Term × R.Term) parseFieldSpec (R.con (quote autoFieldSpec) (ℓ h∷ ℓ₁ h∷ ℓ₂ h∷ R v∷ S h∷ f v∷ [])) = R.reduce ℓ >>= λ ℓ → R.returnTC (ℓ , ℓ₂ , S , f) parseFieldSpec t = R.typeError (R.strErr "Malformed field specification: " ∷ R.termErr t ∷ []) parseSpec : R.Term → R.TC (InternalSpec TypedTerm) parseSpec (R.con (quote autoRecordSpec) (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ srecTerm v∷ erecTerm v∷ fs v∷ [])) = parseFields fs >>= λ fs' → R.returnTC λ { .srec → srecTerm ; .erec → erecTerm ; .fields → fs'} where open InternalSpec parseFields : R.Term → R.TC (List (InternalField × TypedTerm)) parseFields (R.con (quote fields:) _) = R.returnTC [] parseFields (R.con (quote _data[_∣_]) (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ R h∷ ι h∷ fs v∷ ℓ₂ h∷ ℓ₂' h∷ S h∷ ι' h∷ sfieldTerm v∷ efieldTerm v∷ [])) = R.reduce ℓ >>= λ ℓ → findName sfieldTerm >>= λ sfieldName → findName efieldTerm >>= λ efieldName → buildDesc FUEL ℓ ℓ₂ S >>= λ d → let f : InternalField × TypedTerm f = λ { .fst → inl λ { .sfield → sfieldName ; .efield → efieldName } ; .snd .type → R.def (quote ExplicitUnivalentDesc) (ℓ v∷ d v∷ []) ; .snd .term → R.def (quote explicitUnivalentDesc) (ℓ v∷ d v∷ []) } in liftTC (f ∷_) (parseFields fs) parseFields (R.con (quote _prop[_∣_]) (ℓ h∷ ℓ₁ h∷ ℓ₁' h∷ R h∷ ι h∷ fs v∷ ℓ₂ h∷ P h∷ fieldTerm v∷ prop v∷ [])) = findName fieldTerm >>= λ fieldName → let p : InternalField × TypedTerm p = λ { .fst → inr λ { .sfield → fieldName } ; .snd .type → R.def (quote PropHelperType) (srecTerm v∷ erecTerm v∷ fs v∷ P v∷ fieldTerm v∷ []) ; .snd .term → R.def (quote derivePropHelper) (srecTerm v∷ erecTerm v∷ fs v∷ P v∷ fieldTerm v∷ prop v∷ []) } in liftTC (p ∷_) (parseFields fs) parseFields t = R.typeError (R.strErr "Malformed autoRecord specification (1): " ∷ R.termErr t ∷ []) parseSpec t = R.typeError (R.strErr "Malformed autoRecord specification (2): " ∷ R.termErr t ∷ []) -- Build a proof of univalence from an InternalSpec module _ (spec : InternalSpec ℕ) where open InternalSpec spec private fwdDatum : Vec R.Term 4 → R.Term → InternalDatumField × ℕ → R.Term fwdDatum (A ∷ B ∷ e ∷ streq ∷ _) i (dat , n) = R.def (quote equivFun) (tApply (v n) (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ []) v∷ R.def (dat .efield) (streq v∷ []) v∷ i v∷ []) fwdProperty : Vec R.Term 4 → R.Term → R.Term → InternalPropField × ℕ → R.Term fwdProperty (A ∷ B ∷ e ∷ streq ∷ _) i prevPath prop = R.def (quote fst) (v (prop .snd) v∷ A v∷ B v∷ e v∷ prevPath v∷ i v∷ []) bwdClause : Vec R.Term 4 → InternalDatumField × ℕ → R.Clause bwdClause (A ∷ B ∷ e ∷ q ∷ _) (dat , n) = R.clause [] (R.proj (dat .efield) v∷ []) (R.def (quote invEq) (tApply (v n) (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ []) v∷ R.def (quote pathMap) (R.def (dat .sfield) [] v∷ q v∷ []) v∷ [])) fwdBwdDatum : Vec R.Term 4 → R.Term → R.Term → InternalDatumField × ℕ → R.Term fwdBwdDatum (A ∷ B ∷ e ∷ q ∷ _) j i (dat , n) = R.def (quote secEq) (tApply (v n) (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ []) v∷ R.def (quote pathMap) (R.def (dat .sfield) [] v∷ q v∷ []) v∷ j v∷ i v∷ []) fwdBwdProperty : Vec R.Term 4 → (j i prevPath : R.Term) → InternalPropField × ℕ → R.Term fwdBwdProperty (A ∷ B ∷ e ∷ q ∷ _) j i prevPath prop = R.def (quote snd) (v (prop .snd) v∷ A v∷ B v∷ e v∷ q v∷ prevPath v∷ j v∷ i v∷ []) bwdFwdClause : Vec R.Term 4 → R.Term → InternalDatumField × ℕ → R.Clause bwdFwdClause (A ∷ B ∷ e ∷ streq ∷ _) j (dat , n) = R.clause [] (R.proj (dat .efield) v∷ []) (R.def (quote retEq) (tApply (v n) (tStrProj A (dat .sfield) v∷ tStrProj B (dat .sfield) v∷ e v∷ []) v∷ R.def (dat .efield) (streq v∷ []) v∷ j v∷ [])) makeVarsFrom : {n : ℕ} → ℕ → Vec R.Term n makeVarsFrom {zero} k = [] makeVarsFrom {suc n} k = v (n + k) ∷ (makeVarsFrom k) fwd : R.Term fwd = vlam "A" (vlam "B" (vlam "e" (vlam "streq" (vlam "i" (R.pat-lam body []))))) where -- input list is in reverse order fwdClauses : ℕ → List (InternalField × ℕ) → List (R.Name × R.Term) fwdClauses k [] = [] fwdClauses k ((inl f , n) ∷ fs) = fwdClauses k fs ∷ʳ (f .sfield , fwdDatum (makeVarsFrom k) (v 0) (map-snd (4 + k +_) (f , n))) fwdClauses k ((inr p , n) ∷ fs) = fwdClauses k fs ∷ʳ (p .sfield , fwdProperty (makeVarsFrom k) (v 0) prevPath (map-snd (4 + k +_) (p , n))) where prevPath = vlam "i" (List.foldl (λ t (_ , t') → R.con (quote _,_) (t v∷ t' v∷ [])) (R.con (quote tt) []) (fwdClauses (suc k) fs)) body = List.map (λ (n , t) → R.clause [] [ varg (R.proj n) ] t) (fwdClauses 1 fields) bwd : R.Term bwd = vlam "A" (vlam "B" (vlam "e" (vlam "q" (R.pat-lam (bwdClauses fields) [])))) where -- input is in reverse order bwdClauses : List (InternalField × ℕ) → List R.Clause bwdClauses [] = [] bwdClauses ((inl f , n) ∷ fs) = bwdClauses fs ∷ʳ bwdClause (makeVarsFrom 0) (map-snd (4 +_) (f , n)) bwdClauses ((inr p , n) ∷ fs) = bwdClauses fs fwdBwd : R.Term fwdBwd = vlam "A" (vlam "B" (vlam "e" (vlam "q" (vlam "j" (vlam "i" (R.pat-lam body [])))))) where -- input is in reverse order fwdBwdClauses : ℕ → List (InternalField × ℕ) → List (R.Name × R.Term) fwdBwdClauses k [] = [] fwdBwdClauses k ((inl f , n) ∷ fs) = fwdBwdClauses k fs ∷ʳ (f .sfield , fwdBwdDatum (makeVarsFrom k) (v 1) (v 0) (map-snd (4 + k +_) (f , n))) fwdBwdClauses k ((inr p , n) ∷ fs) = fwdBwdClauses k fs ∷ʳ ((p .sfield , fwdBwdProperty (makeVarsFrom k) (v 1) (v 0) prevPath (map-snd (4 + k +_) (p , n)))) where prevPath = vlam "j" (vlam "i" (List.foldl (λ t (_ , t') → R.con (quote _,_) (t v∷ t' v∷ [])) (R.con (quote tt) []) (fwdBwdClauses (2 + k) fs))) body = List.map (λ (n , t) → R.clause [] [ varg (R.proj n) ] t) (fwdBwdClauses 2 fields) bwdFwd : R.Term bwdFwd = vlam "A" (vlam "B" (vlam "e" (vlam "streq" (vlam "j" (R.pat-lam (bwdFwdClauses fields) []))))) where bwdFwdClauses : List (InternalField × ℕ) → List R.Clause bwdFwdClauses [] = [] bwdFwdClauses ((inl f , n) ∷ fs) = bwdFwdClauses fs ∷ʳ bwdFwdClause (makeVarsFrom 1) (v 0) (map-snd (5 +_) (f , n)) bwdFwdClauses ((inr _ , n) ∷ fs) = bwdFwdClauses fs univalentRecord : R.Term univalentRecord = R.def (quote explicitUnivalentStr) (R.unknown v∷ R.unknown v∷ fwd v∷ bwd v∷ fwdBwd v∷ bwdFwd v∷ []) macro autoFieldEquiv : R.Term → R.Term → R.Term → R.Term → R.TC Unit autoFieldEquiv spec A B hole = (R.reduce spec >>= parseFieldSpec) >>= λ (ℓ , ℓ₂ , S , f) → buildDesc FUEL ℓ ℓ₂ S >>= λ d → R.unify hole (R.def (quote M.MacroEquivStr) (d v∷ tStrMap A f v∷ tStrMap B f v∷ [])) autoUnivalentRecord : R.Term → R.Term → R.TC Unit autoUnivalentRecord t hole = (R.reduce t >>= parseSpec) >>= λ spec → -- R.typeError (R.strErr "WOW: " ∷ R.termErr (main spec) ∷ []) R.unify (main spec) hole where module _ (spec : InternalSpec TypedTerm) where open InternalSpec spec mapUp : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → (ℕ → A → B) → ℕ → List A → List B mapUp f _ [] = [] mapUp f n (x ∷ xs) = f n x ∷ mapUp f (suc n) xs closureSpec : InternalSpec ℕ closureSpec .InternalSpec.srec = srec closureSpec .InternalSpec.erec = erec closureSpec .InternalSpec.fields = mapUp (λ n → map-snd (λ _ → n)) 0 fields closure : R.Term closure = iter (List.length fields) (vlam "") (univalentRecord closureSpec) env : List (R.Arg R.Term) env = List.map (varg ∘ term ∘ snd) (List.rev fields) closureTy : R.Term closureTy = List.foldr (λ ty cod → R.def (quote Fun) (ty v∷ cod v∷ [])) (R.def (quote ExplicitUnivalentStr) (srec v∷ erec v∷ [])) (List.map (type ∘ snd) (List.rev fields)) main : R.Term main = R.def (quote idfun) (closureTy v∷ closure v∷ env)