diff --git a/Cubical.CW.Approximation.html b/Cubical.CW.Approximation.html index 7bf7b2eb2..8cf8eecdb 100644 --- a/Cubical.CW.Approximation.html +++ b/Cubical.CW.Approximation.html @@ -147,7 +147,7 @@ invEq propTrunc≃Trunc1 (invEq (_ , InductiveFinSatAC 1 (CWskel-fields.card C (suc m)) _) λ a → fst propTrunc≃Trunc1 - (sphereToTrunc m λ y → + (sphereToTrunc m λ y → TR.map fst (isConnectedCong _ _ (isConnected-CW↪∞ (suc (suc m)) D) (sym (push _) ∙ (fh (CWskel-fields.α C (suc m) (a , y)) @@ -191,8 +191,8 @@ (fib-f-r x)) ∥₁ mere-fib-f-coh = invEq propTrunc≃Trunc1 (invEq (_ , InductiveFinSatAC 1 (card (suc m)) _) - λ a → fst propTrunc≃Trunc1 (sphereToTrunc m - (sphereElim' m + λ a → fst propTrunc≃Trunc1 (sphereToTrunc m + (sphereElim' m (λ x → isOfHLevelRetractFromIso m (invIso (PathPIdTruncIso (suc m))) (isOfHLevelPathP' m (isProp→isOfHLevelSuc m @@ -521,7 +521,7 @@ Iso.inv propTruncTrunc1Iso (invEq (_ , InductiveFinSatAC 1 _ _) λ x → Iso.fun propTruncTrunc1Iso - (sphereToTrunc n' (fiber-cong²-hₙ₊₁-push∞ x))) + (sphereToTrunc n' (fiber-cong²-hₙ₊₁-push∞ x))) module _ (q : (x : Fin (fst (snd C) (suc n'))) (y : S₊ n') → fiber (cong² x y) (hₙ₊₁-push∞ x y)) where diff --git a/Cubical.CW.Properties.html b/Cubical.CW.Properties.html index 375c1182d..ca8bd61ff 100644 --- a/Cubical.CW.Properties.html +++ b/Cubical.CW.Properties.html @@ -240,7 +240,7 @@ inPushoutConnected : isConnectedFun (suc n) inPushout inPushoutConnected = inlConnected (suc n) (α (suc n)) fst - λ b → subst (isConnected (suc n)) (fstProjPath b) (sphereConnected n) + λ b → subst (isConnected (suc n)) (fstProjPath b) (sphereConnected n) -- The embedding of stage n into the colimit is (n+1)-connected isConnected-CW↪∞ : (n : ℕ) (C : CWskel ℓ) → isConnectedFun n (CW↪∞ C n) diff --git a/Cubical.Cohomology.EilenbergMacLane.Groups.Sn.html b/Cubical.Cohomology.EilenbergMacLane.Groups.Sn.html index 3ace6bd5c..c46177d97 100644 --- a/Cubical.Cohomology.EilenbergMacLane.Groups.Sn.html +++ b/Cubical.Cohomology.EilenbergMacLane.Groups.Sn.html @@ -258,7 +258,7 @@ (subst (λ x → (a : S₊ x → EM G 1) → 0ₕ 1 ≡ ∣ a ∣₂) (cong suc (+-comm 1 m)) λ f → TR.rec (squash₂ _ _) - (λ q → cong ∣_∣₂ (funExt (sphereElim (suc m) + (λ q → cong ∣_∣₂ (funExt (sphereElim (suc m) (λ _ → isOfHLevelPath' (suc (suc zero +ℕ m)) (isOfHLevelPlus' {n = m} 3 (hLevelEM _ 1)) _ _) q))) (isConnectedPath 1 (isConnectedEM 1) embase (f north) .fst)))) @@ -277,7 +277,7 @@ λ f → TR.rec (isProp→isOfHLevelSuc (suc n) (squash₂ _ _)) (λ q → cong ∣_∣₂ - (funExt (sphereElim _ + (funExt (sphereElim _ (λ s → isOfHLevelPath' (suc (suc (suc (m +ℕ n)))) (subst (λ x → isOfHLevel x (EM G (suc (suc n)))) (+-assoc m 4 n ∙ cong (_+ℕ n) (+-comm m 4)) @@ -297,7 +297,7 @@ H⁰[Sⁿ,G]≅G n = H⁰conn (∣ ptSn (suc n) ∣ₕ , (TR.elim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _) - (sphereElim n (λ _ → isProp→isOfHLevelSuc n (isOfHLevelTrunc 2 _ _)) + (sphereElim n (λ _ → isProp→isOfHLevelSuc n (isOfHLevelTrunc 2 _ _)) refl))) G Hⁿ[Sᵐ,G]Full : (n m : ℕ) diff --git a/Cubical.Cohomology.EilenbergMacLane.Gysin.html b/Cubical.Cohomology.EilenbergMacLane.Gysin.html index 9fc38198e..738279f4c 100644 --- a/Cubical.Cohomology.EilenbergMacLane.Gysin.html +++ b/Cubical.Cohomology.EilenbergMacLane.Gysin.html @@ -667,8 +667,8 @@ (isoToEquiv (congSuspIso (equivToIso (fst e))) , refl) - (isoToEquiv (invIso (IsoSucSphereSusp n)) - , IsoSucSphereSusp∙ n) + (isoToEquiv (invIso (IsoSucSphereSusp n)) + , IsoSucSphereSusp∙ n) module con (c : (b : fst B) → Q b →∙ EM∙ (CommRing→AbGroup R) (suc n)) (r : c (pt B) ≡ (gen-HⁿSⁿ-raw (CommRing→Ring R) (suc n) ∘∙ ≃∙map Q≃)) diff --git a/Cubical.Experiments.Problem.html b/Cubical.Experiments.Problem.html index 0dd85fa7c..ce9159762 100644 --- a/Cubical.Experiments.Problem.html +++ b/Cubical.Experiments.Problem.html @@ -28,7 +28,7 @@ S³pt : ptType S³pt = (S³ , base) joinpt : ptType -joinpt = (join S¹ S¹ , inl base) +joinpt = (join S¹ S¹ , inl base) Ω : (A : ptType) → ptType Ω A = Path _ (pt A) (pt A) , refl @@ -38,10 +38,10 @@ Ω³ A = Ω² (Ω A) -α : join S¹ S¹ → S² -α (inl _) = base -α (inr _) = base -α (push x y i) = (merid y ∙ merid x) i +α : join S¹ S¹ → S² +α (inl _) = base +α (inr _) = base +α (push x y i) = (merid y ∙ merid x) i where merid : S¹ → Path S² base base merid base = refl @@ -53,7 +53,7 @@ test0To2 i j k = surf i j k f3 : Ω³ S³pt .fst → Ω³ joinpt .fst -f3 p i j k = S³→joinS¹S¹ (p i j k) +f3 p i j k = S³→joinS¹S¹ (p i j k) test0To3 : Ω³ joinpt .fst test0To3 = f3 test0To2 diff --git a/Cubical.Experiments.ZCohomology.Benchmarks.html b/Cubical.Experiments.ZCohomology.Benchmarks.html index 02e2b3f83..d4e01c5fc 100644 --- a/Cubical.Experiments.ZCohomology.Benchmarks.html +++ b/Cubical.Experiments.ZCohomology.Benchmarks.html @@ -361,7 +361,7 @@ transport (λ i → (B : isoToPath IsoS³TotalHopf i → Type) → ((x : _) → isOfHLevel 3 (B x)) → B (transp (λ j → isoToPath IsoS³TotalHopf (i ∨ ~ j)) i (north , base)) → (x : _) → B x) - λ B hLev ind → sphereElim _ (λ _ → hLev _) ind + λ B hLev ind → sphereElim _ (λ _ → hLev _) ind p : (a : TotalHopf) → ∣ fst a ∣ ≡ 0ₖ 2 p = ind _ (λ _ → isOfHLevelTrunc 4 _ _) refl diff --git a/Cubical.Experiments.ZCohomologyOld.KcompPrelims.html b/Cubical.Experiments.ZCohomologyOld.KcompPrelims.html index c2c93b44e..ed3aea6d7 100644 --- a/Cubical.Experiments.ZCohomologyOld.KcompPrelims.html +++ b/Cubical.Experiments.ZCohomologyOld.KcompPrelims.html @@ -72,10 +72,10 @@ ∙ λ i → ∣ north , lUnit r (~ i) ∣ totalFun : (a b : S2+n) → P a b - totalFun = wedgeconFun (suc n) (suc n) hLevelP rightFun leftFun funsAgree + totalFun = wedgeconFun (suc n) (suc n) hLevelP rightFun leftFun funsAgree leftId : (λ x → totalFun x north) ≡ leftFun - leftId x i = wedgeconRight (suc n) (suc n) hLevelP rightFun leftFun funsAgree i x + leftId x i = wedgeconRight (suc n) (suc n) hLevelP rightFun leftFun funsAgree i x fwd : (p : north ≡ north) (a : S2+n) → hLevelTrunc 4n+2 (fiber σ p) @@ -179,7 +179,7 @@ rotLemma (loop i) = refl sphereConnectedSpecCase : isConnected 4 (Susp (Susp S¹)) -sphereConnectedSpecCase = sphereConnected 3 +sphereConnectedSpecCase = sphereConnected 3 d-mapComp : Iso (fiber d-map base) (Path (S₊ 3) north north) d-mapComp = compIso (IsoΣPathTransportPathΣ {B = HopfSuspS¹} _ _) @@ -193,7 +193,7 @@ where contrHelper : isContr (Path (∥ Susp (Susp S¹) ∥ 4) ∣ north ∣ ∣ north ∣) fst contrHelper = refl - snd contrHelper = isOfHLevelPlus {n = 0} 2 (sphereConnected 3) ∣ north ∣ ∣ north ∣ refl + snd contrHelper = isOfHLevelPlus {n = 0} 2 (sphereConnected 3) ∣ north ∣ ∣ north ∣ refl d-Iso : Iso (∥ Path (S₊ 2) north north ∥ 3) (coHomK 1) d-Iso = connectedTruncIso _ d-map is1Connected-dmap diff --git a/Cubical.Experiments.ZCohomologyOld.Properties.html b/Cubical.Experiments.ZCohomologyOld.Properties.html index 74acbdb88..f74694272 100644 --- a/Cubical.Experiments.ZCohomologyOld.Properties.html +++ b/Cubical.Experiments.ZCohomologyOld.Properties.html @@ -65,7 +65,7 @@ (suspToPropElim (ptSn (suc n)) (λ _ → isOfHLevelTrunc 2 _ _) refl)) isConnectedKn : (n : ℕ) → isConnected (2 + n) (coHomK (suc n)) -isConnectedKn n = isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (2 + n) 1)) (sphereConnected (suc n)) +isConnectedKn n = isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (2 + n) 1)) (sphereConnected (suc n)) -- Induction principles for cohomology groups -- If we want to show a proposition about some x : Hⁿ(A), it suffices to show it under the diff --git a/Cubical.HITs.Everything.html b/Cubical.HITs.Everything.html index 6fa2db5c2..389947229 100644 --- a/Cubical.HITs.Everything.html +++ b/Cubical.HITs.Everything.html @@ -59,13 +59,14 @@ import Cubical.HITs.SmashProduct.SymmetricMonoidalCat import Cubical.HITs.Sn import Cubical.HITs.Sn.Degree -import Cubical.HITs.SphereBouquet -import Cubical.HITs.SphereBouquet.Degree -import Cubical.HITs.Susp -import Cubical.HITs.Susp.LoopAdjunction -import Cubical.HITs.Torus -import Cubical.HITs.Truncation -import Cubical.HITs.TypeQuotients -import Cubical.HITs.UnorderedPair -import Cubical.HITs.Wedge +import Cubical.HITs.Sn.Multiplication +import Cubical.HITs.SphereBouquet +import Cubical.HITs.SphereBouquet.Degree +import Cubical.HITs.Susp +import Cubical.HITs.Susp.LoopAdjunction +import Cubical.HITs.Torus +import Cubical.HITs.Truncation +import Cubical.HITs.TypeQuotients +import Cubical.HITs.UnorderedPair +import Cubical.HITs.Wedge \ No newline at end of file diff --git a/Cubical.HITs.Join.Base.html b/Cubical.HITs.Join.Base.html index 9bba20eb8..7b8776f35 100644 --- a/Cubical.HITs.Join.Base.html +++ b/Cubical.HITs.Join.Base.html @@ -5,85 +5,91 @@ open import Cubical.Foundations.Prelude open import Cubical.Foundations.Equiv open import Cubical.Foundations.Isomorphism +open import Cubical.Foundations.Pointed.Base -open import Cubical.HITs.S1 -open import Cubical.HITs.S3 +open import Cubical.HITs.S1 +open import Cubical.HITs.S3 --- redtt version : https://github.com/RedPRL/redtt/blob/master/library/cool/s3-to-join.red +-- redtt version : https://github.com/RedPRL/redtt/blob/master/library/cool/s3-to-join.red -data join {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') : Type (ℓ-max ℓ ℓ') where - inl : A → join A B - inr : B → join A B - push : ∀ a b → inl a ≡ inr b +data join {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') : Type (ℓ-max ℓ ℓ') where + inl : A → join A B + inr : B → join A B + push : ∀ a b → inl a ≡ inr b -facek01 : I → I → I → join S¹ S¹ -facek01 i j k = hfill (λ l → λ { (j = i0) → push base base (~ l ∧ ~ k) - ; (j = i1) → push base base (~ l ∧ ~ k) - ; (k = i0) → push (loop j) base (~ l) - ; (k = i1) → inl base }) - (inS (push base base (~ k))) i +join∙ : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') + → Pointed _ +fst (join∙ A B) = join (fst A) (fst B) +snd (join∙ A B) = inl (pt A) -border-contraction : I → I → I → I → join S¹ S¹ -border-contraction i j k m = - hfill (λ l → λ { (i = i0) → facek01 i1 j l - ; (i = i1) → push base (loop k) (~ l) - ; (j = i0) → push base (loop k) (i ∧ ~ l) - ; (j = i1) → push base (loop k) (i ∧ ~ l) - ; (k = i0) → facek01 (~ i) j l - ; (k = i1) → facek01 (~ i) j l }) - (inS (push (loop j) (loop k) i)) m +facek01 : I → I → I → join S¹ S¹ +facek01 i j k = hfill (λ l → λ { (j = i0) → push base base (~ l ∧ ~ k) + ; (j = i1) → push base base (~ l ∧ ~ k) + ; (k = i0) → push (loop j) base (~ l) + ; (k = i1) → inl base }) + (inS (push base base (~ k))) i -S³→joinS¹S¹ : S³ → join S¹ S¹ -S³→joinS¹S¹ base = inl base -S³→joinS¹S¹ (surf j k i) = border-contraction i j k i1 +border-contraction : I → I → I → I → join S¹ S¹ +border-contraction i j k m = + hfill (λ l → λ { (i = i0) → facek01 i1 j l + ; (i = i1) → push base (loop k) (~ l) + ; (j = i0) → push base (loop k) (i ∧ ~ l) + ; (j = i1) → push base (loop k) (i ∧ ~ l) + ; (k = i0) → facek01 (~ i) j l + ; (k = i1) → facek01 (~ i) j l }) + (inS (push (loop j) (loop k) i)) m -joinS¹S¹→S³ : join S¹ S¹ → S³ -joinS¹S¹→S³ (inl x) = base -joinS¹S¹→S³ (inr x) = base -joinS¹S¹→S³ (push base b i) = base -joinS¹S¹→S³ (push (loop x) base i) = base -joinS¹S¹→S³ (push (loop i) (loop j) k) = surf i j k +S³→joinS¹S¹ : S³ → join S¹ S¹ +S³→joinS¹S¹ base = inl base +S³→joinS¹S¹ (surf j k i) = border-contraction i j k i1 -connection : I → I → I → I → S³ -connection i j k l = - hfill (λ m → λ { (k = i0) → joinS¹S¹→S³ (facek01 m i j) - ; (k = i1) → base - ; (j = i0) → base - ; (j = i1) → base - ; (i = i0) → base - ; (i = i1) → base }) - (inS base) l +joinS¹S¹→S³ : join S¹ S¹ → S³ +joinS¹S¹→S³ (inl x) = base +joinS¹S¹→S³ (inr x) = base +joinS¹S¹→S³ (push base b i) = base +joinS¹S¹→S³ (push (loop x) base i) = base +joinS¹S¹→S³ (push (loop i) (loop j) k) = surf i j k -S³→joinS¹S¹→S³ : ∀ x → joinS¹S¹→S³ (S³→joinS¹S¹ x) ≡ x -S³→joinS¹S¹→S³ base l = base -S³→joinS¹S¹→S³ (surf j k i) l = - hcomp (λ m → λ { (l = i0) → joinS¹S¹→S³ (border-contraction i j k m) - ; (l = i1) → surf j k i - ; (i = i0) → connection j m l i1 - ; (i = i1) → base - ; (j = i0) → base - ; (j = i1) → base - ; (k = i0) → connection j m l (~ i) - ; (k = i1) → connection j m l (~ i) }) - (surf j k i) +connection : I → I → I → I → S³ +connection i j k l = + hfill (λ m → λ { (k = i0) → joinS¹S¹→S³ (facek01 m i j) + ; (k = i1) → base + ; (j = i0) → base + ; (j = i1) → base + ; (i = i0) → base + ; (i = i1) → base }) + (inS base) l -joinS¹S¹→S³→joinS¹S¹ : ∀ x → S³→joinS¹S¹ (joinS¹S¹→S³ x) ≡ x -joinS¹S¹→S³→joinS¹S¹ (inl base) l = inl base -joinS¹S¹→S³→joinS¹S¹ (inl (loop i)) l = facek01 i1 i (~ l) -joinS¹S¹→S³→joinS¹S¹ (inr base) l = push base base l -joinS¹S¹→S³→joinS¹S¹ (inr (loop i)) l = push base (loop i) l -joinS¹S¹→S³→joinS¹S¹ (push base base i) l = push base base (i ∧ l) -joinS¹S¹→S³→joinS¹S¹ (push base (loop k) i) l = push base (loop k) (i ∧ l) -joinS¹S¹→S³→joinS¹S¹ (push (loop k) base i) l = facek01 (~ i) k (~ l) -joinS¹S¹→S³→joinS¹S¹ (push (loop j) (loop k) i) l = border-contraction i j k (~ l) +S³→joinS¹S¹→S³ : ∀ x → joinS¹S¹→S³ (S³→joinS¹S¹ x) ≡ x +S³→joinS¹S¹→S³ base l = base +S³→joinS¹S¹→S³ (surf j k i) l = + hcomp (λ m → λ { (l = i0) → joinS¹S¹→S³ (border-contraction i j k m) + ; (l = i1) → surf j k i + ; (i = i0) → connection j m l i1 + ; (i = i1) → base + ; (j = i0) → base + ; (j = i1) → base + ; (k = i0) → connection j m l (~ i) + ; (k = i1) → connection j m l (~ i) }) + (surf j k i) -S³IsojoinS¹S¹ : Iso S³ (join S¹ S¹) -Iso.fun S³IsojoinS¹S¹ = S³→joinS¹S¹ -Iso.inv S³IsojoinS¹S¹ = joinS¹S¹→S³ -Iso.rightInv S³IsojoinS¹S¹ = joinS¹S¹→S³→joinS¹S¹ -Iso.leftInv S³IsojoinS¹S¹ = S³→joinS¹S¹→S³ +joinS¹S¹→S³→joinS¹S¹ : ∀ x → S³→joinS¹S¹ (joinS¹S¹→S³ x) ≡ x +joinS¹S¹→S³→joinS¹S¹ (inl base) l = inl base +joinS¹S¹→S³→joinS¹S¹ (inl (loop i)) l = facek01 i1 i (~ l) +joinS¹S¹→S³→joinS¹S¹ (inr base) l = push base base l +joinS¹S¹→S³→joinS¹S¹ (inr (loop i)) l = push base (loop i) l +joinS¹S¹→S³→joinS¹S¹ (push base base i) l = push base base (i ∧ l) +joinS¹S¹→S³→joinS¹S¹ (push base (loop k) i) l = push base (loop k) (i ∧ l) +joinS¹S¹→S³→joinS¹S¹ (push (loop k) base i) l = facek01 (~ i) k (~ l) +joinS¹S¹→S³→joinS¹S¹ (push (loop j) (loop k) i) l = border-contraction i j k (~ l) +S³IsojoinS¹S¹ : Iso S³ (join S¹ S¹) +Iso.fun S³IsojoinS¹S¹ = S³→joinS¹S¹ +Iso.inv S³IsojoinS¹S¹ = joinS¹S¹→S³ +Iso.rightInv S³IsojoinS¹S¹ = joinS¹S¹→S³→joinS¹S¹ +Iso.leftInv S³IsojoinS¹S¹ = S³→joinS¹S¹→S³ -S³≡joinS¹S¹ : S³ ≡ join S¹ S¹ -S³≡joinS¹S¹ = isoToPath S³IsojoinS¹S¹ + +S³≡joinS¹S¹ : S³ ≡ join S¹ S¹ +S³≡joinS¹S¹ = isoToPath S³IsojoinS¹S¹ \ No newline at end of file diff --git a/Cubical.HITs.Join.Properties.html b/Cubical.HITs.Join.Properties.html index b30da59e6..e2666fb50 100644 --- a/Cubical.HITs.Join.Properties.html +++ b/Cubical.HITs.Join.Properties.html @@ -41,34 +41,34 @@ -- Characterisation of function type join A B → C IsoFunSpaceJoin : ∀ {ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - → Iso (join A B → C) + → Iso (join A B → C) (Σ[ f ∈ (A → C) ] Σ[ g ∈ (B → C) ] ((a : A) (b : B) → f a ≡ g b)) -fun IsoFunSpaceJoin f = (f ∘ inl) , ((f ∘ inr) , (λ a b → cong f (push a b))) -inv IsoFunSpaceJoin (f , g , p) (inl x) = f x -inv IsoFunSpaceJoin (f , g , p) (inr x) = g x -inv IsoFunSpaceJoin (f , g , p) (push a b i) = p a b i +fun IsoFunSpaceJoin f = (f ∘ inl) , ((f ∘ inr) , (λ a b → cong f (push a b))) +inv IsoFunSpaceJoin (f , g , p) (inl x) = f x +inv IsoFunSpaceJoin (f , g , p) (inr x) = g x +inv IsoFunSpaceJoin (f , g , p) (push a b i) = p a b i rightInv IsoFunSpaceJoin (f , g , p) = refl leftInv IsoFunSpaceJoin f = - funExt λ { (inl x) → refl ; (inr x) → refl ; (push a b i) → refl} + funExt λ { (inl x) → refl ; (inr x) → refl ; (push a b i) → refl} -- Alternative definition of the join using a pushout joinPushout : (A : Type ℓ) → (B : Type ℓ') → Type (ℓ-max ℓ ℓ') joinPushout A B = Pushout {A = A × B} proj₁ proj₂ -- Proof that it is equal -joinPushout-iso-join : (A : Type ℓ) → (B : Type ℓ') → Iso (joinPushout A B) (join A B) +joinPushout-iso-join : (A : Type ℓ) → (B : Type ℓ') → Iso (joinPushout A B) (join A B) joinPushout-iso-join A B = iso joinPushout→join join→joinPushout join→joinPushout→join joinPushout→join→joinPushout where - joinPushout→join : joinPushout A B → join A B - joinPushout→join (inl x) = inl x - joinPushout→join (inr x) = inr x - joinPushout→join (push x i) = push (proj₁ x) (proj₂ x) i + joinPushout→join : joinPushout A B → join A B + joinPushout→join (inl x) = inl x + joinPushout→join (inr x) = inr x + joinPushout→join (push x i) = push (proj₁ x) (proj₂ x) i - join→joinPushout : join A B → joinPushout A B - join→joinPushout (inl x) = inl x - join→joinPushout (inr x) = inr x - join→joinPushout (push a b i) = push (a , b) i + join→joinPushout : join A B → joinPushout A B + join→joinPushout (inl x) = inl x + join→joinPushout (inr x) = inr x + join→joinPushout (push a b i) = push (a , b) i joinPushout→join→joinPushout : ∀ x → join→joinPushout (joinPushout→join x) ≡ x joinPushout→join→joinPushout (inl x) = refl @@ -76,27 +76,27 @@ joinPushout→join→joinPushout (push (a , b) j) = refl join→joinPushout→join : ∀ x → joinPushout→join (join→joinPushout x) ≡ x - join→joinPushout→join (inl x) = refl - join→joinPushout→join (inr x) = refl - join→joinPushout→join (push a b j) = refl + join→joinPushout→join (inl x) = refl + join→joinPushout→join (inr x) = refl + join→joinPushout→join (push a b j) = refl -- We will need both the equivalence and path version -joinPushout≃join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≃ join A B +joinPushout≃join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≃ join A B joinPushout≃join A B = isoToEquiv (joinPushout-iso-join A B) -joinPushout≡join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≡ join A B +joinPushout≡join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≡ join A B joinPushout≡join A B = isoToPath (joinPushout-iso-join A B) {- Proof of associativity of the join -} -join-assoc : (A B C : Type₀) → join (join A B) C ≡ join A (join B C) -join-assoc A B C = (joinPushout≡join (join A B) C) ⁻¹ +join-assoc : (A B C : Type₀) → join (join A B) C ≡ join A (join B C) +join-assoc A B C = (joinPushout≡join (join A B) C) ⁻¹ ∙ (spanEquivToPushoutPath sp3≃sp4) ⁻¹ ∙ (3x3-span.3x3-lemma span) ⁻¹ ∙ (spanEquivToPushoutPath sp1≃sp2) - ∙ (joinPushout≡join A (join B C)) + ∙ (joinPushout≡join A (join B C)) where -- the meat of the proof is handled by the 3x3 lemma applied to this diagram span : 3x3-span @@ -141,8 +141,8 @@ sp2 : 3-span sp2 = record { A0 = A ; - A2 = A × (join B C) ; - A4 = join B C ; + A2 = A × (join B C) ; + A4 = join B C ; f1 = proj₁ ; f3 = proj₂ } @@ -156,17 +156,17 @@ H3 = H2 } where A×join : Type₀ - A×join = A × (join B C) + A×join = A × (join B C) A□2→A×join : 3x3-span.A□2 span → A×join - A□2→A×join (inl (a , b)) = a , inl b - A□2→A×join (inr (a , c)) = a , inr c - A□2→A×join (push (a , (b , c)) i) = a , push b c i + A□2→A×join (inl (a , b)) = a , inl b + A□2→A×join (inr (a , c)) = a , inr c + A□2→A×join (push (a , (b , c)) i) = a , push b c i A×join→A□2 : A×join → 3x3-span.A□2 span - A×join→A□2 (a , inl b) = inl (a , b) - A×join→A□2 (a , inr c) = inr (a , c) - A×join→A□2 (a , push b c i) = push (a , (b , c)) i + A×join→A□2 (a , inl b) = inl (a , b) + A×join→A□2 (a , inr c) = inr (a , c) + A×join→A□2 (a , push b c i) = push (a , (b , c)) i A×join→A□2→A×join : ∀ x → A×join→A□2 (A□2→A×join x) ≡ x A×join→A□2→A×join (inl (a , b)) = refl @@ -174,9 +174,9 @@ A×join→A□2→A×join (push (a , (b , c)) i) = refl A□2→A×join→A□2 : ∀ x → A□2→A×join (A×join→A□2 x) ≡ x - A□2→A×join→A□2 (a , inl b) = refl - A□2→A×join→A□2 (a , inr c) = refl - A□2→A×join→A□2 (a , push b c i) = refl + A□2→A×join→A□2 (a , inl b) = refl + A□2→A×join→A□2 (a , inr c) = refl + A□2→A×join→A□2 (a , push b c i) = refl A□2≃A×join : 3x3-span.A□2 span ≃ A×join A□2≃A×join = isoToEquiv (iso A□2→A×join A×join→A□2 A□2→A×join→A□2 A×join→A□2→A×join) @@ -222,8 +222,8 @@ -- the second span we are interested in sp4 : 3-span sp4 = record { - A0 = join A B ; - A2 = (join A B) × C ; + A0 = join A B ; + A2 = (join A B) × C ; A4 = C ; f1 = proj₁ ; f3 = proj₂ } @@ -238,17 +238,17 @@ H3 = H3 } where join×C : Type₀ - join×C = (join A B) × C + join×C = (join A B) × C A2□→join×C : 3x3-span.A2□ span → join×C - A2□→join×C (inl (a , c)) = (inl a) , c - A2□→join×C (inr (b , c)) = (inr b) , c - A2□→join×C (push (a , (b , c)) i) = push a b i , c + A2□→join×C (inl (a , c)) = (inl a) , c + A2□→join×C (inr (b , c)) = (inr b) , c + A2□→join×C (push (a , (b , c)) i) = push a b i , c join×C→A2□ : join×C → 3x3-span.A2□ span - join×C→A2□ (inl a , c) = inl (a , c) - join×C→A2□ (inr b , c) = inr (b , c) - join×C→A2□ (push a b i , c) = push (a , (b , c)) i + join×C→A2□ (inl a , c) = inl (a , c) + join×C→A2□ (inr b , c) = inr (b , c) + join×C→A2□ (push a b i , c) = push (a , (b , c)) i join×C→A2□→join×C : ∀ x → join×C→A2□ (A2□→join×C x) ≡ x join×C→A2□→join×C (inl (a , c)) = refl @@ -256,9 +256,9 @@ join×C→A2□→join×C (push (a , (b , c)) j) = refl A2□→join×C→A2□ : ∀ x → A2□→join×C (join×C→A2□ x) ≡ x - A2□→join×C→A2□ (inl a , c) = refl - A2□→join×C→A2□ (inr b , c) = refl - A2□→join×C→A2□ (push a b i , c) = refl + A2□→join×C→A2□ (inl a , c) = refl + A2□→join×C→A2□ (inr b , c) = refl + A2□→join×C→A2□ (push a b i , c) = refl A2□≃join×C : 3x3-span.A2□ span ≃ join×C A2□≃join×C = isoToEquiv (iso A2□→join×C join×C→A2□ A2□→join×C→A2□ join×C→A2□→join×C) @@ -297,165 +297,165 @@ commutativity, this implies that the join is associative. -} joinSwitch : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - → join (join A B) C ≃ join (join C B) A + → join (join A B) C ≃ join (join C B) A joinSwitch = isoToEquiv (iso switch switch invol invol) where switch : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - → join (join A B) C → join (join C B) A - switch (inl (inl a)) = inr a - switch (inl (inr b)) = inl (inr b) - switch (inl (push a b i)) = push (inr b) a (~ i) - switch (inr c) = inl (inl c) - switch (push (inl a) c j) = push (inl c) a (~ j) - switch (push (inr b) c j) = inl (push c b (~ j)) - switch (push (push a b i) c j) = + → join (join A B) C → join (join C B) A + switch (inl (inl a)) = inr a + switch (inl (inr b)) = inl (inr b) + switch (inl (push a b i)) = push (inr b) a (~ i) + switch (inr c) = inl (inl c) + switch (push (inl a) c j) = push (inl c) a (~ j) + switch (push (inr b) c j) = inl (push c b (~ j)) + switch (push (push a b i) c j) = hcomp (λ k → λ - { (i = i0) → push (inl c) a (~ j ∨ ~ k) - ; (i = i1) → inl (push c b (~ j)) - ; (j = i0) → push (inr b) a (~ i) - ; (j = i1) → push (inl c) a (~ i ∧ ~ k) + { (i = i0) → push (inl c) a (~ j ∨ ~ k) + ; (i = i1) → inl (push c b (~ j)) + ; (j = i0) → push (inr b) a (~ i) + ; (j = i1) → push (inl c) a (~ i ∧ ~ k) }) - (push (push c b (~ j)) a (~ i)) + (push (push c b (~ j)) a (~ i)) invol : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - (u : join (join A B) C) → switch (switch u) ≡ u - invol (inl (inl a)) = refl - invol (inl (inr b)) = refl - invol (inl (push a b i)) = refl - invol (inr c) = refl - invol (push (inl a) c j) = refl - invol (push (inr b) c j) = refl - invol {A = A} {B} {C} (push (push a b i) c j) l = + (u : join (join A B) C) → switch (switch u) ≡ u + invol (inl (inl a)) = refl + invol (inl (inr b)) = refl + invol (inl (push a b i)) = refl + invol (inr c) = refl + invol (push (inl a) c j) = refl + invol (push (inr b) c j) = refl + invol {A = A} {B} {C} (push (push a b i) c j) l = comp - (λ _ → join (join A B) C) + (λ _ → join (join A B) C) (λ k → λ - { (i = i0) → push (inl a) c (j ∧ (k ∨ l)) - ; (i = i1) → push (inr b) c j - ; (j = i0) → inl (push a b i) - ; (j = i1) → push (inl a) c (i ∨ (k ∨ l)) - ; (l = i1) → push (push a b i) c j + { (i = i0) → push (inl a) c (j ∧ (k ∨ l)) + ; (i = i1) → push (inr b) c j + ; (j = i0) → inl (push a b i) + ; (j = i1) → push (inl a) c (i ∨ (k ∨ l)) + ; (l = i1) → push (push a b i) c j }) (hcomp (λ k → λ - { (i = i0) → push (inl a) c (j ∧ (~ k ∨ l)) - ; (i = i1) → push (inr b) c j - ; (j = i0) → inl (push a b i) - ; (j = i1) → push (inl a) c (i ∨ (~ k ∨ l)) - ; (l = i1) → push (push a b i) c j + { (i = i0) → push (inl a) c (j ∧ (~ k ∨ l)) + ; (i = i1) → push (inr b) c j + ; (j = i0) → inl (push a b i) + ; (j = i1) → push (inl a) c (i ∨ (~ k ∨ l)) + ; (l = i1) → push (push a b i) c j }) - (push (push a b i) c j)) + (push (push a b i) c j)) {- Direct proof of associativity. -} joinAssocDirect : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} - → join (join A B) C ≃ join A (join B C) + → join (join A B) C ≃ join A (join B C) joinAssocDirect {A = A} {B} {C} = isoToEquiv (iso forward back forwardBack backForward) where - forward : join (join A B) C → join A (join B C) - forward (inl (inl a)) = inl a - forward (inl (inr b)) = inr (inl b) - forward (inl (push a b i)) = push a (inl b) i - forward (inr c) = inr (inr c) - forward (push (inl a) c j) = push a (inr c) j - forward (push (inr b) c j) = inr (push b c j) - forward (push (push a b i) c j) = + forward : join (join A B) C → join A (join B C) + forward (inl (inl a)) = inl a + forward (inl (inr b)) = inr (inl b) + forward (inl (push a b i)) = push a (inl b) i + forward (inr c) = inr (inr c) + forward (push (inl a) c j) = push a (inr c) j + forward (push (inr b) c j) = inr (push b c j) + forward (push (push a b i) c j) = hcomp (λ k → λ - { (i = i0) → push a (inr c) (j ∧ k) - ; (i = i1) → inr (push b c j) - ; (j = i0) → push a (inl b) i - ; (j = i1) → push a (inr c) (i ∨ k) + { (i = i0) → push a (inr c) (j ∧ k) + ; (i = i1) → inr (push b c j) + ; (j = i0) → push a (inl b) i + ; (j = i1) → push a (inr c) (i ∨ k) }) - (push a (push b c j) i) - - back : join A (join B C) → join (join A B) C - back (inl a) = inl (inl a) - back (inr (inl b)) = inl (inr b) - back (inr (inr c)) = inr c - back (inr (push b c j)) = push (inr b) c j - back (push a (inl b) i) = inl (push a b i) - back (push a (inr c) i) = push (inl a) c i - back (push a (push b c j) i) = + (push a (push b c j) i) + + back : join A (join B C) → join (join A B) C + back (inl a) = inl (inl a) + back (inr (inl b)) = inl (inr b) + back (inr (inr c)) = inr c + back (inr (push b c j)) = push (inr b) c j + back (push a (inl b) i) = inl (push a b i) + back (push a (inr c) i) = push (inl a) c i + back (push a (push b c j) i) = hcomp (λ k → λ - { (i = i0) → push (inl a) c (j ∧ ~ k) - ; (i = i1) → push (inr b) c j - ; (j = i0) → inl (push a b i) - ; (j = i1) → push (inl a) c (i ∨ ~ k) + { (i = i0) → push (inl a) c (j ∧ ~ k) + ; (i = i1) → push (inr b) c j + ; (j = i0) → inl (push a b i) + ; (j = i1) → push (inl a) c (i ∨ ~ k) }) - (push (push a b i) c j) + (push (push a b i) c j) forwardBack : ∀ u → forward (back u) ≡ u - forwardBack (inl a) = refl - forwardBack (inr (inl b)) = refl - forwardBack (inr (inr c)) = refl - forwardBack (inr (push b c j)) = refl - forwardBack (push a (inl b) i) = refl - forwardBack (push a (inr c) i) = refl - forwardBack (push a (push b c j) i) l = + forwardBack (inl a) = refl + forwardBack (inr (inl b)) = refl + forwardBack (inr (inr c)) = refl + forwardBack (inr (push b c j)) = refl + forwardBack (push a (inl b) i) = refl + forwardBack (push a (inr c) i) = refl + forwardBack (push a (push b c j) i) l = comp - (λ _ → join A (join B C)) + (λ _ → join A (join B C)) (λ k → λ - { (i = i0) → push a (inr c) (j ∧ (~ k ∧ ~ l)) - ; (i = i1) → inr (push b c j) - ; (j = i0) → push a (inl b) i - ; (j = i1) → push a (inr c) (i ∨ (~ k ∧ ~ l)) - ; (l = i1) → push a (push b c j) i + { (i = i0) → push a (inr c) (j ∧ (~ k ∧ ~ l)) + ; (i = i1) → inr (push b c j) + ; (j = i0) → push a (inl b) i + ; (j = i1) → push a (inr c) (i ∨ (~ k ∧ ~ l)) + ; (l = i1) → push a (push b c j) i }) (hcomp (λ k → λ - { (i = i0) → push a (inr c) (j ∧ (k ∧ ~ l)) - ; (i = i1) → inr (push b c j) - ; (j = i0) → push a (inl b) i - ; (j = i1) → push a (inr c) (i ∨ (k ∧ ~ l)) - ; (l = i1) → push a (push b c j) i + { (i = i0) → push a (inr c) (j ∧ (k ∧ ~ l)) + ; (i = i1) → inr (push b c j) + ; (j = i0) → push a (inl b) i + ; (j = i1) → push a (inr c) (i ∨ (k ∧ ~ l)) + ; (l = i1) → push a (push b c j) i }) - (push a (push b c j) i)) + (push a (push b c j) i)) backForward : ∀ u → back (forward u) ≡ u - backForward (inl (inl a)) = refl - backForward (inl (inr b)) = refl - backForward (inl (push a b i)) = refl - backForward (inr c) = refl - backForward (push (inl a) c j) = refl - backForward (push (inr b) c j) = refl - backForward (push (push a b i) c j) l = + backForward (inl (inl a)) = refl + backForward (inl (inr b)) = refl + backForward (inl (push a b i)) = refl + backForward (inr c) = refl + backForward (push (inl a) c j) = refl + backForward (push (inr b) c j) = refl + backForward (push (push a b i) c j) l = comp - (λ _ → join (join A B) C) + (λ _ → join (join A B) C) (λ k → λ - { (i = i0) → push (inl a) c (j ∧ (k ∨ l)) - ; (i = i1) → push (inr b) c j - ; (j = i0) → inl (push a b i) - ; (j = i1) → push (inl a) c (i ∨ (k ∨ l)) - ; (l = i1) → push (push a b i) c j + { (i = i0) → push (inl a) c (j ∧ (k ∨ l)) + ; (i = i1) → push (inr b) c j + ; (j = i0) → inl (push a b i) + ; (j = i1) → push (inl a) c (i ∨ (k ∨ l)) + ; (l = i1) → push (push a b i) c j }) (hcomp (λ k → λ - { (i = i0) → push (inl a) c (j ∧ (~ k ∨ l)) - ; (i = i1) → push (inr b) c j - ; (j = i0) → inl (push a b i) - ; (j = i1) → push (inl a) c (i ∨ (~ k ∨ l)) - ; (l = i1) → push (push a b i) c j + { (i = i0) → push (inl a) c (j ∧ (~ k ∨ l)) + ; (i = i1) → push (inr b) c j + ; (j = i0) → inl (push a b i) + ; (j = i1) → push (inl a) c (i ∨ (~ k ∨ l)) + ; (l = i1) → push (push a b i) c j }) - (push (push a b i) c j)) + (push (push a b i) c j)) -- commutativity -join-commFun : ∀ {ℓ'} {A : Type ℓ} {B : Type ℓ'} → join A B → join B A -join-commFun (inl x) = inr x -join-commFun (inr x) = inl x -join-commFun (push a b i) = push b a (~ i) +join-commFun : ∀ {ℓ'} {A : Type ℓ} {B : Type ℓ'} → join A B → join B A +join-commFun (inl x) = inr x +join-commFun (inr x) = inl x +join-commFun (push a b i) = push b a (~ i) -join-commFun² : ∀ {ℓ'} {A : Type ℓ} {B : Type ℓ'} (x : join A B) +join-commFun² : ∀ {ℓ'} {A : Type ℓ} {B : Type ℓ'} (x : join A B) → join-commFun (join-commFun x) ≡ x -join-commFun² (inl x) = refl -join-commFun² (inr x) = refl -join-commFun² (push a b i) = refl +join-commFun² (inl x) = refl +join-commFun² (inr x) = refl +join-commFun² (push a b i) = refl join-comm : ∀ {ℓ'} {A : Type ℓ} {B : Type ℓ'} - → Iso (join A B) (join B A) + → Iso (join A B) (join B A) fun join-comm = join-commFun inv join-comm = join-commFun rightInv join-comm = join-commFun² @@ -463,32 +463,32 @@ join→ : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} - → (A → C) → (B → D) → join A B → join C D -join→ f g (inl x) = inl (f x) -join→ f g (inr x) = inr (g x) -join→ f g (push a b i) = push (f a) (g b) i + → (A → C) → (B → D) → join A B → join C D +join→ f g (inl x) = inl (f x) +join→ f g (inr x) = inr (g x) +join→ f g (push a b i) = push (f a) (g b) i -- Applying Isos to joins (more efficient than transports) Iso→joinIso : ∀ {ℓ'' ℓ'''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {D : Type ℓ'''} - → Iso A C → Iso B D → Iso (join A B) (join C D) + → Iso A C → Iso B D → Iso (join A B) (join C D) fun (Iso→joinIso is1 is2) x = join→ (Iso.fun is1) (Iso.fun is2) x inv (Iso→joinIso is1 is2) x = join→ (Iso.inv is1) (Iso.inv is2) x -rightInv (Iso→joinIso is1 is2) (inl x) i = inl (rightInv is1 x i) -rightInv (Iso→joinIso is1 is2) (inr x) i = inr (rightInv is2 x i) -rightInv (Iso→joinIso is1 is2) (push a b j) i = - push (rightInv is1 a i) (rightInv is2 b i) j -leftInv (Iso→joinIso is1 is2) (inl x) i = inl (leftInv is1 x i) -leftInv (Iso→joinIso is1 is2) (inr x) i = inr (leftInv is2 x i) -leftInv (Iso→joinIso is1 is2) (push a b i) j = - push (leftInv is1 a j) (leftInv is2 b j) i +rightInv (Iso→joinIso is1 is2) (inl x) i = inl (rightInv is1 x i) +rightInv (Iso→joinIso is1 is2) (inr x) i = inr (rightInv is2 x i) +rightInv (Iso→joinIso is1 is2) (push a b j) i = + push (rightInv is1 a i) (rightInv is2 b i) j +leftInv (Iso→joinIso is1 is2) (inl x) i = inl (leftInv is1 x i) +leftInv (Iso→joinIso is1 is2) (inr x) i = inr (leftInv is2 x i) +leftInv (Iso→joinIso is1 is2) (push a b i) j = + push (leftInv is1 a j) (leftInv is2 b j) i -joinAnnihilL : {A : Type ℓ} → isContr (join (Unit* {ℓ'}) A) -fst joinAnnihilL = inl tt* -snd joinAnnihilL (inl tt*) = refl -snd joinAnnihilL (inr a) = push tt* a -snd joinAnnihilL (push tt* a i) j = push tt* a (i ∧ j) +joinAnnihilL : {A : Type ℓ} → isContr (join (Unit* {ℓ'}) A) +fst joinAnnihilL = inl tt* +snd joinAnnihilL (inl tt*) = refl +snd joinAnnihilL (inr a) = push tt* a +snd joinAnnihilL (push tt* a i) j = push tt* a (i ∧ j) --- Ganea's construction --- @@ -524,11 +524,11 @@ ganea-fill₃ : ∀ {ℓ} {A : Type ℓ} (f : A → B) (b : B) (i k : I) (a : A) (q : f a ≡ b) (p : q (~ i) ≡ b) - → join (fiber f b) (b ≡ b) + → join (fiber f b) (b ≡ b) ganea-fill₃ f b i k a q p = - hfill (λ k → λ {(i = i0) → inr p - ; (i = i1) → push (a , p) (sym q ∙ p) (~ k)}) - (inS (inr λ j → ganea-fill₂ i j i1 _ q _ p)) k + hfill (λ k → λ {(i = i0) → inr p + ; (i = i1) → push (a , p) (sym q ∙ p) (~ k)}) + (inS (inr λ j → ganea-fill₂ i j i1 _ q _ p)) k -- Proof of the main theorem @@ -544,15 +544,15 @@ GaneaFib : Type _ GaneaFib = fiber GaneaMap (pt B) - join→GaneaFib : join (fiber (fst f) (pt B)) (Ω B .fst) → GaneaFib - join→GaneaFib (inl x) = inr (fst x) , snd x - join→GaneaFib (inr x) = (inl tt) , x - proj₁ (join→GaneaFib (push a b i)) = push (fst a , snd a ∙ sym b) (~ i) - snd (join→GaneaFib (push a b i)) j = ganea-fill₁ _ (snd a) _ (sym b) i j i1 + join→GaneaFib : join (fiber (fst f) (pt B)) (Ω B .fst) → GaneaFib + join→GaneaFib (inl x) = inr (fst x) , snd x + join→GaneaFib (inr x) = (inl tt) , x + proj₁ (join→GaneaFib (push a b i)) = push (fst a , snd a ∙ sym b) (~ i) + snd (join→GaneaFib (push a b i)) j = ganea-fill₁ _ (snd a) _ (sym b) i j i1 - GaneaFib→join : GaneaFib → join (fiber (fst f) (pt B)) (Ω B .fst) - GaneaFib→join (inl x , p) = inr p - GaneaFib→join (inr x , p) = inl (x , p) + GaneaFib→join : GaneaFib → join (fiber (fst f) (pt B)) (Ω B .fst) + GaneaFib→join (inl x , p) = inr p + GaneaFib→join (inr x , p) = inl (x , p) GaneaFib→join (push (a , q) i , p) = ganea-fill₃ (fst f) (pt B) i i1 a q p @@ -586,7 +586,7 @@ (inS (compPath-filler (sym q) p j (~ i))) k main' : (p : fst f a ≡ pt B) - → cong join→GaneaFib (push (a , p) (sym q ∙ p)) + → cong join→GaneaFib (push (a , p) (sym q ∙ p)) ≡ λ i → (push (a , q) (~ i)) , (compPath-filler' (sym q) p i) proj₁ (main' p i j) = push (a , λ j → filler₁ i j i1 p) (~ j) snd (main' p i j) r = @@ -634,7 +634,7 @@ main : (p : fst f a ≡ pt B) - → PathP (λ k → join→GaneaFib (push (a , p) (sym q ∙ p) (~ k)) + → PathP (λ k → join→GaneaFib (push (a , p) (sym q ∙ p) (~ k)) ≡ (inr a , p)) (λ i → push (a , q) i , compPath-filler' (sym q) p (~ i)) refl @@ -642,32 +642,32 @@ ◁ λ j i → push (a , q) (j ∨ i) , compPath-filler' (sym q) p (~ (j ∨ i))) - join→GaneaFib→join : (x : join (fiber (fst f) (pt B)) (Ω B .fst)) + join→GaneaFib→join : (x : join (fiber (fst f) (pt B)) (Ω B .fst)) → GaneaFib→join (join→GaneaFib x) ≡ x - join→GaneaFib→join (inl x) = refl - join→GaneaFib→join (inr x) = refl - join→GaneaFib→join (push (a , q) p i) j = + join→GaneaFib→join (inl x) = refl + join→GaneaFib→join (inr x) = refl + join→GaneaFib→join (push (a , q) p i) j = main (fst f) (pt B) q p j i where main : (f : fst A → fst B) (b : fst B) (q : f a ≡ b) (p : b ≡ b) - → Path (Path (join (fiber f b) (b ≡ b)) _ _) + → Path (Path (join (fiber f b) (b ≡ b)) _ _) (λ i → ganea-fill₃ f b (~ i) i1 a (q ∙ sym p) λ j → ganea-fill₁ _ q _ (sym p) i j i1) - (push (a , q) p) + (push (a , q) p) main f = J> λ q i j → hcomp (λ k → λ {(i = i0) → ganea-fill₃ f (f a) (~ j) i1 a (lUnit (sym q) k) (side _ q k j) - ; (i = i1) → push (a , refl) q j - ; (j = i0) → inl (a , refl) - ; (j = i1) → inr q}) + ; (i = i1) → push (a , refl) q j + ; (j = i0) → inl (a , refl) + ; (j = i1) → inr q}) (hcomp (λ k → λ {(i = i0) → ganea-fill₃ f (f a) (~ j) k a (sym q) λ j₂ → q (~ j ∨ j₂) - ; (i = i1) → push (a , refl) q (j ∨ ~ k) - ; (j = i0) → push (a , refl) (rUnit q (~ i)) (~ k) - ; (j = i1) → inr q}) - (inr λ k → btm _ q k i j)) + ; (i = i1) → push (a , refl) q (j ∨ ~ k) + ; (j = i0) → push (a , refl) (rUnit q (~ i)) (~ k) + ; (j = i1) → inr q}) + (inr λ k → btm _ q k i j)) where btm : ∀ {ℓ} {A : Type ℓ} {x : A} (y : A) (q : x ≡ y) → Cube refl refl @@ -699,7 +699,7 @@ x -- Main theorem - GaneaIso : Iso GaneaFib (join (fiber (fst f) (pt B)) (Ω B .fst)) + GaneaIso : Iso GaneaFib (join (fiber (fst f) (pt B)) (Ω B .fst)) fun GaneaIso = GaneaFib→join inv GaneaIso = join→GaneaFib rightInv GaneaIso = join→GaneaFib→join diff --git a/Cubical.HITs.RPn.Base.html b/Cubical.HITs.RPn.Base.html index 6e8236179..e35c646cc 100644 --- a/Cubical.HITs.RPn.Base.html +++ b/Cubical.HITs.RPn.Base.html @@ -186,7 +186,7 @@ TotalCov≃Sn (ℕ→ℕ₋₁ n) = Total (cov⁻¹ (ℕ→ℕ₋₁ n)) ≃⟨ i ⟩ Pushout Σf Σg ≃⟨ ii ⟩ - join (Total (cov⁻¹ (-1+ n))) Bool ≃⟨ iii ⟩ + join (Total (cov⁻¹ (-1+ n))) Bool ≃⟨ iii ⟩ S (ℕ→ℕ₋₁ n) ■ where {- @@ -276,7 +276,7 @@ ; H1 = λ x → cong fst (H x) ; H3 = λ x → cong snd (H x) } - ii : Pushout Σf Σg ≃ join (Total (cov⁻¹ (-1+ n))) Bool + ii : Pushout Σf Σg ≃ join (Total (cov⁻¹ (-1+ n))) Bool ii = compEquiv (pathToEquiv (spanEquivToPushoutPath nat)) (joinPushout≃join _ _) {- @@ -285,8 +285,8 @@ is equivalent to `S n`, which completes the proof. -} - iii : join (Total (cov⁻¹ (-1+ n))) Bool ≃ S (ℕ→ℕ₋₁ n) - iii = join (Total (cov⁻¹ (-1+ n))) Bool ≃⟨ invEquiv Susp≃joinBool ⟩ + iii : join (Total (cov⁻¹ (-1+ n))) Bool ≃ S (ℕ→ℕ₋₁ n) + iii = join (Total (cov⁻¹ (-1+ n))) Bool ≃⟨ invEquiv Susp≃joinBool ⟩ Susp (Total (cov⁻¹ (-1+ n))) ≃⟨ congSuspEquiv (TotalCov≃Sn (-1+ n)) ⟩ S (ℕ→ℕ₋₁ n) ■ diff --git a/Cubical.HITs.SmashProduct.Base.html b/Cubical.HITs.SmashProduct.Base.html index 21199df0c..8d0ffdd6b 100644 --- a/Cubical.HITs.SmashProduct.Base.html +++ b/Cubical.HITs.SmashProduct.Base.html @@ -10,913 +10,1286 @@ open import Cubical.Foundations.Path open import Cubical.Foundations.Function open import Cubical.Foundations.Transport - -open import Cubical.Data.Unit -open import Cubical.Data.Sigma -open import Cubical.Data.Nat -open import Cubical.Data.Fin - -open import Cubical.HITs.Pushout.Base -open import Cubical.HITs.Wedge - -data Smash {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') : Type (ℓ-max ℓ ℓ') where - basel : Smash A B - baser : Smash A B - proj : (x : typ A) → (y : typ B) → Smash A B - gluel : (a : typ A) → proj a (pt B) ≡ basel - gluer : (b : typ B) → proj (pt A) b ≡ baser - -private - variable - ℓ ℓ' : Level - A B C D : Pointed ℓ - -infixl 30 _⋀∙_ - -SmashPt : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ') -SmashPt A B = (Smash A B , basel) - -SmashPtProj : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ') -SmashPtProj A B = Smash A B , (proj (snd A) (snd B)) - -Smash-map : (f : A →∙ C) (g : B →∙ D) → Smash A B → Smash C D -Smash-map f g basel = basel -Smash-map f g baser = baser -Smash-map (f , fpt) (g , gpt) (proj x y) = proj (f x) (g y) -Smash-map (f , fpt) (g , gpt) (gluel a i) = ((λ j → proj (f a) (gpt j)) ∙ gluel (f a)) i -Smash-map (f , fpt) (g , gpt) (gluer b i) = ((λ j → proj (fpt j) (g b)) ∙ gluer (g b)) i - --- Commutativity -comm : Smash A B → Smash B A -comm basel = baser -comm baser = basel -comm (proj x y) = proj y x -comm (gluel a i) = gluer a i -comm (gluer b i) = gluel b i - -commK : (x : Smash A B) → comm (comm x) ≡ x -commK basel = refl -commK baser = refl -commK (proj x y) = refl -commK (gluel a x) = refl -commK (gluer b x) = refl - ---- Alternative definition - -i∧ : {A : Pointed ℓ} {B : Pointed ℓ'} → A ⋁ B → (typ A) × (typ B) -i∧ {A = A , ptA} {B = B , ptB} (inl x) = x , ptB -i∧ {A = A , ptA} {B = B , ptB} (inr x) = ptA , x -i∧ {A = A , ptA} {B = B , ptB} (push tt i) = ptA , ptB - -_⋀_ : Pointed ℓ → Pointed ℓ' → Type (ℓ-max ℓ ℓ') -A ⋀ B = Pushout {A = (A ⋁ B)} (λ _ → tt) i∧ - -_⋀∙_ : Pointed ℓ → Pointed ℓ' → Pointed (ℓ-max ℓ ℓ') -A ⋀∙ B = (A ⋀ B) , (inl tt) - --- iterated products -⋀^ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) → Pointed ℓ -⋀^ zero A = A fzero -⋀^ (suc n) A = ⋀^ n (predFinFamily∙ A) ⋀∙ (A flast) - -⋀comm→ : A ⋀ B → B ⋀ A -⋀comm→ (inl x) = inl x -⋀comm→ (inr (x , y)) = inr (y , x) -⋀comm→ (push (inl x) i) = push (inr x) i -⋀comm→ (push (inr x) i) = push (inl x) i -⋀comm→ (push (push a i₁) i) = push (push tt (~ i₁)) i - -⋀comm→² : {A : Pointed ℓ} {B : Pointed ℓ' } - (x : A ⋀ B) → ⋀comm→ (⋀comm→ {A = A} {B = B} x) ≡ x -⋀comm→² (inl x) = refl -⋀comm→² (inr x) = refl -⋀comm→² (push (inl x) i) = refl -⋀comm→² (push (inr x) i) = refl -⋀comm→² (push (push a i₁) i) = refl - -⋀CommIso : Iso (A ⋀ B) (B ⋀ A) -Iso.fun ⋀CommIso = ⋀comm→ -Iso.inv ⋀CommIso = ⋀comm→ -Iso.rightInv ⋀CommIso = ⋀comm→² -Iso.leftInv ⋀CommIso = ⋀comm→² - -⋀comm→∙ : A ⋀∙ B →∙ B ⋀∙ A -fst ⋀comm→∙ = ⋀comm→ -snd ⋀comm→∙ = refl - -SmashAdjIso : Iso ((A ⋀∙ B) →∙ C) (A →∙ (B →∙ C ∙)) -SmashAdjIso {A = A} {B = B} {C = C} = - compIso is₃ (compIso iso₄ (invIso is₂)) - where - is₁ : Iso (A →∙ (B →∙ C ∙)) - (Σ[ f ∈ (fst A → fst B → fst C) ] - Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ pt C) ] - Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ pt C) ] - PathP (λ i → r (snd B) i ≡ snd C) (l (snd A)) refl) - Iso.fun is₁ f = (λ x y → f .fst x .fst y) - , (λ x → f .fst x .snd) - , (λ x i → f .snd i .fst x) - , λ i j → f .snd i .snd j - fst (fst (Iso.inv is₁ (f , l , r , p)) x) = f x - snd (fst (Iso.inv is₁ (f , l , r , p)) x) = l x - fst (snd (Iso.inv is₁ (f , l , r , p)) i) b = r b i - snd (snd (Iso.inv is₁ (f , l , r , p)) i) j = p i j - Iso.rightInv is₁ _ = refl - Iso.leftInv is₁ _ = refl - - is₂ : Iso (A →∙ (B →∙ C ∙)) ( - (Σ[ f ∈ (fst A → fst B → fst C) ] - Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ pt C) ] - Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ pt C) ] - l (pt A) ≡ r (pt B))) - is₂ = compIso is₁ (Σ-cong-iso-snd - λ f → Σ-cong-iso-snd - λ l → Σ-cong-iso-snd - λ r → pathToIso (PathP≡doubleCompPathʳ _ _ _ _ - ∙ cong (l (snd A) ≡_) - (sym (compPath≡compPath' (r (snd B)) refl) - ∙ sym (rUnit (r (pt B)))))) - - is₃ : Iso ((A ⋀∙ B) →∙ C) - (Σ[ f ∈ (fst A → fst B → fst C) ] - Σ[ p ∈ singl (snd C) ] - Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ fst p) ] - Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ fst p) ] - l (pt A) ≡ r (pt B)) - fst (Iso.fun is₃ f) x y = fst f (inr (x , y)) - fst (fst (snd (Iso.fun is₃ f))) = fst f (inl tt) - snd (fst (snd (Iso.fun is₃ f))) = sym (snd f) - fst (snd (snd (Iso.fun is₃ f))) x = cong (fst f) (sym (push (inl x))) - fst (snd (snd (snd (Iso.fun is₃ f)))) x = cong (fst f) (sym (push (inr x))) - snd (snd (snd (snd (Iso.fun is₃ f)))) i j = fst f (push (push tt i) (~ j)) - fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (inl x) = c* - fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (inr (x , y)) = f x y - fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (inl x) i) = l x (~ i) - fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (inr x) i) = r x (~ i) - fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (push a j) i) = q j (~ i) - snd (Iso.inv is₃ (f , (c* , p) , l , r , q)) = sym p - Iso.rightInv is₃ _ = refl - Iso.leftInv is₃ f = - ΣPathP ((funExt (λ { (inl x) → refl - ; (inr x) → refl - ; (push (inl x) i) → refl - ; (push (inr x) i) → refl - ; (push (push a i₁) i) → refl})) - , refl) - - isContrIso : ∀ {ℓ ℓ'} {A : Type ℓ} (a : A) (B : singl a → Type ℓ') - → Iso (Σ _ B) (B (a , refl)) - isContrIso a B = - compIso (invIso - (Σ-cong-iso-fst (isContr→Iso isContrUnit (isContrSingl a)))) - lUnit×Iso - - iso₄ : Iso (isoToPath is₃ i1) - (isoToPath is₂ i1) - iso₄ = Σ-cong-iso-snd λ f → isContrIso (snd C) _ - --- induction priciples for maps into pointed types -⋀→∙Homogeneous≡ : isHomogeneous C - → {f g : (A ⋀∙ B) →∙ C} - → ((x : fst A) (y : fst B) → fst f (inr (x , y)) ≡ fst g (inr (x , y))) - → f ≡ g -⋀→∙Homogeneous≡ C {f = f} {g = g} p = - sym (Iso.leftInv SmashAdjIso f) - ∙∙ cong (Iso.inv SmashAdjIso) main - ∙∙ Iso.leftInv SmashAdjIso g - where - main : Iso.fun SmashAdjIso f ≡ Iso.fun SmashAdjIso g - main = - →∙Homogeneous≡ (isHomogeneous→∙ C) - (funExt λ x → →∙Homogeneous≡ C (funExt (p x))) - -prod→⋀^ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) - → prodFinFamily n (fst ∘ A) → ⋀^ n A .fst -prod→⋀^ zero A x = x -prod→⋀^ (suc n) A x = - inr ((prod→⋀^ n (predFinFamily∙ A) (fst x)) , (snd x)) - -⋀→Homogeneous≡ : {A B : Pointed ℓ} {D : Type ℓ'} - → {f g : A ⋀ B → D} - → (isHomogeneous (D , f (inl tt))) - → ((x : _) (y : _) → f (inr (x , y)) ≡ g (inr (x , y))) - → f ≡ g -⋀→Homogeneous≡ {A = A} {B} {D} {f = f} {g} hom p = cong fst f^≡g^ - where - f^ g^ : A ⋀∙ B →∙ (D , f (inl tt)) - f^ = f , refl - g^ = g , (cong g (push (inr (pt B))) - ∙∙ sym (p (pt A) (pt B)) - ∙∙ cong f (sym (push (inr (pt B))))) - - f^≡g^ : f^ ≡ g^ - f^≡g^ = ⋀→∙Homogeneous≡ hom p - -⋀^→Homogeneous≡ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) {B : Type ℓ'} - → {f g : ⋀^ n A .fst → B} - → isHomogeneous (B , f (⋀^ n A .snd)) - → ((x : _) → f (prod→⋀^ n A x) ≡ g (prod→⋀^ n A x)) - → f ≡ g -⋀^→Homogeneous≡ zero A hom ind = funExt ind -⋀^→Homogeneous≡ (suc n) A {B = B} {f = f} {g} hom ind = - ⋀→Homogeneous≡ hom λ x y - → funExt⁻ (⋀^→Homogeneous≡ n (predFinFamily∙ A) - {f = λ x → f (inr (x , y))} {g = λ x → g (inr (x , y))} - (subst (isHomogeneous ∘ (B ,_)) - (cong f (push (inr y))) hom ) - λ _ → ind _) x - -⋀^→Homogeneous : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) (B : Pointed ℓ') - → (isHomogeneous B) - → (f g : ⋀^ n A →∙ B) - → ((x : _) → f .fst (prod→⋀^ n A x) ≡ g .fst (prod→⋀^ n A x)) - → f ≡ g -⋀^→Homogeneous zero A B ishom f g ind = →∙Homogeneous≡ ishom (funExt ind) -⋀^→Homogeneous (suc n) A B ishom f g ind = - ⋀→∙Homogeneous≡ ishom λ x y i - → ⋀^→Homogeneous n (predFinFamily∙ A) B ishom - (f' y) (g' y) (λ x → ind (x , y)) i .fst x - where - module _ (y : A flast .fst) where - f' g' : ⋀^ n (predFinFamily∙ A) →∙ B - f' = (λ x → f .fst (inr (x , y))) - , cong (fst f) (sym (push (inr y))) ∙ snd f - g' = (λ x → g .fst (inr (x , y))) - , cong (fst g) (sym (push (inr y))) ∙ snd g - -_⋀→_ : (f : A →∙ C) (g : B →∙ D) → A ⋀ B → C ⋀ D -(f ⋀→ g) (inl tt) = inl tt -((f , fpt) ⋀→ (g , gpt)) (inr (x , x₁)) = inr (f x , g x₁) -_⋀→_ {B = B} {D = D} (f , fpt) (b , gpt) (push (inl x) i) = (push (inl (f x)) ∙ (λ i → inr (f x , gpt (~ i)))) i -_⋀→_ (f , fpt) (g , gpt) (push (inr x) i) = (push (inr (g x)) ∙ (λ i → inr (fpt (~ i) , g x))) i -_⋀→_ {A = A} {C = C} {B = B} {D = D} (f , fpt) (g , gpt) (push (push tt j) i) = - hcomp (λ k → λ { (i = i0) → inl tt - ; (i = i1) → inr (fpt (~ k) , gpt (~ k)) - ; (j = i0) → compPath-filler (push (inl (fpt (~ k)))) - ((λ i → inr (fpt (~ k) , gpt (~ i)))) k i - ; (j = i1) → compPath-filler (push (inr (gpt (~ k)))) - ((λ i → inr (fpt (~ i) , gpt (~ k)))) k i}) - (push (push tt j) i) - -_⋀→∙_ : (f : A →∙ C) (g : B →∙ D) → A ⋀∙ B →∙ C ⋀∙ D -fst (f ⋀→∙ g) = f ⋀→ g -snd (f ⋀→∙ g) = refl - - -_⋀→refl_ : ∀ {ℓ ℓ'} {C : Type ℓ} {D : Type ℓ'} - → (f : typ A → C) - → (g : typ B → D) - → (A ⋀ B) → ((C , f (pt A)) ⋀ (D , g (pt B))) -(f ⋀→refl g) (inl x) = inl tt -(f ⋀→refl g) (inr (x , y)) = inr (f x , g y) -(f ⋀→refl g) (push (inl x) i) = push (inl (f x)) i -(f ⋀→refl g) (push (inr x) i) = push (inr (g x)) i -(f ⋀→refl g) (push (push a i₁) i) = push (push tt i₁) i - -_⋀∙→refl_ : ∀ {ℓ ℓ'} {C : Type ℓ} {D : Type ℓ'} - → (f : typ A → C) - → (g : typ B → D) - → (A ⋀∙ B) →∙ ((C , f (pt A)) ⋀∙ (D , g (pt B))) -fst (f ⋀∙→refl g) = f ⋀→refl g -snd (f ⋀∙→refl g) = refl - -⋀→Smash : A ⋀ B → Smash A B -⋀→Smash (inl x) = basel -⋀→Smash (inr (x , x₁)) = proj x x₁ -⋀→Smash (push (inl x) i) = gluel x (~ i) -⋀→Smash {A = A} {B = B} (push (inr x) i) = - (sym (gluel (snd A)) ∙∙ gluer (snd B) ∙∙ sym (gluer x)) i -⋀→Smash {A = A} {B = B} (push (push a j) i) = - hcomp (λ k → λ { (i = i0) → gluel (snd A) (k ∨ ~ j) - ; (i = i1) → gluer (snd B) (~ k ∧ j) - ; (j = i0) → gluel (snd A) (~ i)}) - (invSides-filler (gluel (snd A)) (gluer (snd B)) j (~ i)) - -Smash→⋀ : Smash A B → A ⋀ B -Smash→⋀ basel = inl tt -Smash→⋀ baser = inl tt -Smash→⋀ (proj x y) = inr (x , y) -Smash→⋀ (gluel a i) = push (inl a) (~ i) -Smash→⋀ (gluer b i) = push (inr b) (~ i) - -{- Associativity -} -module _ {ℓ ℓ' ℓ'' : Level} (A : Pointed ℓ) (B : Pointed ℓ') (C : Pointed ℓ'') where - - -- HIT corresponding to A ⋀ B ⋀ C - data ⋀×2 : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) where - base : ⋀×2 - proj : typ A → typ B → typ C → ⋀×2 - - gluel : (x : typ A) (y : typ B) → proj x y (pt C) ≡ base - gluem : (x : typ A) (z : typ C) → proj x (pt B) z ≡ base - gluer : (y : typ B) (z : typ C) → proj (pt A) y z ≡ base - - gluel≡gluem : (a : typ A) → gluel a (pt B) ≡ gluem a (pt C) - gluel≡gluer : (y : typ B) → Path (Path (⋀×2) _ _) (gluel (pt A) y) (gluer y (pt C)) - gluem≡gluer : (z : typ C) → gluem (pt A) z ≡ gluer (pt B) z - - coh : Cube (gluel≡gluer (snd B)) (gluem≡gluer (pt C)) - (gluel≡gluem (pt A)) (λ _ → gluer (snd B) (pt C)) - refl refl - - -- Step 1 (main step): show A ⋀ (B ⋀ C) ≃ ⋀×2 A B C - - -- some fillers needed for the maps back and forth - filler₁ : typ B → (i j k : I) → ⋀×2 - filler₁ a i j r = - hfill (λ k → λ {(i = i0) → gluer a (pt C) (j ∧ k) - ; (i = i1) → base - ; (j = i0) → gluel (pt A) a i - ; (j = i1) → gluer a (pt C) (i ∨ k)}) - (inS (gluel≡gluer a j i)) - r - - filler₂ : typ C → (i j k : I) → ⋀×2 - filler₂ c i j r = - hfill (λ k → λ {(i = i0) → gluer (pt B) c (j ∧ k) - ; (i = i1) → base - ; (j = i0) → gluem (pt A) c i - ; (j = i1) → gluer (pt B) c (i ∨ k)}) - (inS (gluem≡gluer c j i)) - r - - filler₃ : typ B → (i j r : I) → A ⋀ (B ⋀∙ C) - filler₃ b i j r = - hfill (λ k → λ {(i = i0) → compPath-filler' - (λ j → inr (pt A , (push (inl b) (~ j)))) - (sym (push (inl (pt A)))) k j - ; (i = i1) → push (inr (push (inl b) k)) (~ j) - ; (j = i0) → inr (pt A , push (inl b) k) - ; (j = i1) → inl tt}) - (inS (push (push tt i) (~ j))) - r - - filler₄ : typ C → (i j r : I) → A ⋀ (B ⋀∙ C) - filler₄ c i j r = - hfill (λ k → λ {(i = i0) → compPath-filler' - (λ j → inr (pt A , (push (inr c) (~ j)))) - (sym (push (inl (pt A)))) k j - ; (i = i1) → push (inr (push (inr c) k)) (~ j) - ; (j = i0) → inr (pt A , push (inr c) k) - ; (j = i1) → inl tt}) - (inS (push (push tt i) (~ j))) - r - - filler₅ : (i j k : I) → A ⋀ (B ⋀∙ C) - filler₅ i j r = - hfill (λ k → λ {(i = i0) → push (inl (pt A)) j - ; (i = i1) → push (inr (inl tt)) (j ∧ ~ k) - ; (j = i0) → inl tt - ; (j = i1) → push (inr (inl tt)) (~ i ∨ ~ k)}) - (inS (push (push tt i) j)) - r - - coh-filler : (i j k r : I) → ⋀×2 - coh-filler i j k r = - hfill (λ r → λ {(i = i0) → filler₁ (pt B) j k r - ; (i = i1) → filler₂ (pt C) j k r - ; (j = i0) → gluer (snd B) (snd C) (k ∧ r) - ; (j = i1) → base - ; (k = i0) → gluel≡gluem (pt A) i j - ; (k = i1) → gluer (snd B) (snd C) (j ∨ r)}) - (inS (coh i k j)) - r - - coh-filler₂ : (i j k r : I) → A ⋀ (B ⋀∙ C) - coh-filler₂ i j k r = - hfill (λ r → λ {(i = i0) → filler₃ (snd B) j k r - ; (i = i1) → filler₄ (pt C) j k r - ; (j = i0) → compPath-filler' - (λ k₁ → inr (pt A , push (push tt i) (~ k₁))) - (sym (push (inl (pt A)))) r k - ; (j = i1) → push (inr (push (push tt i) r)) (~ k) - ; (k = i0) → inr (pt A , push (push tt i) r) - ; (k = i1) → inl tt}) - (inS (push (push tt j) (~ k))) - r - - ⋀→⋀×2 : A ⋀ (B ⋀∙ C) → ⋀×2 - ⋀→⋀×2 (inl x) = base - ⋀→⋀×2 (inr (x , inl y)) = base - ⋀→⋀×2 (inr (x , inr (y , z))) = proj x y z - ⋀→⋀×2 (inr (x , push (inl a) i)) = gluel x a (~ i) - ⋀→⋀×2 (inr (x , push (inr b) i)) = gluem x b (~ i) - ⋀→⋀×2 (inr (x , push (push a i) j)) = gluel≡gluem x i (~ j) - ⋀→⋀×2 (push (inl x) i) = base - ⋀→⋀×2 (push (inr (inl x)) i) = base - ⋀→⋀×2 (push (inr (inr (x , y))) i) = gluer x y (~ i) - ⋀→⋀×2 (push (inr (push (inl x) i)) j) = filler₁ x (~ i) (~ j) i1 - ⋀→⋀×2 (push (inr (push (inr x) i)) j) = filler₂ x (~ i) (~ j) i1 - ⋀→⋀×2 (push (inr (push (push a i) j)) k) = coh-filler i (~ j) (~ k) i1 - ⋀→⋀×2 (push (push a i₁) i) = base - - ⋀×2→⋀ : ⋀×2 → A ⋀ (B ⋀∙ C) - ⋀×2→⋀ base = inl tt - ⋀×2→⋀ (proj x x₁ x₂) = inr (x , inr (x₁ , x₂)) - ⋀×2→⋀ (gluel x y i) = - ((λ i → inr (x , (push (inl y) (~ i)))) ∙ sym (push (inl x))) i - ⋀×2→⋀ (gluem x z i) = - ((λ i → inr (x , (push (inr z) (~ i)))) ∙ sym (push (inl x))) i - ⋀×2→⋀ (gluer y z i) = push (inr (inr (y , z))) (~ i) - ⋀×2→⋀ (gluel≡gluem a i j) = - ((λ k → inr (a , (push (push tt i) (~ k)))) ∙ sym (push (inl a))) j - ⋀×2→⋀ (gluel≡gluer b i j) = filler₃ b i j i1 - ⋀×2→⋀ (gluem≡gluer c i j) = filler₄ c i j i1 - ⋀×2→⋀ (coh i j k) = coh-filler₂ i j k i1 - - -- fillers for cancellation - gluel-fill : (x : typ A) (b : typ B) (i j k : I) → ⋀×2 - gluel-fill x y i j k = - hfill (λ k → λ {(i = i0) → gluel x y (~ k) - ; (i = i1) → base - ; (j = i0) → - ⋀→⋀×2 (compPath-filler' - (λ i → (inr (x , (push (inl y) (~ i))))) - (sym (push (inl x))) k i) - ; (j = i1) → gluel x y (i ∨ ~ k) }) - (inS base) - k - - gluem-fill : (x : typ A) (z : typ C) (i j k : I) → ⋀×2 - gluem-fill x z i j k = - hfill (λ k → λ {(i = i0) → gluem x z (~ k) - ; (i = i1) → base - ; (j = i0) → ⋀→⋀×2 (compPath-filler' - (λ i → (inr (x , (push (inr z) (~ i))))) - (sym (push (inl x))) k i) - ; (j = i1) → gluem x z (i ∨ ~ k)}) - (inS base) - k - - gluel≡gluer₁ : (y : typ B) (i j r k : I) → ⋀×2 - gluel≡gluer₁ y i j r k = - hfill (λ k → λ {(r = i0) → base - ; (r = i1) → gluer y (snd C) (i ∧ k) - ; (i = i0) → gluel≡gluer y j (~ r) - ; (i = i1) → gluer y (snd C) (~ r ∨ k) - ; (j = i0) → filler₁ y (~ r) i k - ; (j = i1) → gluer y (snd C) ((i ∧ k) ∨ ~ r)}) - (inS (gluel≡gluer y (j ∨ i) (~ r))) - k - - - gluem≡gluer₁ : (y : typ C) (i j r k : I) → ⋀×2 - gluem≡gluer₁ z i j r k = - hfill (λ k → λ {(i = i0) → gluem≡gluer z j (~ r) - ; (i = i1) → gluer (snd B) z (~ r ∨ k) - ; (j = i0) → filler₂ z (~ r) i k - ; (j = i1) → gluer (snd B) z (~ r ∨ (k ∧ i)) - ; (r = i0) → base - ; (r = i1) → gluer (snd B) z (i ∧ k)}) - (inS (gluem≡gluer z (j ∨ i) (~ r))) - k - - gluel≡gluer₂ : (y : typ B) (k i j r : I) → ⋀×2 - gluel≡gluer₂ y k i j r = - hfill (λ r → λ {(i = i0) → gluel≡gluer y (k ∧ j) (~ r) - ; (i = i1) → base - ; (j = i0) → ⋀→⋀×2 (filler₃ y k i r) - ; (j = i1) → gluel≡gluer y k (i ∨ ~ r) - ; (k = i0) → gluel-fill (pt A) y i j r - ; (k = i1) → gluel≡gluer₁ y i j r i1}) - (inS base) - r - - gluem≡gluer₂ : (y : typ C) (k i j r : I) → ⋀×2 - gluem≡gluer₂ y k i j r = - hfill (λ r → λ {(i = i0) → gluem≡gluer y (k ∧ j) (~ r) - ; (i = i1) → base - ; (j = i0) → ⋀→⋀×2 (filler₄ y k i r) - ; (j = i1) → gluem≡gluer y k (i ∨ ~ r) - ; (k = i0) → gluem-fill (pt A) y i j r - ; (k = i1) → gluem≡gluer₁ y i j r i1}) - (inS base) - r - - gluel≡gluem-fill : (a : typ A) (i j k r : I) → ⋀×2 - gluel≡gluem-fill a i j k r = - hfill (λ r → λ {(i = i0) → gluel≡gluem a k (~ r) - ; (i = i1) → base - ; (j = i0) → ⋀→⋀×2 (compPath-filler' - (λ i → inr (a , push (push tt k) (~ i))) (sym (push (inl a))) r i) - ; (j = i1) → gluel≡gluem a k (i ∨ ~ r) - ; (k = i0) → gluel-fill a (pt B) i j r - ; (k = i1) → gluem-fill a (pt C) i j r}) - (inS base) - r - - ⋀×2→⋀→⋀×2 : (x : ⋀×2) → ⋀→⋀×2 (⋀×2→⋀ x) ≡ x - ⋀×2→⋀→⋀×2 base = refl - ⋀×2→⋀→⋀×2 (proj x x₁ x₂) = refl - ⋀×2→⋀→⋀×2 (gluel x y i) j = gluel-fill x y i j i1 - ⋀×2→⋀→⋀×2 (gluem x z i) j = gluem-fill x z i j i1 - ⋀×2→⋀→⋀×2 (gluer y z i) = refl - ⋀×2→⋀→⋀×2 (gluel≡gluem a k i) j = gluel≡gluem-fill a i j k i1 - ⋀×2→⋀→⋀×2 (gluel≡gluer y k i) j = gluel≡gluer₂ y k i j i1 - ⋀×2→⋀→⋀×2 (gluem≡gluer z k i) j = gluem≡gluer₂ z k i j i1 - ⋀×2→⋀→⋀×2 (coh i j k) r = - hcomp (λ l → λ {(i = i0) → gluel≡gluer₂ (snd B) j k r l - ; (i = i1) → gluem≡gluer₂ (pt C) j k r l - ; (j = i0) → gluel≡gluem-fill (pt A) k r i l - ; (j = i1) → coh-lem l i k r - ; (k = i0) → coh i (j ∧ r) (~ l) - ; (k = i1) → base - ; (r = i0) → ⋀→⋀×2 (coh-filler₂ i j k l) - ; (r = i1) → coh i j (k ∨ ~ l)}) - base - where - coh-lem : PathP - (λ l → Cube (λ k r → gluel≡gluer₂ (snd B) i1 k r l) - (λ k r → gluem≡gluer₂ (pt C) i1 k r l) - (λ i r → coh i r (~ l)) - (λ i r → base) - (λ i k → coh-filler i (~ l) k i1) - λ i k → gluer (snd B) (snd C) (k ∨ ~ l)) - (λ _ _ _ → base) - λ i k r → gluer (snd B) (pt C) k - coh-lem l i k r = - hcomp (λ j → λ {(i = i0) → gluel≡gluer₁ (pt B) k r l j - ; (i = i1) → gluem≡gluer₁ (pt C) k r l j - ; (l = i0) → base - ; (l = i1) → gluer (snd B) (pt C) (k ∧ j) - ; (k = i0) → coh i r (~ l) - ; (k = i1) → gluem≡gluer₁ (pt C) k r l j - ; (r = i0) → coh-filler i (~ l) k j - ; (r = i1) → gluer (snd B) (snd C) (~ l ∨ (j ∧ k))}) - (hcomp (λ j → λ {(i = i0) → gluel≡gluer (snd B) (r ∨ k) (~ l) - ; (i = i1) → gluem≡gluer (snd C) (r ∨ k) (~ l) - ; (l = i0) → base - ; (l = i1) → proj (pt A) (pt B) (snd C) - ; (k = i0) → coh i r (~ l) - ; (k = i1) → gluer (snd B) (snd C) (~ l) - ; (r = i0) → coh i k (~ l) - ; (r = i1) → gluer (snd B) (snd C) (~ l)}) - (coh i (r ∨ k) (~ l))) - - filler₆ : (x : typ A) (a : typ B) (i j k : I) → A ⋀ (B ⋀ C , inl tt) - filler₆ x a i j k = - hfill (λ k → λ {(i = i0) → inr (x , push (inl a) k) - ; (i = i1) → push (inl x) j - ; (j = i0) → compPath-filler' - (λ i₁ → inr (x , (push (inl a) (~ i₁)))) - (sym (push (inl x))) k i - ; (j = i1) → inr (x , push (inl a) (~ i ∧ k)) }) - (inS (push (inl x) (j ∨ ~ i))) - k - - filler₇ : (x : typ A) (a : typ C) (i j k : I) → A ⋀ (B ⋀ C , inl tt) - filler₇ x a i j k = - hfill (λ k → λ {(i = i0) → inr (x , push (inr a) k) - ; (i = i1) → push (inl x) j - ; (j = i0) → compPath-filler' - (λ i₁ → inr (x , (push (inr a) (~ i₁)))) - (sym (push (inl x))) k i - ; (j = i1) → inr (x , push (inr a) (~ i ∧ k)) }) - (inS (push (inl x) (j ∨ ~ i))) - k - - filler₈ : (x : typ A) (i j k r : I) → A ⋀ (B ⋀ C , inl tt) - filler₈ x i j k r = - hfill (λ r → λ {(i = i0) → inr (x , push (push tt k) r) - ; (i = i1) → push (inl x) j - ; (j = i0) → compPath-filler' - (λ j → inr (x , push (push tt k) (~ j))) - (sym (push (inl x))) r i - ; (j = i1) → inr (x , push (push tt k) (~ i ∧ r)) }) - (inS ((push (inl x) (j ∨ ~ i)))) - r - - btm-fill : (i j k r : I) → A ⋀ (B ⋀∙ C) - btm-fill i j k r = - hfill (λ r → λ {(i = i0) → push (inr (inl tt)) (~ j ∨ (r ∧ ~ k)) - ; (i = i1) → filler₅ j k i1 - ; (j = i1) → push (inr (inl tt)) (~ i ∧ (r ∧ ~ k)) - ; (j = i0) → push (inl (pt A)) (~ i ∨ k) - ; (k = i0) → filler₅ j (~ i) (~ r) - ; (k = i1) → push (inr (inl tt)) (~ j)}) - (inS (filler₅ j (~ i ∨ k) i1)) - r - - lr-fill₁ : (b : typ C) (i j k r : I) → A ⋀ (B ⋀∙ C) - lr-fill₁ a i j k r = - hfill (λ r → λ {(i = i0) → push (inr (push (inr a) r)) (~ j ∨ ~ k) - ; (i = i1) → filler₅ j k i1 - ; (j = i1) → push (inr (push (inr a) r)) (~ i ∧ ~ k) - ; (j = i0) → filler₇ (pt A) a i k r - ; (k = i0) → filler₄ a j i r - ; (k = i1) → push (inr (push (inr a) (~ i ∧ r))) (~ j)}) - (inS (btm-fill i j k i1)) - r - - ll-fill₁ : (a : typ B) (i j k r : I) → A ⋀ (B ⋀∙ C) - ll-fill₁ a i j k r = - hfill (λ r → λ {(i = i0) → push (inr (push (inl a) r)) (~ j ∨ ~ k) - ; (i = i1) → filler₅ j k i1 - ; (j = i1) → push (inr (push (inl a) r)) (~ i ∧ ~ k) - ; (j = i0) → filler₆ (pt A) a i k r - ; (k = i0) → filler₃ a j i r - ; (k = i1) → push (inr (push (inl a) (~ i ∧ r))) (~ j)}) - (inS (btm-fill i j k i1)) - r - - ll-fill₂ : (a : typ B) (i j k r : I) → A ⋀ (B ⋀∙ C) - ll-fill₂ a i j k r = - hfill (λ r → λ {(i = i0) → push (inr (inr (a , pt C))) (~ j ∨ (~ r ∧ ~ k)) - ; (i = i1) → filler₅ j k i1 - ; (j = i1) → push (inr (inr (a , (snd C)))) ((~ r ∧ ~ i) ∧ ~ k) - ; (j = i0) → filler₆ (pt A) a i k i1 - ; (k = i0) → ⋀×2→⋀ (filler₁ a i j r) - ; (k = i1) → push (inr (push (inl a) (~ i))) (~ j) }) - (inS (ll-fill₁ a i j k i1)) - r - - lr-fill₂ : (a : typ C) (i j k r : I) → A ⋀ (B ⋀∙ C) - lr-fill₂ a i j k r = - hfill (λ r → λ {(i = i0) → push (inr (inr (pt B , a))) (~ j ∨ (~ r ∧ ~ k)) - ; (i = i1) → filler₅ j k i1 - ; (j = i1) → push (inr (inr (pt B , a))) ((~ r ∧ ~ i) ∧ ~ k) - ; (j = i0) → filler₇ (pt A) a i k i1 - ; (k = i0) → ⋀×2→⋀ (filler₂ a i j r) - ; (k = i1) → push (inr (push (inr a) (~ i))) (~ j) }) - (inS (lr-fill₁ a i j k i1)) - r - - ⋀→⋀×2→⋀ : (x : A ⋀ (B ⋀∙ C)) - → ⋀×2→⋀ (⋀→⋀×2 x) ≡ x - ⋀→⋀×2→⋀ (inl x) = refl - ⋀→⋀×2→⋀ (inr (x , inl x₁)) = push (inl x) - ⋀→⋀×2→⋀ (inr (x , inr x₁)) = refl - ⋀→⋀×2→⋀ (inr (x , push (inl a) i)) j = filler₆ x a (~ i) j i1 - ⋀→⋀×2→⋀ (inr (x , push (inr b) i)) j = filler₇ x b (~ i) j i1 - ⋀→⋀×2→⋀ (inr (x , push (push a r) i)) j = filler₈ x (~ i) j r i1 - ⋀→⋀×2→⋀ (push (inl x) i) j = push (inl x) (j ∧ i) - ⋀→⋀×2→⋀ (push (inr (inl x)) i) j = filler₅ (~ i) j i1 - ⋀→⋀×2→⋀ (push (inr (inr x)) i) j = push (inr (inr x)) i - ⋀→⋀×2→⋀ (push (inr (push (inl x) i)) j) k = ll-fill₂ x (~ i) (~ j) k i1 - ⋀→⋀×2→⋀ (push (inr (push (inr x) i)) j) k = lr-fill₂ x (~ i) (~ j) k i1 - ⋀→⋀×2→⋀ (push (inr (push (push a r) i)) j) k = - hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 - ; (i = i1) → push (inr (inr (snd B , snd C))) (j ∨ ~ s ∧ ~ k) - ; (j = i0) → push (inr (inr (pt B , pt C))) ((~ s ∧ i) ∧ ~ k) - ; (j = i1) → filler₈ (pt A) (~ i) k r i1 - ; (k = i0) → ⋀×2→⋀ (coh-filler r (~ i) (~ j) s) - ; (k = i1) → push (inr (push (push tt r) i)) j - ; (r = i0) → ll-fill₂ (pt B) (~ i) (~ j) k s - ; (r = i1) → lr-fill₂ (pt C) (~ i) (~ j) k s }) - (hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 - ; (i = i1) → push (inr (push (push tt r) s)) (j ∨ ~ k) - ; (j = i0) → push (inr (push (push tt r) s)) (i ∧ ~ k) - ; (j = i1) → filler₈ (pt A) (~ i) k r s - ; (k = i0) → coh-filler₂ r (~ j) (~ i) s - ; (k = i1) → push (inr (push (push tt r) (i ∧ s))) j - ; (r = i0) → ll-fill₁ (pt B) (~ i) (~ j) k s - ; (r = i1) → lr-fill₁ (pt C) (~ i) (~ j) k s}) - (hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 - ; (i = i1) → push (inr (inl tt)) (j ∨ (s ∧ ~ k)) - ; (j = i0) → push (inr (inl tt)) (i ∧ s ∧ ~ k) - ; (j = i1) → push (inl (snd A)) (i ∨ k) - ; (k = i0) → filler₅ (~ j) i (~ s) - ; (k = i1) → push (inr (inl tt)) j - ; (r = i0) → btm-fill (~ i) (~ j) k s - ; (r = i1) → btm-fill (~ i) (~ j) k s}) - (filler₅ (~ j) (i ∨ k) i1))) - ⋀→⋀×2→⋀ (push (push a i) j) k = - hcomp (λ r → λ {(i = i0) → push (inl (pt A)) (k ∧ j ∨ ~ r) - ; (i = i1) → filler₅ (~ j) k r - ; (j = i0) → push (push tt i) (k ∧ ~ r) - ; (j = i1) → push (inl (snd A)) k - ; (k = i0) → inl tt - ; (k = i1) → push (push tt i) (j ∨ ~ r)}) - (push (push tt (~ j ∧ i)) k) - - -- The main result of step 1 - Iso-⋀-⋀×2 : Iso (A ⋀ (B ⋀∙ C)) ⋀×2 - Iso.fun Iso-⋀-⋀×2 = ⋀→⋀×2 - Iso.inv Iso-⋀-⋀×2 = ⋀×2→⋀ - Iso.rightInv Iso-⋀-⋀×2 = ⋀×2→⋀→⋀×2 - Iso.leftInv Iso-⋀-⋀×2 = ⋀→⋀×2→⋀ - -module _ {ℓ ℓ' ℓ'' : Level} (A : Pointed ℓ) (B : Pointed ℓ') (C : Pointed ℓ'') where - -- Step 2: show that ⋀×2 A B C ≃ ⋀×2 C A B - - -- some fillers - permute-fill→ : (i j k r : I) → ⋀×2 C A B - permute-fill→ i j k r = - hfill (λ r → λ {(i = i0) → gluem≡gluer (snd B) (~ j ∨ ~ r) k - ; (i = i1) → gluel≡gluem (pt C) j k - ; (j = i0) → gluel≡gluer (pt A) (~ i) k - ; (j = i1) → gluem≡gluer (snd B) (~ i ∧ ~ r) k - ; (k = i0) → proj (pt C) (pt A) (snd B) - ; (k = i1) → base}) - (inS (coh j (~ i) k)) - r - - permute-fill← : (i j k r : I) → ⋀×2 A B C - permute-fill← i j k r = - hfill (λ r → λ {(i = i0) → gluel≡gluem (snd A) (~ j) k - ; (i = i1) → gluel≡gluer (pt B) (~ j ∨ ~ r) k - ; (j = i0) → gluem≡gluer (pt C) i k - ; (j = i1) → gluel≡gluer (pt B) (i ∧ ~ r) k - ; (k = i0) → proj (snd A) (pt B) (pt C) - ; (k = i1) → base}) - (inS (coh (~ j) i k)) - r - - ⋀×2-permuteFun : ⋀×2 A B C → ⋀×2 C A B - ⋀×2-permuteFun base = base - ⋀×2-permuteFun (proj x x₁ x₂) = proj x₂ x x₁ - ⋀×2-permuteFun (gluel x y i) = gluer x y i - ⋀×2-permuteFun (gluem x z i) = gluel z x i - ⋀×2-permuteFun (gluer y z i) = gluem z y i - ⋀×2-permuteFun (gluel≡gluem a i j) = gluel≡gluer a (~ i) j - ⋀×2-permuteFun (gluel≡gluer y i j) = gluem≡gluer y (~ i) j - ⋀×2-permuteFun (gluem≡gluer z i j) = gluel≡gluem z i j - ⋀×2-permuteFun (coh i j k) = - hcomp (λ r → λ {(i = i0) → gluem≡gluer (snd B) (~ j ∨ ~ r) k - ; (i = i1) → gluel≡gluem (pt C) j k - ; (j = i0) → gluel≡gluer (pt A) (~ i) k - ; (j = i1) → gluem≡gluer (snd B) (~ i ∧ ~ r) k - ; (k = i0) → proj (pt C) (pt A) (snd B) - ; (k = i1) → base}) - (coh j (~ i) k) - - ⋀×2-permuteInv : ⋀×2 C A B → ⋀×2 A B C - ⋀×2-permuteInv base = base - ⋀×2-permuteInv (proj x x₁ x₂) = proj x₁ x₂ x - ⋀×2-permuteInv (gluel x y i) = gluem y x i - ⋀×2-permuteInv (gluem x z i) = gluer z x i - ⋀×2-permuteInv (gluer y z i) = gluel y z i - ⋀×2-permuteInv (gluel≡gluem a i j) = gluem≡gluer a i j - ⋀×2-permuteInv (gluel≡gluer y i j) = gluel≡gluem y (~ i) j - ⋀×2-permuteInv (gluem≡gluer z i j) = gluel≡gluer z (~ i) j - ⋀×2-permuteInv (coh i j k) = permute-fill← i j k i1 - - ⋀×2-permuteIso : Iso (⋀×2 A B C) (⋀×2 C A B) - Iso.fun ⋀×2-permuteIso = ⋀×2-permuteFun - Iso.inv ⋀×2-permuteIso = ⋀×2-permuteInv - Iso.rightInv ⋀×2-permuteIso base = refl - Iso.rightInv ⋀×2-permuteIso (proj x x₁ x₂) = refl - Iso.rightInv ⋀×2-permuteIso (gluel x y i) = refl - Iso.rightInv ⋀×2-permuteIso (gluem x z i) = refl - Iso.rightInv ⋀×2-permuteIso (gluer y z i) = refl - Iso.rightInv ⋀×2-permuteIso (gluel≡gluem a i i₁) = refl - Iso.rightInv ⋀×2-permuteIso (gluel≡gluer y x x₁) = refl - Iso.rightInv ⋀×2-permuteIso (gluem≡gluer z i i₁) = refl - Iso.rightInv ⋀×2-permuteIso (coh i j k) r = - hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd A) j k - ; (i = i1) → gluem≡gluer (snd B) (j ∧ (r ∨ l)) k - ; (j = i0) → gluel≡gluem (snd C) i k - ; (j = i1) → gluem≡gluer (snd B) (~ i ∨ (l ∨ r)) k - ; (k = i0) → proj (snd C) (snd A) (snd B) - ; (k = i1) → base - ; (r = i0) → ⋀×2-permuteFun (permute-fill← i j k l) - ; (r = i1) → coh i j k}) - (hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd A) j k - ; (i = i1) → gluem≡gluer (snd B) (j ∧ (~ l ∨ r)) k - ; (j = i0) → gluel≡gluem (snd C) i k - ; (j = i1) → gluem≡gluer (snd B) (~ i ∨ (~ l ∨ r)) k - ; (k = i0) → proj (snd C) (snd A) (snd B) - ; (k = i1) → base - ; (r = i0) → permute-fill→ (~ j) i k l - ; (r = i1) → coh i j k}) - (coh i j k)) - Iso.leftInv ⋀×2-permuteIso base = refl - Iso.leftInv ⋀×2-permuteIso (proj x x₁ x₂) = refl - Iso.leftInv ⋀×2-permuteIso (gluel x y i) = refl - Iso.leftInv ⋀×2-permuteIso (gluem x z i) = refl - Iso.leftInv ⋀×2-permuteIso (gluer y z i) = refl - Iso.leftInv ⋀×2-permuteIso (gluel≡gluem a i i₁) = refl - Iso.leftInv ⋀×2-permuteIso (gluel≡gluer y x x₁) = refl - Iso.leftInv ⋀×2-permuteIso (gluem≡gluer z i i₁) = refl - Iso.leftInv ⋀×2-permuteIso (coh i j k) r = - hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd B) (j ∧ (l ∨ r)) k - ; (i = i1) → gluem≡gluer (snd C) j k - ; (j = i0) → gluel≡gluem (snd A) i k - ; (j = i1) → gluel≡gluer (snd B) (i ∨ (l ∨ r)) k - ; (k = i0) → proj (pt A) (pt B) (pt C) - ; (k = i1) → base - ; (r = i0) → ⋀×2-permuteInv (permute-fill→ i j k l) - ; (r = i1) → coh i j k}) - (hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd B) (j ∧ (~ l ∨ r)) k - ; (i = i1) → gluem≡gluer (snd C) j k - ; (j = i0) → gluel≡gluem (snd A) i k - ; (j = i1) → gluel≡gluer (snd B) (i ∨ (~ l ∨ r)) k - ; (k = i0) → proj (pt A) (pt B) (pt C) - ; (k = i1) → base - ; (r = i0) → permute-fill← j (~ i) k l - ; (r = i1) → coh i j k}) - (coh i j k)) - --- Step 3: Combine the previous steps with commutativity of ⋀, and we are done -SmashAssocIso : Iso (A ⋀ (B ⋀∙ C)) ((A ⋀∙ B) ⋀ C) -SmashAssocIso {A = A} {B = B} {C = C} = - compIso - (Iso-⋀-⋀×2 A B C) - (compIso - (⋀×2-permuteIso A B C) - (compIso - (invIso (Iso-⋀-⋀×2 C A B)) - ⋀CommIso)) - -SmashAssocEquiv∙ : A ⋀∙ (B ⋀∙ C) ≃∙ (A ⋀∙ B) ⋀∙ C -fst SmashAssocEquiv∙ = isoToEquiv SmashAssocIso -snd SmashAssocEquiv∙ = refl - -module _ {C : Type ℓ} (f g : A ⋀ B → C) - (bp : f (inl tt) ≡ g (inl tt)) - (proj : (x : _) → f (inr x) ≡ g (inr x)) - (pl : (x : typ A) → PathP (λ i → f (push (inl x) i) ≡ g (push (inl x) i)) - bp (proj (x , pt B))) - (p-r : (x : typ B) → PathP (λ i → f (push (inr x) i) ≡ g (push (inr x) i)) - bp (proj (pt A , x))) - where - private - ⋆act : bp ≡ bp - ⋆act i j = - hcomp (λ k → λ { (i = i0) → pl (pt A) (~ k) j - ; (i = i1) → p-r (pt B) (~ k) j - ; (j = i0) → f (push (push tt i) (~ k)) - ; (j = i1) → g (push (push tt i) (~ k))}) - (proj (snd A , snd B) j) - - ⋀-fun≡ : (x : _) → f x ≡ g x - ⋀-fun≡ (inl x) = bp - ⋀-fun≡ (inr x) = proj x - ⋀-fun≡ (push (inl x) i) = pl x i - ⋀-fun≡ (push (inr x) i) j = - hcomp (λ r → λ {(i = i0) → bp j - ; (i = i1) → p-r x r j - ; (j = i0) → f (push (inr x) (r ∧ i)) - ; (j = i1) → g (push (inr x) (r ∧ i)) }) - (⋆act i j) - ⋀-fun≡ (push (push a i) j) k = - hcomp (λ r → λ { (i = i0) → pl (snd A) (j ∧ r) k - ; (j = i0) → bp k - ; (j = i1) → side i k r - ; (k = i0) → f (push (push a i) (j ∧ r)) - ; (k = i1) → g (push (push a i) (j ∧ r))}) - (⋆act (i ∧ j) k) - where - side : Cube (λ k r → pl (snd A) r k) - (λ k r → p-r (snd B) r k) - (λ i r → f (push (push a i) r)) - (λ i r → g (push (push a i) r)) - ⋆act λ i → proj (snd A , snd B) - side i k r = - hcomp (λ j → λ { (i = i0) → pl (pt A) (~ j ∨ r) k - ; (i = i1) → p-r (snd B) (~ j ∨ r) k - ; (k = i0) → f (push (push a i) (~ j ∨ r)) - ; (k = i1) → g (push (push a i) (~ j ∨ r)) - ; (r = i1) → proj (snd A , snd B) k}) - (proj (snd A , snd B) k) - --- Techincal lemma allowing for use of ⋀→∙Homogeneous≡ on --- when proving equalities of functions A ⋀ B → C -module ⋀-fun≡' {C : Type ℓ} (f g : A ⋀ B → C) - (pr : (x : _) → f (inr x) ≡ g (inr x)) where - - p : f (inl tt) ≡ g (inl tt) - p = cong f (push (inr (pt B))) - ∙∙ pr (pt A , pt B) - ∙∙ sym (cong g (push (inr (pt B)))) - - - p' : f (inl tt) ≡ g (inl tt) - p' = cong f (push (inl (pt A))) - ∙∙ pr (pt A , pt B) - ∙∙ sym (cong g (push (inl (pt A)))) - - p≡p' : p ≡ p' - p≡p' i = (cong f (push (push tt (~ i)))) - ∙∙ pr (pt A , pt B) - ∙∙ sym (cong g (push (push tt (~ i)))) - - Fₗ : B →∙ ((f (inl tt) ≡ g (inl tt)) , p) - fst Fₗ b = cong f (push (inr b)) ∙∙ pr (pt A , b) ∙∙ sym (cong g (push (inr b))) - snd Fₗ = refl - - Fᵣ : B →∙ ((f (inl tt) ≡ g (inl tt)) , p) - fst Fᵣ b = p - snd Fᵣ = refl - - module _ - (lp : (x : fst A) → PathP (λ i → f (push (inl x) i) ≡ g (push (inl x) i)) - p (pr (x , pt B))) - (q : Fₗ ≡ Fᵣ) where - private - lem : (b : fst B) - → Square p (pr (snd A , b)) - (cong f (push (inr b))) (cong g (push (inr b))) - lem b i j = - hcomp (λ k → λ {(i = i0) → p j - ; (i = i1) → doubleCompPath-filler - (cong f (push (inr b))) - (pr (pt A , b)) - (sym (cong g (push (inr b)))) (~ k) j - ; (j = i0) → f (push (inr b) (i ∧ k)) - ; (j = i1) → g (push (inr b) (i ∧ k))}) - (q (~ i) .fst b j) - - main : (x : _) → f x ≡ g x - main = ⋀-fun≡ {A = A} {B = B} f g p pr lp lem +open import Cubical.Foundations.Equiv + +open import Cubical.Data.Unit +open import Cubical.Data.Sigma +open import Cubical.Data.Nat +open import Cubical.Data.Fin + +open import Cubical.HITs.Pushout.Base +open import Cubical.HITs.Wedge +open import Cubical.HITs.Susp renaming (toSusp to σ) +open import Cubical.HITs.Join + +open import Cubical.Homotopy.Loopspace + +data Smash {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') : Type (ℓ-max ℓ ℓ') where + basel : Smash A B + baser : Smash A B + proj : (x : typ A) → (y : typ B) → Smash A B + gluel : (a : typ A) → proj a (pt B) ≡ basel + gluer : (b : typ B) → proj (pt A) b ≡ baser + +private + variable + ℓ ℓ' : Level + A B C D : Pointed ℓ + +infixl 30 _⋀∙_ + +SmashPt : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ') +SmashPt A B = (Smash A B , basel) + +SmashPtProj : (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ') +SmashPtProj A B = Smash A B , (proj (snd A) (snd B)) + +Smash-map : (f : A →∙ C) (g : B →∙ D) → Smash A B → Smash C D +Smash-map f g basel = basel +Smash-map f g baser = baser +Smash-map (f , fpt) (g , gpt) (proj x y) = proj (f x) (g y) +Smash-map (f , fpt) (g , gpt) (gluel a i) = ((λ j → proj (f a) (gpt j)) ∙ gluel (f a)) i +Smash-map (f , fpt) (g , gpt) (gluer b i) = ((λ j → proj (fpt j) (g b)) ∙ gluer (g b)) i + +-- Commutativity +comm : Smash A B → Smash B A +comm basel = baser +comm baser = basel +comm (proj x y) = proj y x +comm (gluel a i) = gluer a i +comm (gluer b i) = gluel b i + +commK : (x : Smash A B) → comm (comm x) ≡ x +commK basel = refl +commK baser = refl +commK (proj x y) = refl +commK (gluel a x) = refl +commK (gluer b x) = refl + +--- Alternative definition + +i∧ : {A : Pointed ℓ} {B : Pointed ℓ'} → A ⋁ B → (typ A) × (typ B) +i∧ {A = A , ptA} {B = B , ptB} (inl x) = x , ptB +i∧ {A = A , ptA} {B = B , ptB} (inr x) = ptA , x +i∧ {A = A , ptA} {B = B , ptB} (push tt i) = ptA , ptB + +_⋀_ : Pointed ℓ → Pointed ℓ' → Type (ℓ-max ℓ ℓ') +A ⋀ B = Pushout {A = (A ⋁ B)} (λ _ → tt) i∧ + +_⋀∙_ : Pointed ℓ → Pointed ℓ' → Pointed (ℓ-max ℓ ℓ') +A ⋀∙ B = (A ⋀ B) , (inl tt) + +-- iterated products +⋀^ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) → Pointed ℓ +⋀^ zero A = A fzero +⋀^ (suc n) A = ⋀^ n (predFinFamily∙ A) ⋀∙ (A flast) + +⋀comm→ : A ⋀ B → B ⋀ A +⋀comm→ (inl x) = inl x +⋀comm→ (inr (x , y)) = inr (y , x) +⋀comm→ (push (inl x) i) = push (inr x) i +⋀comm→ (push (inr x) i) = push (inl x) i +⋀comm→ (push (push a i₁) i) = push (push tt (~ i₁)) i + +⋀comm→² : {A : Pointed ℓ} {B : Pointed ℓ' } + (x : A ⋀ B) → ⋀comm→ (⋀comm→ {A = A} {B = B} x) ≡ x +⋀comm→² (inl x) = refl +⋀comm→² (inr x) = refl +⋀comm→² (push (inl x) i) = refl +⋀comm→² (push (inr x) i) = refl +⋀comm→² (push (push a i₁) i) = refl + +⋀CommIso : Iso (A ⋀ B) (B ⋀ A) +Iso.fun ⋀CommIso = ⋀comm→ +Iso.inv ⋀CommIso = ⋀comm→ +Iso.rightInv ⋀CommIso = ⋀comm→² +Iso.leftInv ⋀CommIso = ⋀comm→² + +⋀comm→∙ : A ⋀∙ B →∙ B ⋀∙ A +fst ⋀comm→∙ = ⋀comm→ +snd ⋀comm→∙ = refl + +SmashAdjIso : Iso ((A ⋀∙ B) →∙ C) (A →∙ (B →∙ C ∙)) +SmashAdjIso {A = A} {B = B} {C = C} = + compIso is₃ (compIso iso₄ (invIso is₂)) + where + is₁ : Iso (A →∙ (B →∙ C ∙)) + (Σ[ f ∈ (fst A → fst B → fst C) ] + Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ pt C) ] + Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ pt C) ] + PathP (λ i → r (snd B) i ≡ snd C) (l (snd A)) refl) + Iso.fun is₁ f = (λ x y → f .fst x .fst y) + , (λ x → f .fst x .snd) + , (λ x i → f .snd i .fst x) + , λ i j → f .snd i .snd j + fst (fst (Iso.inv is₁ (f , l , r , p)) x) = f x + snd (fst (Iso.inv is₁ (f , l , r , p)) x) = l x + fst (snd (Iso.inv is₁ (f , l , r , p)) i) b = r b i + snd (snd (Iso.inv is₁ (f , l , r , p)) i) j = p i j + Iso.rightInv is₁ _ = refl + Iso.leftInv is₁ _ = refl + + is₂ : Iso (A →∙ (B →∙ C ∙)) ( + (Σ[ f ∈ (fst A → fst B → fst C) ] + Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ pt C) ] + Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ pt C) ] + l (pt A) ≡ r (pt B))) + is₂ = compIso is₁ (Σ-cong-iso-snd + λ f → Σ-cong-iso-snd + λ l → Σ-cong-iso-snd + λ r → pathToIso (PathP≡doubleCompPathʳ _ _ _ _ + ∙ cong (l (snd A) ≡_) + (sym (compPath≡compPath' (r (snd B)) refl) + ∙ sym (rUnit (r (pt B)))))) + + is₃ : Iso ((A ⋀∙ B) →∙ C) + (Σ[ f ∈ (fst A → fst B → fst C) ] + Σ[ p ∈ singl (snd C) ] + Σ[ l ∈ ((x : fst A) → f x (pt B) ≡ fst p) ] + Σ[ r ∈ ((b : fst B) → f (pt A) b ≡ fst p) ] + l (pt A) ≡ r (pt B)) + fst (Iso.fun is₃ f) x y = fst f (inr (x , y)) + fst (fst (snd (Iso.fun is₃ f))) = fst f (inl tt) + snd (fst (snd (Iso.fun is₃ f))) = sym (snd f) + fst (snd (snd (Iso.fun is₃ f))) x = cong (fst f) (sym (push (inl x))) + fst (snd (snd (snd (Iso.fun is₃ f)))) x = cong (fst f) (sym (push (inr x))) + snd (snd (snd (snd (Iso.fun is₃ f)))) i j = fst f (push (push tt i) (~ j)) + fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (inl x) = c* + fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (inr (x , y)) = f x y + fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (inl x) i) = l x (~ i) + fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (inr x) i) = r x (~ i) + fst (Iso.inv is₃ (f , (c* , p) , l , r , q)) (push (push a j) i) = q j (~ i) + snd (Iso.inv is₃ (f , (c* , p) , l , r , q)) = sym p + Iso.rightInv is₃ _ = refl + Iso.leftInv is₃ f = + ΣPathP ((funExt (λ { (inl x) → refl + ; (inr x) → refl + ; (push (inl x) i) → refl + ; (push (inr x) i) → refl + ; (push (push a i₁) i) → refl})) + , refl) + + isContrIso : ∀ {ℓ ℓ'} {A : Type ℓ} (a : A) (B : singl a → Type ℓ') + → Iso (Σ _ B) (B (a , refl)) + isContrIso a B = + compIso (invIso + (Σ-cong-iso-fst (isContr→Iso isContrUnit (isContrSingl a)))) + lUnit×Iso + + iso₄ : Iso (isoToPath is₃ i1) + (isoToPath is₂ i1) + iso₄ = Σ-cong-iso-snd λ f → isContrIso (snd C) _ + +-- induction priciples for maps into pointed types +⋀→∙Homogeneous≡ : isHomogeneous C + → {f g : (A ⋀∙ B) →∙ C} + → ((x : fst A) (y : fst B) → fst f (inr (x , y)) ≡ fst g (inr (x , y))) + → f ≡ g +⋀→∙Homogeneous≡ C {f = f} {g = g} p = + sym (Iso.leftInv SmashAdjIso f) + ∙∙ cong (Iso.inv SmashAdjIso) main + ∙∙ Iso.leftInv SmashAdjIso g + where + main : Iso.fun SmashAdjIso f ≡ Iso.fun SmashAdjIso g + main = + →∙Homogeneous≡ (isHomogeneous→∙ C) + (funExt λ x → →∙Homogeneous≡ C (funExt (p x))) + +prod→⋀^ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) + → prodFinFamily n (fst ∘ A) → ⋀^ n A .fst +prod→⋀^ zero A x = x +prod→⋀^ (suc n) A x = + inr ((prod→⋀^ n (predFinFamily∙ A) (fst x)) , (snd x)) + +⋀→Homogeneous≡ : {A B : Pointed ℓ} {D : Type ℓ'} + → {f g : A ⋀ B → D} + → (isHomogeneous (D , f (inl tt))) + → ((x : _) (y : _) → f (inr (x , y)) ≡ g (inr (x , y))) + → f ≡ g +⋀→Homogeneous≡ {A = A} {B} {D} {f = f} {g} hom p = cong fst f^≡g^ + where + f^ g^ : A ⋀∙ B →∙ (D , f (inl tt)) + f^ = f , refl + g^ = g , (cong g (push (inr (pt B))) + ∙∙ sym (p (pt A) (pt B)) + ∙∙ cong f (sym (push (inr (pt B))))) + + f^≡g^ : f^ ≡ g^ + f^≡g^ = ⋀→∙Homogeneous≡ hom p + +⋀^→Homogeneous≡ : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) {B : Type ℓ'} + → {f g : ⋀^ n A .fst → B} + → isHomogeneous (B , f (⋀^ n A .snd)) + → ((x : _) → f (prod→⋀^ n A x) ≡ g (prod→⋀^ n A x)) + → f ≡ g +⋀^→Homogeneous≡ zero A hom ind = funExt ind +⋀^→Homogeneous≡ (suc n) A {B = B} {f = f} {g} hom ind = + ⋀→Homogeneous≡ hom λ x y + → funExt⁻ (⋀^→Homogeneous≡ n (predFinFamily∙ A) + {f = λ x → f (inr (x , y))} {g = λ x → g (inr (x , y))} + (subst (isHomogeneous ∘ (B ,_)) + (cong f (push (inr y))) hom ) + λ _ → ind _) x + +⋀^→Homogeneous : (n : ℕ) (A : Fin (suc n) → Pointed ℓ) (B : Pointed ℓ') + → (isHomogeneous B) + → (f g : ⋀^ n A →∙ B) + → ((x : _) → f .fst (prod→⋀^ n A x) ≡ g .fst (prod→⋀^ n A x)) + → f ≡ g +⋀^→Homogeneous zero A B ishom f g ind = →∙Homogeneous≡ ishom (funExt ind) +⋀^→Homogeneous (suc n) A B ishom f g ind = + ⋀→∙Homogeneous≡ ishom λ x y i + → ⋀^→Homogeneous n (predFinFamily∙ A) B ishom + (f' y) (g' y) (λ x → ind (x , y)) i .fst x + where + module _ (y : A flast .fst) where + f' g' : ⋀^ n (predFinFamily∙ A) →∙ B + f' = (λ x → f .fst (inr (x , y))) + , cong (fst f) (sym (push (inr y))) ∙ snd f + g' = (λ x → g .fst (inr (x , y))) + , cong (fst g) (sym (push (inr y))) ∙ snd g + +_⋀→_ : (f : A →∙ C) (g : B →∙ D) → A ⋀ B → C ⋀ D +(f ⋀→ g) (inl tt) = inl tt +((f , fpt) ⋀→ (g , gpt)) (inr (x , x₁)) = inr (f x , g x₁) +_⋀→_ {B = B} {D = D} (f , fpt) (b , gpt) (push (inl x) i) = (push (inl (f x)) ∙ (λ i → inr (f x , gpt (~ i)))) i +_⋀→_ (f , fpt) (g , gpt) (push (inr x) i) = (push (inr (g x)) ∙ (λ i → inr (fpt (~ i) , g x))) i +_⋀→_ {A = A} {C = C} {B = B} {D = D} (f , fpt) (g , gpt) (push (push tt j) i) = + hcomp (λ k → λ { (i = i0) → inl tt + ; (i = i1) → inr (fpt (~ k) , gpt (~ k)) + ; (j = i0) → compPath-filler (push (inl (fpt (~ k)))) + ((λ i → inr (fpt (~ k) , gpt (~ i)))) k i + ; (j = i1) → compPath-filler (push (inr (gpt (~ k)))) + ((λ i → inr (fpt (~ i) , gpt (~ k)))) k i}) + (push (push tt j) i) + +_⋀→∙_ : (f : A →∙ C) (g : B →∙ D) → A ⋀∙ B →∙ C ⋀∙ D +fst (f ⋀→∙ g) = f ⋀→ g +snd (f ⋀→∙ g) = refl + + +_⋀→refl_ : ∀ {ℓ ℓ'} {C : Type ℓ} {D : Type ℓ'} + → (f : typ A → C) + → (g : typ B → D) + → (A ⋀ B) → ((C , f (pt A)) ⋀ (D , g (pt B))) +(f ⋀→refl g) (inl x) = inl tt +(f ⋀→refl g) (inr (x , y)) = inr (f x , g y) +(f ⋀→refl g) (push (inl x) i) = push (inl (f x)) i +(f ⋀→refl g) (push (inr x) i) = push (inr (g x)) i +(f ⋀→refl g) (push (push a i₁) i) = push (push tt i₁) i + +_⋀∙→refl_ : ∀ {ℓ ℓ'} {C : Type ℓ} {D : Type ℓ'} + → (f : typ A → C) + → (g : typ B → D) + → (A ⋀∙ B) →∙ ((C , f (pt A)) ⋀∙ (D , g (pt B))) +fst (f ⋀∙→refl g) = f ⋀→refl g +snd (f ⋀∙→refl g) = refl + + +⋀≃ : ∀ {ℓ ℓ'} {A B : Pointed ℓ} {C D : Pointed ℓ'} + → (f : A ≃∙ B) (g : C ≃∙ D) + → (A ⋀ C) ≃ (B ⋀ D) +⋀≃ {ℓ = ℓ} {ℓ'} {B = B} {D = D} f g = _ , ⋀≃-isEq f g + where + help : (x : _) → (idfun∙ B ⋀→ idfun∙ D) x ≡ x + help (inl x) = refl + help (inr x) = refl + help (push (inl x) i) j = rUnit (push (inl x)) (~ j) i + help (push (inr x) i) j = rUnit (push (inr x)) (~ j) i + help (push (push a i) j) k = + hcomp (λ r → λ {(i = i0) → rUnit (push (inl (snd B))) (~ k ∧ r) j + ; (i = i1) → rUnit (push (inr (snd D))) (~ k ∧ r) j + ; (j = i0) → inl tt + ; (j = i1) → inr (snd B , snd D) + ; (k = i1) → push (push tt i) j}) + (push (push tt i) j) + + ⋀≃-isEq : {A : Pointed ℓ} {C : Pointed ℓ'} + (f : A ≃∙ B) (g : C ≃∙ D) → isEquiv (≃∙map f ⋀→ ≃∙map g) + ⋀≃-isEq {C = C} = + Equiv∙J (λ A f → (g : C ≃∙ D) + → isEquiv (≃∙map f ⋀→ ≃∙map g)) + (Equiv∙J (λ _ g → isEquiv (idfun∙ _ ⋀→ ≃∙map g)) + (subst isEquiv (sym (funExt help)) (idIsEquiv _))) + + +⋀→Smash : A ⋀ B → Smash A B +⋀→Smash (inl x) = basel +⋀→Smash (inr (x , x₁)) = proj x x₁ +⋀→Smash (push (inl x) i) = gluel x (~ i) +⋀→Smash {A = A} {B = B} (push (inr x) i) = + (sym (gluel (snd A)) ∙∙ gluer (snd B) ∙∙ sym (gluer x)) i +⋀→Smash {A = A} {B = B} (push (push a j) i) = + hcomp (λ k → λ { (i = i0) → gluel (snd A) (k ∨ ~ j) + ; (i = i1) → gluer (snd B) (~ k ∧ j) + ; (j = i0) → gluel (snd A) (~ i)}) + (invSides-filler (gluel (snd A)) (gluer (snd B)) j (~ i)) + +Smash→⋀ : Smash A B → A ⋀ B +Smash→⋀ basel = inl tt +Smash→⋀ baser = inl tt +Smash→⋀ (proj x y) = inr (x , y) +Smash→⋀ (gluel a i) = push (inl a) (~ i) +Smash→⋀ (gluer b i) = push (inr b) (~ i) + +{- Associativity -} +module _ {ℓ ℓ' ℓ'' : Level} (A : Pointed ℓ) (B : Pointed ℓ') (C : Pointed ℓ'') where + + -- HIT corresponding to A ⋀ B ⋀ C + data ⋀×2 : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) where + base : ⋀×2 + proj : typ A → typ B → typ C → ⋀×2 + + gluel : (x : typ A) (y : typ B) → proj x y (pt C) ≡ base + gluem : (x : typ A) (z : typ C) → proj x (pt B) z ≡ base + gluer : (y : typ B) (z : typ C) → proj (pt A) y z ≡ base + + gluel≡gluem : (a : typ A) → gluel a (pt B) ≡ gluem a (pt C) + gluel≡gluer : (y : typ B) → Path (Path (⋀×2) _ _) (gluel (pt A) y) (gluer y (pt C)) + gluem≡gluer : (z : typ C) → gluem (pt A) z ≡ gluer (pt B) z + + coh : Cube (gluel≡gluer (snd B)) (gluem≡gluer (pt C)) + (gluel≡gluem (pt A)) (λ _ → gluer (snd B) (pt C)) + refl refl + + -- Step 1 (main step): show A ⋀ (B ⋀ C) ≃ ⋀×2 A B C + + -- some fillers needed for the maps back and forth + filler₁ : typ B → (i j k : I) → ⋀×2 + filler₁ a i j r = + hfill (λ k → λ {(i = i0) → gluer a (pt C) (j ∧ k) + ; (i = i1) → base + ; (j = i0) → gluel (pt A) a i + ; (j = i1) → gluer a (pt C) (i ∨ k)}) + (inS (gluel≡gluer a j i)) + r + + filler₂ : typ C → (i j k : I) → ⋀×2 + filler₂ c i j r = + hfill (λ k → λ {(i = i0) → gluer (pt B) c (j ∧ k) + ; (i = i1) → base + ; (j = i0) → gluem (pt A) c i + ; (j = i1) → gluer (pt B) c (i ∨ k)}) + (inS (gluem≡gluer c j i)) + r + + filler₃ : typ B → (i j r : I) → A ⋀ (B ⋀∙ C) + filler₃ b i j r = + hfill (λ k → λ {(i = i0) → compPath-filler' + (λ j → inr (pt A , (push (inl b) (~ j)))) + (sym (push (inl (pt A)))) k j + ; (i = i1) → push (inr (push (inl b) k)) (~ j) + ; (j = i0) → inr (pt A , push (inl b) k) + ; (j = i1) → inl tt}) + (inS (push (push tt i) (~ j))) + r + + filler₄ : typ C → (i j r : I) → A ⋀ (B ⋀∙ C) + filler₄ c i j r = + hfill (λ k → λ {(i = i0) → compPath-filler' + (λ j → inr (pt A , (push (inr c) (~ j)))) + (sym (push (inl (pt A)))) k j + ; (i = i1) → push (inr (push (inr c) k)) (~ j) + ; (j = i0) → inr (pt A , push (inr c) k) + ; (j = i1) → inl tt}) + (inS (push (push tt i) (~ j))) + r + + filler₅ : (i j k : I) → A ⋀ (B ⋀∙ C) + filler₅ i j r = + hfill (λ k → λ {(i = i0) → push (inl (pt A)) j + ; (i = i1) → push (inr (inl tt)) (j ∧ ~ k) + ; (j = i0) → inl tt + ; (j = i1) → push (inr (inl tt)) (~ i ∨ ~ k)}) + (inS (push (push tt i) j)) + r + + coh-filler : (i j k r : I) → ⋀×2 + coh-filler i j k r = + hfill (λ r → λ {(i = i0) → filler₁ (pt B) j k r + ; (i = i1) → filler₂ (pt C) j k r + ; (j = i0) → gluer (snd B) (snd C) (k ∧ r) + ; (j = i1) → base + ; (k = i0) → gluel≡gluem (pt A) i j + ; (k = i1) → gluer (snd B) (snd C) (j ∨ r)}) + (inS (coh i k j)) + r + + coh-filler₂ : (i j k r : I) → A ⋀ (B ⋀∙ C) + coh-filler₂ i j k r = + hfill (λ r → λ {(i = i0) → filler₃ (snd B) j k r + ; (i = i1) → filler₄ (pt C) j k r + ; (j = i0) → compPath-filler' + (λ k₁ → inr (pt A , push (push tt i) (~ k₁))) + (sym (push (inl (pt A)))) r k + ; (j = i1) → push (inr (push (push tt i) r)) (~ k) + ; (k = i0) → inr (pt A , push (push tt i) r) + ; (k = i1) → inl tt}) + (inS (push (push tt j) (~ k))) + r + + ⋀→⋀×2 : A ⋀ (B ⋀∙ C) → ⋀×2 + ⋀→⋀×2 (inl x) = base + ⋀→⋀×2 (inr (x , inl y)) = base + ⋀→⋀×2 (inr (x , inr (y , z))) = proj x y z + ⋀→⋀×2 (inr (x , push (inl a) i)) = gluel x a (~ i) + ⋀→⋀×2 (inr (x , push (inr b) i)) = gluem x b (~ i) + ⋀→⋀×2 (inr (x , push (push a i) j)) = gluel≡gluem x i (~ j) + ⋀→⋀×2 (push (inl x) i) = base + ⋀→⋀×2 (push (inr (inl x)) i) = base + ⋀→⋀×2 (push (inr (inr (x , y))) i) = gluer x y (~ i) + ⋀→⋀×2 (push (inr (push (inl x) i)) j) = filler₁ x (~ i) (~ j) i1 + ⋀→⋀×2 (push (inr (push (inr x) i)) j) = filler₂ x (~ i) (~ j) i1 + ⋀→⋀×2 (push (inr (push (push a i) j)) k) = coh-filler i (~ j) (~ k) i1 + ⋀→⋀×2 (push (push a i₁) i) = base + + ⋀×2→⋀ : ⋀×2 → A ⋀ (B ⋀∙ C) + ⋀×2→⋀ base = inl tt + ⋀×2→⋀ (proj x x₁ x₂) = inr (x , inr (x₁ , x₂)) + ⋀×2→⋀ (gluel x y i) = + ((λ i → inr (x , (push (inl y) (~ i)))) ∙ sym (push (inl x))) i + ⋀×2→⋀ (gluem x z i) = + ((λ i → inr (x , (push (inr z) (~ i)))) ∙ sym (push (inl x))) i + ⋀×2→⋀ (gluer y z i) = push (inr (inr (y , z))) (~ i) + ⋀×2→⋀ (gluel≡gluem a i j) = + ((λ k → inr (a , (push (push tt i) (~ k)))) ∙ sym (push (inl a))) j + ⋀×2→⋀ (gluel≡gluer b i j) = filler₃ b i j i1 + ⋀×2→⋀ (gluem≡gluer c i j) = filler₄ c i j i1 + ⋀×2→⋀ (coh i j k) = coh-filler₂ i j k i1 + + -- fillers for cancellation + gluel-fill : (x : typ A) (b : typ B) (i j k : I) → ⋀×2 + gluel-fill x y i j k = + hfill (λ k → λ {(i = i0) → gluel x y (~ k) + ; (i = i1) → base + ; (j = i0) → + ⋀→⋀×2 (compPath-filler' + (λ i → (inr (x , (push (inl y) (~ i))))) + (sym (push (inl x))) k i) + ; (j = i1) → gluel x y (i ∨ ~ k) }) + (inS base) + k + + gluem-fill : (x : typ A) (z : typ C) (i j k : I) → ⋀×2 + gluem-fill x z i j k = + hfill (λ k → λ {(i = i0) → gluem x z (~ k) + ; (i = i1) → base + ; (j = i0) → ⋀→⋀×2 (compPath-filler' + (λ i → (inr (x , (push (inr z) (~ i))))) + (sym (push (inl x))) k i) + ; (j = i1) → gluem x z (i ∨ ~ k)}) + (inS base) + k + + gluel≡gluer₁ : (y : typ B) (i j r k : I) → ⋀×2 + gluel≡gluer₁ y i j r k = + hfill (λ k → λ {(r = i0) → base + ; (r = i1) → gluer y (snd C) (i ∧ k) + ; (i = i0) → gluel≡gluer y j (~ r) + ; (i = i1) → gluer y (snd C) (~ r ∨ k) + ; (j = i0) → filler₁ y (~ r) i k + ; (j = i1) → gluer y (snd C) ((i ∧ k) ∨ ~ r)}) + (inS (gluel≡gluer y (j ∨ i) (~ r))) + k + + + gluem≡gluer₁ : (y : typ C) (i j r k : I) → ⋀×2 + gluem≡gluer₁ z i j r k = + hfill (λ k → λ {(i = i0) → gluem≡gluer z j (~ r) + ; (i = i1) → gluer (snd B) z (~ r ∨ k) + ; (j = i0) → filler₂ z (~ r) i k + ; (j = i1) → gluer (snd B) z (~ r ∨ (k ∧ i)) + ; (r = i0) → base + ; (r = i1) → gluer (snd B) z (i ∧ k)}) + (inS (gluem≡gluer z (j ∨ i) (~ r))) + k + + gluel≡gluer₂ : (y : typ B) (k i j r : I) → ⋀×2 + gluel≡gluer₂ y k i j r = + hfill (λ r → λ {(i = i0) → gluel≡gluer y (k ∧ j) (~ r) + ; (i = i1) → base + ; (j = i0) → ⋀→⋀×2 (filler₃ y k i r) + ; (j = i1) → gluel≡gluer y k (i ∨ ~ r) + ; (k = i0) → gluel-fill (pt A) y i j r + ; (k = i1) → gluel≡gluer₁ y i j r i1}) + (inS base) + r + + gluem≡gluer₂ : (y : typ C) (k i j r : I) → ⋀×2 + gluem≡gluer₂ y k i j r = + hfill (λ r → λ {(i = i0) → gluem≡gluer y (k ∧ j) (~ r) + ; (i = i1) → base + ; (j = i0) → ⋀→⋀×2 (filler₄ y k i r) + ; (j = i1) → gluem≡gluer y k (i ∨ ~ r) + ; (k = i0) → gluem-fill (pt A) y i j r + ; (k = i1) → gluem≡gluer₁ y i j r i1}) + (inS base) + r + + gluel≡gluem-fill : (a : typ A) (i j k r : I) → ⋀×2 + gluel≡gluem-fill a i j k r = + hfill (λ r → λ {(i = i0) → gluel≡gluem a k (~ r) + ; (i = i1) → base + ; (j = i0) → ⋀→⋀×2 (compPath-filler' + (λ i → inr (a , push (push tt k) (~ i))) (sym (push (inl a))) r i) + ; (j = i1) → gluel≡gluem a k (i ∨ ~ r) + ; (k = i0) → gluel-fill a (pt B) i j r + ; (k = i1) → gluem-fill a (pt C) i j r}) + (inS base) + r + + ⋀×2→⋀→⋀×2 : (x : ⋀×2) → ⋀→⋀×2 (⋀×2→⋀ x) ≡ x + ⋀×2→⋀→⋀×2 base = refl + ⋀×2→⋀→⋀×2 (proj x x₁ x₂) = refl + ⋀×2→⋀→⋀×2 (gluel x y i) j = gluel-fill x y i j i1 + ⋀×2→⋀→⋀×2 (gluem x z i) j = gluem-fill x z i j i1 + ⋀×2→⋀→⋀×2 (gluer y z i) = refl + ⋀×2→⋀→⋀×2 (gluel≡gluem a k i) j = gluel≡gluem-fill a i j k i1 + ⋀×2→⋀→⋀×2 (gluel≡gluer y k i) j = gluel≡gluer₂ y k i j i1 + ⋀×2→⋀→⋀×2 (gluem≡gluer z k i) j = gluem≡gluer₂ z k i j i1 + ⋀×2→⋀→⋀×2 (coh i j k) r = + hcomp (λ l → λ {(i = i0) → gluel≡gluer₂ (snd B) j k r l + ; (i = i1) → gluem≡gluer₂ (pt C) j k r l + ; (j = i0) → gluel≡gluem-fill (pt A) k r i l + ; (j = i1) → coh-lem l i k r + ; (k = i0) → coh i (j ∧ r) (~ l) + ; (k = i1) → base + ; (r = i0) → ⋀→⋀×2 (coh-filler₂ i j k l) + ; (r = i1) → coh i j (k ∨ ~ l)}) + base + where + coh-lem : PathP + (λ l → Cube (λ k r → gluel≡gluer₂ (snd B) i1 k r l) + (λ k r → gluem≡gluer₂ (pt C) i1 k r l) + (λ i r → coh i r (~ l)) + (λ i r → base) + (λ i k → coh-filler i (~ l) k i1) + λ i k → gluer (snd B) (snd C) (k ∨ ~ l)) + (λ _ _ _ → base) + λ i k r → gluer (snd B) (pt C) k + coh-lem l i k r = + hcomp (λ j → λ {(i = i0) → gluel≡gluer₁ (pt B) k r l j + ; (i = i1) → gluem≡gluer₁ (pt C) k r l j + ; (l = i0) → base + ; (l = i1) → gluer (snd B) (pt C) (k ∧ j) + ; (k = i0) → coh i r (~ l) + ; (k = i1) → gluem≡gluer₁ (pt C) k r l j + ; (r = i0) → coh-filler i (~ l) k j + ; (r = i1) → gluer (snd B) (snd C) (~ l ∨ (j ∧ k))}) + (hcomp (λ j → λ {(i = i0) → gluel≡gluer (snd B) (r ∨ k) (~ l) + ; (i = i1) → gluem≡gluer (snd C) (r ∨ k) (~ l) + ; (l = i0) → base + ; (l = i1) → proj (pt A) (pt B) (snd C) + ; (k = i0) → coh i r (~ l) + ; (k = i1) → gluer (snd B) (snd C) (~ l) + ; (r = i0) → coh i k (~ l) + ; (r = i1) → gluer (snd B) (snd C) (~ l)}) + (coh i (r ∨ k) (~ l))) + + filler₆ : (x : typ A) (a : typ B) (i j k : I) → A ⋀ (B ⋀ C , inl tt) + filler₆ x a i j k = + hfill (λ k → λ {(i = i0) → inr (x , push (inl a) k) + ; (i = i1) → push (inl x) j + ; (j = i0) → compPath-filler' + (λ i₁ → inr (x , (push (inl a) (~ i₁)))) + (sym (push (inl x))) k i + ; (j = i1) → inr (x , push (inl a) (~ i ∧ k)) }) + (inS (push (inl x) (j ∨ ~ i))) + k + + filler₇ : (x : typ A) (a : typ C) (i j k : I) → A ⋀ (B ⋀ C , inl tt) + filler₇ x a i j k = + hfill (λ k → λ {(i = i0) → inr (x , push (inr a) k) + ; (i = i1) → push (inl x) j + ; (j = i0) → compPath-filler' + (λ i₁ → inr (x , (push (inr a) (~ i₁)))) + (sym (push (inl x))) k i + ; (j = i1) → inr (x , push (inr a) (~ i ∧ k)) }) + (inS (push (inl x) (j ∨ ~ i))) + k + + filler₈ : (x : typ A) (i j k r : I) → A ⋀ (B ⋀ C , inl tt) + filler₈ x i j k r = + hfill (λ r → λ {(i = i0) → inr (x , push (push tt k) r) + ; (i = i1) → push (inl x) j + ; (j = i0) → compPath-filler' + (λ j → inr (x , push (push tt k) (~ j))) + (sym (push (inl x))) r i + ; (j = i1) → inr (x , push (push tt k) (~ i ∧ r)) }) + (inS ((push (inl x) (j ∨ ~ i)))) + r + + btm-fill : (i j k r : I) → A ⋀ (B ⋀∙ C) + btm-fill i j k r = + hfill (λ r → λ {(i = i0) → push (inr (inl tt)) (~ j ∨ (r ∧ ~ k)) + ; (i = i1) → filler₅ j k i1 + ; (j = i1) → push (inr (inl tt)) (~ i ∧ (r ∧ ~ k)) + ; (j = i0) → push (inl (pt A)) (~ i ∨ k) + ; (k = i0) → filler₅ j (~ i) (~ r) + ; (k = i1) → push (inr (inl tt)) (~ j)}) + (inS (filler₅ j (~ i ∨ k) i1)) + r + + lr-fill₁ : (b : typ C) (i j k r : I) → A ⋀ (B ⋀∙ C) + lr-fill₁ a i j k r = + hfill (λ r → λ {(i = i0) → push (inr (push (inr a) r)) (~ j ∨ ~ k) + ; (i = i1) → filler₅ j k i1 + ; (j = i1) → push (inr (push (inr a) r)) (~ i ∧ ~ k) + ; (j = i0) → filler₇ (pt A) a i k r + ; (k = i0) → filler₄ a j i r + ; (k = i1) → push (inr (push (inr a) (~ i ∧ r))) (~ j)}) + (inS (btm-fill i j k i1)) + r + + ll-fill₁ : (a : typ B) (i j k r : I) → A ⋀ (B ⋀∙ C) + ll-fill₁ a i j k r = + hfill (λ r → λ {(i = i0) → push (inr (push (inl a) r)) (~ j ∨ ~ k) + ; (i = i1) → filler₅ j k i1 + ; (j = i1) → push (inr (push (inl a) r)) (~ i ∧ ~ k) + ; (j = i0) → filler₆ (pt A) a i k r + ; (k = i0) → filler₃ a j i r + ; (k = i1) → push (inr (push (inl a) (~ i ∧ r))) (~ j)}) + (inS (btm-fill i j k i1)) + r + + ll-fill₂ : (a : typ B) (i j k r : I) → A ⋀ (B ⋀∙ C) + ll-fill₂ a i j k r = + hfill (λ r → λ {(i = i0) → push (inr (inr (a , pt C))) (~ j ∨ (~ r ∧ ~ k)) + ; (i = i1) → filler₅ j k i1 + ; (j = i1) → push (inr (inr (a , (snd C)))) ((~ r ∧ ~ i) ∧ ~ k) + ; (j = i0) → filler₆ (pt A) a i k i1 + ; (k = i0) → ⋀×2→⋀ (filler₁ a i j r) + ; (k = i1) → push (inr (push (inl a) (~ i))) (~ j) }) + (inS (ll-fill₁ a i j k i1)) + r + + lr-fill₂ : (a : typ C) (i j k r : I) → A ⋀ (B ⋀∙ C) + lr-fill₂ a i j k r = + hfill (λ r → λ {(i = i0) → push (inr (inr (pt B , a))) (~ j ∨ (~ r ∧ ~ k)) + ; (i = i1) → filler₅ j k i1 + ; (j = i1) → push (inr (inr (pt B , a))) ((~ r ∧ ~ i) ∧ ~ k) + ; (j = i0) → filler₇ (pt A) a i k i1 + ; (k = i0) → ⋀×2→⋀ (filler₂ a i j r) + ; (k = i1) → push (inr (push (inr a) (~ i))) (~ j) }) + (inS (lr-fill₁ a i j k i1)) + r + + ⋀→⋀×2→⋀ : (x : A ⋀ (B ⋀∙ C)) + → ⋀×2→⋀ (⋀→⋀×2 x) ≡ x + ⋀→⋀×2→⋀ (inl x) = refl + ⋀→⋀×2→⋀ (inr (x , inl x₁)) = push (inl x) + ⋀→⋀×2→⋀ (inr (x , inr x₁)) = refl + ⋀→⋀×2→⋀ (inr (x , push (inl a) i)) j = filler₆ x a (~ i) j i1 + ⋀→⋀×2→⋀ (inr (x , push (inr b) i)) j = filler₇ x b (~ i) j i1 + ⋀→⋀×2→⋀ (inr (x , push (push a r) i)) j = filler₈ x (~ i) j r i1 + ⋀→⋀×2→⋀ (push (inl x) i) j = push (inl x) (j ∧ i) + ⋀→⋀×2→⋀ (push (inr (inl x)) i) j = filler₅ (~ i) j i1 + ⋀→⋀×2→⋀ (push (inr (inr x)) i) j = push (inr (inr x)) i + ⋀→⋀×2→⋀ (push (inr (push (inl x) i)) j) k = ll-fill₂ x (~ i) (~ j) k i1 + ⋀→⋀×2→⋀ (push (inr (push (inr x) i)) j) k = lr-fill₂ x (~ i) (~ j) k i1 + ⋀→⋀×2→⋀ (push (inr (push (push a r) i)) j) k = + hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 + ; (i = i1) → push (inr (inr (snd B , snd C))) (j ∨ ~ s ∧ ~ k) + ; (j = i0) → push (inr (inr (pt B , pt C))) ((~ s ∧ i) ∧ ~ k) + ; (j = i1) → filler₈ (pt A) (~ i) k r i1 + ; (k = i0) → ⋀×2→⋀ (coh-filler r (~ i) (~ j) s) + ; (k = i1) → push (inr (push (push tt r) i)) j + ; (r = i0) → ll-fill₂ (pt B) (~ i) (~ j) k s + ; (r = i1) → lr-fill₂ (pt C) (~ i) (~ j) k s }) + (hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 + ; (i = i1) → push (inr (push (push tt r) s)) (j ∨ ~ k) + ; (j = i0) → push (inr (push (push tt r) s)) (i ∧ ~ k) + ; (j = i1) → filler₈ (pt A) (~ i) k r s + ; (k = i0) → coh-filler₂ r (~ j) (~ i) s + ; (k = i1) → push (inr (push (push tt r) (i ∧ s))) j + ; (r = i0) → ll-fill₁ (pt B) (~ i) (~ j) k s + ; (r = i1) → lr-fill₁ (pt C) (~ i) (~ j) k s}) + (hcomp (λ s → λ {(i = i0) → filler₅ (~ j) k i1 + ; (i = i1) → push (inr (inl tt)) (j ∨ (s ∧ ~ k)) + ; (j = i0) → push (inr (inl tt)) (i ∧ s ∧ ~ k) + ; (j = i1) → push (inl (snd A)) (i ∨ k) + ; (k = i0) → filler₅ (~ j) i (~ s) + ; (k = i1) → push (inr (inl tt)) j + ; (r = i0) → btm-fill (~ i) (~ j) k s + ; (r = i1) → btm-fill (~ i) (~ j) k s}) + (filler₅ (~ j) (i ∨ k) i1))) + ⋀→⋀×2→⋀ (push (push a i) j) k = + hcomp (λ r → λ {(i = i0) → push (inl (pt A)) (k ∧ j ∨ ~ r) + ; (i = i1) → filler₅ (~ j) k r + ; (j = i0) → push (push tt i) (k ∧ ~ r) + ; (j = i1) → push (inl (snd A)) k + ; (k = i0) → inl tt + ; (k = i1) → push (push tt i) (j ∨ ~ r)}) + (push (push tt (~ j ∧ i)) k) + + -- The main result of step 1 + Iso-⋀-⋀×2 : Iso (A ⋀ (B ⋀∙ C)) ⋀×2 + Iso.fun Iso-⋀-⋀×2 = ⋀→⋀×2 + Iso.inv Iso-⋀-⋀×2 = ⋀×2→⋀ + Iso.rightInv Iso-⋀-⋀×2 = ⋀×2→⋀→⋀×2 + Iso.leftInv Iso-⋀-⋀×2 = ⋀→⋀×2→⋀ + +module _ {ℓ ℓ' ℓ'' : Level} (A : Pointed ℓ) (B : Pointed ℓ') (C : Pointed ℓ'') where + -- Step 2: show that ⋀×2 A B C ≃ ⋀×2 C A B + + -- some fillers + permute-fill→ : (i j k r : I) → ⋀×2 C A B + permute-fill→ i j k r = + hfill (λ r → λ {(i = i0) → gluem≡gluer (snd B) (~ j ∨ ~ r) k + ; (i = i1) → gluel≡gluem (pt C) j k + ; (j = i0) → gluel≡gluer (pt A) (~ i) k + ; (j = i1) → gluem≡gluer (snd B) (~ i ∧ ~ r) k + ; (k = i0) → proj (pt C) (pt A) (snd B) + ; (k = i1) → base}) + (inS (coh j (~ i) k)) + r + + permute-fill← : (i j k r : I) → ⋀×2 A B C + permute-fill← i j k r = + hfill (λ r → λ {(i = i0) → gluel≡gluem (snd A) (~ j) k + ; (i = i1) → gluel≡gluer (pt B) (~ j ∨ ~ r) k + ; (j = i0) → gluem≡gluer (pt C) i k + ; (j = i1) → gluel≡gluer (pt B) (i ∧ ~ r) k + ; (k = i0) → proj (snd A) (pt B) (pt C) + ; (k = i1) → base}) + (inS (coh (~ j) i k)) + r + + ⋀×2-permuteFun : ⋀×2 A B C → ⋀×2 C A B + ⋀×2-permuteFun base = base + ⋀×2-permuteFun (proj x x₁ x₂) = proj x₂ x x₁ + ⋀×2-permuteFun (gluel x y i) = gluer x y i + ⋀×2-permuteFun (gluem x z i) = gluel z x i + ⋀×2-permuteFun (gluer y z i) = gluem z y i + ⋀×2-permuteFun (gluel≡gluem a i j) = gluel≡gluer a (~ i) j + ⋀×2-permuteFun (gluel≡gluer y i j) = gluem≡gluer y (~ i) j + ⋀×2-permuteFun (gluem≡gluer z i j) = gluel≡gluem z i j + ⋀×2-permuteFun (coh i j k) = + hcomp (λ r → λ {(i = i0) → gluem≡gluer (snd B) (~ j ∨ ~ r) k + ; (i = i1) → gluel≡gluem (pt C) j k + ; (j = i0) → gluel≡gluer (pt A) (~ i) k + ; (j = i1) → gluem≡gluer (snd B) (~ i ∧ ~ r) k + ; (k = i0) → proj (pt C) (pt A) (snd B) + ; (k = i1) → base}) + (coh j (~ i) k) + + ⋀×2-permuteInv : ⋀×2 C A B → ⋀×2 A B C + ⋀×2-permuteInv base = base + ⋀×2-permuteInv (proj x x₁ x₂) = proj x₁ x₂ x + ⋀×2-permuteInv (gluel x y i) = gluem y x i + ⋀×2-permuteInv (gluem x z i) = gluer z x i + ⋀×2-permuteInv (gluer y z i) = gluel y z i + ⋀×2-permuteInv (gluel≡gluem a i j) = gluem≡gluer a i j + ⋀×2-permuteInv (gluel≡gluer y i j) = gluel≡gluem y (~ i) j + ⋀×2-permuteInv (gluem≡gluer z i j) = gluel≡gluer z (~ i) j + ⋀×2-permuteInv (coh i j k) = permute-fill← i j k i1 + + ⋀×2-permuteIso : Iso (⋀×2 A B C) (⋀×2 C A B) + Iso.fun ⋀×2-permuteIso = ⋀×2-permuteFun + Iso.inv ⋀×2-permuteIso = ⋀×2-permuteInv + Iso.rightInv ⋀×2-permuteIso base = refl + Iso.rightInv ⋀×2-permuteIso (proj x x₁ x₂) = refl + Iso.rightInv ⋀×2-permuteIso (gluel x y i) = refl + Iso.rightInv ⋀×2-permuteIso (gluem x z i) = refl + Iso.rightInv ⋀×2-permuteIso (gluer y z i) = refl + Iso.rightInv ⋀×2-permuteIso (gluel≡gluem a i i₁) = refl + Iso.rightInv ⋀×2-permuteIso (gluel≡gluer y x x₁) = refl + Iso.rightInv ⋀×2-permuteIso (gluem≡gluer z i i₁) = refl + Iso.rightInv ⋀×2-permuteIso (coh i j k) r = + hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd A) j k + ; (i = i1) → gluem≡gluer (snd B) (j ∧ (r ∨ l)) k + ; (j = i0) → gluel≡gluem (snd C) i k + ; (j = i1) → gluem≡gluer (snd B) (~ i ∨ (l ∨ r)) k + ; (k = i0) → proj (snd C) (snd A) (snd B) + ; (k = i1) → base + ; (r = i0) → ⋀×2-permuteFun (permute-fill← i j k l) + ; (r = i1) → coh i j k}) + (hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd A) j k + ; (i = i1) → gluem≡gluer (snd B) (j ∧ (~ l ∨ r)) k + ; (j = i0) → gluel≡gluem (snd C) i k + ; (j = i1) → gluem≡gluer (snd B) (~ i ∨ (~ l ∨ r)) k + ; (k = i0) → proj (snd C) (snd A) (snd B) + ; (k = i1) → base + ; (r = i0) → permute-fill→ (~ j) i k l + ; (r = i1) → coh i j k}) + (coh i j k)) + Iso.leftInv ⋀×2-permuteIso base = refl + Iso.leftInv ⋀×2-permuteIso (proj x x₁ x₂) = refl + Iso.leftInv ⋀×2-permuteIso (gluel x y i) = refl + Iso.leftInv ⋀×2-permuteIso (gluem x z i) = refl + Iso.leftInv ⋀×2-permuteIso (gluer y z i) = refl + Iso.leftInv ⋀×2-permuteIso (gluel≡gluem a i i₁) = refl + Iso.leftInv ⋀×2-permuteIso (gluel≡gluer y x x₁) = refl + Iso.leftInv ⋀×2-permuteIso (gluem≡gluer z i i₁) = refl + Iso.leftInv ⋀×2-permuteIso (coh i j k) r = + hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd B) (j ∧ (l ∨ r)) k + ; (i = i1) → gluem≡gluer (snd C) j k + ; (j = i0) → gluel≡gluem (snd A) i k + ; (j = i1) → gluel≡gluer (snd B) (i ∨ (l ∨ r)) k + ; (k = i0) → proj (pt A) (pt B) (pt C) + ; (k = i1) → base + ; (r = i0) → ⋀×2-permuteInv (permute-fill→ i j k l) + ; (r = i1) → coh i j k}) + (hcomp (λ l → λ { (i = i0) → gluel≡gluer (snd B) (j ∧ (~ l ∨ r)) k + ; (i = i1) → gluem≡gluer (snd C) j k + ; (j = i0) → gluel≡gluem (snd A) i k + ; (j = i1) → gluel≡gluer (snd B) (i ∨ (~ l ∨ r)) k + ; (k = i0) → proj (pt A) (pt B) (pt C) + ; (k = i1) → base + ; (r = i0) → permute-fill← j (~ i) k l + ; (r = i1) → coh i j k}) + (coh i j k)) + +-- Step 3: Combine the previous steps with commutativity of ⋀, and we are done +SmashAssocIso : Iso (A ⋀ (B ⋀∙ C)) ((A ⋀∙ B) ⋀ C) +SmashAssocIso {A = A} {B = B} {C = C} = + compIso + (Iso-⋀-⋀×2 A B C) + (compIso + (⋀×2-permuteIso A B C) + (compIso + (invIso (Iso-⋀-⋀×2 C A B)) + ⋀CommIso)) + +SmashAssocEquiv∙ : A ⋀∙ (B ⋀∙ C) ≃∙ (A ⋀∙ B) ⋀∙ C +fst SmashAssocEquiv∙ = isoToEquiv SmashAssocIso +snd SmashAssocEquiv∙ = refl + +module _ {C : Type ℓ} (f g : A ⋀ B → C) + (bp : f (inl tt) ≡ g (inl tt)) + (proj : (x : _) → f (inr x) ≡ g (inr x)) + (pl : (x : typ A) → PathP (λ i → f (push (inl x) i) ≡ g (push (inl x) i)) + bp (proj (x , pt B))) + (p-r : (x : typ B) → PathP (λ i → f (push (inr x) i) ≡ g (push (inr x) i)) + bp (proj (pt A , x))) + where + private + ⋆act : bp ≡ bp + ⋆act i j = + hcomp (λ k → λ { (i = i0) → pl (pt A) (~ k) j + ; (i = i1) → p-r (pt B) (~ k) j + ; (j = i0) → f (push (push tt i) (~ k)) + ; (j = i1) → g (push (push tt i) (~ k))}) + (proj (snd A , snd B) j) + + ⋀-fun≡ : (x : _) → f x ≡ g x + ⋀-fun≡ (inl x) = bp + ⋀-fun≡ (inr x) = proj x + ⋀-fun≡ (push (inl x) i) = pl x i + ⋀-fun≡ (push (inr x) i) j = + hcomp (λ r → λ {(i = i0) → bp j + ; (i = i1) → p-r x r j + ; (j = i0) → f (push (inr x) (r ∧ i)) + ; (j = i1) → g (push (inr x) (r ∧ i)) }) + (⋆act i j) + ⋀-fun≡ (push (push a i) j) k = + hcomp (λ r → λ { (i = i0) → pl (snd A) (j ∧ r) k + ; (j = i0) → bp k + ; (j = i1) → side i k r + ; (k = i0) → f (push (push a i) (j ∧ r)) + ; (k = i1) → g (push (push a i) (j ∧ r))}) + (⋆act (i ∧ j) k) + where + side : Cube (λ k r → pl (snd A) r k) + (λ k r → p-r (snd B) r k) + (λ i r → f (push (push a i) r)) + (λ i r → g (push (push a i) r)) + ⋆act λ i → proj (snd A , snd B) + side i k r = + hcomp (λ j → λ { (i = i0) → pl (pt A) (~ j ∨ r) k + ; (i = i1) → p-r (snd B) (~ j ∨ r) k + ; (k = i0) → f (push (push a i) (~ j ∨ r)) + ; (k = i1) → g (push (push a i) (~ j ∨ r)) + ; (r = i1) → proj (snd A , snd B) k}) + (proj (snd A , snd B) k) + +-- Techincal lemma allowing for use of ⋀→∙Homogeneous≡ on +-- when proving equalities of functions A ⋀ B → C +module ⋀-fun≡' {C : Type ℓ} (f g : A ⋀ B → C) + (pr : (x : _) → f (inr x) ≡ g (inr x)) where + + p : f (inl tt) ≡ g (inl tt) + p = cong f (push (inr (pt B))) + ∙∙ pr (pt A , pt B) + ∙∙ sym (cong g (push (inr (pt B)))) + + + p' : f (inl tt) ≡ g (inl tt) + p' = cong f (push (inl (pt A))) + ∙∙ pr (pt A , pt B) + ∙∙ sym (cong g (push (inl (pt A)))) + + p≡p' : p ≡ p' + p≡p' i = (cong f (push (push tt (~ i)))) + ∙∙ pr (pt A , pt B) + ∙∙ sym (cong g (push (push tt (~ i)))) + + Fₗ : B →∙ ((f (inl tt) ≡ g (inl tt)) , p) + fst Fₗ b = cong f (push (inr b)) ∙∙ pr (pt A , b) ∙∙ sym (cong g (push (inr b))) + snd Fₗ = refl + + Fᵣ : B →∙ ((f (inl tt) ≡ g (inl tt)) , p) + fst Fᵣ b = p + snd Fᵣ = refl + + module _ + (lp : (x : fst A) → PathP (λ i → f (push (inl x) i) ≡ g (push (inl x) i)) + p (pr (x , pt B))) + (q : Fₗ ≡ Fᵣ) where + private + lem : (b : fst B) + → Square p (pr (snd A , b)) + (cong f (push (inr b))) (cong g (push (inr b))) + lem b i j = + hcomp (λ k → λ {(i = i0) → p j + ; (i = i1) → doubleCompPath-filler + (cong f (push (inr b))) + (pr (pt A , b)) + (sym (cong g (push (inr b)))) (~ k) j + ; (j = i0) → f (push (inr b) (i ∧ k)) + ; (j = i1) → g (push (inr b) (i ∧ k))}) + (q (~ i) .fst b j) + + main : (x : _) → f x ≡ g x + main = ⋀-fun≡ {A = A} {B = B} f g p pr lp lem + +-- Suspension of a smash product is a join +module _ {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} where + private + sm-fillᵣ : ∀ {ℓ} {A : Type ℓ} {x* : A} (y* : A) (p* : x* ≡ y*) + (y : A) → (p : x* ≡ y) + → sym p* ≡ (sym p* ∙∙ p ∙∙ sym p) + sm-fillᵣ y* p* y p j i = + hcomp (λ r → λ {(i = i0) → p* r + ; (i = i1) → p (~ r ∧ j) + ; (j = i0) → p* (~ i ∧ r) + ; (j = i1) → doubleCompPath-filler + (sym p*) p (sym p) r i}) + (p (i ∧ j)) + + sm-fillₗ : ∀ {ℓ} {A : Type ℓ} {x* : A} (y* : A) (p* : x* ≡ y*) + (y : A) (p : x* ≡ y) + → p* ≡ (p ∙∙ sym p ∙∙ p*) + sm-fillₗ y* p* y p j i = + hcomp (λ r → λ {(i = i0) → p (~ r ∧ j) + ; (i = i1) → p* r + ; (j = i0) → p* (r ∧ i) + ; (j = i1) → doubleCompPath-filler + p (sym p) p* r i}) + (p (~ i ∧ j)) + + sm-fillₗᵣ≡ : ∀ {ℓ} {A : Type ℓ} {x* : A} (y* : A) (p* : x* ≡ y*) + → sm-fillₗ _ (sym p*) _ (sym p*) ≡ sm-fillᵣ _ p* _ p* + sm-fillₗᵣ≡ = J> refl + + SuspSmash→Join : Susp (A ⋀ B) → (join (typ A) (typ B)) + SuspSmash→Join north = inr (pt B) + SuspSmash→Join south = inl (pt A) + SuspSmash→Join (merid (inl x) i) = + push (pt A) (pt B) (~ i) + SuspSmash→Join (merid (inr (x , b)) i) = + (sym (push x (pt B)) ∙∙ push x b ∙∙ sym (push (pt A) b)) i + SuspSmash→Join (merid (push (inl x) j) i) = + sm-fillₗ {A = join (typ A) (typ B)} _ + (sym (push (pt A) (pt B))) _ (sym (push x (pt B))) j i + SuspSmash→Join (merid (push (inr x) j) i) = + sm-fillᵣ {A = join (typ A) (typ B)} _ + (push (pt A) (pt B)) _ (push (pt A) x) j i + SuspSmash→Join (merid (push (push a k) j) i) = + sm-fillₗᵣ≡ _ (push (pt A) (pt B)) k j i + + Join→SuspSmash : join (typ A) (typ B) → Susp (A ⋀ B) + Join→SuspSmash (inl x) = north + Join→SuspSmash (inr x) = south + Join→SuspSmash (push a b i) = merid (inr (a , b)) i + + Join→SuspSmash→Join : (x : join (typ A) (typ B)) + → SuspSmash→Join (Join→SuspSmash x) ≡ x + Join→SuspSmash→Join (inl x) = sym (push x (pt B)) + Join→SuspSmash→Join (inr x) = push (pt A) x + Join→SuspSmash→Join (push a b i) j = + doubleCompPath-filler + (sym (push a (pt B))) (push a b) (sym (push (pt A) b)) (~ j) i + + SuspSmash→Join→SuspSmash : (x : Susp (A ⋀ B)) + → Join→SuspSmash (SuspSmash→Join x) ≡ x + SuspSmash→Join→SuspSmash north = sym (merid (inr (pt A , pt B))) + SuspSmash→Join→SuspSmash south = merid (inr (pt A , pt B)) + SuspSmash→Join→SuspSmash (merid a i) j = + hcomp (λ r + → λ {(i = i0) → merid (inr (pt A , pt B)) (~ j ∨ ~ r) + ; (i = i1) → merid (inr (pt A , pt B)) (j ∧ r) + ; (j = i0) → Join→SuspSmash (SuspSmash→Join (merid a i)) + ; (j = i1) → doubleCompPath-filler + (sym (merid (inr (pt A , pt B)))) + (merid a) + (sym (merid (inr (pt A , pt B)))) (~ r) i}) + (f₁₂ j .fst a i) + where + f₁ f₂ : A ⋀∙ B →∙ (Path (Susp (A ⋀ B)) south north + , sym (merid (inr (snd A , snd B)))) + (fst f₁) a i = Join→SuspSmash (SuspSmash→Join (merid a i)) + snd f₁ = refl + (fst f₂) a = + sym (merid (inr (pt A , pt B))) + ∙∙ merid a + ∙∙ sym (merid (inr (pt A , pt B))) + snd f₂ = cong₂ (λ x y → sym x ∙∙ y ∙∙ sym x) + refl (cong merid (push (inl (pt A)))) + ∙ doubleCompPath≡compPath + (sym (merid (inr (pt A , pt B)))) _ _ + ∙ cong₂ _∙_ refl (rCancel (merid (inr (pt A , pt B)))) + ∙ sym (rUnit _) + + f₁₂ : f₁ ≡ f₂ + f₁₂ = ⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + λ x y → cong-∙∙ Join→SuspSmash + (sym (push x (pt B))) + (push x y) + (sym (push (pt A) y)) + ∙ (λ i → sym (merid ((sym (push (inl x)) + ∙ push (inl (pt A))) i)) + ∙∙ merid (inr (x , y)) + ∙∙ sym (merid ((sym (push (inr y)) + ∙ push (inl (pt A))) i))) + + SmashJoinIso : Iso (Susp (A ⋀ B)) (join (typ A) (typ B)) + Iso.fun SmashJoinIso = SuspSmash→Join + Iso.inv SmashJoinIso = Join→SuspSmash + Iso.rightInv SmashJoinIso = Join→SuspSmash→Join + Iso.leftInv SmashJoinIso = SuspSmash→Join→SuspSmash + +-- Suspension commutes with smash products +module _ {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} where + + -- some fillers + merid-fill : typ A → I → I → I → Susp (A ⋀ B) + merid-fill a i j k = + hfill (λ k → λ {(i = i0) → north + ; (i = i1) → merid (push (inl a) k) j + ; (j = i0) → north + ; (j = i1) → merid (inl tt) i}) + (inS (merid (inl tt) (i ∧ j))) k + + inl-fill₁ : typ A → I → I → I → (Susp∙ (typ A)) ⋀ B + inl-fill₁ a i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → inr (σ A a j , snd B) + ; (j = i0) → push (push tt k) i + ; (j = i1) → push (push tt k) i}) + (inS (push (inl (σ A a j)) i)) k + + inl-fill : typ A → I → I → I → (Susp∙ (typ A)) ⋀ B + inl-fill a i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → doubleCompPath-filler + (push (inr (snd B))) + (λ i₂ → inr (σ A a i₂ , snd B)) + (sym (push (inr (snd B)))) k j + ; (j = i0) → push (inr (snd B)) (~ k ∧ i) + ; (j = i1) → push (inr (snd B)) (~ k ∧ i)}) + (inS (inl-fill₁ a i j i1)) k + + inr-fill₁ : typ B → I → I → I → (Susp∙ (typ A)) ⋀ B + inr-fill₁ b i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → inr (rCancel (merid (pt A)) (~ k) j , b) + ; (j = i0) → push (inr b) i + ; (j = i1) → push (inr b) i}) + (inS (push (inr b) i)) k + + inr-fill : typ B → I → I → I → (Susp∙ (typ A)) ⋀ B + inr-fill b i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → doubleCompPath-filler + (push (inr b)) + (λ i₂ → inr (σ A (pt A) i₂ , b)) + (sym (push (inr b))) k j + ; (j = i0) → push (inr b) (~ k ∧ i) + ; (j = i1) → push (inr b) (~ k ∧ i)}) + (inS (inr-fill₁ b i j i1)) k + + SuspL→Susp⋀ : (Susp∙ (typ A)) ⋀ B → Susp (A ⋀ B) + SuspL→Susp⋀ (inl x) = north + SuspL→Susp⋀ (inr (north , y)) = north + SuspL→Susp⋀ (inr (south , y)) = south + SuspL→Susp⋀ (inr (merid a i , y)) = merid (inr (a , y)) i + SuspL→Susp⋀ (push (inl north) i) = north + SuspL→Susp⋀ (push (inl south) i) = merid (inl tt) i + SuspL→Susp⋀ (push (inl (merid a j)) i) = merid-fill a i j i1 + SuspL→Susp⋀ (push (inr x) i) = north + SuspL→Susp⋀ (push (push a i₁) i) = north + + Susp⋀→SuspL : Susp (A ⋀ B) → (Susp∙ (typ A)) ⋀ B + Susp⋀→SuspL north = inl tt + Susp⋀→SuspL south = inl tt + Susp⋀→SuspL (merid (inl x) i) = inl tt + Susp⋀→SuspL (merid (inr (x , y)) i) = + (push (inr y) ∙∙ (λ i → inr (σ A x i , y)) ∙∙ sym (push (inr y))) i + Susp⋀→SuspL (merid (push (inl x) i₁) i) = inl-fill x i₁ i i1 + Susp⋀→SuspL (merid (push (inr x) i₁) i) = inr-fill x i₁ i i1 + Susp⋀→SuspL (merid (push (push a k) j) i) = + hcomp (λ r → λ {(i = i0) → inl-fill (snd A) j i r + ; (i = i1) → inr-fill (snd B) j i r + ; (j = i0) → inl tt + ; (j = i1) → doubleCompPath-filler + (push (inr (pt B))) + (λ i₂ → inr (σ A (pt A) i₂ , (pt B))) + (sym (push (inr (pt B)))) r i + ; (k = i0) → inl-fill (snd A) j i r + ; (k = i1) → inr-fill (snd B) j i r}) + (hcomp (λ r → λ {(i = i0) → push (push tt (r ∨ k)) j + ; (i = i1) → push (push tt (r ∨ k)) j + ; (j = i0) → inl tt + ; (j = i1) → inr (rCancel (merid (pt A)) + (~ r ∧ k) i , pt B) + ; (k = i0) → inl-fill₁ (snd A) j i r + ; (k = i1) → inr-fill₁ (snd B) j i r}) + (hcomp (λ r → λ {(i = i0) → push (push tt k) j + ; (i = i1) → push (push tt k) j + ; (j = i0) → inl tt + ; (j = i1) → inr (rCancel (merid (pt A)) + (~ r ∨ k) i , pt B) + ; (k = i0) → push (inl (rCancel (merid (pt A)) + (~ r) i)) j + ; (k = i1) → push (inr (snd B)) j}) + (push (push tt k) j))) + + SuspSmashCommIso : Iso (Susp∙ (typ A) ⋀ B) (Susp (A ⋀ B)) + Iso.fun SuspSmashCommIso = SuspL→Susp⋀ + Iso.inv SuspSmashCommIso = Susp⋀→SuspL + Iso.rightInv SuspSmashCommIso north = refl + Iso.rightInv SuspSmashCommIso south = merid (inl tt) + Iso.rightInv SuspSmashCommIso (merid a i) j = + hcomp (λ r → λ {(i = i0) → north + ; (i = i1) → merid (inl tt) (j ∧ r) + ; (j = i0) → f₁≡f₂ (~ r) .fst a i + ; (j = i1) → compPath-filler + (merid a) (sym (merid (inl tt))) (~ r) i }) + (f₂ .fst a i) + where + f₁ f₂ : (A ⋀∙ B) →∙ Ω (Susp∙ (A ⋀ B)) + fst f₁ x = cong SuspL→Susp⋀ (cong Susp⋀→SuspL (merid x)) + snd f₁ = refl + fst f₂ = σ (A ⋀∙ B) + snd f₂ = rCancel (merid (inl tt)) + + inr' : (Susp (typ A)) × (typ B) → (Susp∙ (typ A)) ⋀ B + inr' = inr + + f₁≡f₂ : f₁ ≡ f₂ + f₁≡f₂ = + ⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + λ x y + → cong (cong SuspL→Susp⋀) (cong (push (inr y) ∙∙_∙∙ sym (push (inr y))) + (cong-∙ (λ x → inr' (x , y)) (merid x) (sym (merid (pt A))))) + ∙∙ cong-∙∙ SuspL→Susp⋀ (push (inr y)) + (cong (λ x → inr' (x , y)) (merid x) + ∙ cong (λ x → inr' (x , y)) (sym (merid (pt A)))) (sym (push (inr y))) + ∙∙ (sym (rUnit _) + ∙ cong-∙ SuspL→Susp⋀ + (λ i → inr' (merid x i , y)) (λ i → inr' (merid (pt A) (~ i) , y)) + ∙ cong (merid (inr (x , y)) ∙_) + λ j i → merid (push (inr y) (~ j)) (~ i) ) + Iso.leftInv SuspSmashCommIso = + ⋀-fun≡ _ _ refl + (λ x → main (snd x) (fst x)) + (λ { north i j → sₙ i j i1 + ; south i j → sₛ i j i1 + ; (merid a k) i j → cube a j k i}) + λ x i j → push (inr x) (i ∧ j) + where + inr' : Susp (typ A) × (typ B) → (Susp∙ (typ A)) ⋀ B + inr' = inr + sₙ : I → I → I → (Susp∙ (typ A)) ⋀ B + sₙ i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → push (inr (pt B)) (j ∨ ~ k) + ; (j = i0) → push (inr (pt B)) (i ∧ ~ k) + ; (j = i1) → push (inl north) i}) + (inS (push (push tt (~ j)) i)) + k + + sₛ : I → I → I → (Susp∙ (typ A)) ⋀ B + sₛ i j k = + hfill (λ k → λ {(i = i0) → inl tt + ; (i = i1) → compPath-filler + (push (inr (pt B))) + (λ i → inr (merid (pt A) i , pt B)) k j + ; (j = i0) → inl tt + ; (j = i1) → push (inl (merid (pt A) k)) i}) + (inS (sₙ i j i1)) + k + + filler : fst A → fst B → I → I → I → (Susp∙ (typ A)) ⋀ B + filler a y i j k = + hfill (λ k → λ {(i = i0) → push (inr y) j + ; (i = i1) → compPath-filler + (push (inr y)) + (λ i₁ → inr (merid (pt A) i₁ , y)) k j + ; (j = i0) → Susp⋀→SuspL (SuspL→Susp⋀ (inr (merid a i , y))) + ; (j = i1) → inr (compPath-filler + (merid a) + (sym (merid (pt A))) (~ k) i , y)}) + (inS (doubleCompPath-filler + (push (inr y)) + (λ i₁ → inr' (σ A a i₁ , y)) + (sym (push (inr y))) (~ j) i)) k + + cube₁ : (a : typ A) + → Cube (λ k i → Iso.inv SuspSmashCommIso (merid-fill a k i i1)) + (λ k i → inl-fill a k i i1) + (λ _ _ → inl tt) + refl + (λ _ _ → inl tt) + λ _ _ → inl tt + cube₁ a j k i = + hcomp (λ r → λ {(i = i0) → inl tt + ; (i = i1) → inl tt + ; (j = i0) → Iso.inv SuspSmashCommIso (merid-fill a k i r) + ; (j = i1) → inl-fill a k i i1 + ; (k = i0) → inl tt + ; (k = i1) → inl-fill a (j ∨ r) i i1}) + (inl-fill a (j ∧ k) i i1) + + cube : (a : typ A) + → Cube (λ k i → Iso.inv SuspSmashCommIso + (Iso.fun SuspSmashCommIso (push (inl (merid a k)) i))) + (λ k i → push (inl (merid a k)) i) + (λ j i → sₙ i j i1) (λ j i → sₛ i j i1) + (λ j k → inl tt) (λ j k → filler a (pt B) k j i1) + cube a = (λ j k i → cube₁ a j i k) ◁ + (λ j k i → + hcomp (λ r + → λ {(i = i0) → inl tt + ; (i = i1) → filler a (pt B) k j r + ; (j = i0) → inl-fill a i k i1 + ; (j = i1) → push (inl (compPath-filler + (merid a) (sym (merid (pt A))) (~ r) k)) i + ; (k = i0) → sₙ i j i1 + ; (k = i1) → sₛ i j r}) + (hcomp (λ r + → λ {(i = i0) → inl tt + ; (i = i1) → doubleCompPath-filler + (push (inr (pt B))) + (λ i₁ → inr' (σ A a i₁ , (pt B))) + (sym (push (inr (pt B)))) (~ j ∧ r) k + ; (j = i0) → inl-fill a i k r + ; (j = i1) → push (inl (σ A a k)) i + ; (k = i0) → sₙ i j r + ; (k = i1) → sₙ i j r}) + (hcomp (λ r + → λ {(i = i0) → inl tt + ; (i = i1) → inl-fill₁ a i k r + ; (j = i0) → inl-fill₁ a i k r + ; (j = i1) → push (inl (σ A a k)) i + ; (k = i0) → push (push tt (r ∧ (~ j))) i + ; (k = i1) → push (push tt (r ∧ (~ j))) i}) + (push (inl (σ A a k)) i)))) + + main : (y : typ B) (x : Susp (typ A)) + → Susp⋀→SuspL (SuspL→Susp⋀ (inr (x , y))) ≡ inr (x , y) + main y north = push (inr y) + main y south = push (inr y) ∙ λ i → inr (merid (pt A) i , y) + main y (merid a i) j = filler a y i j i1 \ No newline at end of file diff --git a/Cubical.HITs.SmashProduct.Hexagon.html b/Cubical.HITs.SmashProduct.Hexagon.html index 0542b8718..d5a7656fa 100644 --- a/Cubical.HITs.SmashProduct.Hexagon.html +++ b/Cubical.HITs.SmashProduct.Hexagon.html @@ -21,45 +21,45 @@ module _ {ℓ ℓ' ℓ'' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''} where - hex₁∙ : A ⋀∙ (B ⋀∙ C) →∙ (A ⋀∙ (C ⋀∙ B)) - hex₁∙ = idfun∙ A ⋀→∙ ⋀comm→∙ + hex₁∙ : A ⋀∙ (B ⋀∙ C) →∙ (A ⋀∙ (C ⋀∙ B)) + hex₁∙ = idfun∙ A ⋀→∙ ⋀comm→∙ hex₁ = fst hex₁∙ - hex₂∙ : A ⋀∙ (C ⋀∙ B) →∙ ((A ⋀∙ C) ⋀∙ B) - hex₂∙ = ≃∙map SmashAssocEquiv∙ + hex₂∙ : A ⋀∙ (C ⋀∙ B) →∙ ((A ⋀∙ C) ⋀∙ B) + hex₂∙ = ≃∙map SmashAssocEquiv∙ hex₂ = fst hex₂∙ - hex₃∙ : ((A ⋀∙ C) ⋀∙ B) →∙ ((C ⋀∙ A) ⋀∙ B) - hex₃∙ = ⋀comm→∙ ⋀→∙ idfun∙ B + hex₃∙ : ((A ⋀∙ C) ⋀∙ B) →∙ ((C ⋀∙ A) ⋀∙ B) + hex₃∙ = ⋀comm→∙ ⋀→∙ idfun∙ B hex₃ = fst hex₃∙ - hexₗ∙ : A ⋀∙ (B ⋀∙ C) →∙ ((C ⋀∙ A) ⋀∙ B) + hexₗ∙ : A ⋀∙ (B ⋀∙ C) →∙ ((C ⋀∙ A) ⋀∙ B) hexₗ∙ = hex₃∙ ∘∙ (hex₂∙ ∘∙ hex₁∙) hexₗ = fst hexₗ∙ - hex₄∙ : A ⋀∙ (B ⋀∙ C) →∙ (A ⋀∙ B) ⋀∙ C - hex₄∙ = ≃∙map SmashAssocEquiv∙ + hex₄∙ : A ⋀∙ (B ⋀∙ C) →∙ (A ⋀∙ B) ⋀∙ C + hex₄∙ = ≃∙map SmashAssocEquiv∙ hex₄ = fst hex₄∙ - hex₅∙ : (A ⋀∙ B) ⋀∙ C →∙ (C ⋀∙ (A ⋀∙ B)) - hex₅∙ = ⋀comm→∙ + hex₅∙ : (A ⋀∙ B) ⋀∙ C →∙ (C ⋀∙ (A ⋀∙ B)) + hex₅∙ = ⋀comm→∙ hex₅ = fst hex₅∙ - hex₆∙ : C ⋀∙ (A ⋀∙ B) →∙ ((C ⋀∙ A) ⋀∙ B) - hex₆∙ = ≃∙map SmashAssocEquiv∙ + hex₆∙ : C ⋀∙ (A ⋀∙ B) →∙ ((C ⋀∙ A) ⋀∙ B) + hex₆∙ = ≃∙map SmashAssocEquiv∙ hex₆ = fst hex₆∙ - hexᵣ∙ : A ⋀∙ (B ⋀∙ C) →∙ ((C ⋀∙ A) ⋀∙ B) + hexᵣ∙ : A ⋀∙ (B ⋀∙ C) →∙ ((C ⋀∙ A) ⋀∙ B) hexᵣ∙ = hex₆∙ ∘∙ (hex₅∙ ∘∙ hex₄∙) hexᵣ = fst hexᵣ∙ - hexagon-main : Σ[ h ∈ ((x : A ⋀ (B ⋀∙ C)) → hexₗ x ≡ hexᵣ x) ] + hexagon-main : Σ[ h ∈ ((x : A ⋀ (B ⋀∙ C)) → hexₗ x ≡ hexᵣ x) ] h (inl tt) ≡ refl - hexagon-main = ⋀-fun≡'.main _ _ + hexagon-main = ⋀-fun≡'.main _ _ (λ a → r-lem (fst a) (snd a) ) (λ a → p≡refl ◁ λ i j → hex₃ (hex₂ (rUnit (push (inl a)) (~ j) i))) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ b c → (λ i → push-lem₂ b c i ∙∙ refl ∙∙ sym (push-lem₂ b c i1)) ∙∙ ∙∙lCancel _ ∙∙ sym p≡refl) @@ -71,16 +71,16 @@ push-lem a = cong (cong (hex₃ ∘ hex₂)) (sym (rUnit (push (inl a)))) - r-lem : (a : fst A) (y : B ⋀ C) → hexₗ (inr (a , y)) ≡ hexᵣ (inr (a , y)) - r-lem a = ⋀-fun≡ _ _ refl (λ _ → refl) + r-lem : (a : fst A) (y : B ⋀ C) → hexₗ (inr (a , y)) ≡ hexᵣ (inr (a , y)) + r-lem a = ⋀-fun≡ _ _ refl (λ _ → refl) (λ b → flipSquare - (cong-∙∙ (hex₃ ∘ ⋀comm→) + (cong-∙∙ (hex₃ ∘ ⋀comm→) (push (inl b)) (λ i → inr (b , (push (inl a) i))) refl ∙∙ sym (compPath≡compPath' (push (inr b) ∙ refl) (λ i → inr (push (inr a) i , b))) ∙ (λ i → rUnit (push (inr b)) (~ i) ∙ λ j → inr (push (inr a) j , b)) ∙∙ sym - (cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inr a) i)) refl + (cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inr a) i)) refl ∙ sym (compPath≡compPath' (push (inr b)) (λ i → inr (push (inr a) i , b)))))) (λ c → flipSquare (sym (rUnit (push (inl (inr (c , a))))) @@ -90,7 +90,7 @@ → cong hex₄ (λ i → inr (a , push (inr c) i)) ≡ push (inr c) ∙∙ (λ i → inr (push (inl a) i , c)) ∙∙ refl lem₁ c = - cong-∙∙ ⋀comm→ (push (inl c)) (λ i → inr (c , push (inl a) i)) refl + cong-∙∙ ⋀comm→ (push (inl c)) (λ i → inr (c , push (inl a) i)) refl lemC : (c : fst C) → cong (hex₆ ∘ hex₅ ∘ hex₄) (λ i → inr (a , push (inr c) i)) @@ -107,7 +107,7 @@ cong (cong (hex₃ ∘ hex₂)) (sym (rUnit (push (inr (inr (c , b)))))) ∙∙ cong (cong hex₃) - (cong-∙∙ ⋀comm→ + (cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inr c) i)) refl @@ -120,13 +120,13 @@ ∙∙ cong-∙ (hex₆ ∘ hex₅) (push (inr c)) (λ i → inr (push (inr b) i , c)) ∙∙ (sym (lUnit _) - ∙ cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inl c) i)) refl + ∙ cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inl c) i)) refl ∙ sym (compPath≡compPath' _ _ ))) where speedup-lem : cong hex₄ (push (inr (inr (b , c)))) ≡ push (inr c) ∙ λ i → inr (push (inr b) i , c) speedup-lem = - cong-∙∙ ⋀comm→ (push (inl c)) + cong-∙∙ ⋀comm→ (push (inl c)) (λ i → inr (c , push (inr b) i)) refl ∙ sym (compPath≡compPath' _ _) @@ -135,9 +135,9 @@ ≡ _ speedup = cong (cong (hex₆ ∘ hex₅)) speedup-lem - module M = ⋀-fun≡' hexₗ hexᵣ (λ a → r-lem (fst a) (snd a)) + module M = ⋀-fun≡' hexₗ hexᵣ (λ a → r-lem (fst a) (snd a)) - p≡refl : M.p ≡ refl + p≡refl : M.p ≡ refl p≡refl = sym (compPath≡compPath' (cong (hexₗ) (push (inr (inl tt)))) refl) diff --git a/Cubical.HITs.SmashProduct.Induction.html b/Cubical.HITs.SmashProduct.Induction.html index 0fe2bf929..e45b96c8f 100644 --- a/Cubical.HITs.SmashProduct.Induction.html +++ b/Cubical.HITs.SmashProduct.Induction.html @@ -72,25 +72,25 @@ -- we need the following coherence const≡prod→⋀^∘FS→Prod : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) (a : FS n ((λ r → fst r) ∘ A)) - → ⋀^ n A .snd ≡ prod→⋀^ n A (FS→Prod n A a) + → ⋀^ n A .snd ≡ prod→⋀^ n A (FS→Prod n A a) const≡prod→⋀^∘FS→Prod zero A a = refl const≡prod→⋀^∘FS→Prod (suc n) A (inl x) = push (inr (snd x)) ∙ λ i → inr (const≡prod→⋀^∘FS→Prod n (predFinFamily∙ A) (fst x) i , snd x) const≡prod→⋀^∘FS→Prod (suc n) A (inr x) = - push (inl (prod→⋀^ n (predFinFamily∙ A) x)) + push (inl (prod→⋀^ n (predFinFamily∙ A) x)) -- natural map ⋀̂ A → ⋀ A ⋀̃→⋀ : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) - → ⋀̃ n A → ⋀^ n A .fst -⋀̃→⋀ n A (inl x) = ⋀^ n A .snd -⋀̃→⋀ n A (inr x) = prod→⋀^ n A x + → ⋀̃ n A → ⋀^ n A .fst +⋀̃→⋀ n A (inl x) = ⋀^ n A .snd +⋀̃→⋀ n A (inr x) = prod→⋀^ n A x ⋀̃→⋀ n A (push a i) = const≡prod→⋀^∘FS→Prod n A a i -- pointed version ⋀̃→⋀∙ : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) - → ⋀̃∙ n A →∙ ⋀^ n A + → ⋀̃∙ n A →∙ ⋀^ n A fst (⋀̃→⋀∙ n A) = ⋀̃→⋀ n A snd (⋀̃→⋀∙ n A) = refl @@ -109,22 +109,22 @@ -- Finally, the induction principle ⋀̃→⋀-ind... ⋀̃→⋀-ind : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) {B : Type ℓ'} - {f g : ⋀^ n A .fst → B} + {f g : ⋀^ n A .fst → B} (ind : (x : ⋀̃ n A) → f (⋀̃→⋀ n A x) ≡ g (⋀̃→⋀ n A x)) → f ≡ g -- ...together with some computation rules (needed to strengthen the -- inductive hypothesis in the proof), but should be useful in their -- own right. ⋀̃→⋀-ind-coh : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) {B : Type ℓ'} - {f g : ⋀^ n A .fst → B} + {f g : ⋀^ n A .fst → B} (ind : (x : ⋀̃ n A) → f (⋀̃→⋀ n A x) ≡ g (⋀̃→⋀ n A x)) - → (funExt⁻ (⋀̃→⋀-ind n A {f = f} {g = g} ind) (⋀^ n A .snd) ≡ ind (inl tt)) + → (funExt⁻ (⋀̃→⋀-ind n A {f = f} {g = g} ind) (⋀^ n A .snd) ≡ ind (inl tt)) × ((x : prodFinFamily∙ n A .fst) → funExt⁻ (⋀̃→⋀-ind n A {f = f} {g = g} ind) (⋀̃→⋀ n A (inr x)) ≡ ind (inr x)) ⋀̃→⋀-ind zero A ind = funExt (ind ∘ inr) ⋀̃→⋀-ind (suc n) A {B = B} {f = f} {g} ind = - funExt (⋀-fun≡ f g (ind (inl tt)) + funExt (⋀-fun≡ f g (ind (inl tt)) (λ x → h (snd x) (fst x)) (λ x → transport (sym (PathP≡doubleCompPathʳ _ _ _ _)) (funExt⁻ mainSquareAsCompPath-const x)) @@ -134,7 +134,7 @@ (cong g (push (inr x)))) ▷ sym (h-coh x .fst)) where - f↓ g↓ : (y : typ (A flast)) → ⋀^ n (predFinFamily∙ A) .fst → B + f↓ g↓ : (y : typ (A flast)) → ⋀^ n (predFinFamily∙ A) .fst → B f↓ y = f ∘ inr ∘ (_, y) g↓ y = g ∘ inr ∘ (_, y) @@ -154,28 +154,28 @@ -- coherence mainSquare : (x : prodFinFamily n (fst ∘ (predFinFamily∙ A))) - → PathP (λ i → f (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) i) - ≡ g (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) i)) + → PathP (λ i → f (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) i) + ≡ g (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) i)) (ind (inl tt)) - (h (A flast .snd) (prod→⋀^ n (predFinFamily∙ A) x)) + (h (A flast .snd) (prod→⋀^ n (predFinFamily∙ A) x)) mainSquare x i j = hcomp (λ k → λ {(i = i0) → ind (push (inr x) (~ k)) j ; (i = i1) → ⋀̃→⋀-ind-coh n (predFinFamily∙ A) {f = f↓ (A flast .snd)} {g↓ (A flast .snd)} (f↓≡g↓ (A flast .snd)) .snd x (~ k) j - ; (j = i0) → f (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) (i ∨ ~ k)) - ; (j = i1) → g (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) (i ∨ ~ k))}) + ; (j = i0) → f (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) (i ∨ ~ k)) + ; (j = i1) → g (push (inl (prod→⋀^ n (predFinFamily∙ A) x)) (i ∨ ~ k))}) (rUnit (ind (inr (x , A flast .snd))) i j) - mainSquareAsCompPath : ⋀^ n (predFinFamily∙ A) .fst → f (inl tt) ≡ g (inl tt) + mainSquareAsCompPath : ⋀^ n (predFinFamily∙ A) .fst → f (inl tt) ≡ g (inl tt) mainSquareAsCompPath x = cong f (push (inl x)) ∙∙ h (snd (A flast)) x ∙∙ cong g (sym (push (inl x))) mainSquareAsCompPath-const : (λ _ → ind (inl tt)) ≡ mainSquareAsCompPath - mainSquareAsCompPath-const = ⋀^→Homogeneous≡ n _ (isHomogeneousPath _ _) + mainSquareAsCompPath-const = ⋀^→Homogeneous≡ n _ (isHomogeneousPath _ _) λ x → transport (PathP≡doubleCompPathʳ _ _ _ _) (mainSquare x) fst (⋀̃→⋀-ind-coh zero A ind) = cong ind (sym (push tt*)) fst (⋀̃→⋀-ind-coh (suc n) A ind) = refl @@ -186,7 +186,7 @@ -- Pointed version ⋀̃→⋀-ind∙ : (n : ℕ) (A : FinFamily∙ (suc n) ℓ) {B : Pointed ℓ'} - {f g : ⋀^ n A →∙ B} + {f g : ⋀^ n A →∙ B} → f ∘∙ ⋀̃→⋀∙ n A ≡ (g ∘∙ ⋀̃→⋀∙ n A) → f ≡ g -- ...together with some computation rules (needed to strengthen the diff --git a/Cubical.HITs.SmashProduct.Pentagon.html b/Cubical.HITs.SmashProduct.Pentagon.html index 802e02247..78ce5f956 100644 --- a/Cubical.HITs.SmashProduct.Pentagon.html +++ b/Cubical.HITs.SmashProduct.Pentagon.html @@ -21,47 +21,47 @@ module _ {ℓ ℓ' ℓ'' ℓ''' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''} {D : Pointed ℓ'''} where - assc₁∙ : (A ⋀∙ (B ⋀∙ (C ⋀∙ D))) →∙ ((A ⋀∙ B) ⋀∙ (C ⋀∙ D)) - assc₁∙ = ≃∙map SmashAssocEquiv∙ + assc₁∙ : (A ⋀∙ (B ⋀∙ (C ⋀∙ D))) →∙ ((A ⋀∙ B) ⋀∙ (C ⋀∙ D)) + assc₁∙ = ≃∙map SmashAssocEquiv∙ assc₁ = fst assc₁∙ - assc₂∙ : ((A ⋀∙ B) ⋀∙ (C ⋀∙ D)) →∙ (((A ⋀∙ B) ⋀∙ C) ⋀∙ D) - assc₂∙ = ≃∙map SmashAssocEquiv∙ + assc₂∙ : ((A ⋀∙ B) ⋀∙ (C ⋀∙ D)) →∙ (((A ⋀∙ B) ⋀∙ C) ⋀∙ D) + assc₂∙ = ≃∙map SmashAssocEquiv∙ assc₂ = fst assc₂∙ asscᵣ = assc₂ ∘ assc₁ asscᵣ∙ = assc₂∙ ∘∙ assc₁∙ - assc₃∙ : A ⋀∙ (B ⋀∙ (C ⋀∙ D)) →∙ A ⋀∙ ((B ⋀∙ C) ⋀∙ D) - assc₃∙ = (idfun∙ A) ⋀→∙ (≃∙map SmashAssocEquiv∙) + assc₃∙ : A ⋀∙ (B ⋀∙ (C ⋀∙ D)) →∙ A ⋀∙ ((B ⋀∙ C) ⋀∙ D) + assc₃∙ = (idfun∙ A) ⋀→∙ (≃∙map SmashAssocEquiv∙) assc₃ = fst assc₃∙ - assc₄∙ : A ⋀∙ ((B ⋀∙ C) ⋀∙ D) →∙ (A ⋀∙ (B ⋀∙ C)) ⋀∙ D - assc₄∙ = ≃∙map SmashAssocEquiv∙ + assc₄∙ : A ⋀∙ ((B ⋀∙ C) ⋀∙ D) →∙ (A ⋀∙ (B ⋀∙ C)) ⋀∙ D + assc₄∙ = ≃∙map SmashAssocEquiv∙ assc₄ = fst assc₄∙ - assc₅∙ : (A ⋀∙ (B ⋀∙ C)) ⋀∙ D →∙ ((A ⋀∙ B) ⋀∙ C) ⋀∙ D - assc₅∙ = ≃∙map SmashAssocEquiv∙ ⋀→∙ idfun∙ D + assc₅∙ : (A ⋀∙ (B ⋀∙ C)) ⋀∙ D →∙ ((A ⋀∙ B) ⋀∙ C) ⋀∙ D + assc₅∙ = ≃∙map SmashAssocEquiv∙ ⋀→∙ idfun∙ D assc₅ = fst assc₅∙ asscₗ = assc₅ ∘ assc₄ ∘ assc₃ asscₗ∙ = assc₅∙ ∘∙ (assc₄∙ ∘∙ assc₃∙) -- pointed version - pentagon∙main : Σ[ f ∈ ((x : A ⋀ (B ⋀∙ (C ⋀∙ D))) → asscₗ x ≡ asscᵣ x) ] + pentagon∙main : Σ[ f ∈ ((x : A ⋀ (B ⋀∙ (C ⋀∙ D))) → asscₗ x ≡ asscᵣ x) ] f (inl tt) ≡ refl pentagon∙main = - (⋀-fun≡'.main {A = A} {B = (B ⋀∙ (C ⋀∙ D))} _ _ + (⋀-fun≡'.main {A = A} {B = (B ⋀∙ (C ⋀∙ D))} _ _ (λ x → main₁ (fst x) (snd x)) (λ x → p≡refl ◁ ((λ i j → assc₅ (assc₄ (rUnit (push (inl x)) (~ j) i))) ▷ sym (main₁≡refl x))) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ x y → funExt⁻ (cong fst (to→∙ₗ≡to→∙ᵣ x)) y ∙ sym p≡refl) , p≡refl) where module lemmas₁ (x : typ A) (y : typ B) where - module N = ⋀-fun≡' (λ z → asscₗ (inr (x , inr (y , z)))) + module N = ⋀-fun≡' (λ z → asscₗ (inr (x , inr (y , z)))) (λ z → asscᵣ (inr (x , inr (y , z)))) (λ _ → refl) open N @@ -81,11 +81,11 @@ lem₁ : cong assc₃ (λ i → (inr (x , inr (y , push (inr d) i)))) ≡ (λ j → inr (x , push (inr d) j)) ∙ λ j → inr (x , inr ((push (inl y) j) , d)) - lem₁ = (λ k i → inr (x , Iso.fun ⋀CommIso + lem₁ = (λ k i → inr (x , Iso.fun ⋀CommIso (compPath≡compPath' (push (inl d)) (λ i → inr (d , push (inl y) i)) (~ k) i))) - ∙ (λ k i → inr (x , cong-∙ (Iso.fun ⋀CommIso) + ∙ (λ k i → inr (x , cong-∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inl y) i)) k i)) ∙ cong-∙ (λ y → inr (x , y)) @@ -100,10 +100,10 @@ lem₂ = cong-∙ assc₄ (λ j → inr (x , push (inr d) j)) (λ j → inr (x , inr ((push (inl y) j) , d))) ∙ cong (_∙ (λ i → inr (inr (x , push (inl y) i) , d))) - ((cong (cong (Iso.fun ⋀CommIso)) + ((cong (cong (Iso.fun ⋀CommIso)) (sym (compPath≡compPath' (push (inl d)) (λ i → inr (d , push (inl x) i)))) - ∙ cong-∙ (Iso.fun ⋀CommIso) + ∙ cong-∙ (Iso.fun ⋀CommIso) (push (inl d)) λ i → inr (d , push (inl x) i)) ∙ λ _ → push (inr d) ∙ λ i → inr ((push (inl x) i) , d)) @@ -128,24 +128,24 @@ ≡ ((λ i → push (inr d) i) ∙ (λ i → inr (push (inl (inr (x , y))) i , d))) lem₄ = (λ _ i → assc₂ (inr (inr (x , y) , push (inr d) i))) - ∙ (cong (cong (Iso.fun (⋀CommIso))) - (cong (cong (Iso.inv (Iso-⋀-⋀×2 D (A ⋀∙ B) C))) - (refl {x = sym (gluel d (inr (x , y))) })) - ∙ cong-∙∙ (Iso.fun (⋀CommIso)) + ∙ (cong (cong (Iso.fun (⋀CommIso))) + (cong (cong (Iso.inv (Iso-⋀-⋀×2 D (A ⋀∙ B) C))) + (refl {x = sym (gluel d (inr (x , y))) })) + ∙ cong-∙∙ (Iso.fun (⋀CommIso)) (push (inl d)) (λ i → inr (d , push (inl (inr (x , y))) i)) refl) ∙ sym (compPath≡compPath' _ _) - p≡refl : p ≡ refl - p≡refl = p≡p' + p≡refl : p ≡ refl + p≡refl = p≡p' ∙ (λ j → assc-r-r-p-l (pt C) j ∙∙ refl ∙∙ sym (assc-r-r-p-l (pt C) i1)) ∙ ∙∙lCancel _ - main₂ : (x : typ A) (y : typ B) (c : (C ⋀ D)) + main₂ : (x : typ A) (y : typ B) (c : (C ⋀ D)) → asscₗ (inr (x , inr (y , c))) ≡ asscᵣ (inr (x , inr (y , c))) - main₂ x y = ⋀-fun≡'.main {A = C} {B = D} _ _ + main₂ x y = ⋀-fun≡'.main {A = C} {B = D} _ _ (λ _ → refl) (λ c → lemmas₁.p≡refl x y ◁ flipSquare (lemmas₁.assc-r-r-p-l x y c)) (→∙Homogeneous≡ (isHomogeneousPath _ _) @@ -157,11 +157,11 @@ ∙ sym (lemmas₁.p≡refl x y))) module lemmas₂ (x : typ A) where - module K = ⋀-fun≡' (λ z → asscₗ (inr (x , z))) + module K = ⋀-fun≡' (λ z → asscₗ (inr (x , z))) (λ z → asscᵣ (inr (x , z))) (λ y₁ → main₂ x (fst y₁) (snd y₁)) open K - main₂∙ : (y : _) → main₂ x y (pt (C ⋀∙ D)) ≡ refl + main₂∙ : (y : _) → main₂ x y (pt (C ⋀∙ D)) ≡ refl main₂∙ y = (λ i → lemmas₁.assc-r-r-p-r x y (pt D) i ∙∙ refl ∙∙ sym (lemmas₁.assc-r-r-p-r x y (pt D) i1)) @@ -179,7 +179,7 @@ lem₄ : cong assc₁ (λ i → inr (x , push (inr (inr (c , d))) i)) ≡ push (inr (inr (c , d))) ∙ (λ i → inr (push (inl x) i , inr (c , d))) - lem₄ = cong-∙∙ (Iso.fun ⋀CommIso) + lem₄ = cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inr (c , d)))) (λ i → inr (inr (c , d) , push (inl x) i)) refl @@ -195,7 +195,7 @@ (push (inr (inr (c , d)))) (λ i → inr (push (inl x) i , inr (c , d))) ∙∙ cong₂ _∙_ - (cong-∙∙ (Iso.fun ⋀CommIso) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inr c) i)) refl ∙ sym (compPath≡compPath' (push (inr d)) @@ -211,7 +211,7 @@ ≡ (λ i → inr (x , (push (inr d) i))) ∙ (λ i → inr (x , inr (push (inr c) i , d))) lem₁ = (λ k i → inr (x - , (cong-∙∙ (Iso.fun ⋀CommIso) + , (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inr c) i)) refl ∙ sym (compPath≡compPath' (push (inr d)) @@ -228,7 +228,7 @@ (λ i → inr (x , (push (inr d) i))) (λ i → inr (x , inr (push (inr c) i , d))) ∙ cong₂ _∙_ - (cong-∙∙ (Iso.fun ⋀CommIso) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inl x) i)) refl @@ -250,7 +250,7 @@ ∙ cong₂ _∙_ (sym (rUnit (push (inr d)))) refl ∙ sym (rUnit (push (inr d)))) (λ k i → inr - ((cong-∙∙ (Iso.fun ⋀CommIso) + ((cong-∙∙ (Iso.fun ⋀CommIso) (push (inl c)) (λ i → inr (c , push (inl x) i)) refl @@ -262,7 +262,7 @@ ≡ cong asscᵣ (λ i → inr (x , push (inr (inl tt)) i)) assc-r-p-r-l = sym (cong (cong assc₂) - (cong-∙∙ (Iso.fun ⋀CommIso) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inl tt))) (λ i → inr (inl tt , push (inl x) i)) refl @@ -272,19 +272,19 @@ (λ i → inr ((push (inl x) i) , (inl tt))) ∙∙ sym (rUnit refl)) - p≡refl : p ≡ refl + p≡refl : p ≡ refl p≡refl = (λ i → assc-r-p-r-l i ∙∙ main₂∙ (pt B) i ∙∙ sym (assc-r-p-r-l i1)) ∙ ∙∙lCancel _ - main₁ : (x : typ A) (y : B ⋀ (C ⋀∙ D)) + main₁ : (x : typ A) (y : B ⋀ (C ⋀∙ D)) → asscₗ (inr (x , y)) ≡ asscᵣ (inr (x , y)) - main₁ x = ⋀-fun≡'.main {A = B} {B = (C ⋀∙ D)} _ _ + main₁ x = ⋀-fun≡'.main {A = B} {B = (C ⋀∙ D)} _ _ (λ y → main₂ x (fst y) (snd y)) (λ y → (lemmas₂.p≡refl x ∙ sym (lemmas₂.main₂∙ x y))) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ c d → ((λ i → lemmas₂.assc-r-p-r-r x c d i ∙∙ refl ∙∙ sym (lemmas₂.assc-r-p-r-r x c d i1)) @@ -304,7 +304,7 @@ assc-p-r-r-l x = cong (cong (assc₅ ∘ assc₄)) (sym (rUnit (push (inr (inl tt))))) ∙ sym (cong (cong assc₂) - (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inl tt))) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inl tt))) (λ i → inr (inl tt , push (inr x) i)) refl ∙ sym (compPath≡compPath' (push (inr (inl tt))) @@ -314,8 +314,8 @@ ∙ sym (rUnit refl)) to→∙ₗ : (x : fst B) - → (C ⋀∙ D) - →∙ (Path (((A ⋀∙ B) ⋀∙ C) ⋀ D) (inl tt) (inl tt) , refl) + → (C ⋀∙ D) + →∙ (Path (((A ⋀∙ B) ⋀∙ C) ⋀ D) (inl tt) (inl tt) , refl) fst (to→∙ₗ x) y = ((λ i → asscₗ (push (inr (inr (x , y))) i)) ∙∙ main₁ (pt A) (inr (x , y)) ∙∙ (λ i → asscᵣ (push (inr (inr (x , y))) (~ i)))) @@ -326,12 +326,12 @@ ∙ ∙∙lCancel _ to→∙ᵣ : (x : fst B) - → (C ⋀∙ D) - →∙ (Path (((A ⋀∙ B) ⋀∙ C) ⋀ D) (inl tt) (inl tt) , refl) + → (C ⋀∙ D) + →∙ (Path (((A ⋀∙ B) ⋀∙ C) ⋀ D) (inl tt) (inl tt) , refl) fst (to→∙ᵣ x) y = refl snd (to→∙ᵣ x) = refl - module L = ⋀-fun≡' asscₗ asscᵣ (λ x₁ → main₁ (fst x₁) (snd x₁)) + module L = ⋀-fun≡' asscₗ asscᵣ (λ x₁ → main₁ (fst x₁) (snd x₁)) open L main₁≡refl : (x : _) → main₁ x (inl tt) ≡ refl main₁≡refl x = (λ i → lemmas₂.assc-r-p-r-l x i @@ -343,7 +343,7 @@ ≡ cong asscᵣ (push (inr (inl tt))) assc-p-r-l i = cong (assc₅ ∘ assc₄) (rUnit (push (inr (inl tt))) (~ i)) - p≡refl : p ≡ refl + p≡refl : p ≡ refl p≡refl = (λ i → assc-p-r-l i ∙∙ main₁≡refl (pt A) i ∙∙ sym (assc-p-r-l i1)) ∙ ∙∙lCancel _ @@ -359,20 +359,20 @@ cong (cong (assc₅ ∘ assc₄)) (sym (rUnit (push (inr (inr (inr (x , c) , d)))))) ∙∙ cong (cong assc₅) - (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inr (inr (x , c))) i)) refl ∙ sym (compPath≡compPath' (push (inr d)) λ i → inr (push (inr (inr (x , c))) i , d))) ∙ (cong-∙ assc₅ (push (inr d)) λ i → inr (push (inr (inr (x , c))) i , d)) ∙∙ (cong₂ _∙_ (sym (rUnit (push (inr d)))) - (λ k i → inr ((cong-∙∙ (Iso.fun ⋀CommIso) (push (inl c)) + (λ k i → inr ((cong-∙∙ (Iso.fun ⋀CommIso) (push (inl c)) (λ i → inr (c , push (inr x) i)) refl ∙ sym (compPath≡compPath' (push (inr c)) λ i → inr (push (inr x) i , c))) k i , d)) ∙ sym (cong (cong assc₂) - (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inr (c , d)))) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl (inr (c , d)))) (λ i → inr (inr (c , d) , push (inr x) i)) refl ∙ sym (compPath≡compPath' @@ -381,7 +381,7 @@ ∙∙ cong-∙ assc₂ (push (inr (inr (c , d)))) (λ i → inr (push (inr x) i , inr (c , d))) ∙∙ (cong₂ _∙_ - (cong-∙∙ (Iso.fun ⋀CommIso) + (cong-∙∙ (Iso.fun ⋀CommIso) (push (inl d)) (λ i → inr (d , push (inr c) i)) refl ∙ sym (compPath≡compPath' (push (inr d)) λ i → inr (push (inr c) i , d))) @@ -392,14 +392,14 @@ λ i → inr (push (inr x) i , c)))))) to→∙ₗ≡to→∙ᵣ : (x : fst B) → to→∙ₗ x ≡ to→∙ᵣ x - to→∙ₗ≡to→∙ᵣ x = ⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + to→∙ₗ≡to→∙ᵣ x = ⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ c d → (λ i → assc-p-r-r-r x c d i ∙∙ refl ∙∙ sym (assc-p-r-r-r x c d i1)) ∙ ∙∙lCancel _ -- plain penetagon - pentagon : (x : A ⋀ (B ⋀∙ (C ⋀∙ D))) → asscₗ x ≡ asscᵣ x + pentagon : (x : A ⋀ (B ⋀∙ (C ⋀∙ D))) → asscₗ x ≡ asscᵣ x pentagon x = fst pentagon∙main x -- pointed pentagon diff --git a/Cubical.HITs.SmashProduct.SymmetricMonoidal.html b/Cubical.HITs.SmashProduct.SymmetricMonoidal.html index aa015a109..e75a60c98 100644 --- a/Cubical.HITs.SmashProduct.SymmetricMonoidal.html +++ b/Cubical.HITs.SmashProduct.SymmetricMonoidal.html @@ -26,10 +26,10 @@ A B : Pointed ℓ ⋀→∙-idfun : {A : Pointed ℓ} {B : Pointed ℓ'} - → (_⋀→∙_ (idfun∙ A) (idfun∙ B)) ≡ idfun∙ (A ⋀∙ B) + → (_⋀→∙_ (idfun∙ A) (idfun∙ B)) ≡ idfun∙ (A ⋀∙ B) ⋀→∙-idfun = ΣPathP (funExt - (⋀-fun≡ _ _ refl (λ _ → refl) + (⋀-fun≡ _ _ refl (λ _ → refl) (λ x → flipSquare (sym (rUnit (push (inl x))))) λ x → flipSquare (sym (rUnit (push (inr x))))) , refl) @@ -37,10 +37,10 @@ ⋀→∙-comp : {A A' A'' B B' B'' : Pointed ℓ} (f : A →∙ A') (f' : A' →∙ A'') (g : B →∙ B') (g' : B' →∙ B'') - → ((f' ∘∙ f) ⋀→∙ (g' ∘∙ g)) ≡ ((f' ⋀→∙ g') ∘∙ (f ⋀→∙ g)) + → ((f' ∘∙ f) ⋀→∙ (g' ∘∙ g)) ≡ ((f' ⋀→∙ g') ∘∙ (f ⋀→∙ g)) ⋀→∙-comp f f' g g' = ΣPathP ((funExt - (⋀-fun≡ _ _ refl (λ _ → refl) + (⋀-fun≡ _ _ refl (λ _ → refl) (λ x → flipSquare (cong (push (inl (fst f' (fst f x))) ∙_) ((λ i j → cong-∙ (λ y → inr (fst f' (fst f x) , y)) @@ -52,7 +52,7 @@ ∙∙ (λ j → (push (inl (fst f' (fst f x))) ∙ (λ j → inr (fst f' (fst f x) , snd g' (~ j)))) ∙ λ j → inr (fst f' (f .fst x) , fst g' (snd g (~ j)))) - ∙∙ sym (cong-∙ (f' ⋀→ g') (push (inl (fst f x))) + ∙∙ sym (cong-∙ (f' ⋀→ g') (push (inl (fst f x))) λ i → inr (fst f x , g .snd (~ i))))) λ x → flipSquare (cong (push (inr (fst g' (fst g x))) ∙_) @@ -65,23 +65,23 @@ ∙∙ (λ j → (push (inr (fst g' (fst g x))) ∙ (λ j → inr (snd f' (~ j) , fst g' (fst g x)))) ∙ λ j → inr (fst f' (snd f (~ j)) , fst g' (g .fst x))) - ∙∙ sym (cong-∙ (f' ⋀→ g') (push (inr (fst g x))) + ∙∙ sym (cong-∙ (f' ⋀→ g') (push (inr (fst g x))) λ i → inr ((snd f (~ i)) , fst g x))))) , (rUnit refl)) ⋀assoc-⋀→∙ : {A A' B B' C C' : Pointed ℓ} (f : A →∙ A') (g : B →∙ B') (h : C →∙ C') → - ≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)) - ≡ ((f ⋀→∙ g) ⋀→∙ h) ∘∙ ≃∙map SmashAssocEquiv∙ + ≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)) + ≡ ((f ⋀→∙ g) ⋀→∙ h) ∘∙ ≃∙map SmashAssocEquiv∙ ⋀assoc-⋀→∙ {A = A} {A' = A'} {B = B} {B' = B'} {C = C} {C' = C'} f g h = ΣPathP - ((funExt (⋀-fun≡'.main _ _ + ((funExt (⋀-fun≡'.main _ _ (λ x → mainᵣ (fst x) (snd x)) (λ x → p≡refl ◁ flipSquare - (cong (cong (SmashAssocIso .Iso.fun)) + (cong (cong (SmashAssocIso .Iso.fun)) (sym (rUnit (push (inl (fst f x)))))) ▷ λ _ → refl) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ y z → (λ i → push-lem y z (~ i) ∙∙ refl ∙∙ sym (push-lem y z i0)) @@ -89,24 +89,24 @@ ∙ sym p≡refl))) , λ i j → pt-lem-main i j) where - mainᵣ : (x : fst A) (y : B ⋀ C) - → SmashAssocIso .Iso.fun (inr (fst f x , (g ⋀→ h) y)) - ≡ ((f ⋀→∙ g) ⋀→ h) (SmashAssocIso .Iso.fun (inr (x , y))) + mainᵣ : (x : fst A) (y : B ⋀ C) + → SmashAssocIso .Iso.fun (inr (fst f x , (g ⋀→ h) y)) + ≡ ((f ⋀→∙ g) ⋀→ h) (SmashAssocIso .Iso.fun (inr (x , y))) mainᵣ x = - ⋀-fun≡ _ _ refl (λ _ → refl) + ⋀-fun≡ _ _ refl (λ _ → refl) (λ b → flipSquare - (cong-∙ (λ z → SmashAssocIso .Iso.fun (inr (fst f x , z))) + (cong-∙ (λ z → SmashAssocIso .Iso.fun (inr (fst f x , z))) (push (inl (fst g b))) (λ i₁ → inr (fst g b , snd h (~ i₁))))) λ b → flipSquare - (cong-∙ (λ z → SmashAssocIso .Iso.fun (inr (fst f x , z))) + (cong-∙ (λ z → SmashAssocIso .Iso.fun (inr (fst f x , z))) (push (inr (fst h b))) (λ i₁ → inr (snd g (~ i₁) , fst h b)) - ∙∙ cong₂ _∙_ ((λ j i → ⋀CommIso .Iso.fun + ∙∙ cong₂ _∙_ ((λ j i → ⋀CommIso .Iso.fun (compPath≡compPath' (push (inl (fst h b))) (λ i → inr (fst h b , push (inl (fst f x)) i)) (~ j) i)) - ∙ cong-∙ (⋀CommIso .Iso.fun) + ∙ cong-∙ (⋀CommIso .Iso.fun) (push (inl (fst h b))) λ i → inr (fst h b , push (inl (fst f x)) i)) refl @@ -116,76 +116,76 @@ (λ i₁ → inr (fst f x , snd g (~ i₁))))) ∙∙ sym (lem b)) where - lem : (b : _) → cong ((f ⋀→∙ g) ⋀→ h) - (cong (SmashAssocIso .Iso.fun) λ i → inr (x , push (inr b) i)) + lem : (b : _) → cong ((f ⋀→∙ g) ⋀→ h) + (cong (SmashAssocIso .Iso.fun) λ i → inr (x , push (inr b) i)) ≡ (push (inr (fst h b))) ∙ λ i → inr (((push (inl (fst f x)) ∙ λ i₁ → inr (fst f x , snd g (~ i₁))) i) , (fst h b)) - lem b = (λ j i → ((f ⋀→∙ g) ⋀→ h) - (⋀CommIso .Iso.fun + lem b = (λ j i → ((f ⋀→∙ g) ⋀→ h) + (⋀CommIso .Iso.fun (compPath≡compPath' (push (inl b)) (λ i → inr (b , push (inl x) i)) (~ j) i))) - ∙∙ cong-∙ (((f ⋀→∙ g) ⋀→ h) ∘ ⋀CommIso .Iso.fun) + ∙∙ cong-∙ (((f ⋀→∙ g) ⋀→ h) ∘ ⋀CommIso .Iso.fun) (push (inl b)) (λ i → inr (b , push (inl x) i)) ∙∙ cong₂ _∙_ (sym (rUnit _)) refl push-lem : (y : _) (z : _) - → cong (((f ⋀→∙ g) ⋀→ h) ∘ (fst (fst SmashAssocEquiv∙))) + → cong (((f ⋀→∙ g) ⋀→ h) ∘ (fst (fst SmashAssocEquiv∙))) (push (inr (inr (y , z)))) - ≡ cong (fst (≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)))) + ≡ cong (fst (≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)))) (push (inr (inr (y , z)))) push-lem y z = - cong (cong ((f ⋀→∙ g) ⋀→ h)) - (cong-∙∙ ⋀comm→ (push (inl z)) + cong (cong ((f ⋀→∙ g) ⋀→ h)) + (cong-∙∙ ⋀comm→ (push (inl z)) (λ i → inr (z , push (inr y) i)) refl ∙ sym (compPath≡compPath' (push (inr z)) _)) - ∙∙ cong-∙ ((f ⋀→∙ g) ⋀→ h) + ∙∙ cong-∙ ((f ⋀→∙ g) ⋀→ h) (push (inr z)) (λ i → inr (push (inr y) i , z)) ∙∙ (cong₂ _∙_ (sym (rUnit (push (inr (fst h z))))) (cong-∙ (λ x → inr (x , fst h z)) (push (inr (fst g y))) (λ i → inr (snd f (~ i) , fst g y))) - ∙ sym (cong-∙ (SmashAssocIso .Iso.fun) + ∙ sym (cong-∙ (SmashAssocIso .Iso.fun) (push (inr (inr (fst g y , fst h z)))) (λ i → inr (snd f (~ i) , inr (fst g y , fst h z))) ∙∙ cong (_∙ (λ i → inr (inr (snd f (~ i) , fst g y) , fst h z))) - (cong-∙∙ ⋀comm→ + (cong-∙∙ ⋀comm→ (push (inl (fst h z))) (λ i → inr (fst h z , push (inr (fst g y)) i)) refl ∙ sym (compPath≡compPath' (push (inr (fst h z))) _)) ∙∙ sym (assoc _ _ _))) - module N = ⋀-fun≡' - (λ z → SmashAssocIso .Iso.fun ((f ⋀→ (g ⋀→∙ h)) z)) - (λ z → ((f ⋀→∙ g) ⋀→ h) (SmashAssocIso .Iso.fun z)) + module N = ⋀-fun≡' + (λ z → SmashAssocIso .Iso.fun ((f ⋀→ (g ⋀→∙ h)) z)) + (λ z → ((f ⋀→∙ g) ⋀→ h) (SmashAssocIso .Iso.fun z)) (λ x₁ → mainᵣ (fst x₁) (snd x₁)) - p≡refl : N.p ≡ refl - p≡refl = (λ j → cong (SmashAssocIso .Iso.fun - ∘ ((f ⋀→ (g ⋀→∙ h)))) + p≡refl : N.p ≡ refl + p≡refl = (λ j → cong (SmashAssocIso .Iso.fun + ∘ ((f ⋀→ (g ⋀→∙ h)))) (push (inr (inl tt))) ∙∙ refl - ∙∙ cong (((f ⋀→∙ g) ⋀→ h) - ∘ (SmashAssocIso .Iso.fun)) + ∙∙ cong (((f ⋀→∙ g) ⋀→ h) + ∘ (SmashAssocIso .Iso.fun)) (sym (push (push tt j)))) ∙ cong (λ x → x ∙∙ refl ∙∙ refl) - (cong-∙ (SmashAssocIso .Iso.fun) + (cong-∙ (SmashAssocIso .Iso.fun) (push (inr (inl tt))) (λ i → inr (snd f (~ i) , inl tt)) ∙ sym (rUnit refl)) ∙ sym (rUnit refl) - pt-lem : cong (fst (≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)))) + pt-lem : cong (fst (≃∙map SmashAssocEquiv∙ ∘∙ (f ⋀→∙ (g ⋀→∙ h)))) (push (inr (inl tt))) - ≡ cong (fst (((f ⋀→∙ g) ⋀→∙ h) ∘∙ ≃∙map SmashAssocEquiv∙)) + ≡ cong (fst (((f ⋀→∙ g) ⋀→∙ h) ∘∙ ≃∙map SmashAssocEquiv∙)) (push (inr (inl tt))) pt-lem i j = - fst (≃∙map SmashAssocEquiv∙) (rUnit (push (inr (inl tt))) (~ i) j) + fst (≃∙map SmashAssocEquiv∙) (rUnit (push (inr (inl tt))) (~ i) j) pt-lem-main : I → I → _ pt-lem-main i j = @@ -197,31 +197,31 @@ ⋀comm-sq : {A A' B B' : Pointed ℓ} (f : A →∙ A') (g : B →∙ B') - → (⋀comm→∙ ∘∙ (f ⋀→∙ g)) ≡ ((g ⋀→∙ f) ∘∙ ⋀comm→∙) + → (⋀comm→∙ ∘∙ (f ⋀→∙ g)) ≡ ((g ⋀→∙ f) ∘∙ ⋀comm→∙) ⋀comm-sq f g = ΣPathP ((funExt - (⋀-fun≡ _ _ refl (λ _ → refl) + (⋀-fun≡ _ _ refl (λ _ → refl) (λ x → flipSquare - (cong-∙ ⋀comm→ + (cong-∙ ⋀comm→ (push (inl (fst f x))) (λ i → inr (fst f x , snd g (~ i))))) - λ b → flipSquare (cong-∙ ⋀comm→ + λ b → flipSquare (cong-∙ ⋀comm→ (push (inr (fst g b))) (λ i → inr (snd f (~ i) , fst g b))))) , refl) ⋀comm-sq' : {A A' B B' : Pointed ℓ} (f : A →∙ A') (g : B →∙ B') - → (f ⋀→∙ g) ≡ (⋀comm→∙ ∘∙ ((g ⋀→∙ f) ∘∙ ⋀comm→∙)) + → (f ⋀→∙ g) ≡ (⋀comm→∙ ∘∙ ((g ⋀→∙ f) ∘∙ ⋀comm→∙)) ⋀comm-sq' f g = - sym (∘∙-idʳ (f ⋀→∙ g)) - ∙∙ cong (_∘∙ (f ⋀→∙ g)) (sym lem) - ∙∙ ∘∙-assoc ⋀comm→∙ ⋀comm→∙ (f ⋀→∙ g) - ∙ cong (λ w → ⋀comm→∙ ∘∙ w) (⋀comm-sq f g) + sym (∘∙-idʳ (f ⋀→∙ g)) + ∙∙ cong (_∘∙ (f ⋀→∙ g)) (sym lem) + ∙∙ ∘∙-assoc ⋀comm→∙ ⋀comm→∙ (f ⋀→∙ g) + ∙ cong (λ w → ⋀comm→∙ ∘∙ w) (⋀comm-sq f g) where - lem : ⋀comm→∙ ∘∙ ⋀comm→∙ ≡ idfun∙ _ - lem = ΣPathP ((funExt (Iso.rightInv ⋀CommIso)) , (sym (rUnit refl))) + lem : ⋀comm→∙ ∘∙ ⋀comm→∙ ≡ idfun∙ _ + lem = ΣPathP ((funExt (Iso.rightInv ⋀CommIso)) , (sym (rUnit refl))) -Bool⋀→ : Bool*∙ {ℓ} ⋀ A → typ A +Bool⋀→ : Bool*∙ {ℓ} ⋀ A → typ A Bool⋀→ {A = A} (inl x) = pt A Bool⋀→ (inr (lift false , a)) = a Bool⋀→ {A = A} (inr (lift true , a)) = pt A @@ -230,13 +230,13 @@ Bool⋀→ {A = A} (push (inr x) i) = pt A Bool⋀→ {A = A} (push (push a i₁) i) = pt A -⋀lIdIso : Iso (Bool*∙ {ℓ} ⋀ A) (typ A) +⋀lIdIso : Iso (Bool*∙ {ℓ} ⋀ A) (typ A) Iso.fun (⋀lIdIso {A = A}) (inl x) = pt A Iso.fun ⋀lIdIso = Bool⋀→ Iso.inv ⋀lIdIso a = inr (false* , a) Iso.rightInv ⋀lIdIso a = refl Iso.leftInv (⋀lIdIso {A = A}) = - ⋀-fun≡ _ _ (sym (push (inl false*))) h hₗ + ⋀-fun≡ _ _ (sym (push (inl false*))) h hₗ λ x → compPath-filler (sym (push (inl false*))) (push (inr x)) where h : (x : (Lift Bool) × fst A) → @@ -254,16 +254,16 @@ ▷ (cong (sym (push (inl false*)) ∙_) λ j i → push (push tt j) i) -⋀lIdEquiv∙ : Bool*∙ {ℓ} ⋀∙ A ≃∙ A +⋀lIdEquiv∙ : Bool*∙ {ℓ} ⋀∙ A ≃∙ A fst ⋀lIdEquiv∙ = isoToEquiv ⋀lIdIso snd ⋀lIdEquiv∙ = refl ⋀lId-sq : (f : A →∙ B) → - (≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ (idfun∙ Bool*∙ ⋀→∙ f)) + (≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ (idfun∙ Bool*∙ ⋀→∙ f)) ≡ (f ∘∙ ≃∙map ⋀lIdEquiv∙) ⋀lId-sq {ℓ} {A = A} {B = B} f = ΣPathP ((funExt - (⋀-fun≡ _ _ (sym (snd f)) (λ x → h (fst x) (snd x)) hₗ hᵣ)) + (⋀-fun≡ _ _ (sym (snd f)) (λ x → h (fst x) (snd x)) hₗ hᵣ)) , (sym (rUnit refl) ◁ (λ i j → snd f (~ i ∨ j)) ▷ lUnit (snd f))) where @@ -273,7 +273,7 @@ h (lift true) a = sym (snd f) hₗ : (x : Lift Bool) - → PathP (λ i → Bool⋀→ ((idfun∙ Bool*∙ ⋀→ f) (push (inl x) i)) + → PathP (λ i → Bool⋀→ ((idfun∙ Bool*∙ ⋀→ f) (push (inl x) i)) ≡ fst f (Bool⋀→ (push (inl x) i))) (sym (snd f)) (h x (pt A)) hₗ (lift false) = @@ -290,7 +290,7 @@ ◁ λ i _ → snd f (~ i)) hᵣ : (x : fst A) - → PathP (λ i → Bool⋀→ {ℓ} ((idfun∙ Bool*∙ ⋀→ f) (push (inr x) i)) + → PathP (λ i → Bool⋀→ {ℓ} ((idfun∙ Bool*∙ ⋀→ f) (push (inr x) i)) ≡ fst f (snd A)) (sym (snd f)) (h true* x) hᵣ x = flipSquare ((cong-∙ (Bool⋀→ {ℓ}) @@ -299,15 +299,15 @@ ∙ sym (rUnit refl)) ◁ λ i _ → snd f (~ i)) -⋀lId-assoc : ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→∙ idfun∙ B) - ∘∙ ≃∙map SmashAssocEquiv∙) +⋀lId-assoc : ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→∙ idfun∙ B) + ∘∙ ≃∙map SmashAssocEquiv∙) ≡ ≃∙map ⋀lIdEquiv∙ ⋀lId-assoc {ℓ} {A = A} {B = B} = ΣPathP (funExt - (⋀-fun≡'.main _ _ + (⋀-fun≡'.main _ _ (λ xy → mainᵣ (fst xy) (snd xy)) (λ x → sym (rUnit refl) ◁ mainᵣ-pt-coh x) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) mainᵣ-coh)) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) mainᵣ-coh)) , (sym (rUnit refl) ◁ flipSquare (sym (rUnit refl)))) where @@ -324,7 +324,7 @@ l₁≡l₂-left : (x : Lift Bool) (y : fst A) → PathP (λ i → l₁ x i ≡ l₂ x (y , pt B) i) (push (inl (Bool⋀→ (inr (x , y))))) - λ i → Bool⋀→ {ℓ} {A = A ⋀∙ B} (inr (x , push (inl y) i)) + λ i → Bool⋀→ {ℓ} {A = A ⋀∙ B} (inr (x , push (inl y) i)) l₁≡l₂-left (lift true) y = (λ i → push (push tt i)) ◁ λ i j → push (inr (pt B)) (~ i ∧ j) l₁≡l₂-left (lift false) y = refl @@ -332,25 +332,25 @@ l₁≡l₂-right : (x : Lift Bool) (y : fst B) → PathP (λ i → l₁ x i ≡ l₂ x ((pt A) , y) i) (push (inr y) ∙ (λ i → inr (Bool⋀→ {A = A} (push (inl x) i) , y))) - (λ i → Bool⋀→ {A = A ⋀∙ B} (inr (x , push (inr y) i))) + (λ i → Bool⋀→ {A = A ⋀∙ B} (inr (x , push (inr y) i))) l₁≡l₂-right (lift false) y = sym (rUnit (push (inr y))) l₁≡l₂-right (lift true) y = sym (rUnit (push (inr y))) ◁ λ i j → push (inr y) (j ∧ ~ i) - mainᵣ : (x : Lift Bool) (y : A ⋀ B) - → (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) - (SmashAssocIso .Iso.fun (inr (x , y))) + mainᵣ : (x : Lift Bool) (y : A ⋀ B) + → (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) + (SmashAssocIso .Iso.fun (inr (x , y))) ≡ Bool⋀→ {ℓ} (inr (x , y)) - mainᵣ x = ⋀-fun≡ _ _ (l₁ x) (l₂ x) + mainᵣ x = ⋀-fun≡ _ _ (l₁ x) (l₂ x) (λ y → flipSquare (sym (rUnit (push (inl (Bool⋀→ (inr (x , y)))))) ◁ l₁≡l₂-left x y)) λ y → flipSquare ( - (cong (cong (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B)) - (cong-∙∙ ⋀comm→ + (cong (cong (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B)) + (cong-∙∙ ⋀comm→ (push (inl y)) (λ i → inr (y , push (inl x) i)) refl ∙ sym (compPath≡compPath' (push (inr y)) (λ i → inr (push (inl x) i , y)))) - ∙ cong-∙ (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) + ∙ cong-∙ (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) (push (inr y)) λ i → inr (push (inl x) i , y)) ◁ (cong₂ _∙_ (sym (rUnit (push (inr y)))) refl @@ -362,31 +362,31 @@ mainᵣ-pt-coh (lift false) = refl mainᵣ-pt-coh (lift true) = refl - module N = ⋀-fun≡' - (λ z → (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) (SmashAssocIso .Iso.fun z)) + module N = ⋀-fun≡' + (λ z → (≃∙map ⋀lIdEquiv∙ ⋀→ idfun∙ B) (SmashAssocIso .Iso.fun z)) (λ z → ⋀lIdIso .Iso.fun z) (λ xy → mainᵣ (fst xy) (snd xy)) open N lem : (x : fst A) (y : fst B) - → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B) - ∘ SmashAssocIso .Iso.fun) + → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B) + ∘ SmashAssocIso .Iso.fun) (push (inr (inr (x , y)))) ≡ push (inr y) lem x y = - cong (cong (≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B)) - (cong-∙∙ ⋀comm→ + cong (cong (≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B)) + (cong-∙∙ ⋀comm→ (push (inl y)) (λ i → inr (y , push (inr x) i)) refl ∙ sym (compPath≡compPath' (push (inr y)) λ i → inr (push (inr x) i , y))) - ∙∙ cong-∙ (≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B) + ∙∙ cong-∙ (≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ⋀→ idfun∙ B) (push (inr y)) (λ i → inr (push (inr x) i , y)) ∙∙ (sym (rUnit _) ∙ sym (rUnit _)) mainᵣ-coh : (x : fst A) (y : fst B) - → Fₗ .fst (inr (x , y)) ≡ Fᵣ .fst (inr (x , y)) + → Fₗ .fst (inr (x , y)) ≡ Fᵣ .fst (inr (x , y)) mainᵣ-coh x y = (λ i → lem x y i ∙∙ sym (lem x y i1) ∙∙ refl) ∙ sym (compPath≡compPath' @@ -396,30 +396,30 @@ -- Triangle equality ⋀triang : ∀ {ℓ} {A B : Pointed ℓ} - → (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→∙ idfun∙ B) - ∘∙ ≃∙map SmashAssocEquiv∙) - ≡ idfun∙ A ⋀→∙ ≃∙map (⋀lIdEquiv∙ {ℓ} {A = B}) + → (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→∙ idfun∙ B) + ∘∙ ≃∙map SmashAssocEquiv∙) + ≡ idfun∙ A ⋀→∙ ≃∙map (⋀lIdEquiv∙ {ℓ} {A = B}) ⋀triang {ℓ = ℓ} {A = A} {B = B} = - ΣPathP ((funExt (⋀-fun≡'.main _ _ + ΣPathP ((funExt (⋀-fun≡'.main _ _ (λ x → mainᵣ (fst x) (snd x)) (λ x → p≡refl ◁ flipSquare ((λ i j → push (inl x) (i ∧ j)) ▷ rUnit (push (inl x)))) - (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) + (⋀→∙Homogeneous≡ (isHomogeneousPath _ _) λ x y → Fₗ≡refl x y ∙ sym (Fᵣ≡refl x y)))) , (sym (rUnit refl) ◁ flipSquare p≡refl)) where mainᵣ-hom : (x : fst A) (y : Bool* {ℓ}) (z : fst B) - → Path (A ⋀ B) (inr (Bool⋀→ (inr (y , x)) , z)) + → Path (A ⋀ B) (inr (Bool⋀→ (inr (y , x)) , z)) (inr (x , Bool⋀→ (inr (y , z)))) mainᵣ-hom x (lift false) z = refl mainᵣ-hom x (lift true) z = sym (push (inr z)) ∙ push (inl x) - mainᵣ : (x : fst A) (y : Bool*∙ {ℓ} ⋀ B) → - ((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ (idfun∙ B)) - (Iso.fun (SmashAssocIso {A = A} {B = Bool*∙ {ℓ}} {C = B}) (inr (x , y))) + mainᵣ : (x : fst A) (y : Bool*∙ {ℓ} ⋀ B) → + ((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ (idfun∙ B)) + (Iso.fun (SmashAssocIso {A = A} {B = Bool*∙ {ℓ}} {C = B}) (inr (x , y))) ≡ inr (x , ⋀lIdIso .Iso.fun y) - mainᵣ x = ⋀-fun≡ _ _ (push (inl x)) + mainᵣ x = ⋀-fun≡ _ _ (push (inl x)) (λ y → mainᵣ-hom x (fst y) (snd y)) (λ { (lift false) → flipSquare (sym (rUnit (push (inl x))) ◁ λ i j → push (inl x) (j ∨ i)) @@ -428,68 +428,68 @@ ◁ λ i j → compPath-filler' (sym (push (inr (pt B)))) (push (inl x)) j i)}) λ b → flipSquare - ((cong (cong (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B))) - (cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inl x) i)) refl + ((cong (cong (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B))) + (cong-∙∙ ⋀comm→ (push (inl b)) (λ i → inr (b , push (inl x) i)) refl ∙ sym (compPath≡compPath' (push (inr b)) (λ i → inr (push (inl x) i , b)))) - ∙ cong-∙ (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) + ∙ cong-∙ (((≃∙map (⋀lIdEquiv∙ {ℓ}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) (push (inr b)) (λ i → inr (push (inl x) i , b)) ∙ sym (rUnit _) ∙ (λ i → (push (inr b) ∙ (λ j → inr (rUnit (λ _ → pt A) (~ i) j , b)))) ∙ sym (rUnit (push (inr b)))) ◁ λ i j → compPath-filler' (sym (push (inr b))) (push (inl x)) j i) - lemₗ : cong (idfun∙ A ⋀→ ≃∙map (⋀lIdEquiv∙ {ℓ} {A = B})) + lemₗ : cong (idfun∙ A ⋀→ ≃∙map (⋀lIdEquiv∙ {ℓ} {A = B})) (push (inr (inl tt))) ≡ (push (inl (snd A))) lemₗ = sym (rUnit _) ∙ λ i → push (push tt (~ i)) - module K = ⋀-fun≡' (λ z → - ((≃∙map ⋀lIdEquiv∙ ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) - (SmashAssocIso .Iso.fun z)) - (λ z → (idfun∙ A ⋀→ ≃∙map ⋀lIdEquiv∙) z) + module K = ⋀-fun≡' (λ z → + ((≃∙map ⋀lIdEquiv∙ ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) + (SmashAssocIso .Iso.fun z)) + (λ z → (idfun∙ A ⋀→ ≃∙map ⋀lIdEquiv∙) z) (λ x₁ → mainᵣ (fst x₁) (snd x₁)) open K - p≡refl : p ≡ refl + p≡refl : p ≡ refl p≡refl = cong (push (inl (snd A)) ∙_) (cong sym lemₗ) ∙ rCancel (push (inl (pt A))) Fₗ-false : (y : fst B) - → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) - (cong ⋀comm→ (push (inl y) + → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) + (cong ⋀comm→ (push (inl y) ∙' (λ i → inr (y , push (inr (lift false)) i)))) ≡ push (inr y) Fₗ-false y = - cong (cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) - (cong (cong ⋀comm→) + cong (cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) + (cong (cong ⋀comm→) (sym (compPath≡compPath' (push (inl y)) (λ i → inr (y , push (inr (lift false)) i)))) - ∙ cong-∙ ⋀comm→ (push (inl y)) + ∙ cong-∙ ⋀comm→ (push (inl y)) (λ i → inr (y , push (inr (lift false)) i))) - ∙∙ cong-∙ ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) + ∙∙ cong-∙ ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) (push (inr y)) (λ i → inr (push (inr (lift false)) i , y)) ∙∙ (sym (rUnit _) ∙ (λ i → push (inr y) ∙ (λ j → inr (rUnit (λ _ → pt A) (~ i) j , y))) ∙ sym (rUnit _)) Fₗ-true : (y : fst B) - → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) - (cong (SmashAssocIso .Iso.fun) (push (inr (inr (lift true , y))))) + → cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) + (cong (SmashAssocIso .Iso.fun) (push (inr (inr (lift true , y))))) ≡ push (inr y) Fₗ-true y = - cong (cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) - (cong-∙∙ ⋀comm→ (push (inl y)) (λ i → inr (y , push (inr true*) i)) refl + cong (cong ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B)) + (cong-∙∙ ⋀comm→ (push (inl y)) (λ i → inr (y , push (inr true*) i)) refl ∙ sym (compPath≡compPath' (push (inr y)) λ i → inr (push (inr true*) i , y))) - ∙∙ cong-∙ ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) + ∙∙ cong-∙ ((≃∙map (⋀lIdEquiv∙ {ℓ} {A = A}) ∘∙ ⋀comm→∙) ⋀→ idfun∙ B) (push (inr y)) (λ i → inr (push (inr true*) i , y)) ∙∙ ((sym (rUnit _) ∙ (λ i → push (inr y) ∙ (λ j → inr (rUnit (λ _ → pt A) (~ i) j , y))) ∙ sym (rUnit _))) - Fₗ≡refl : (x : Lift Bool) (y : fst B) → Fₗ .fst (inr (x , y)) ≡ refl + Fₗ≡refl : (x : Lift Bool) (y : fst B) → Fₗ .fst (inr (x , y)) ≡ refl Fₗ≡refl (lift false) y = (λ i → Fₗ-false y i ∙∙ refl ∙∙ sym (rUnit (push (inr y)) (~ i))) ∙ ∙∙lCancel _ @@ -504,7 +504,7 @@ ∙ cong (_∙ sym (push (inr (pt B)))) (sym (lUnit (push (inr (pt B))))) ∙ rCancel _ - Fᵣ≡refl : (x : Lift Bool) (y : fst B) → Fᵣ .fst (inr (x , y)) ≡ refl + Fᵣ≡refl : (x : Lift Bool) (y : fst B) → Fᵣ .fst (inr (x , y)) ≡ refl Fᵣ≡refl x y = cong (push (inl (snd A)) ∙_) (sym (rUnit _) ∙ (λ i j → push (push tt (~ i)) (~ j))) diff --git a/Cubical.HITs.SmashProduct.SymmetricMonoidalCat.html b/Cubical.HITs.SmashProduct.SymmetricMonoidalCat.html index fe95d7f54..dc435b5e3 100644 --- a/Cubical.HITs.SmashProduct.SymmetricMonoidalCat.html +++ b/Cubical.HITs.SmashProduct.SymmetricMonoidalCat.html @@ -45,8 +45,8 @@ -- ⋀ as a functor ⋀F : ∀ {ℓ} → WildFunctor (PointedCat ℓ × PointedCat ℓ) (PointedCat ℓ) -F-ob ⋀F (A , B) = A ⋀∙ B -F-hom ⋀F (f , g) = f ⋀→∙ g +F-ob ⋀F (A , B) = A ⋀∙ B +F-hom ⋀F (f , g) = f ⋀→∙ g F-id ⋀F = ⋀→∙-idfun F-seq ⋀F (f , g) (f' , g') = ⋀→∙-comp f f' g g' @@ -68,31 +68,31 @@ restrₗᵣ : WildNatIso (PointedCat ℓ) (PointedCat ℓ) (restrFunctorᵣ ⋀F Bool*∙) (restrFunctorₗ ⋀F Bool*∙) -N-ob (trans restrₗᵣ) X = ⋀comm→∙ +N-ob (trans restrₗᵣ) X = ⋀comm→∙ N-hom (trans restrₗᵣ) f = ⋀comm-sq f (idfun∙ Bool*∙) -isIs restrₗᵣ c = makeIsIso-Pointed (isoToIsEquiv ⋀CommIso) +isIs restrₗᵣ c = makeIsIso-Pointed (isoToIsEquiv ⋀CommIso) -- main result ⋀Symm : ∀ {ℓ} → isSymmetricWildCat (PointedCat ℓ) _⊗_ (isMonoidal ⋀Symm) = ⋀F 𝟙 (isMonoidal ⋀Symm) = Bool*∙ -N-ob (trans (⊗assoc (isMonoidal ⋀Symm))) (A , B , C) = ≃∙map SmashAssocEquiv∙ +N-ob (trans (⊗assoc (isMonoidal ⋀Symm))) (A , B , C) = ≃∙map SmashAssocEquiv∙ N-hom (trans (⊗assoc (isMonoidal ⋀Symm))) (f , g , h) = ⋀assoc-⋀→∙ f g h inv' (isIs (⊗assoc (isMonoidal ⋀Symm)) (A , B , C)) = - ≃∙map (invEquiv∙ SmashAssocEquiv∙) + ≃∙map (invEquiv∙ SmashAssocEquiv∙) sect (isIs (⊗assoc (isMonoidal ⋀Symm)) (A , B , C)) = - ≃∙→ret/sec∙ SmashAssocEquiv∙ .snd + ≃∙→ret/sec∙ SmashAssocEquiv∙ .snd retr (isIs (⊗assoc (isMonoidal ⋀Symm)) (A , B , C)) = - ≃∙→ret/sec∙ SmashAssocEquiv∙ .fst + ≃∙→ret/sec∙ SmashAssocEquiv∙ .fst ⊗lUnit (isMonoidal ⋀Symm) = ⋀lUnitNatIso ⊗rUnit (isMonoidal ⋀Symm) = compWildNatIso _ _ _ restrₗᵣ ⋀lUnitNatIso triang (isMonoidal (⋀Symm {ℓ})) X Y = ⋀triang ⊗pentagon (isMonoidal ⋀Symm) X Y Z W = (∘∙-assoc assc₅∙ assc₄∙ assc₃∙) ∙ pentagon∙ -N-ob (trans (Braid ⋀Symm)) X = ⋀comm→∙ +N-ob (trans (Braid ⋀Symm)) X = ⋀comm→∙ N-hom (trans (Braid ⋀Symm)) (f , g) = ⋀comm-sq f g -isIs (Braid ⋀Symm) _ = makeIsIso-Pointed (isoToIsEquiv ⋀CommIso) +isIs (Braid ⋀Symm) _ = makeIsIso-Pointed (isoToIsEquiv ⋀CommIso) isSymmetricWildCat.hexagon ⋀Symm a b c = hexagon∙ symBraiding ⋀Symm X Y = - ΣPathP ((funExt (Iso.rightInv ⋀CommIso)) , (sym (rUnit refl))) + ΣPathP ((funExt (Iso.rightInv ⋀CommIso)) , (sym (rUnit refl))) \ No newline at end of file diff --git a/Cubical.HITs.Sn.Degree.html b/Cubical.HITs.Sn.Degree.html index 4de8c90e9..fa48b694b 100644 --- a/Cubical.HITs.Sn.Degree.html +++ b/Cubical.HITs.Sn.Degree.html @@ -138,7 +138,7 @@ ∙ Iso.leftInv (degree∥₂Iso n) (∣ g ∘ f ∣₂))) degreeSusp : (n : ℕ) (f : S₊ n → S₊ n) - → degree n f ≡ degree (suc n) (suspFunS∙ f .fst) + → degree n f ≡ degree (suc n) (suspFunS∙ f .fst) degreeSusp zero f with (f true) | (f false) ... | false | false = refl ... | false | true = refl @@ -159,7 +159,7 @@ degreeIdfun : (n : ℕ) → degree n (λ x → x) ≡ 1 degreeIdfun zero = refl degreeIdfun (suc n) = - cong (degree (suc n)) (sym (cong fst suspFunS∙Id)) + cong (degree (suc n)) (sym (cong fst suspFunS∙Id)) ∙∙ (sym (degreeSusp n (idfun _))) ∙∙ degreeIdfun n \ No newline at end of file diff --git a/Cubical.HITs.Sn.Multiplication.html b/Cubical.HITs.Sn.Multiplication.html new file mode 100644 index 000000000..4b244ee6d --- /dev/null +++ b/Cubical.HITs.Sn.Multiplication.html @@ -0,0 +1,900 @@ + +Cubical.HITs.Sn.Multiplication
{-# OPTIONS --safe #-}
+
+{-
+This file contains:
+1. Definition of the multplication Sⁿ × Sᵐ → Sⁿ⁺ᵐ
+2. The fact that the multiplication induces an equivalence Sⁿ ∧ Sᵐ ≃ Sⁿ⁺ᵐ
+3. The algebraic properties of this map
+-}
+
+module Cubical.HITs.Sn.Multiplication where
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Pointed
+open import Cubical.Foundations.Path
+open import Cubical.Foundations.Function
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.HLevels
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Transport
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Pointed.Homogeneous
+
+open import Cubical.Data.Sum
+open import Cubical.Data.Bool hiding (elim)
+open import Cubical.Data.Nat hiding (elim)
+open import Cubical.Data.Sigma
+
+open import Cubical.HITs.S1 hiding (_·_)
+open import Cubical.HITs.Sn hiding (IsoSphereJoin)
+open import Cubical.HITs.Susp renaming (toSusp to σ)
+open import Cubical.HITs.Join
+open import Cubical.HITs.Pushout
+open import Cubical.HITs.SmashProduct
+
+open import Cubical.Homotopy.Loopspace
+
+open Iso
+
+open PlusBis
+
+
+---- Sphere multiplication
+-- auxiliary function
+sphereFun↑ : {n m k : ℕ}
+  → (f : S₊ n → S₊ m → S₊ k)
+  → S₊ (suc n) → S₊ m → S₊ (suc k)
+sphereFun↑ {n = zero} {m = m} f base y = ptSn _
+sphereFun↑ {n = zero} {m = m} f (loop i) y = σS (f false y) i
+sphereFun↑ {n = suc n} {m = m} f north y = ptSn _
+sphereFun↑ {n = suc n} {m = m} f south y = ptSn _
+sphereFun↑ {n = suc n} {m = m} f (merid a i) y = σS (f a y) i
+
+-- sphere multiplication
+_⌣S_ : {n m : ℕ} → S₊ n → S₊ m → S₊ (n + m)
+_⌣S_ {n = zero} {m = m} false y = y
+_⌣S_ {n = zero} {m = m} true y = ptSn m
+_⌣S_ {n = suc n} {m = m} = sphereFun↑ (_⌣S_ {n = n})
+
+-- Left- and right-unit laws
+IdR⌣S : {n m : ℕ} (y : S₊ m)
+  → Path (S₊ (n + m)) (ptSn n ⌣S y) (ptSn (n + m))
+IdR⌣S {n = zero} {m = m} y = refl
+IdR⌣S {n = suc zero} {m = m} y = refl
+IdR⌣S {n = suc (suc n)} {m = m} y = refl
+
+IdL⌣S : {n m : ℕ} (x : S₊ n)
+  → Path (S₊ (n + m)) (x ⌣S (ptSn m)) (ptSn (n + m))
+IdL⌣S {n = zero} false = refl
+IdL⌣S {n = zero} true = refl
+IdL⌣S {n = suc zero} base = refl
+IdL⌣S {n = suc zero} {zero} (loop i) j = base
+IdL⌣S {n = suc zero} {suc m} (loop i) j = rCancel (merid (ptSn (suc m))) j i
+IdL⌣S {n = suc (suc n)} {m} north j = north
+IdL⌣S {n = suc (suc n)} {m} south j = north
+IdL⌣S {n = suc (suc n)} {m} (merid a i) j =
+  (cong σS (IdL⌣S a)
+  ∙ rCancel (merid (ptSn _))) j i
+
+IdL⌣S≡IdR⌣S : (n m : ℕ)
+  → IdL⌣S {n = n} {m = m} (ptSn n) ≡ IdR⌣S (ptSn m)
+IdL⌣S≡IdR⌣S zero m = refl
+IdL⌣S≡IdR⌣S (suc zero) m = refl
+IdL⌣S≡IdR⌣S (suc (suc n)) m = refl
+
+-- Multiplication induced on smash products of spheres
+⋀S∙ : (n m : ℕ) → S₊∙ n ⋀∙ S₊∙ m →∙ S₊∙ (n + m)
+fst (⋀S∙ n m) (inl x) = ptSn _
+fst (⋀S∙ n m) (inr x) = (fst x) ⌣S (snd x)
+fst (⋀S∙ n m) (push (inl x) i) = IdL⌣S x (~ i)
+fst (⋀S∙ n m) (push (inr x) i) = IdR⌣S x (~ i)
+fst (⋀S∙ n m) (push (push a i₁) i) = IdL⌣S≡IdR⌣S n m i₁ (~ i)
+snd (⋀S∙ n m) = refl
+
+⋀S : (n m : ℕ) → S₊∙ n ⋀ S₊∙ m → S₊ (n + m)
+⋀S n m = fst (⋀S∙ n m)
+
+-- Proof that it is an equivalence
+⋀S-base : (m : ℕ)
+  → Iso (S₊∙ zero ⋀ S₊∙ m) (S₊ m)
+fun (⋀S-base m) = ⋀S zero m
+inv (⋀S-base m) x = inr (false , x)
+rightInv (⋀S-base m) x = refl
+leftInv (⋀S-base m) =
+  ⋀-fun≡ _ _
+    (sym (push (inl false)))
+    (λ { (false , y) → refl
+       ; (true , y) → sym (push (inl false)) ∙ push (inr y)})
+     (λ { false i j → push (inl false) (i ∨ ~ j)
+        ; true → compPath-filler (sym (push (inl false))) (push (inl true))
+        ▷ cong (sym (push (inl false)) ∙_)
+                (λ i → push (push tt i) )})
+        λ x → compPath-filler (sym (push (inl false))) (push (inr x))
+{-
+Proof that ⋀S respects suspension, i.e. that the following diagram commutes
+                ⋀S
+Sⁿ⁺¹ ∧ Sᵐ ---------------> Sⁿ⁺ᵐ⁺¹
+|                          |
+|                          |
+v                          v
+Σ (Sⁿ ∧ Sᵐ)  -----------> Σ Sⁿ⁺ᵐ
+                Σ(⋀S)
+-}
+
+⋀S-ind : (n m : ℕ) (x : _)
+  → ⋀S (suc n) m x
+   ≡ Iso.inv (IsoSucSphereSusp (n + m))
+      (suspFun (⋀S n m) (Iso.fun SuspSmashCommIso
+        (((Iso.fun (IsoSucSphereSusp n) , IsoSucSphereSusp∙' n)
+      ⋀→ idfun∙ (S₊∙ m)) x)))
+⋀S-ind zero m = ⋀-fun≡ _ _
+  (sym (IsoSucSphereSusp∙ m))
+    (λ x → main m (fst x) (snd x))
+    (mainₗ m)
+    mainᵣ
+  where
+  F' :  (m : ℕ) → Susp ((Bool , true) ⋀ S₊∙ m) → _
+  F' m = inv (IsoSucSphereSusp (zero + m)) ∘ suspFun (⋀S zero m)
+
+  F : (m : ℕ) → Susp∙ Bool ⋀ S₊∙ m → _
+  F m = F' m ∘ fun SuspSmashCommIso
+
+  G : (m : ℕ) → _ → _
+  G m = _⋀→_ {A = S₊∙ 1} {B = S₊∙ m}
+         (fun (IsoSucSphereSusp zero) , (λ _ → north))
+         (idfun∙ (S₊∙ m))
+
+  main : (m : ℕ) (x : S¹) (y : S₊ m)
+    → x ⌣S y
+    ≡ F m (inr (S¹→SuspBool x , y))
+  main m base y = sym (IsoSucSphereSusp∙ m)
+  main zero (loop i) false j =
+    ((cong-∙ (λ x → F zero (inr (x , false)))
+             (merid false) (sym (merid true)))
+    ∙ sym (rUnit loop)) (~ j) i
+  main zero (loop i) true j =
+    F zero (inr (rCancel (merid true) (~ j) i , false))
+  main (suc m) (loop i) y j =
+    cong-∙ (λ x → F (suc m) (inr (x , y)))
+           (merid false) (sym (merid true)) (~ j) i
+
+  mainₗ : (m : ℕ) (x : S¹)
+    → PathP (λ i → IdL⌣S {m = m} x (~ i)
+            ≡ F m (G m (push (inl x) i)))
+             (sym (IsoSucSphereSusp∙ m))
+             (main m x (ptSn m))
+  mainₗ zero =
+    toPropElim (λ _ → isOfHLevelPathP' 1 (isGroupoidS¹ _ _) _ _)
+     (flipSquare (cong (cong (F zero)) (rUnit (push (inl north)))))
+  mainₗ (suc m) x = flipSquare (help x
+    ▷ (cong (cong (F (suc m))) (rUnit (push (inl (S¹→SuspBool x))))))
+    where
+    help : (x : S¹)
+      → PathP (λ i → north ≡ main (suc m) x (ptSn (suc m)) i)
+           (sym (IdL⌣S {n = 1} x))
+           (cong (F (suc m)) (push (inl (S¹→SuspBool x))))
+    help base = refl
+    help (loop i) j k =
+      hcomp (λ r
+        → λ {(i = i0) → north
+            ; (i = i1) → F' (suc m)
+                           (merid-fill
+                            {A = Bool , true}
+                            {B = S₊∙ (suc m)} true (~ r) k j)
+            ; (j = i0) → rCancel-filler (merid (ptSn (suc m))) r (~ k) i
+            ; (j = i1) → F (suc m)
+                           (push (inl (compPath-filler
+                             (merid false) (sym (merid true)) r i)) k)
+            ; (k = i0) → north
+            ; (k = i1) → cong-∙∙-filler
+                            (λ x₁ → F (suc m) (inr (x₁ , ptSn (suc m))))
+                            refl (merid false) (sym (merid true)) r (~ j) i})
+       (F' (suc m) (merid-fill {A = Bool , true} {B = S₊∙ (suc m)} false k i j))
+  mainᵣ : (x : S₊ m)
+    → PathP (λ i → ptSn (suc m) ≡ F m (G m (push (inr x) i)))
+             (sym (IsoSucSphereSusp∙ m))
+             (sym (IsoSucSphereSusp∙ m))
+  mainᵣ x = flipSquare ((λ i j → (IsoSucSphereSusp∙ m) (~ i))
+                       ▷ cong (cong (F m)) (rUnit (push (inr x))))
+⋀S-ind (suc n) m = ⋀-fun≡ _ _ refl
+  (λ x → h (fst x) (snd x))
+  hₗ
+  λ x → flipSquare (cong (cong (suspFun (⋀S (suc n) m)
+                              ∘ fun SuspSmashCommIso))
+                    (rUnit (push (inr x))))
+  where
+  h : (x : S₊ (suc (suc n))) (y : S₊ m)
+    → (x ⌣S y)
+    ≡ suspFun (⋀S (suc n) m)
+       (SuspL→Susp⋀ (inr (idfun (Susp (S₊ (suc n))) x , y)))
+  h north y = refl
+  h south y = merid (ptSn _)
+  h (merid a i) y j = compPath-filler
+           (merid (a ⌣S y)) (sym (merid (ptSn (suc (n + m))))) (~ j) i
+
+  hₗ-lem : (x : Susp (S₊ (suc n)))
+    → PathP (λ i → north ≡ h x (ptSn m) i)
+             (sym (IdL⌣S x))
+             (cong (suspFun (⋀S (suc n) m)
+                  ∘ fun SuspSmashCommIso)
+                   (push (inl x)))
+  hₗ-lem north = refl
+  hₗ-lem south i j = merid (ptSn (suc (n + m))) (i ∧ j)
+  hₗ-lem (merid a i) j k = help j k i
+    where
+    help : Cube (sym (cong σS
+                  (IdL⌣S {n = suc n} {m = m} a)
+                 ∙ rCancel (merid (ptSn (suc n + m)))))
+                (λ k i → suspFun (⋀S (suc n) m)
+                           (SuspL→Susp⋀ (push (inl (merid a i)) k)))
+                (λ j i → north)
+                (λ j i → compPath-filler
+                           (merid (a ⌣S ptSn m))
+                           (sym (merid (ptSn (suc (n + m))))) (~ j) i)
+                (λ j k → north)
+                λ j k → merid (ptSn (suc (n + m))) (j ∧ k)
+    help j k i =
+      hcomp (λ r
+        → λ {(i = i0) → north
+            ; (i = i1) → merid (ptSn (suc (n + m))) (j ∧ k)
+            ; (j = i0) → compPath-filler'
+                           (cong σS
+                            (IdL⌣S {n = suc n} {m = m} a))
+                           (rCancel (merid (ptSn (suc n + m)))) r (~ k) i
+            ; (j = i1) → suspFun (⋀S (suc n) m)
+                           (merid-fill a k i r)
+            ; (k = i0) → north
+            ; (k = i1) → compPath-filler
+                           (merid (IdL⌣S a (~ r)))
+                           (sym (merid (ptSn (suc (n + m))))) (~ j) i})
+         (hcomp (λ r → λ {(i = i0) → north
+                        ; (i = i1) → merid (ptSn (suc (n + m))) ((j ∨ ~ r) ∧ k)
+                        ; (j = i0) → rCancel-filler (merid (ptSn _)) r (~ k) i
+                        ; (j = i1) → merid (ptSn (suc (n + m))) (i ∧ k)
+                        ; (k = i0) → north
+                        ; (k = i1) → compPath-filler
+                                       (merid (ptSn _))
+                                       (sym (merid (ptSn (suc (n + m)))))
+                                       (~ j ∧ r) i})
+                  (merid (ptSn (suc (n + m))) (i ∧ k)))
+
+  hₗ : (x : Susp (S₊ (suc n)))
+    → PathP (λ i → IdL⌣S x (~ i)
+      ≡ inv (IsoSucSphereSusp (suc n + m))
+         (suspFun (⋀S (suc n) m)
+          (fun SuspSmashCommIso
+           (((fun (IsoSucSphereSusp (suc n)) , IsoSucSphereSusp∙' (suc n)) ⋀→
+             idfun∙ (S₊∙ m))
+            (push (inl x) i))))) refl (h x (ptSn m))
+  hₗ x =
+    flipSquare
+       ((hₗ-lem x
+      ▷ sym (cong (cong (inv (IsoSucSphereSusp (suc n + m))
+                  ∘ suspFun (⋀S (suc n) m)
+                  ∘ fun SuspSmashCommIso))
+                  (sym (rUnit (push (inl x)))))))
+
+
+isEquiv-⋀S : (n m : ℕ) → isEquiv (⋀S n m)
+isEquiv-⋀S zero m = isoToIsEquiv (⋀S-base m)
+isEquiv-⋀S (suc n) m =
+  subst isEquiv (sym (funExt (⋀S-ind n m)))
+    (snd (helpEq (isEquiv-⋀S n m)))
+  where
+  r = isoToEquiv (IsoSucSphereSusp n)
+
+  helpEq : isEquiv (⋀S n m) → (S₊∙ (suc n) ⋀ S₊∙ m) ≃ S₊ (suc n + m)
+  helpEq iseq =
+    compEquiv
+     (compEquiv
+       (compEquiv
+         (⋀≃ (r , IsoSucSphereSusp∙' n) (idEquiv (S₊ m) , refl))
+         (isoToEquiv SuspSmashCommIso))
+       (isoToEquiv
+         (congSuspIso (equivToIso (⋀S n m , iseq)))))
+      (isoToEquiv (invIso (IsoSucSphereSusp (n + m))))
+
+SphereSmashIso : (n m : ℕ) → Iso (S₊∙ n ⋀ S₊∙ m) (S₊ (n + m))
+SphereSmashIso n m = equivToIso (⋀S n m , isEquiv-⋀S n m)
+
+-- Proof that the pinch map Sⁿ * Sᵐ → Sⁿ⁺ᵐ⁺¹ is an equivalence
+join→Sphere : (n m : ℕ)
+  → join (S₊ n) (S₊ m) → S₊ (suc (n + m))
+join→Sphere n m (inl x) = ptSn _
+join→Sphere n m (inr x) = ptSn _
+join→Sphere n m (push a b i) = σS (a ⌣S b) i
+
+join→Sphere∙ : (n m : ℕ)
+  → join∙ (S₊∙ n) (S₊∙ m) →∙ S₊∙ (suc (n + m))
+fst (join→Sphere∙ n m) = join→Sphere n m
+snd (join→Sphere∙ n m) = refl
+
+joinSphereIso' : (n m : ℕ)
+  → Iso (join (S₊ n) (S₊ m)) (S₊ (suc (n + m)))
+joinSphereIso' n m =
+  compIso (invIso (SmashJoinIso {A = S₊∙ n} {B = S₊∙ m}))
+   (compIso (congSuspIso (SphereSmashIso n m))
+    (invIso (IsoSucSphereSusp (n + m))))
+
+join→Sphere≡ : (n m : ℕ) (x : _)
+  → join→Sphere n m x ≡ joinSphereIso' n m .Iso.fun x
+join→Sphere≡ zero zero (inl x) = refl
+join→Sphere≡ zero (suc m) (inl x) = refl
+join→Sphere≡ (suc n) m (inl x) = refl
+join→Sphere≡ zero zero (inr x) = refl
+join→Sphere≡ zero (suc m) (inr x) = merid (ptSn (suc m))
+join→Sphere≡ (suc n) zero (inr x) = merid (ptSn (suc n + zero))
+join→Sphere≡ (suc n) (suc m) (inr x) = merid (ptSn (suc n + suc m))
+join→Sphere≡ zero zero (push false false i) j = loop i
+join→Sphere≡ zero zero (push false true i) j = base
+join→Sphere≡ zero zero (push true b i) j = base
+join→Sphere≡ zero (suc m) (push a b i) j =
+  compPath-filler
+    (merid (a ⌣S b)) (sym (merid (ptSn (suc m)))) (~ j) i
+join→Sphere≡ (suc n) zero (push a b i) j =
+  compPath-filler
+    (merid (a ⌣S b)) (sym (merid (ptSn (suc n + zero)))) (~ j) i
+join→Sphere≡ (suc n) (suc m) (push a b i) j =
+  compPath-filler
+    (merid (a ⌣S b)) (sym (merid (ptSn (suc n + suc m)))) (~ j) i
+
+-- Todo: integrate with Sn.Properties IsoSphereJoin
+IsoSphereJoin : (n m : ℕ)
+  → Iso (join (S₊ n) (S₊ m)) (S₊ (suc (n + m)))
+fun (IsoSphereJoin n m) = join→Sphere n m
+inv (IsoSphereJoin n m) = joinSphereIso' n m .Iso.inv
+rightInv (IsoSphereJoin n m) x =
+  join→Sphere≡ n m (joinSphereIso' n m .Iso.inv x)
+  ∙ joinSphereIso' n m .Iso.rightInv x
+leftInv (IsoSphereJoin n m) x =
+  cong (joinSphereIso' n m .inv) (join→Sphere≡ n m x)
+  ∙ joinSphereIso' n m .Iso.leftInv x
+
+joinSphereEquiv∙ : (n m : ℕ) → join∙ (S₊∙ n) (S₊∙ m) ≃∙ S₊∙ (suc (n + m))
+fst (joinSphereEquiv∙ n m) = isoToEquiv (IsoSphereJoin n m)
+snd (joinSphereEquiv∙ n m) = refl
+
+
+-- Associativity ⌣S
+-- Preliminary lemma
+⌣S-false : {n : ℕ} (x : S₊ n) → PathP (λ i → S₊ (+-comm n zero i)) (x ⌣S false) x
+⌣S-false {n = zero} false = refl
+⌣S-false {n = zero} true = refl
+⌣S-false {n = suc zero} base = refl
+⌣S-false {n = suc zero} (loop i) = refl
+⌣S-false {n = suc (suc n)} north i = north
+⌣S-false {n = suc (suc n)} south i = merid (ptSn (suc (+-zero n i))) i
+⌣S-false {n = suc (suc n)} (merid a i) j =
+  hcomp (λ k → λ {(i = i0) → north
+                 ; (i = i1) → merid (ptSn (suc (+-zero n j))) (j ∨ ~ k)
+                 ; (j = i1) → merid a i})
+        (merid (⌣S-false a j) i)
+
+assoc⌣S : {n m l : ℕ} (x : S₊ n) (y : S₊ m) (z : S₊ l)
+  → PathP (λ i → S₊ (+-assoc n m l i))
+           (x ⌣S (y ⌣S z)) ((x ⌣S y) ⌣S z)
+assoc⌣S {n = zero} {m = m} false y z = refl
+assoc⌣S {n = zero} {m = m} true y z = sym (IdR⌣S z)
+assoc⌣S {n = suc zero} {m = m} base y z = sym (IdR⌣S z)
+assoc⌣S {n = suc zero} {m = m} (loop i) y z j = help m y j i
+  where
+  help : (m : ℕ) (y : S₊ m)
+    → Square (σS (y ⌣S z)) (cong (λ w → sphereFun↑ _⌣S_ w z) (σS y))
+                (sym (IdR⌣S z)) (sym (IdR⌣S z))
+  help zero false = refl
+  help zero true = σS∙
+  help (suc m) y =
+      rUnit (σS (y ⌣S z))
+    ∙ cong (σS (y ⌣S z) ∙_)
+           (cong sym ((sym σS∙)
+                ∙ congS σS (sym (IdR⌣S z))))
+    ∙ sym (cong-∙ (λ k → sphereFun↑ _⌣S_ k z)
+           (merid y)
+           (sym (merid (ptSn (suc m)))))
+assoc⌣S {n = suc (suc n)} {m = m} north y z k = north
+assoc⌣S {n = suc (suc n)} {m = m} south y z k = north
+assoc⌣S {n = suc (suc n)} {m = m} {l} (merid a i) y z j =
+  help m y (assoc⌣S a y z) j i
+  where
+  help : (m : ℕ) (y : S₊ m)
+    → PathP (λ i₁ → S₊ (suc (+-assoc n m l i₁)))
+             (a ⌣S (y ⌣S z))
+             ((a ⌣S y) ⌣S z)
+    → SquareP (λ j i → S₊ (+-assoc (suc (suc n)) m l j))
+              (σS (a ⌣S (y ⌣S z)))
+              (λ i → (merid a i ⌣S y) ⌣S z)
+              (λ _ → north) (λ _ → north)
+  help zero false _ =
+      (λ i j → σ (S₊∙ (suc (+-assoc n zero l i))) (lem i) j)
+    ▷ rUnit _
+     ∙ cong₂ _∙_ (congS σS (λ _ → (a ⌣S false) ⌣S z))
+                 (cong sym (sym σS∙
+                 ∙ congS σS
+                     (sym (IdR⌣S z))))
+     ∙ sym (cong-∙ (_⌣S z)
+           (merid (a ⌣S false))
+           (sym (merid (ptSn (suc (n + zero))))))
+    where
+    lem : PathP (λ i → S₊ (suc (+-assoc n zero l i)))
+                (a ⌣S z) ((a ⌣S false) ⌣S z)
+    lem = toPathP ((λ i → subst (S₊ ∘ suc)
+                            (isSetℕ _ _ (+-assoc n zero l)
+                                         (λ j → +-zero n (~ j) + l) i)
+                            (a ⌣S z))
+                  ∙ fromPathP (λ i → ⌣S-false a (~ i) ⌣S z))
+  help zero true _ =
+    (congS σS (IdL⌣S a) ∙ σS∙)
+    ◁ (λ i j → north)
+    ▷ (cong (cong (_⌣S z))
+           (sym σS∙
+         ∙ congS σS (sym (IdL⌣S a))))
+  help (suc m) y q =
+      (λ i j → σS (q i) j)
+    ▷ (rUnit _
+     ∙ cong₂ _∙_ refl
+             (cong sym (sym σS∙ ∙ cong σS (sym (IdR⌣S z))))
+     ∙ sym (cong-∙ (_⌣S z) (merid (a ⌣S y))
+           (sym (merid (ptSn (suc (n + suc m)))))))
+
+-- Goal: graded commutativity
+
+-- To state it: we'll need iterated negations
+-S^ : {k : ℕ} (n : ℕ) → S₊ k → S₊ k
+-S^ zero x = x
+-S^ (suc n) x = invSphere (-S^ n x)
+
+-- The folowing is an explicit definition of -S^ (n · m) which is
+-- often easier to reason about
+-S^-expl : {k : ℕ} (n m : ℕ)
+  → isEvenT n ⊎ isOddT n
+  → isEvenT m ⊎ isOddT m
+  → S₊ k → S₊ k
+-S^-expl {k = zero} n m (inl x₁) q x = x
+-S^-expl {k = zero} n m (inr x₁) (inl x₂) x = x
+-S^-expl {k = zero} n m (inr x₁) (inr x₂) false = true
+-S^-expl {k = zero} n m (inr x₁) (inr x₂) true = false
+-S^-expl {k = suc zero} n m p q base = base
+-S^-expl {k = suc zero} n m (inl x) q (loop i) = loop i
+-S^-expl {k = suc zero} n m (inr x) (inl x₁) (loop i) = loop i
+-S^-expl {k = suc zero} n m (inr x) (inr x₁) (loop i) = loop (~ i)
+-S^-expl {k = suc (suc k)} n m p q north = north
+-S^-expl {k = suc (suc k)} n m p q south = north
+-S^-expl {k = suc (suc k)} n m (inl x) q (merid a i) = σS a i
+-S^-expl {k = suc (suc k)} n m (inr x) (inl x₁) (merid a i) = σS a i
+-S^-expl {k = suc (suc k)} n m (inr x) (inr x₁) (merid a i) = σS a (~ i)
+
+--  invSphere commutes with S^
+invSphere-S^ : {k : ℕ} (n : ℕ) (x : S₊ k)
+  → invSphere (-S^ n x) ≡ -S^ n (invSphere x)
+invSphere-S^ zero x = refl
+invSphere-S^ (suc n) x = cong invSphere (invSphere-S^ n x)
+
+-S^² : {k : ℕ} (n : ℕ) (x : S₊ k) → -S^ n (-S^ n x) ≡ x
+-S^² zero x = refl
+-S^² (suc n) x =
+  cong invSphere (sym (invSphere-S^ n (-S^ n x)))
+  ∙ invSphere² _ (-S^ n (-S^ n x))
+  ∙ -S^² n x
+
+-S^Iso : {k : ℕ} (n : ℕ) → Iso (S₊ k) (S₊ k)
+fun (-S^Iso n) = -S^ n
+inv (-S^Iso n) = -S^ n
+rightInv (-S^Iso n) = -S^² n
+leftInv (-S^Iso n) = -S^² n
+
+-S^-comp : {k : ℕ} (n m : ℕ) (x : S₊ k)
+  → -S^ n (-S^ m x) ≡ -S^ (n + m) x
+-S^-comp zero m x = refl
+-S^-comp (suc n) m x = cong invSphere (-S^-comp n m x)
+
+-S^·2 : {k : ℕ} (n : ℕ) (x : S₊ k) → -S^ (n + n) x ≡ x
+-S^·2 zero x = refl
+-S^·2 (suc n) x =
+    cong invSphere (λ i → -S^ (+-comm n (suc n) i) x)
+  ∙ invSphere² _ (-S^ (n + n) x)
+  ∙ -S^·2 n x
+
+-- technical transport lemma
+private
+  -S^-transp : {k : ℕ} (m : ℕ) (p : k ≡ m) (n : ℕ) (x : S₊ k)
+    → subst S₊ p (-S^ n x) ≡ -S^ n (subst S₊ p x)
+  -S^-transp =
+    J> λ n x → transportRefl _
+              ∙ sym (cong (-S^ n) (transportRefl x))
+
+-- Iterated path inversion
+sym^ : ∀ {ℓ} {A : Type ℓ} {x : A} (n : ℕ) → x ≡ x → x ≡ x
+sym^ zero p = p
+sym^ (suc n) p = sym (sym^ n p)
+
+-- Interaction between -S^ and sym^
+σS-S^ : {k : ℕ} (n : ℕ) (x : S₊ (suc k))
+  → σS (-S^ n x) ≡ sym^ n (σS x)
+σS-S^ {k = k} zero x = refl
+σS-S^ {k = k} (suc n) x =
+  σ-invSphere k _ ∙ cong sym (σS-S^ n x)
+
+sphereFun↑-subst : {n m : ℕ} (k' k : ℕ) (p : k' ≡ k)
+  → (f : S₊ n → S₊ m → S₊ k') (x : S₊ _) (y : S₊ _)
+  → sphereFun↑ (λ x y → subst S₊ p (f x y)) x y
+   ≡ subst S₊ (cong suc p) (sphereFun↑ f x y)
+sphereFun↑-subst k' = J> λ f x y
+  → (λ i → sphereFun↑ (λ x₁ y₁ → transportRefl (f x₁ y₁) i) x y)
+   ∙ sym (transportRefl _)
+
+sphereFun↑-invSphere : {n m k : ℕ}
+  → (f : S₊ (suc n) → S₊ (suc m) → S₊ (suc k)) (x : S₊ _) (y : S₊ _)
+  → sphereFun↑ (λ x y → invSphere' (f x y)) x y
+   ≡ invSphere' (sphereFun↑ (λ x y → (f x y)) x y)
+sphereFun↑-invSphere {n = n} {m = m} {k = k} f north y = refl
+sphereFun↑-invSphere {n = n} {m = m} {k = k} f south y = refl
+sphereFun↑-invSphere {n = n} {m = m} {k = k} f (merid a i) y j =
+  lem k (f a y) j i
+  where
+  lem : (k : ℕ) (x : S₊ (suc k))
+    → (σS (invSphere' x)) ≡ (cong invSphere' (σS x))
+  lem k x =
+    sym (cong-∙ invSphere' (merid x) (sym (merid (ptSn _)))
+      ∙∙ cong (cong invSphere' (merid x) ∙_)
+          (rCancel (merid (ptSn _)))
+      ∙∙ (sym (rUnit _)
+        ∙ sym (σ-invSphere k x)
+        ∙ cong (σ (S₊∙ (suc k)))
+           (sym (invSphere'≡ x))))
+
+sphereFun↑^ : {n m k : ℕ} (l : ℕ)
+  → (f : S₊ (suc n) → S₊ (suc m) → S₊ (suc k)) (x : S₊ _) (y : S₊ _)
+  → sphereFun↑ (λ x y → -S^ l (f x y)) x y
+   ≡ -S^ l (sphereFun↑ (λ x y → (f x y)) x y)
+sphereFun↑^ zero f x y = refl
+sphereFun↑^ (suc l) f x y =
+    (λ i → sphereFun↑ (λ x₁ y₁ → invSphere'≡ (-S^ l (f x₁ y₁)) (~ i)) x y)
+  ∙ sphereFun↑-invSphere (λ x₁ y₁ → (-S^ l (f x₁ y₁))) x y
+  ∙ invSphere'≡ ((sphereFun↑ (λ x₁ y₁ → -S^ l (f x₁ y₁)) x y))
+  ∙ cong invSphere (sphereFun↑^ l f x y)
+
+S^-even : {k : ℕ} (n : ℕ) (x : S₊ k) → isEvenT n → -S^ n x ≡ x
+S^-even zero x p = refl
+S^-even (suc (suc n)) x p = invSphere² _ (-S^ n x) ∙ S^-even n x p
+
+private
+  move-transp-S^ : {k : ℕ} (n : ℕ) (p : k ≡ n) (m : ℕ)
+    → (x : S₊ k) (y : S₊ n)
+    → subst S₊ p (-S^ m x) ≡ y
+    → subst S₊ (sym p) (-S^ m y) ≡ x
+  move-transp-S^ =
+    J> λ m x → J> transportRefl _
+    ∙ cong (-S^ m) (transportRefl _)
+    ∙ -S^² m x
+
+  master-lem : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (coh : refl ≡ p)
+    (q : p ≡ p)
+    → Cube (λ j k → coh j (~ k)) (λ j k → coh j (~ k))
+            (λ i k → q k i) (λ i k → q i (~ k))
+            (λ j k → coh (~ k) j) λ j k → coh (~ k) j
+  master-lem = J> λ q → λ i j k → sym≡flipSquare q j (~ k) i
+
+  comm⌣S₁ : {m : ℕ} → (x : S¹) (y : S₊ (suc m))
+    → (x ⌣S y)
+     ≡ subst S₊ (+-comm (suc m) 1)
+                (-S^ (suc m) (y ⌣S x))
+  comm⌣S₁ {m = zero} x y =
+      (main x y ∙ invSphere'≡ (y ⌣S x))
+    ∙ sym (transportRefl (invSusp (y ⌣S x)))
+    where
+    pp-main : (x : S¹) → PathP (λ i → IdL⌣S {m = 1} x i
+            ≡ IdL⌣S {m = 1} x i) (cong (x ⌣S_) loop) (sym (σS x))
+    pp-main base i j = rCancel (merid base) (~ i) (~ j)
+    pp-main (loop k) i j =
+      master-lem _ (sym (rCancel (merid base)))
+                   (λ j k → σS (loop j) k) k i j
+
+    pp-help : (x : S¹) → PathP (λ i → IdL⌣S {m = 1} x i
+            ≡ IdL⌣S {m = 1} x i)
+                     (cong (x ⌣S_) loop) (cong invSphere' (σS x))
+    pp-help x = pp-main x
+      ▷ (rUnit _
+      ∙∙ cong (sym (σS x) ∙_) (sym (rCancel (merid base)))
+      ∙∙ sym (cong-∙ invSphere' (merid x) (sym (merid base))))
+
+    main : (x y : S¹) → (x ⌣S y) ≡ invSphere' (y ⌣S x)
+    main x base = IdL⌣S {m = 1} x
+    main x (loop i) = flipSquare (pp-help x) i
+  comm⌣S₁ {m = suc m} x y =
+      (main-lem x y
+     ∙ sym (transportRefl (invSphere' (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x)))
+    ∙ sym (compSubstℕ {A = S₊} (cong suc (sym (+-comm (suc m) 1)))
+                                (+-comm (suc (suc m)) 1) refl
+       {x = invSphere' (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x)}))
+    ∙ cong (subst S₊ (+-comm (suc (suc m)) 1))
+        (cong (subst S₊ (cong suc (sym (+-comm (suc m) 1))))
+          (sym (S^-lem (suc m) (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x)))
+        ∙ -S^-transp _ (cong suc (sym (+-comm (suc m) 1)))
+           (suc (suc m) + suc m)
+           (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x)
+        ∙ sym (-S^-comp (suc (suc m)) (suc m)
+           (subst S₊ (cong suc (sym (+-comm (suc m) 1)))
+             (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x))))
+    ∙ cong (subst S₊ (+-comm (suc (suc m)) 1)
+         ∘ -S^ (suc (suc m)))
+         ((sym (-S^-transp _ (cong suc (sym (+-comm (suc m) 1))) (suc m)
+               (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x))
+         ∙ cong (subst S₊ (cong suc (sym (+-comm (suc m) 1))))
+               (sym (sphereFun↑^ (suc m)
+                (λ x₂ x₃ →  (x₃ ⌣S x₂)) y x))
+         ∙ sym (sphereFun↑-subst _ _ (sym (+-comm (suc m) 1))
+           (λ x₂ x₃ →  (-S^ (suc m) (x₃ ⌣S x₂))) y x))
+         ∙ cong (λ (s : S₊ (suc m) → S¹ → S₊ (suc m + 1))
+                  → sphereFun↑ s y x)
+                 (refl
+               ∙ sym (funExt λ x → funExt λ y
+               → sym (move-transp-S^ _ (+-comm (suc m) 1)
+               (suc m) (x ⌣S y) (y ⌣S x)
+                (sym (comm⌣S₁ y x)))
+               ∙ refl)))
+    where
+    S^-lem : {k : ℕ} (m : ℕ) (x : S₊ k)
+      → -S^ (suc m + m) x ≡ invSphere' x
+    S^-lem m x =
+         sym (invSphere'≡ (-S^ (m + m) x))
+       ∙ cong invSphere' (-S^·2 m x)
+
+    ⌣S-south : (x : S¹) → x ⌣S south ≡ north
+    ⌣S-south base = refl
+    ⌣S-south (loop i) j =
+      (cong σS (sym (merid (ptSn (suc m))) )
+      ∙ rCancel (merid (ptSn _))) j i
+
+    PathP-main : (x : S¹) (a : S₊ (suc m))
+      → PathP (λ i → IdL⌣S x i ≡ ⌣S-south x i) (cong (x ⌣S_) (merid a))
+          (sym (σS (x ⌣S a)))
+    PathP-main base a j i = rCancel (merid north) (~ j) (~ i)
+    PathP-main (loop k) a j i =
+      hcomp (λ r → λ {(i = i0) → rCancel (merid north) j k
+                     ; (i = i1) → compPath-filler'
+                                   (cong σS (sym (merid (ptSn (suc m)))))
+                                   (rCancel (merid north)) r j k
+                     ; (j = i0) → σS (compPath-filler (merid a)
+                                        (sym (merid (ptSn (suc m)))) (~ r) i) k
+                     ; (j = i1) → σS (σS a k) (~ i)
+                     ; (k = i0) → rCancel (merid north) (~ j) (~ i)
+                     ; (k = i1) → rCancel (merid north) (~ j) (~ i)})
+            (master-lem _ (sym (rCancel (merid north)))
+             (λ i k → σS (loop i ⌣S a) k) k j i)
+
+    pp : (x : S¹) (a : S₊ (suc m))
+      → PathP (λ i → IdL⌣S x i ≡ ⌣S-south x i) (cong (x ⌣S_) (merid a))
+          (cong invSphere' (σS (x ⌣S a)))
+    pp x a = PathP-main x a
+        ▷ (rUnit _
+       ∙∙ cong (sym (σS (x ⌣S a)) ∙_) (sym (rCancel (merid north)))
+       ∙∙ sym (cong-∙ invSphere' (merid (x ⌣S a)) (sym (merid north))))
+
+    main-lem : (x : S¹) (y : S₊ (2 + m))
+      → (x ⌣S y)
+        ≡ invSphere' (sphereFun↑ (λ x₂ x₃ → x₃ ⌣S x₂) y x)
+    main-lem x north = IdL⌣S x
+    main-lem x south = ⌣S-south x
+    main-lem x (merid a i) j = pp x a j i
+
+  comm⌣S-lem : {n m : ℕ}
+    → ((x : S₊ (suc n)) (y : S₊ (suc (suc m)))
+       → (x ⌣S y) ≡ subst S₊ (+-comm (suc (suc m)) (suc n))
+                              (-S^ (suc (suc m) · (suc n)) (y ⌣S x)))
+    → (((x : S₊ (suc m)) (y : S₊ (suc (suc n)))
+       → (x ⌣S y) ≡ subst S₊ (+-comm (suc (suc n)) (suc m))
+                              (-S^ ((suc (suc n)) · (suc m)) (y ⌣S x))))
+    → (((x : S₊ (suc n)) (y : S₊ (suc m))
+       → (y ⌣S x) ≡ subst S₊ (sym (+-comm (suc m) (suc n)))
+                              (-S^ ((suc n) · (suc m)) (x ⌣S y))))
+    → (x : S₊ (suc (suc n))) (y : S₊ (suc (suc m)))
+    → (x ⌣S y) ≡ subst S₊ (+-comm (suc (suc m)) (suc (suc n)))
+                           (-S^ (suc (suc m) · (suc (suc n))) (y ⌣S x))
+  comm⌣S-lem {n = n} {m = m} ind1 ind2 ind3 x y =
+       cong (λ (s : S₊ (suc n) → S₊ (suc (suc m))
+            → S₊ ((suc n) + (suc (suc m)))) → sphereFun↑ s x y)
+            (funExt (λ x → funExt λ y
+            → ind1 x y))
+    ∙ (sphereFun↑-subst _ _ (+-comm (suc (suc m)) (suc n))
+                            (λ x y → -S^ (suc (suc m) · suc n) (y ⌣S x)) x y
+    ∙ cong (subst S₊ (cong suc (+-comm (suc (suc m)) (suc n))))
+        (sphereFun↑^ (suc (suc m) · suc n)  (λ x y → y ⌣S x) x y
+        ∙ cong (-S^ (suc (suc m) · suc n))
+           (cong (λ (s : S₊ (suc n) → S₊ (suc (suc m))
+                  → S₊ ((suc (suc m)) + (suc n))) → sphereFun↑ s x y)
+             (funExt (λ x → funExt λ y →
+              cong (λ (s : S₊ (suc m) → S₊ (suc n) → S₊ ((suc m) + (suc n)))
+                    → sphereFun↑ s y x)
+               (funExt λ x
+                      → funExt λ y
+                       → ind3 y x)
+            ∙ sphereFun↑-subst _ _ (sym (+-comm (suc m) (suc n)))
+                (λ x y → -S^ (suc n · suc m) (y ⌣S x)) y x
+            ∙ cong (subst S₊ (cong suc (sym (+-comm (suc m) (suc n)))))
+                   (sphereFun↑^ (suc n · suc m) (λ x y → (y ⌣S x)) y x)))
+            ∙ sphereFun↑-subst _ _  (sym (cong suc (+-comm (suc m) (suc n))))
+                ((λ x₁ x₂ →
+                 (-S^ (suc n · suc m)
+                      (sphereFun↑ (λ x₃ y₁ → y₁ ⌣S x₃) x₂ x₁)))) x y
+            ∙ cong (subst S₊ (sym (cong (suc ∘ suc) (+-comm (suc m) (suc n)))))
+                     ((sphereFun↑^ (suc n · suc m)
+                       ((λ x₁ x₂ → (sphereFun↑ (λ x₃ y₁ → y₁ ⌣S x₃) x₂ x₁))) x y
+                    ∙ cong (-S^ (suc n · suc m)) (lem₃ x y)))))
+    ∙ big-lem (suc n) (suc m)
+        _ (λ i → suc (suc (+-comm (suc m) (suc n) (~ i))))
+        _ (λ i → suc (+-comm (suc (suc m)) (suc n) i)) _
+        (sym (+-comm (suc (suc m)) (suc (suc n))))
+        (λ i → suc (+-comm (suc (suc n)) (suc m) i))
+        (sphereFun↑ (λ x₁ y₂ → y₂ ⌣S x₁) y x)
+    ∙ sym (cong (subst S₊ (+-comm (suc (suc m)) (suc (suc n))))
+           (cong (-S^ (suc (suc m) · suc (suc n)))
+            ((λ i → sphereFun↑ (λ x y → ind2 x y i) y x)
+           ∙ sphereFun↑-subst _ _
+               (+-comm (suc (suc n)) (suc m))
+                 (λ x y → -S^ (suc (suc n) · suc m) (y ⌣S x)) y x
+           ∙ cong (subst S₊ (cong suc (+-comm (suc (suc n)) (suc m))))
+              (sphereFun↑^ (suc (suc n) · suc m) (λ x y → y ⌣S x) y x)))))
+      where
+      ℕ-p : (n m : ℕ)
+        → (suc m · suc n + suc n · m)
+         ≡ (m + m) + ((n · m + n · m) + (suc n))
+      ℕ-p n m =
+        cong suc (cong (_+ (m + n · m)) (cong (n +_) (·-comm m (suc n)))
+               ∙ sym (+-assoc n (m + n · m) _)
+               ∙ +-comm n _
+               ∙ cong (_+ n) (+-assoc (m + n · m) m (n · m)
+                           ∙ cong (_+ (n · m))
+                                (sym (+-assoc m (n · m) m)
+                              ∙ cong (m +_) (+-comm (n · m) m)
+                              ∙ +-assoc m m (n · m))
+                              ∙ sym (+-assoc (m + m) (n · m) (n · m))))
+        ∙ sym (+-suc (m + m + (n · m + n · m)) n)
+        ∙ sym (+-assoc (m + m) (n · m + n · m) (suc n))
+
+      ℕ-p2 : (n m : ℕ) → suc m · n + n · m + 1 ≡ (((n · m) + (n · m)) + (suc n))
+      ℕ-p2 n m = (λ _ → ((n + m · n) + n · m) + 1)
+        ∙ cong (_+ 1) (sym (+-assoc n (m · n) (n · m))
+                      ∙ (λ i → +-comm n ((·-comm m n i) + n · m) i))
+        ∙ sym (+-assoc (n · m + n · m) n 1)
+        ∙ cong (n · m + n · m +_) (+-comm n 1)
+
+      big-lem : (n m : ℕ) {x : ℕ} (y : ℕ) (p : x ≡ y) (z : ℕ) (s : y ≡ z)
+                (d : ℕ) (r : z ≡ d) (t : x ≡ d)
+         (a : S₊ x)
+        → subst S₊ s (-S^ (suc m · n) (subst S₊ p (-S^ (n · m) (invSphere' a))))
+        ≡ subst S₊ (sym r)
+            (-S^ (suc m · suc n)
+             (subst S₊ t (-S^ (suc n · m) a)))
+      big-lem n m =
+        J> (J> (J> λ t a
+        → transportRefl _
+        ∙ cong (-S^ (n + m · n)) (transportRefl _)
+        ∙ sym (transportRefl _
+             ∙ cong (-S^ (suc m · suc n))
+                    ((λ i → subst S₊ (isSetℕ _ _ t refl i) (-S^ (m + n · m) a))
+                 ∙ transportRefl (-S^ (m + n · m) a) )
+             ∙ -S^-comp (suc m · suc n) (suc n · m) a
+             ∙ ((funExt⁻ (cong -S^ (ℕ-p n m)) a
+               ∙ (sym (-S^-comp (m + m) _ a)
+                ∙ -S^·2 m (-S^ (n · m + n · m + suc n) a))
+               ∙ funExt⁻ (cong -S^ (sym (ℕ-p2 n m))) a)
+              ∙ sym (-S^-comp (suc m · n + n · m) 1 a)
+              ∙ cong (-S^ (suc m · n + n · m))
+                 (sym (invSphere'≡ a)))
+             ∙ sym (-S^-comp (suc m · n) (n · m) (invSphere' a)) )))
+
+      lem₁ : (x :  S₊ (2 + n))
+        → sphereFun↑ (λ x₂ x₃ → sphereFun↑ (λ x₄ y₁ → y₁ ⌣S x₄) x₃ x₂) x north ≡ north
+      lem₁ north = refl
+      lem₁ south = refl
+      lem₁ (merid a i) j = rCancel (merid north) j i
+
+      lem₂ : (x :  S₊ (2 + n))
+        → sphereFun↑ (λ x₂ x₃
+          → sphereFun↑ (λ x₄ y₁ → y₁ ⌣S x₄) x₃ x₂) x south
+          ≡ north
+      lem₂ north = refl
+      lem₂ south = refl
+      lem₂ (merid a i) j = rCancel (merid north) j i
+
+      lem₃ : (x : S₊ (2 + n)) (y : S₊ (2 + m))
+         → (sphereFun↑ (λ x₁ x₂
+            → sphereFun↑ (λ x₃ y₁ → y₁ ⌣S x₃) x₂ x₁) x y)
+          ≡ invSphere' (sphereFun↑ (λ x₁ y₂ → y₂ ⌣S x₁) y x)
+      lem₃ x north = lem₁ x
+      lem₃ x south = lem₂ x
+      lem₃ x (merid a i) j = h j i
+        where
+        main : (x : _) → PathP (λ i → lem₁ x i ≡ lem₂ x i)
+               (cong (sphereFun↑ (λ x₂ x₃
+                → sphereFun↑ (λ x₄ y₁ → y₁ ⌣S x₄) x₃ x₂) x )
+                 (merid a))
+               (sym (σS (x ⌣S a)))
+        main north = cong sym (sym (rCancel (merid north)))
+        main south = cong sym (sym (rCancel (merid north)))
+        main (merid z i) j k =
+          master-lem _
+            (sym (rCancel (merid north)))
+            (cong (λ x → σS (x ⌣S a)) (merid z)) i j k
+
+        h : PathP (λ i → lem₁ x i ≡ lem₂ x i)
+                  (cong (sphereFun↑
+                   (λ x₂ x₃ → sphereFun↑ (λ x₄ y₁ → y₁ ⌣S x₄) x₃ x₂) x)
+                    (merid a)) (cong invSphere' (σS (x ⌣S a)))
+        h = main x
+          ▷ ((rUnit _ ∙ cong (sym (σS (x ⌣S a)) ∙_)
+              (sym (rCancel (merid north))))
+             ∙ sym (cong-∙ invSphere'
+                (merid (x ⌣S a)) (sym (merid (ptSn _)))))
+
+  comm⌣S₀ : (x : Bool) (m : ℕ) (y : S₊ m)
+    → PathP (λ i → S₊ (+-zero m (~ i))) (x ⌣S y) (y ⌣S x)
+  comm⌣S₀ false =
+    elim+2 (λ { false → refl ; true → refl})
+           (λ { base → refl ; (loop i) → refl})
+      ind
+    where
+    ind : (n : ℕ) →
+        ((y : S₊ (suc n)) →
+         PathP (λ i → S₊ (suc (+-zero n (~ i)))) y (y ⌣S false)) →
+        (y : Susp (S₊ (suc n))) →
+        PathP (λ i → Susp (S₊ (suc (+-zero n (~ i))))) y (y ⌣S false)
+    ind n p north i = north
+    ind n p south i = merid (ptSn (suc (+-zero n (~ i)))) (~ i)
+    ind n p (merid a j) i =
+      comp (λ k → Susp (S₊ (suc (+-zero n (~ i ∨ ~ k)))))
+           (λ r →
+           λ {(i = i0) → merid a j
+            ; (i = i1) →
+              σ (S₊∙ (suc (+-zero n (~ r)))) (p a r) j
+            ; (j = i0) → north
+            ; (j = i1) → merid (ptSn (suc (+-zero n (~ i ∨ ~ r)))) (~ i)})
+           (compPath-filler (merid a) (sym (merid (ptSn _))) i j)
+  comm⌣S₀ true m y = (λ i → ptSn (+-zero m (~ i))) ▷ (sym (IdL⌣S y))
+
+-- Graded commutativity
+comm⌣S : {n m : ℕ} (x : S₊ n) (y : S₊ m)
+  → (x ⌣S y) ≡ subst S₊ (+-comm m n) (-S^ (m · n) (y ⌣S x))
+comm⌣S {n = zero} {m = m} x y =
+  sym (fromPathP (symP {A = λ i → S₊ (+-zero m i)} ((comm⌣S₀ x m y))))
+  ∙ sym (cong (subst S₊ (+-zero m))
+        ((λ i → -S^ (0≡m·0 m (~ i)) (y ⌣S x))))
+comm⌣S {n = suc n} {m = zero} x y =
+  sym (fromPathP (comm⌣S₀ y (suc n) x))
+  ∙ (λ i → subst S₊ (isSetℕ _ _
+             (sym (+-comm (suc n) zero))
+             (+-comm zero (suc n)) i) (y ⌣S x))
+comm⌣S {n = suc zero} {m = suc m} x y =
+    comm⌣S₁ x y
+  ∙ cong (subst S₊ (+-comm (suc m) 1))
+     λ i → -S^ (·-identityʳ (suc m) (~ i)) (y ⌣S x)
+comm⌣S {n = suc (suc n)} {m = suc zero} x y =
+    sym (substSubst⁻ S₊ (+-comm 1 (suc (suc n))) (x ⌣S y))
+  ∙ cong (subst S₊ (+-comm 1 (suc (suc n))))
+        ((λ i → subst S₊ (isSetℕ _ _
+           (sym (+-comm 1 (suc (suc n)))) (+-comm (suc (suc n)) 1) i)
+           (x ⌣S y))
+      ∙ (sym (sym
+         (-S^-transp _ (+-comm (suc (suc n)) 1) (1 · suc (suc n))
+           (-S^ (suc (suc n)) (x ⌣S y)))
+            ∙ cong (subst S₊ (+-comm (suc (suc n)) 1))
+               (cong (-S^ (1 · suc (suc n)))
+                 (λ i → -S^ (·-identityˡ (suc (suc n)) (~ i)) (x ⌣S y))
+              ∙ -S^² (1 · suc (suc n)) (x ⌣S y)))))
+  ∙ sym (cong (subst S₊ (+-comm 1 (suc (suc n)))
+             ∘ -S^ (1 · suc (suc n))) (comm⌣S₁ y x))
+comm⌣S {n = suc (suc n)} {m = suc (suc m)} x y =
+  comm⌣S-lem comm⌣S comm⌣S
+    (λ x y → (sym (cong (subst S₊ (sym (+-comm (suc m) (suc n))))
+               (sym (-S^-transp _ (+-comm (suc m) (suc n))
+                 (suc n · suc m) (-S^ (suc m · suc n) (y ⌣S x)))
+             ∙ cong (subst S₊ (+-comm (suc m) (suc n)))
+                (cong (-S^ (suc n · suc m))
+                    (λ i → -S^ (·-comm (suc m) (suc n) i) (y ⌣S x))
+                  ∙ -S^² (suc n · suc m) (y ⌣S x) ))
+            ∙ subst⁻Subst S₊ (+-comm (suc m) (suc n)) (y ⌣S x) ))
+      ∙ sym (cong (subst S₊ (sym (+-comm (suc m) (suc n)))
+                 ∘ -S^ (suc n · suc m))
+         (comm⌣S x y))) x y
+
\ No newline at end of file diff --git a/Cubical.HITs.Sn.Properties.html b/Cubical.HITs.Sn.Properties.html index 472ef23c6..8492c4006 100644 --- a/Cubical.HITs.Sn.Properties.html +++ b/Cubical.HITs.Sn.Properties.html @@ -21,451 +21,465 @@ open import Cubical.HITs.Susp open import Cubical.HITs.Truncation open import Cubical.HITs.PropositionalTruncation as PT hiding (rec ; elim) -open import Cubical.Homotopy.Connected -open import Cubical.HITs.Join renaming (joinS¹S¹→S³ to joinS¹S¹→S3) -open import Cubical.Data.Bool hiding (elim) - -private - variable - ℓ : Level - -open Iso - -σSn : (n : ℕ) → S₊ n → Path (S₊ (suc n)) (ptSn (suc n)) (ptSn (suc n)) -σSn zero false = loop -σSn zero true = refl -σSn (suc n) x = toSusp (S₊∙ (suc n)) x - -IsoSucSphereSusp : (n : ℕ) → Iso (S₊ (suc n)) (Susp (S₊ n)) -IsoSucSphereSusp zero = S¹IsoSuspBool -IsoSucSphereSusp (suc n) = idIso - -IsoSucSphereSusp∙ : (n : ℕ) - → Iso.inv (IsoSucSphereSusp n) north ≡ ptSn (suc n) -IsoSucSphereSusp∙ zero = refl -IsoSucSphereSusp∙ (suc n) = refl - -suspFunS∙ : {n : ℕ} → (S₊ n → S₊ n) → S₊∙ (suc n) →∙ S₊∙ (suc n) -suspFunS∙ {n = zero} f = - (λ x → Iso.inv S¹IsoSuspBool (suspFun f (Iso.fun S¹IsoSuspBool x))) , refl -suspFunS∙ {n = suc n} f = suspFun f , refl - -suspFunS∙Id : {n : ℕ} → suspFunS∙ (idfun (S₊ n)) ≡ idfun∙ _ -suspFunS∙Id {n = zero} = ΣPathP ((funExt (λ { base → refl - ; (loop i) j → help j i})) , refl) - where - help : cong (fst (suspFunS∙ (idfun (S₊ zero)))) loop ≡ loop - help = (λ j → cong (λ x → SuspBool→S¹ (suspFunIdFun {A = Bool} j - (S¹→SuspBool x))) loop) - ∙ λ i j → S¹→SuspBool→S¹ (loop j) i -suspFunS∙Id {n = suc n} = ΣPathP (suspFunIdFun , refl) - --- Elimination principles for spheres -sphereElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isOfHLevel (suc n) (A x)) - → A (ptSn (suc n)) - → (x : S₊ (suc n)) → A x -sphereElim zero hlev pt = toPropElim hlev pt -sphereElim (suc n) hlev pt north = pt -sphereElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt -sphereElim (suc n) {A = A} hlev pt (merid a i) = - sphereElim n {A = λ a → PathP (λ i → A (merid a i)) pt (subst A (merid (ptSn (suc n))) pt)} - (λ a → isOfHLevelPathP' (suc n) (hlev south) _ _) - (λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∧ j))) (~ i) pt) - a i - -sphereElim2 : ∀ {ℓ} (n : ℕ) {A : (S₊ (suc n)) → (S₊ (suc n)) → Type ℓ} - → ((x y : S₊ (suc n)) → isOfHLevel (suc n) (A x y)) - → A (ptSn (suc n)) (ptSn (suc n)) - → (x y : S₊ (suc n)) → A x y -sphereElim2 n hlev pt = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → hlev _ _) - (sphereElim n (hlev _ ) pt) - -private - compPath-lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y) - → PathP (λ i → (p ∙ sym q) i ≡ y) p q - compPath-lem {y = y} p q i j = - hcomp (λ k → λ { (i = i0) → p j - ; (i = i1) → q (~ k ∨ j) - ; (j = i1) → y }) - (p (j ∨ i)) - -sphereElim' : (n : ℕ) {A : S₊ n → Type ℓ} → - ((x : S₊ n) → isOfHLevel n (A x)) → - A (ptSn n) → (x : S₊ n) → A x -sphereElim' zero st _ x = st x .fst -sphereElim' (suc n) = sphereElim n - -sphereToPropElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isProp (A x)) - → A (ptSn (suc n)) - → (x : S₊ (suc n)) → A x -sphereToPropElim zero = toPropElim -sphereToPropElim (suc n) hlev pt north = pt -sphereToPropElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt -sphereToPropElim (suc n) {A = A} hlev pt (merid a i) = - isProp→PathP {B = λ i → A (merid a i)} (λ _ → hlev _) pt (subst A (merid (ptSn (suc n))) pt) i - --- Elimination rule for fibrations (x : Sⁿ) → (y : Sᵐ) → A x y of h-Level (n + m). --- The following principle is just the special case of the "Wedge Connectivity Lemma" --- for spheres (See Cubical.Homotopy.WedgeConnectivity or chapter 8.6 in the HoTT book). --- We prove it directly here for three reasons: --- (i) it should perform better --- (ii) we get a slightly stronger statement for spheres: one of the homotopies will, by design, be refl --- (iii) the fact that the two homotopies only differ by (composition with) the homotopy leftFunction(base) ≡ rightFunction(base) --- is close to trivial - -wedgeconFun : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} - → ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y)) - → (f : (x : _) → A (ptSn (suc n)) x) - → (g : (x : _) → A x (ptSn (suc m))) - → (g (ptSn (suc n)) ≡ f (ptSn (suc m))) - → (x : S₊ (suc n)) (y : S₊ (suc m)) → A x y -wedgeconLeft : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} - → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))) - → (f : (x : _) → A (ptSn (suc n)) x) - → (g : (x : _) → A x (ptSn (suc m))) - → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m))) - → (x : _) → wedgeconFun n m hLev f g hom (ptSn (suc n)) x ≡ f x -wedgeconRight : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} - → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))) - → (f : (x : _) → A (ptSn (suc n)) x) - → (g : (x : _) → A x (ptSn (suc m))) - → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m))) - → (x : _) → wedgeconFun n m hLev f g hom x (ptSn (suc m)) ≡ g x -wedgeconFun zero zero {A = A} hlev f g hom = F - where - helper : SquareP (λ i j → A (loop i) (loop j)) (cong f loop) (cong f loop) - (λ i → hcomp (λ k → λ { (i = i0) → hom k - ; (i = i1) → hom k }) - (g (loop i))) - λ i → hcomp (λ k → λ { (i = i0) → hom k - ; (i = i1) → hom k }) - (g (loop i)) - helper = toPathP (isOfHLevelPathP' 1 (hlev _ _) _ _ _ _) - - F : (x y : S¹) → A x y - F base y = f y - F (loop i) base = hcomp (λ k → λ { (i = i0) → hom k - ; (i = i1) → hom k }) - (g (loop i)) - F (loop i) (loop j) = helper i j - -wedgeconFun zero (suc m) {A = A} hlev f g hom = F₀ - module _ where - transpLemma₀ : (x : S₊ (suc m)) → transport (λ i₁ → A base (merid x i₁)) (g base) ≡ f south - transpLemma₀ x = cong (transport (λ i₁ → A base (merid x i₁))) - hom - ∙ (λ i → transp (λ j → A base (merid x (i ∨ j))) i - (f (merid x i))) - - pathOverMerid₀ : (x : S₊ (suc m)) → PathP (λ i₁ → A base (merid x i₁)) - (g base) - (transport (λ i₁ → A base (merid (ptSn (suc m)) i₁)) - (g base)) - pathOverMerid₀ x i = hcomp (λ k → λ { (i = i0) → g base - ; (i = i1) → (transpLemma₀ x ∙ sym (transpLemma₀ (ptSn (suc m)))) k}) - (transp (λ i₁ → A base (merid x (i₁ ∧ i))) (~ i) - (g base)) - - pathOverMeridId₀ : pathOverMerid₀ (ptSn (suc m)) ≡ λ i → transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) - (g base) - pathOverMeridId₀ = - (λ j i → hcomp (λ k → λ {(i = i0) → g base - ; (i = i1) → rCancel (transpLemma₀ (ptSn (suc m))) j k}) - (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) - (g base))) - ∙ λ j i → hfill (λ k → λ { (i = i0) → g base - ; (i = i1) → transport (λ i₁ → A base (merid (ptSn (suc m)) i₁)) - (g base)}) - (inS (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) - (g base))) (~ j) - - indStep₀ : (x : _) (a : _) → PathP (λ i → A x (merid a i)) - (g x) - (subst (λ y → A x y) (merid (ptSn (suc m))) - (g x)) - indStep₀ = wedgeconFun zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _) - pathOverMerid₀ - (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) - (g a)) - (sym pathOverMeridId₀) - - F₀ : (x : S¹) (y : Susp (S₊ (suc m))) → A x y - F₀ x north = g x - F₀ x south = subst (λ y → A x y) (merid (ptSn (suc m))) (g x) - F₀ x (merid a i) = indStep₀ x a i -wedgeconFun (suc n) m {A = A} hlev f g hom = F₁ - module _ where - transpLemma₁ : (x : S₊ (suc n)) → transport (λ i₁ → A (merid x i₁) (ptSn (suc m))) (f (ptSn (suc m))) ≡ g south - transpLemma₁ x = cong (transport (λ i₁ → A (merid x i₁) (ptSn (suc m)))) - (sym hom) - ∙ (λ i → transp (λ j → A (merid x (i ∨ j)) (ptSn (suc m))) i - (g (merid x i))) - - pathOverMerid₁ : (x : S₊ (suc n)) → PathP (λ i₁ → A (merid x i₁) (ptSn (suc m))) - (f (ptSn (suc m))) - (transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m))) - (f (ptSn (suc m)))) - pathOverMerid₁ x i = hcomp (λ k → λ { (i = i0) → f (ptSn (suc m)) - ; (i = i1) → (transpLemma₁ x ∙ sym (transpLemma₁ (ptSn (suc n)))) k }) - (transp (λ i₁ → A (merid x (i₁ ∧ i)) (ptSn (suc m))) (~ i) - (f (ptSn (suc m)))) - - pathOverMeridId₁ : pathOverMerid₁ (ptSn (suc n)) ≡ λ i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) - (f (ptSn (suc m))) - pathOverMeridId₁ = - (λ j i → hcomp (λ k → λ { (i = i0) → f (ptSn (suc m)) - ; (i = i1) → rCancel (transpLemma₁ (ptSn (suc n))) j k }) - (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) - (f (ptSn (suc m))))) - ∙ λ j i → hfill (λ k → λ { (i = i0) → f (ptSn (suc m)) - ; (i = i1) → transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m))) - (f (ptSn (suc m))) }) - (inS (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) - (f (ptSn (suc m))))) (~ j) - - indStep₁ : (a : _) (y : _) → PathP (λ i → A (merid a i) y) - (f y) - (subst (λ x → A x y) (merid (ptSn (suc n))) - (f y)) - indStep₁ = wedgeconFun n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _) - (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i) - (f a)) - pathOverMerid₁ - pathOverMeridId₁ - - F₁ : (x : Susp (S₊ (suc n))) (y : S₊ (suc m)) → A x y - F₁ north y = f y - F₁ south y = subst (λ x → A x y) (merid (ptSn (suc n))) (f y) - F₁ (merid a i) y = indStep₁ a y i -wedgeconRight zero zero {A = A} hlev f g hom = right - where - right : (x : S¹) → _ - right base = sym hom - right (loop i) j = hcomp (λ k → λ { (i = i0) → hom (~ j ∧ k) - ; (i = i1) → hom (~ j ∧ k) - ; (j = i1) → g (loop i) }) - (g (loop i)) -wedgeconRight zero (suc m) {A = A} hlev f g hom x = refl -wedgeconRight (suc n) m {A = A} hlev f g hom = right - where - lem : (x : _) → indStep₁ n m hlev f g hom x (ptSn (suc m)) ≡ _ - lem = wedgeconRight n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _) - (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i) - (f a)) - (pathOverMerid₁ n m hlev f g hom) - (pathOverMeridId₁ n m hlev f g hom) - - right : (x : Susp (S₊ (suc n))) → _ ≡ g x - right north = sym hom - right south = cong (subst (λ x → A x (ptSn (suc m))) - (merid (ptSn (suc n)))) - (sym hom) - ∙ λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∨ j)) (ptSn (suc m))) i - (g (merid (ptSn (suc n)) i)) - right (merid a i) j = - hcomp (λ k → λ { (i = i0) → hom (~ j) - ; (i = i1) → transpLemma₁ n m hlev f g hom (ptSn (suc n)) j - ; (j = i0) → lem a (~ k) i - ; (j = i1) → g (merid a i)}) - (hcomp (λ k → λ { (i = i0) → hom (~ j) - ; (i = i1) → compPath-lem (transpLemma₁ n m hlev f g hom a) (transpLemma₁ n m hlev f g hom (ptSn (suc n))) k j - ; (j = i1) → g (merid a i)}) - (hcomp (λ k → λ { (i = i0) → hom (~ j) - ; (j = i0) → transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i) - (f (ptSn (suc m))) - ; (j = i1) → transp (λ j → A (merid a (i ∧ (j ∨ k))) (ptSn (suc m))) (k ∨ ~ i) - (g (merid a (i ∧ k))) }) - (transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i) - (hom (~ j))))) -wedgeconLeft zero zero {A = A} hlev f g hom x = refl -wedgeconLeft zero (suc m) {A = A} hlev f g hom = help - where - left₁ : (x : _) → indStep₀ m hlev f g hom base x ≡ _ - left₁ = wedgeconLeft zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _) - (pathOverMerid₀ m hlev f g hom) - (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) - (g a)) - (sym (pathOverMeridId₀ m hlev f g hom)) - - help : (x : S₊ (suc (suc m))) → _ - help north = hom - help south = cong (subst (A base) (merid (ptSn (suc m)))) hom - ∙ λ i → transp (λ j → A base (merid (ptSn (suc m)) (i ∨ j))) i - (f (merid (ptSn (suc m)) i)) - help (merid a i) j = - hcomp (λ k → λ { (i = i0) → hom j - ; (i = i1) → transpLemma₀ m hlev f g hom (ptSn (suc m)) j - ; (j = i0) → left₁ a (~ k) i - ; (j = i1) → f (merid a i)}) - (hcomp (λ k → λ { (i = i0) → hom j - ; (i = i1) → compPath-lem (transpLemma₀ m hlev f g hom a) - (transpLemma₀ m hlev f g hom (ptSn (suc m))) k j - ; (j = i1) → f (merid a i)}) - (hcomp (λ k → λ { (i = i0) → hom j - ; (j = i0) → transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i) - (g base) - ; (j = i1) → transp (λ j → A base (merid a (i ∧ (j ∨ k)))) (k ∨ ~ i) - (f (merid a (i ∧ k)))}) - (transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i) - (hom j)))) -wedgeconLeft (suc n) m {A = A} hlev f g hom _ = refl - ----------- Connectedness ----------- - -sphereConnected : (n : HLevel) → isConnected (suc n) (S₊ n) -sphereConnected n = ∣ ptSn n ∣ , elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) - (λ a → sym (spoke ∣_∣ (ptSn n)) ∙ spoke ∣_∣ a) - -sphereToTrunc : (n : ℕ) {A : S₊ n → Type ℓ} - → ((x : S₊ n) → hLevelTrunc (suc n) (A x)) - → ∥ ((x : _) → A x) ∥₁ -sphereToTrunc zero {A = A} indr = - rec squash₁ (λ p → rec squash₁ - (λ q → ∣ (λ { false → q ; true → p}) ∣₁) - (indr false)) (indr true) -sphereToTrunc (suc zero) {A = A} indr = - lem (indr base) (cong indr loop) - where - lem : (x : hLevelTrunc 2 (A base)) - → PathP (λ i → hLevelTrunc 2 (A (loop i))) x x - → ∥ ((x : S¹) → A x) ∥₁ - lem = elim (λ _ → isSetΠ λ _ → isProp→isSet squash₁) λ a p - → rec squash₁ (λ q → ∣ (λ { base → a - ; (loop i) → toPathP {A = λ i → A (loop i)} q i}) ∣₁) - (PathIdTruncIso 1 .Iso.fun - (fromPathP p)) -sphereToTrunc (suc (suc n)) {A = A} indr = - lem (sphereToTrunc (suc n)) (indr north) (indr south) - λ a → cong indr (merid a) - where - lem : ({A : S₊ (suc n) → Type _} → - ((i : S₊ (suc n)) → hLevelTrunc (suc (suc n)) (A i)) → - ∥ ((x : S₊ (suc n)) → A x) ∥₁) - → (x : hLevelTrunc (3 + n) (A north)) - (y : hLevelTrunc (3 + n) (A south)) - → ((a : _) → PathP (λ i → hLevelTrunc (3 + n) (A (merid a i))) x y) - → ∥ ((x : S₊ (2 + n)) → A x) ∥₁ - lem indr = - elim (λ _ → isOfHLevelΠ2 (3 + n) - λ _ _ → isProp→isOfHLevelSuc (2 + n) squash₁) - λ a → elim (λ _ → isOfHLevelΠ (3 + n) - λ _ → isProp→isOfHLevelSuc (2 + n) squash₁) - λ b → λ f → - PT.map (λ ma → λ { north → a - ; south → b - ; (merid a i) → ma a i}) - (indr {A = λ x → PathP (λ i → A (merid x i)) a b} - λ x → rec (isOfHLevelTrunc (2 + n)) - (λ p → ∣ toPathP p ∣) - (Iso.fun (PathIdTruncIso _) (fromPathP (f x)))) - --- The fact that path spaces of Sn are connected can be proved directly for Sⁿ. --- (Unfortunately, this does not work for higher paths) -pathIdTruncSⁿ : (n : ℕ) (x y : S₊ (suc n)) - → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣ - → hLevelTrunc (suc n) (x ≡ y) -pathIdTruncSⁿ n = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) - (sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) - λ _ → ∣ refl ∣) - -pathIdTruncSⁿ⁻ : (n : ℕ) (x y : S₊ (suc n)) - → hLevelTrunc (suc n) (x ≡ y) - → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣ -pathIdTruncSⁿ⁻ n x y = rec (isOfHLevelTrunc (2 + n) _ _) - (J (λ y _ → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣) refl) - -pathIdTruncSⁿretract : (n : ℕ) (x y : S₊ (suc n)) → (p : hLevelTrunc (suc n) (x ≡ y)) → pathIdTruncSⁿ n x y (pathIdTruncSⁿ⁻ n x y p) ≡ p -pathIdTruncSⁿretract n = - sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) - λ y → elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) - (J (λ y p → pathIdTruncSⁿ n (ptSn (suc n)) y (pathIdTruncSⁿ⁻ n (ptSn (suc n)) y ∣ p ∣) ≡ ∣ p ∣) - (cong (pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n))) (transportRefl refl) ∙ pm-help n)) - where - pm-help : (n : ℕ) → pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n)) refl ≡ ∣ refl ∣ - pm-help zero = refl - pm-help (suc n) = refl - -isConnectedPathSⁿ : (n : ℕ) (x y : S₊ (suc n)) → isConnected (suc n) (x ≡ y) -isConnectedPathSⁿ n x y = - isContrRetract - (pathIdTruncSⁿ⁻ n x y) - (pathIdTruncSⁿ n x y) - (pathIdTruncSⁿretract n x y) - ((isContr→isProp (sphereConnected (suc n)) ∣ x ∣ ∣ y ∣) - , isProp→isSet (isContr→isProp (sphereConnected (suc n))) _ _ _) - --- Some lemmas on the H space structure on S¹ -rUnitS¹ : (x : S¹) → x * base ≡ x -rUnitS¹ base = refl -rUnitS¹ (loop i₁) = refl - -commS¹ : (a x : S¹) → a * x ≡ x * a -commS¹ = wedgeconFun _ _ (λ _ _ → isGroupoidS¹ _ _) - (sym ∘ rUnitS¹) - rUnitS¹ - refl - -assocS¹ : (x y z : S¹) → x * (y * z) ≡ (x * y) * z -assocS¹ = wedgeconFun _ _ (λ _ _ → isSetΠ λ _ → isGroupoidS¹ _ _) - (λ _ _ → refl) - (λ x z i → (rUnitS¹ x (~ i)) * z) - refl - -invLooperDistr : (x y : S¹) → invLooper (x * y) ≡ invLooper x * invLooper y -invLooperDistr = - wedgeconFun 0 0 (λ _ _ → isGroupoidS¹ _ _) (λ _ → refl) - (λ x → cong invLooper (rUnitS¹ x) ∙ sym (rUnitS¹ (invLooper x))) - (sym (rUnit refl)) - -SuspS¹-hom : (a x : S¹) - → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _) - (cong ∣_∣ₕ (σSn 1 (a * x))) - (cong ∣_∣ₕ (σSn 1 a) - ∙ (cong ∣_∣ₕ (σSn 1 x))) -SuspS¹-hom = wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 4 _ _ _ _) - (λ x → lUnit _ - ∙ cong (_∙ cong ∣_∣ₕ (σSn 1 x)) - (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))) - (λ x → (λ i → cong ∣_∣ₕ (σSn 1 (rUnitS¹ x i))) - ∙∙ rUnit _ - ∙∙ cong (cong ∣_∣ₕ (σSn 1 x) ∙_) - (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))) - (sym (l (cong ∣_∣ₕ (σSn 1 base)) - (cong (cong ∣_∣ₕ) (sym (rCancel (merid base)))))) - where - l : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (P : refl ≡ p) - → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P - l p = J (λ p P → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P) refl - -rCancelS¹ : (x : S¹) → ptSn 1 ≡ x * (invLooper x) -rCancelS¹ base = refl -rCancelS¹ (loop i) j = - hcomp (λ r → λ {(i = i0) → base ; (i = i1) → base ; (j = i0) → base}) - base - -SuspS¹-inv : (x : S¹) → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _) - (cong ∣_∣ₕ (σSn 1 (invLooper x))) - (cong ∣_∣ₕ (sym (σSn 1 x))) -SuspS¹-inv x = (lUnit _ - ∙∙ cong (_∙ cong ∣_∣ₕ (σSn 1 (invLooper x))) - (sym (lCancel (cong ∣_∣ₕ (σSn 1 x)))) - ∙∙ sym (assoc _ _ _)) - ∙∙ cong (sym (cong ∣_∣ₕ (σSn 1 x)) ∙_) lem - ∙∙ (assoc _ _ _ - ∙∙ cong (_∙ (cong ∣_∣ₕ (sym (σSn 1 x)))) - (lCancel (cong ∣_∣ₕ (σSn 1 x))) - ∙∙ sym (lUnit _)) - where - lem : cong ∣_∣ₕ (σSn 1 x) - ∙ cong ∣_∣ₕ (σSn 1 (invLooper x)) - ≡ cong ∣_∣ₕ (σSn 1 x) - ∙ cong ∣_∣ₕ (sym (σSn 1 x)) - lem = sym (SuspS¹-hom x (invLooper x)) - ∙ ((λ i → cong ∣_∣ₕ (σSn 1 (rCancelS¹ x (~ i)))) - ∙ cong (cong ∣_∣ₕ) (rCancel (merid base))) ∙ sym (rCancel _) - --------------------- join Sⁿ Sᵐ ≃ Sⁿ⁺¹⁺ᵐ ------------------------- -{- +open import Cubical.HITs.SmashProduct.Base +open import Cubical.HITs.Pushout.Base +open import Cubical.Homotopy.Connected +open import Cubical.HITs.Join renaming (joinS¹S¹→S³ to joinS¹S¹→S3) +open import Cubical.Data.Bool hiding (elim) + +private + variable + ℓ : Level + +open Iso + +σSn : (n : ℕ) → S₊ n → Path (S₊ (suc n)) (ptSn (suc n)) (ptSn (suc n)) +σSn zero false = loop +σSn zero true = refl +σSn (suc n) x = toSusp (S₊∙ (suc n)) x + +σS : {n : ℕ} → S₊ n → Path (S₊ (suc n)) (ptSn _) (ptSn _) +σS {n = n} = σSn n + +σS∙ : {n : ℕ} → σS (ptSn n) ≡ refl +σS∙ {n = zero} = refl +σS∙ {n = suc n} = rCancel (merid (ptSn (suc n))) + +IsoSucSphereSusp : (n : ℕ) → Iso (S₊ (suc n)) (Susp (S₊ n)) +IsoSucSphereSusp zero = S¹IsoSuspBool +IsoSucSphereSusp (suc n) = idIso + +IsoSucSphereSusp∙ : (n : ℕ) + → Iso.inv (IsoSucSphereSusp n) north ≡ ptSn (suc n) +IsoSucSphereSusp∙ zero = refl +IsoSucSphereSusp∙ (suc n) = refl + +IsoSucSphereSusp∙' : (n : ℕ) + → Iso.fun (IsoSucSphereSusp n) (ptSn (suc n)) ≡ north +IsoSucSphereSusp∙' zero = refl +IsoSucSphereSusp∙' (suc n) = refl + +suspFunS∙ : {n : ℕ} → (S₊ n → S₊ n) → S₊∙ (suc n) →∙ S₊∙ (suc n) +suspFunS∙ {n = zero} f = + (λ x → Iso.inv S¹IsoSuspBool (suspFun f (Iso.fun S¹IsoSuspBool x))) , refl +suspFunS∙ {n = suc n} f = suspFun f , refl + +suspFunS∙Id : {n : ℕ} → suspFunS∙ (idfun (S₊ n)) ≡ idfun∙ _ +suspFunS∙Id {n = zero} = ΣPathP ((funExt (λ { base → refl + ; (loop i) j → help j i})) , refl) + where + help : cong (fst (suspFunS∙ (idfun (S₊ zero)))) loop ≡ loop + help = (λ j → cong (λ x → SuspBool→S¹ (suspFunIdFun {A = Bool} j + (S¹→SuspBool x))) loop) + ∙ λ i j → S¹→SuspBool→S¹ (loop j) i +suspFunS∙Id {n = suc n} = ΣPathP (suspFunIdFun , refl) + +-- Elimination principles for spheres +sphereElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isOfHLevel (suc n) (A x)) + → A (ptSn (suc n)) + → (x : S₊ (suc n)) → A x +sphereElim zero hlev pt = toPropElim hlev pt +sphereElim (suc n) hlev pt north = pt +sphereElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt +sphereElim (suc n) {A = A} hlev pt (merid a i) = + sphereElim n {A = λ a → PathP (λ i → A (merid a i)) pt (subst A (merid (ptSn (suc n))) pt)} + (λ a → isOfHLevelPathP' (suc n) (hlev south) _ _) + (λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∧ j))) (~ i) pt) + a i + +sphereElim2 : ∀ {ℓ} (n : ℕ) {A : (S₊ (suc n)) → (S₊ (suc n)) → Type ℓ} + → ((x y : S₊ (suc n)) → isOfHLevel (suc n) (A x y)) + → A (ptSn (suc n)) (ptSn (suc n)) + → (x y : S₊ (suc n)) → A x y +sphereElim2 n hlev pt = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → hlev _ _) + (sphereElim n (hlev _ ) pt) + +private + compPath-lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y) + → PathP (λ i → (p ∙ sym q) i ≡ y) p q + compPath-lem {y = y} p q i j = + hcomp (λ k → λ { (i = i0) → p j + ; (i = i1) → q (~ k ∨ j) + ; (j = i1) → y }) + (p (j ∨ i)) + +sphereElim' : (n : ℕ) {A : S₊ n → Type ℓ} → + ((x : S₊ n) → isOfHLevel n (A x)) → + A (ptSn n) → (x : S₊ n) → A x +sphereElim' zero st _ x = st x .fst +sphereElim' (suc n) = sphereElim n + +sphereToPropElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isProp (A x)) + → A (ptSn (suc n)) + → (x : S₊ (suc n)) → A x +sphereToPropElim zero = toPropElim +sphereToPropElim (suc n) hlev pt north = pt +sphereToPropElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt +sphereToPropElim (suc n) {A = A} hlev pt (merid a i) = + isProp→PathP {B = λ i → A (merid a i)} (λ _ → hlev _) pt (subst A (merid (ptSn (suc n))) pt) i + +-- Elimination rule for fibrations (x : Sⁿ) → (y : Sᵐ) → A x y of h-Level (n + m). +-- The following principle is just the special case of the "Wedge Connectivity Lemma" +-- for spheres (See Cubical.Homotopy.WedgeConnectivity or chapter 8.6 in the HoTT book). +-- We prove it directly here for three reasons: +-- (i) it should perform better +-- (ii) we get a slightly stronger statement for spheres: one of the homotopies will, by design, be refl +-- (iii) the fact that the two homotopies only differ by (composition with) the homotopy leftFunction(base) ≡ rightFunction(base) +-- is close to trivial + +wedgeconFun : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} + → ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y)) + → (f : (x : _) → A (ptSn (suc n)) x) + → (g : (x : _) → A x (ptSn (suc m))) + → (g (ptSn (suc n)) ≡ f (ptSn (suc m))) + → (x : S₊ (suc n)) (y : S₊ (suc m)) → A x y +wedgeconLeft : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} + → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))) + → (f : (x : _) → A (ptSn (suc n)) x) + → (g : (x : _) → A x (ptSn (suc m))) + → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m))) + → (x : _) → wedgeconFun n m hLev f g hom (ptSn (suc n)) x ≡ f x +wedgeconRight : (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} + → (hLev : ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))) + → (f : (x : _) → A (ptSn (suc n)) x) + → (g : (x : _) → A x (ptSn (suc m))) + → (hom : g (ptSn (suc n)) ≡ f (ptSn (suc m))) + → (x : _) → wedgeconFun n m hLev f g hom x (ptSn (suc m)) ≡ g x +wedgeconFun zero zero {A = A} hlev f g hom = F + where + helper : SquareP (λ i j → A (loop i) (loop j)) (cong f loop) (cong f loop) + (λ i → hcomp (λ k → λ { (i = i0) → hom k + ; (i = i1) → hom k }) + (g (loop i))) + λ i → hcomp (λ k → λ { (i = i0) → hom k + ; (i = i1) → hom k }) + (g (loop i)) + helper = toPathP (isOfHLevelPathP' 1 (hlev _ _) _ _ _ _) + + F : (x y : S¹) → A x y + F base y = f y + F (loop i) base = hcomp (λ k → λ { (i = i0) → hom k + ; (i = i1) → hom k }) + (g (loop i)) + F (loop i) (loop j) = helper i j + +wedgeconFun zero (suc m) {A = A} hlev f g hom = F₀ + module _ where + transpLemma₀ : (x : S₊ (suc m)) → transport (λ i₁ → A base (merid x i₁)) (g base) ≡ f south + transpLemma₀ x = cong (transport (λ i₁ → A base (merid x i₁))) + hom + ∙ (λ i → transp (λ j → A base (merid x (i ∨ j))) i + (f (merid x i))) + + pathOverMerid₀ : (x : S₊ (suc m)) → PathP (λ i₁ → A base (merid x i₁)) + (g base) + (transport (λ i₁ → A base (merid (ptSn (suc m)) i₁)) + (g base)) + pathOverMerid₀ x i = hcomp (λ k → λ { (i = i0) → g base + ; (i = i1) → (transpLemma₀ x ∙ sym (transpLemma₀ (ptSn (suc m)))) k}) + (transp (λ i₁ → A base (merid x (i₁ ∧ i))) (~ i) + (g base)) + + pathOverMeridId₀ : pathOverMerid₀ (ptSn (suc m)) ≡ λ i → transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) + (g base) + pathOverMeridId₀ = + (λ j i → hcomp (λ k → λ {(i = i0) → g base + ; (i = i1) → rCancel (transpLemma₀ (ptSn (suc m))) j k}) + (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) + (g base))) + ∙ λ j i → hfill (λ k → λ { (i = i0) → g base + ; (i = i1) → transport (λ i₁ → A base (merid (ptSn (suc m)) i₁)) + (g base)}) + (inS (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) + (g base))) (~ j) + + indStep₀ : (x : _) (a : _) → PathP (λ i → A x (merid a i)) + (g x) + (subst (λ y → A x y) (merid (ptSn (suc m))) + (g x)) + indStep₀ = wedgeconFun zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _) + pathOverMerid₀ + (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) + (g a)) + (sym pathOverMeridId₀) + + F₀ : (x : S¹) (y : Susp (S₊ (suc m))) → A x y + F₀ x north = g x + F₀ x south = subst (λ y → A x y) (merid (ptSn (suc m))) (g x) + F₀ x (merid a i) = indStep₀ x a i +wedgeconFun (suc n) m {A = A} hlev f g hom = F₁ + module _ where + transpLemma₁ : (x : S₊ (suc n)) → transport (λ i₁ → A (merid x i₁) (ptSn (suc m))) (f (ptSn (suc m))) ≡ g south + transpLemma₁ x = cong (transport (λ i₁ → A (merid x i₁) (ptSn (suc m)))) + (sym hom) + ∙ (λ i → transp (λ j → A (merid x (i ∨ j)) (ptSn (suc m))) i + (g (merid x i))) + + pathOverMerid₁ : (x : S₊ (suc n)) → PathP (λ i₁ → A (merid x i₁) (ptSn (suc m))) + (f (ptSn (suc m))) + (transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m))) + (f (ptSn (suc m)))) + pathOverMerid₁ x i = hcomp (λ k → λ { (i = i0) → f (ptSn (suc m)) + ; (i = i1) → (transpLemma₁ x ∙ sym (transpLemma₁ (ptSn (suc n)))) k }) + (transp (λ i₁ → A (merid x (i₁ ∧ i)) (ptSn (suc m))) (~ i) + (f (ptSn (suc m)))) + + pathOverMeridId₁ : pathOverMerid₁ (ptSn (suc n)) ≡ λ i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) + (f (ptSn (suc m))) + pathOverMeridId₁ = + (λ j i → hcomp (λ k → λ { (i = i0) → f (ptSn (suc m)) + ; (i = i1) → rCancel (transpLemma₁ (ptSn (suc n))) j k }) + (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) + (f (ptSn (suc m))))) + ∙ λ j i → hfill (λ k → λ { (i = i0) → f (ptSn (suc m)) + ; (i = i1) → transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m))) + (f (ptSn (suc m))) }) + (inS (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i) + (f (ptSn (suc m))))) (~ j) + + indStep₁ : (a : _) (y : _) → PathP (λ i → A (merid a i) y) + (f y) + (subst (λ x → A x y) (merid (ptSn (suc n))) + (f y)) + indStep₁ = wedgeconFun n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _) + (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i) + (f a)) + pathOverMerid₁ + pathOverMeridId₁ + + F₁ : (x : Susp (S₊ (suc n))) (y : S₊ (suc m)) → A x y + F₁ north y = f y + F₁ south y = subst (λ x → A x y) (merid (ptSn (suc n))) (f y) + F₁ (merid a i) y = indStep₁ a y i +wedgeconRight zero zero {A = A} hlev f g hom = right + where + right : (x : S¹) → _ + right base = sym hom + right (loop i) j = hcomp (λ k → λ { (i = i0) → hom (~ j ∧ k) + ; (i = i1) → hom (~ j ∧ k) + ; (j = i1) → g (loop i) }) + (g (loop i)) +wedgeconRight zero (suc m) {A = A} hlev f g hom x = refl +wedgeconRight (suc n) m {A = A} hlev f g hom = right + where + lem : (x : _) → indStep₁ n m hlev f g hom x (ptSn (suc m)) ≡ _ + lem = wedgeconRight n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _) + (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i) + (f a)) + (pathOverMerid₁ n m hlev f g hom) + (pathOverMeridId₁ n m hlev f g hom) + + right : (x : Susp (S₊ (suc n))) → _ ≡ g x + right north = sym hom + right south = cong (subst (λ x → A x (ptSn (suc m))) + (merid (ptSn (suc n)))) + (sym hom) + ∙ λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∨ j)) (ptSn (suc m))) i + (g (merid (ptSn (suc n)) i)) + right (merid a i) j = + hcomp (λ k → λ { (i = i0) → hom (~ j) + ; (i = i1) → transpLemma₁ n m hlev f g hom (ptSn (suc n)) j + ; (j = i0) → lem a (~ k) i + ; (j = i1) → g (merid a i)}) + (hcomp (λ k → λ { (i = i0) → hom (~ j) + ; (i = i1) → compPath-lem (transpLemma₁ n m hlev f g hom a) (transpLemma₁ n m hlev f g hom (ptSn (suc n))) k j + ; (j = i1) → g (merid a i)}) + (hcomp (λ k → λ { (i = i0) → hom (~ j) + ; (j = i0) → transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i) + (f (ptSn (suc m))) + ; (j = i1) → transp (λ j → A (merid a (i ∧ (j ∨ k))) (ptSn (suc m))) (k ∨ ~ i) + (g (merid a (i ∧ k))) }) + (transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i) + (hom (~ j))))) +wedgeconLeft zero zero {A = A} hlev f g hom x = refl +wedgeconLeft zero (suc m) {A = A} hlev f g hom = help + where + left₁ : (x : _) → indStep₀ m hlev f g hom base x ≡ _ + left₁ = wedgeconLeft zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _) + (pathOverMerid₀ m hlev f g hom) + (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i) + (g a)) + (sym (pathOverMeridId₀ m hlev f g hom)) + + help : (x : S₊ (suc (suc m))) → _ + help north = hom + help south = cong (subst (A base) (merid (ptSn (suc m)))) hom + ∙ λ i → transp (λ j → A base (merid (ptSn (suc m)) (i ∨ j))) i + (f (merid (ptSn (suc m)) i)) + help (merid a i) j = + hcomp (λ k → λ { (i = i0) → hom j + ; (i = i1) → transpLemma₀ m hlev f g hom (ptSn (suc m)) j + ; (j = i0) → left₁ a (~ k) i + ; (j = i1) → f (merid a i)}) + (hcomp (λ k → λ { (i = i0) → hom j + ; (i = i1) → compPath-lem (transpLemma₀ m hlev f g hom a) + (transpLemma₀ m hlev f g hom (ptSn (suc m))) k j + ; (j = i1) → f (merid a i)}) + (hcomp (λ k → λ { (i = i0) → hom j + ; (j = i0) → transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i) + (g base) + ; (j = i1) → transp (λ j → A base (merid a (i ∧ (j ∨ k)))) (k ∨ ~ i) + (f (merid a (i ∧ k)))}) + (transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i) + (hom j)))) +wedgeconLeft (suc n) m {A = A} hlev f g hom _ = refl + +---------- Connectedness ----------- + +sphereConnected : (n : HLevel) → isConnected (suc n) (S₊ n) +sphereConnected n = ∣ ptSn n ∣ , elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) + (λ a → sym (spoke ∣_∣ (ptSn n)) ∙ spoke ∣_∣ a) + +sphereToTrunc : (n : ℕ) {A : S₊ n → Type ℓ} + → ((x : S₊ n) → hLevelTrunc (suc n) (A x)) + → ∥ ((x : _) → A x) ∥₁ +sphereToTrunc zero {A = A} indr = + rec squash₁ (λ p → rec squash₁ + (λ q → ∣ (λ { false → q ; true → p}) ∣₁) + (indr false)) (indr true) +sphereToTrunc (suc zero) {A = A} indr = + lem (indr base) (cong indr loop) + where + lem : (x : hLevelTrunc 2 (A base)) + → PathP (λ i → hLevelTrunc 2 (A (loop i))) x x + → ∥ ((x : S¹) → A x) ∥₁ + lem = elim (λ _ → isSetΠ λ _ → isProp→isSet squash₁) λ a p + → rec squash₁ (λ q → ∣ (λ { base → a + ; (loop i) → toPathP {A = λ i → A (loop i)} q i}) ∣₁) + (PathIdTruncIso 1 .Iso.fun + (fromPathP p)) +sphereToTrunc (suc (suc n)) {A = A} indr = + lem (sphereToTrunc (suc n)) (indr north) (indr south) + λ a → cong indr (merid a) + where + lem : ({A : S₊ (suc n) → Type _} → + ((i : S₊ (suc n)) → hLevelTrunc (suc (suc n)) (A i)) → + ∥ ((x : S₊ (suc n)) → A x) ∥₁) + → (x : hLevelTrunc (3 + n) (A north)) + (y : hLevelTrunc (3 + n) (A south)) + → ((a : _) → PathP (λ i → hLevelTrunc (3 + n) (A (merid a i))) x y) + → ∥ ((x : S₊ (2 + n)) → A x) ∥₁ + lem indr = + elim (λ _ → isOfHLevelΠ2 (3 + n) + λ _ _ → isProp→isOfHLevelSuc (2 + n) squash₁) + λ a → elim (λ _ → isOfHLevelΠ (3 + n) + λ _ → isProp→isOfHLevelSuc (2 + n) squash₁) + λ b → λ f → + PT.map (λ ma → λ { north → a + ; south → b + ; (merid a i) → ma a i}) + (indr {A = λ x → PathP (λ i → A (merid x i)) a b} + λ x → rec (isOfHLevelTrunc (2 + n)) + (λ p → ∣ toPathP p ∣) + (Iso.fun (PathIdTruncIso _) (fromPathP (f x)))) + +-- The fact that path spaces of Sn are connected can be proved directly for Sⁿ. +-- (Unfortunately, this does not work for higher paths) +pathIdTruncSⁿ : (n : ℕ) (x y : S₊ (suc n)) + → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣ + → hLevelTrunc (suc n) (x ≡ y) +pathIdTruncSⁿ n = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) + (sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) + λ _ → ∣ refl ∣) + +pathIdTruncSⁿ⁻ : (n : ℕ) (x y : S₊ (suc n)) + → hLevelTrunc (suc n) (x ≡ y) + → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣ +pathIdTruncSⁿ⁻ n x y = rec (isOfHLevelTrunc (2 + n) _ _) + (J (λ y _ → Path (hLevelTrunc (2 + n) (S₊ (suc n))) ∣ x ∣ ∣ y ∣) refl) + +pathIdTruncSⁿretract : (n : ℕ) (x y : S₊ (suc n)) → (p : hLevelTrunc (suc n) (x ≡ y)) → pathIdTruncSⁿ n x y (pathIdTruncSⁿ⁻ n x y p) ≡ p +pathIdTruncSⁿretract n = + sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) + λ y → elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) + (J (λ y p → pathIdTruncSⁿ n (ptSn (suc n)) y (pathIdTruncSⁿ⁻ n (ptSn (suc n)) y ∣ p ∣) ≡ ∣ p ∣) + (cong (pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n))) (transportRefl refl) ∙ pm-help n)) + where + pm-help : (n : ℕ) → pathIdTruncSⁿ n (ptSn (suc n)) (ptSn (suc n)) refl ≡ ∣ refl ∣ + pm-help zero = refl + pm-help (suc n) = refl + +isConnectedPathSⁿ : (n : ℕ) (x y : S₊ (suc n)) → isConnected (suc n) (x ≡ y) +isConnectedPathSⁿ n x y = + isContrRetract + (pathIdTruncSⁿ⁻ n x y) + (pathIdTruncSⁿ n x y) + (pathIdTruncSⁿretract n x y) + ((isContr→isProp (sphereConnected (suc n)) ∣ x ∣ ∣ y ∣) + , isProp→isSet (isContr→isProp (sphereConnected (suc n))) _ _ _) + +-- Some lemmas on the H space structure on S¹ +rUnitS¹ : (x : S¹) → x * base ≡ x +rUnitS¹ base = refl +rUnitS¹ (loop i₁) = refl + +commS¹ : (a x : S¹) → a * x ≡ x * a +commS¹ = wedgeconFun _ _ (λ _ _ → isGroupoidS¹ _ _) + (sym ∘ rUnitS¹) + rUnitS¹ + refl + +assocS¹ : (x y z : S¹) → x * (y * z) ≡ (x * y) * z +assocS¹ = wedgeconFun _ _ (λ _ _ → isSetΠ λ _ → isGroupoidS¹ _ _) + (λ _ _ → refl) + (λ x z i → (rUnitS¹ x (~ i)) * z) + refl + +invLooperDistr : (x y : S¹) → invLooper (x * y) ≡ invLooper x * invLooper y +invLooperDistr = + wedgeconFun 0 0 (λ _ _ → isGroupoidS¹ _ _) (λ _ → refl) + (λ x → cong invLooper (rUnitS¹ x) ∙ sym (rUnitS¹ (invLooper x))) + (sym (rUnit refl)) + +SuspS¹-hom : (a x : S¹) + → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _) + (cong ∣_∣ₕ (σSn 1 (a * x))) + (cong ∣_∣ₕ (σSn 1 a) + ∙ (cong ∣_∣ₕ (σSn 1 x))) +SuspS¹-hom = wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 4 _ _ _ _) + (λ x → lUnit _ + ∙ cong (_∙ cong ∣_∣ₕ (σSn 1 x)) + (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))) + (λ x → (λ i → cong ∣_∣ₕ (σSn 1 (rUnitS¹ x i))) + ∙∙ rUnit _ + ∙∙ cong (cong ∣_∣ₕ (σSn 1 x) ∙_) + (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))) + (sym (l (cong ∣_∣ₕ (σSn 1 base)) + (cong (cong ∣_∣ₕ) (sym (rCancel (merid base)))))) + where + l : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (P : refl ≡ p) + → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P + l p = J (λ p P → lUnit p ∙ cong (_∙ p) P ≡ rUnit p ∙ cong (p ∙_) P) refl + +rCancelS¹ : (x : S¹) → ptSn 1 ≡ x * (invLooper x) +rCancelS¹ base = refl +rCancelS¹ (loop i) j = + hcomp (λ r → λ {(i = i0) → base ; (i = i1) → base ; (j = i0) → base}) + base + +SuspS¹-inv : (x : S¹) → Path (Path (hLevelTrunc 4 (S₊ 2)) _ _) + (cong ∣_∣ₕ (σSn 1 (invLooper x))) + (cong ∣_∣ₕ (sym (σSn 1 x))) +SuspS¹-inv x = (lUnit _ + ∙∙ cong (_∙ cong ∣_∣ₕ (σSn 1 (invLooper x))) + (sym (lCancel (cong ∣_∣ₕ (σSn 1 x)))) + ∙∙ sym (assoc _ _ _)) + ∙∙ cong (sym (cong ∣_∣ₕ (σSn 1 x)) ∙_) lem + ∙∙ (assoc _ _ _ + ∙∙ cong (_∙ (cong ∣_∣ₕ (sym (σSn 1 x)))) + (lCancel (cong ∣_∣ₕ (σSn 1 x))) + ∙∙ sym (lUnit _)) + where + lem : cong ∣_∣ₕ (σSn 1 x) + ∙ cong ∣_∣ₕ (σSn 1 (invLooper x)) + ≡ cong ∣_∣ₕ (σSn 1 x) + ∙ cong ∣_∣ₕ (sym (σSn 1 x)) + lem = sym (SuspS¹-hom x (invLooper x)) + ∙ ((λ i → cong ∣_∣ₕ (σSn 1 (rCancelS¹ x (~ i)))) + ∙ cong (cong ∣_∣ₕ) (rCancel (merid base))) ∙ sym (rCancel _) + +-------------------- join Sⁿ Sᵐ ≃ Sⁿ⁺¹⁺ᵐ ------------------------- +{- This section contains a proof that join Sⁿ Sᵐ ≃ Sⁿ⁺ᵐ⁺¹. This is easy using various properties proved in HITs.Join. However, we would like the map join Sⁿ Sᵐ → Sⁿ⁺ᵐ⁺¹ @@ -474,316 +488,332 @@ -} -{- We begin with join S¹ S¹ ≃ S³. The iso is induced by: -} -S¹×S¹→S² : S¹ → S¹ → S₊ 2 -S¹×S¹→S² base y = north -S¹×S¹→S² (loop i) base = north -S¹×S¹→S² (loop i) (loop j) = - (sym (rCancel (merid base)) - ∙∙ (λ i → merid (loop i) ∙ sym (merid base)) - ∙∙ rCancel (merid base)) i j +{- We begin with join S¹ S¹ ≃ S³. The iso is induced by: -} +S¹×S¹→S² : S¹ → S¹ → S₊ 2 +S¹×S¹→S² base y = north +S¹×S¹→S² (loop i) base = north +S¹×S¹→S² (loop i) (loop j) = + (sym (rCancel (merid base)) + ∙∙ (λ i → merid (loop i) ∙ sym (merid base)) + ∙∙ rCancel (merid base)) i j -joinS¹S¹→S³ : join S¹ S¹ → S₊ 3 -joinS¹S¹→S³ (inl x) = north -joinS¹S¹→S³ (inr x) = south -joinS¹S¹→S³ (push a b i) = merid (S¹×S¹→S² a b) i +joinS¹S¹→S³ : join S¹ S¹ → S₊ 3 +joinS¹S¹→S³ (inl x) = north +joinS¹S¹→S³ (inr x) = south +joinS¹S¹→S³ (push a b i) = merid (S¹×S¹→S² a b) i -{- Proving that this is an equivalence directly is painful, +{- Proving that this is an equivalence directly is painful, so we simply prove that it is equal to the old definition of the equivalence join S¹ S¹ ≃ S³ ≃ S₊ 3 To this end, we start by rephrasing the map -} -private - 3cell : (r i j k : I) → S₊ 3 - 3cell r i j k = - hfill (λ r → λ {(i = i0) → merid (merid base j) (k ∧ ~ r) - ; (i = i1) → merid (merid base j) (k ∧ ~ r) - ; (j = i0) → merid north (k ∧ ~ r) - ; (j = i1) → merid south (k ∧ ~ r) - ; (k = i0) → north - ; (k = i1) → merid (merid base j) (~ r)}) - (inS (merid (merid (loop i) j) k)) - r - -joinS¹S¹→S³' : join S¹ S¹ → S₊ 3 -joinS¹S¹→S³' (inl x) = north -joinS¹S¹→S³' (inr x) = north -joinS¹S¹→S³' (push base b i) = north -joinS¹S¹→S³' (push (loop i₁) base i) = north -joinS¹S¹→S³' (push (loop i₁) (loop i₂) i) = 3cell i1 i₁ i₂ i - -{- These two maps are equal -} -joinS¹S¹→S³'≡joinS¹S¹→S³' : (x : _) → joinS¹S¹→S³ x ≡ joinS¹S¹→S³' x -joinS¹S¹→S³'≡joinS¹S¹→S³' (inl base) = refl -joinS¹S¹→S³'≡joinS¹S¹→S³' (inl (loop i)) = refl -joinS¹S¹→S³'≡joinS¹S¹→S³' (inr base) = sym (merid north) -joinS¹S¹→S³'≡joinS¹S¹→S³' (inr (loop i)) = sym (merid north) -joinS¹S¹→S³'≡joinS¹S¹→S³' (push base base i) k = merid north (~ k ∧ i) -joinS¹S¹→S³'≡joinS¹S¹→S³' (push base (loop i₁) i) k = merid north (~ k ∧ i) -joinS¹S¹→S³'≡joinS¹S¹→S³' (push (loop i₁) base i) k = (merid north) (~ k ∧ i) -joinS¹S¹→S³'≡joinS¹S¹→S³' (push (loop i) (loop j) k) l = - hcomp (λ r → λ { (i = i0) → merid (sym (rCancel (merid base)) (~ r) j) - (~ l ∧ k) - ; (i = i1) → merid (sym (rCancel (merid base)) (~ r) j) - (~ l ∧ k) - ; (j = i0) → merid north (~ l ∧ k) - ; (j = i1) → merid north (~ l ∧ k) - ; (k = i0) → north - ; (k = i1) → merid (sym (rCancel (merid base)) (~ r) j) (~ l) - ; (l = i0) → merid (doubleCompPath-filler - (sym (rCancel (merid base))) - (cong (σSn 1) loop) - (rCancel (merid base)) r i j) k - ; (l = i1) → 3cell i1 i j k}) - (hcomp (λ r → λ {(i = i0) → merid (cp-fill base r j) (k ∧ ~ l) - ; (i = i1) → merid (cp-fill base r j) (k ∧ ~ l) - ; (j = i0) → merid north (~ l ∧ k) - ; (j = i1) → merid (merid base (~ r)) (~ l ∧ k) - ; (k = i0) → north - ; (k = i1) → merid (cp-fill base r j) (~ l) - ; (l = i0) → merid (cp-fill (loop i) r j) k - ; (l = i1) → 3cell i1 i j k}) - (hcomp (λ r → λ {(i = i0) → merid (merid base j) (k ∧ (~ r ∨ ~ l)) - ; (i = i1) → merid (merid base j) (k ∧ (~ r ∨ ~ l)) - ; (j = i0) → merid north (k ∧ (~ l ∨ ~ r)) - ; (j = i1) → merid south (k ∧ (~ l ∨ ~ r)) - ; (k = i0) → north - ; (k = i1) → merid (merid base j) (~ r ∨ ~ l) - ; (l = i0) → merid (merid (loop i) j) k - ; (l = i1) → 3cell r i j k}) - (merid (merid (loop i) j) k))) - where - cp-fill : (a : S¹) → _ - cp-fill a = compPath-filler (merid a) (sym (merid base)) - -{- joinS¹S¹→S³' is equal to the original +private + 3cell : (r i j k : I) → S₊ 3 + 3cell r i j k = + hfill (λ r → λ {(i = i0) → merid (merid base j) (k ∧ ~ r) + ; (i = i1) → merid (merid base j) (k ∧ ~ r) + ; (j = i0) → merid north (k ∧ ~ r) + ; (j = i1) → merid south (k ∧ ~ r) + ; (k = i0) → north + ; (k = i1) → merid (merid base j) (~ r)}) + (inS (merid (merid (loop i) j) k)) + r + +joinS¹S¹→S³' : join S¹ S¹ → S₊ 3 +joinS¹S¹→S³' (inl x) = north +joinS¹S¹→S³' (inr x) = north +joinS¹S¹→S³' (push base b i) = north +joinS¹S¹→S³' (push (loop i₁) base i) = north +joinS¹S¹→S³' (push (loop i₁) (loop i₂) i) = 3cell i1 i₁ i₂ i + +{- These two maps are equal -} +joinS¹S¹→S³'≡joinS¹S¹→S³' : (x : _) → joinS¹S¹→S³ x ≡ joinS¹S¹→S³' x +joinS¹S¹→S³'≡joinS¹S¹→S³' (inl base) = refl +joinS¹S¹→S³'≡joinS¹S¹→S³' (inl (loop i)) = refl +joinS¹S¹→S³'≡joinS¹S¹→S³' (inr base) = sym (merid north) +joinS¹S¹→S³'≡joinS¹S¹→S³' (inr (loop i)) = sym (merid north) +joinS¹S¹→S³'≡joinS¹S¹→S³' (push base base i) k = merid north (~ k ∧ i) +joinS¹S¹→S³'≡joinS¹S¹→S³' (push base (loop i₁) i) k = merid north (~ k ∧ i) +joinS¹S¹→S³'≡joinS¹S¹→S³' (push (loop i₁) base i) k = (merid north) (~ k ∧ i) +joinS¹S¹→S³'≡joinS¹S¹→S³' (push (loop i) (loop j) k) l = + hcomp (λ r → λ { (i = i0) → merid (sym (rCancel (merid base)) (~ r) j) + (~ l ∧ k) + ; (i = i1) → merid (sym (rCancel (merid base)) (~ r) j) + (~ l ∧ k) + ; (j = i0) → merid north (~ l ∧ k) + ; (j = i1) → merid north (~ l ∧ k) + ; (k = i0) → north + ; (k = i1) → merid (sym (rCancel (merid base)) (~ r) j) (~ l) + ; (l = i0) → merid (doubleCompPath-filler + (sym (rCancel (merid base))) + (cong (σSn 1) loop) + (rCancel (merid base)) r i j) k + ; (l = i1) → 3cell i1 i j k}) + (hcomp (λ r → λ {(i = i0) → merid (cp-fill base r j) (k ∧ ~ l) + ; (i = i1) → merid (cp-fill base r j) (k ∧ ~ l) + ; (j = i0) → merid north (~ l ∧ k) + ; (j = i1) → merid (merid base (~ r)) (~ l ∧ k) + ; (k = i0) → north + ; (k = i1) → merid (cp-fill base r j) (~ l) + ; (l = i0) → merid (cp-fill (loop i) r j) k + ; (l = i1) → 3cell i1 i j k}) + (hcomp (λ r → λ {(i = i0) → merid (merid base j) (k ∧ (~ r ∨ ~ l)) + ; (i = i1) → merid (merid base j) (k ∧ (~ r ∨ ~ l)) + ; (j = i0) → merid north (k ∧ (~ l ∨ ~ r)) + ; (j = i1) → merid south (k ∧ (~ l ∨ ~ r)) + ; (k = i0) → north + ; (k = i1) → merid (merid base j) (~ r ∨ ~ l) + ; (l = i0) → merid (merid (loop i) j) k + ; (l = i1) → 3cell r i j k}) + (merid (merid (loop i) j) k))) + where + cp-fill : (a : S¹) → _ + cp-fill a = compPath-filler (merid a) (sym (merid base)) + +{- joinS¹S¹→S³' is equal to the original equivalence (modulo a flipping of interval variables) -} -joinS¹S¹→S³'Id : (x : join S¹ S¹) - → joinS¹S¹→S³' x ≡ (Iso.fun IsoS³S3 ∘ flip₀₂S³ ∘ joinS¹S¹→S3) x -joinS¹S¹→S³'Id (inl x) = refl -joinS¹S¹→S³'Id (inr x) = refl -joinS¹S¹→S³'Id (push base base i) = refl -joinS¹S¹→S³'Id (push base (loop i₁) i) = refl -joinS¹S¹→S³'Id (push (loop i₁) base i) = refl -joinS¹S¹→S³'Id (push (loop i) (loop j) k) l = - hcomp (λ r → λ {(i = i0) → merid (merid base (j ∧ ~ l)) (~ r ∧ k) - ; (i = i1) → merid (merid base (j ∧ ~ l)) (~ r ∧ k) - ; (j = i0) → merid north (k ∧ ~ r) - ; (j = i1) → merid (merid base (~ l)) (~ r ∧ k) - ; (k = i0) → north - ; (k = i1) → merid (merid base (j ∧ ~ l)) (~ r) - ; (l = i0) → 3cell r i j k - ; (l = i1) → Iso.fun (IsoType→IsoSusp S²IsoSuspS¹) - (meridian-contraction-2 k j i r)}) - (merid (S²Cube i j l) k) - where - S²Cube : Cube {A = S₊ 2} (λ j l → merid base (j ∧ ~ l)) - (λ j l → merid base (j ∧ ~ l)) - (λ i l → north) - (λ i l → merid base (~ l)) - (λ i j → merid (loop i) j) - λ i j → fun S²IsoSuspS¹ (surf j i) - S²Cube i j l = - hcomp (λ r → λ {(i = i0) → merid base (j ∧ (~ l ∨ ~ r)) - ; (i = i1) → merid base (j ∧ (~ l ∨ ~ r)) - ; (j = i0) → north - ; (j = i1) → merid base (~ l ∨ ~ r) - ; (l = i0) → merid (loop i) j - ; (l = i1) → meridian-contraction j i r}) - (merid (loop i) j) - -{-So, finally our map joinS¹S¹→S³ is an iso. We state its inverse explicitly. -} -Iso-joinS¹S¹-S³ : Iso (join S¹ S¹) (S₊ 3) -fun Iso-joinS¹S¹-S³ = joinS¹S¹→S³ -inv Iso-joinS¹S¹-S³ = S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3 -rightInv Iso-joinS¹S¹-S³ x = - joinS¹S¹→S³'≡joinS¹S¹→S³' - ((S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3) x) - ∙∙ joinS¹S¹→S³'Id ((S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3) x) - ∙∙ Iso.leftInv (compIso (invIso IsoS³S3) - (compIso flip₀₂S³Iso (S³IsojoinS¹S¹))) x -leftInv Iso-joinS¹S¹-S³ x = - cong (S³→joinS¹S¹ ∘ flip₀₂S³ ∘ inv IsoS³S3) - (joinS¹S¹→S³'≡joinS¹S¹→S³' x ∙ joinS¹S¹→S³'Id x) - ∙ Iso.rightInv (compIso (invIso IsoS³S3) (compIso flip₀₂S³Iso (S³IsojoinS¹S¹))) x - -{- We now get the full iso Sⁿ * Sᵐ ≃ Sⁿ⁺ᵐ⁺¹ -} -IsoSphereJoin : (n m : ℕ) - → Iso (join (S₊ n) (S₊ m)) (S₊ (suc (n + m))) -IsoSphereJoin zero zero = compIso (invIso Susp-iso-joinBool) (invIso S¹IsoSuspBool) -IsoSphereJoin zero (suc m) = compIso join-comm (invIso Susp-iso-joinBool) -IsoSphereJoin (suc zero) zero = (invIso Susp-iso-joinBool) -IsoSphereJoin (suc zero) (suc zero) = Iso-joinS¹S¹-S³ -IsoSphereJoin (suc zero) (suc (suc m)) = - compIso join-comm - (compIso (compIso (Iso-joinSusp-suspJoin {A = S₊∙ (suc m)} {B = S₊∙ (suc zero)}) - (congSuspIso join-comm)) - (congSuspIso (IsoSphereJoin (suc zero) (suc m)))) -IsoSphereJoin (suc (suc n)) m = - compIso (Iso-joinSusp-suspJoin {A = S₊∙ (suc n)} {B = S₊∙ m}) (congSuspIso (IsoSphereJoin (suc n) m)) - -{- Pointedness holds by refl. +joinS¹S¹→S³'Id : (x : join S¹ S¹) + → joinS¹S¹→S³' x ≡ (Iso.fun IsoS³S3 ∘ flip₀₂S³ ∘ joinS¹S¹→S3) x +joinS¹S¹→S³'Id (inl x) = refl +joinS¹S¹→S³'Id (inr x) = refl +joinS¹S¹→S³'Id (push base base i) = refl +joinS¹S¹→S³'Id (push base (loop i₁) i) = refl +joinS¹S¹→S³'Id (push (loop i₁) base i) = refl +joinS¹S¹→S³'Id (push (loop i) (loop j) k) l = + hcomp (λ r → λ {(i = i0) → merid (merid base (j ∧ ~ l)) (~ r ∧ k) + ; (i = i1) → merid (merid base (j ∧ ~ l)) (~ r ∧ k) + ; (j = i0) → merid north (k ∧ ~ r) + ; (j = i1) → merid (merid base (~ l)) (~ r ∧ k) + ; (k = i0) → north + ; (k = i1) → merid (merid base (j ∧ ~ l)) (~ r) + ; (l = i0) → 3cell r i j k + ; (l = i1) → Iso.fun (IsoType→IsoSusp S²IsoSuspS¹) + (meridian-contraction-2 k j i r)}) + (merid (S²Cube i j l) k) + where + S²Cube : Cube {A = S₊ 2} (λ j l → merid base (j ∧ ~ l)) + (λ j l → merid base (j ∧ ~ l)) + (λ i l → north) + (λ i l → merid base (~ l)) + (λ i j → merid (loop i) j) + λ i j → fun S²IsoSuspS¹ (surf j i) + S²Cube i j l = + hcomp (λ r → λ {(i = i0) → merid base (j ∧ (~ l ∨ ~ r)) + ; (i = i1) → merid base (j ∧ (~ l ∨ ~ r)) + ; (j = i0) → north + ; (j = i1) → merid base (~ l ∨ ~ r) + ; (l = i0) → merid (loop i) j + ; (l = i1) → meridian-contraction j i r}) + (merid (loop i) j) + +{-So, finally our map joinS¹S¹→S³ is an iso. We state its inverse explicitly. -} +Iso-joinS¹S¹-S³ : Iso (join S¹ S¹) (S₊ 3) +fun Iso-joinS¹S¹-S³ = joinS¹S¹→S³ +inv Iso-joinS¹S¹-S³ = S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3 +rightInv Iso-joinS¹S¹-S³ x = + joinS¹S¹→S³'≡joinS¹S¹→S³' + ((S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3) x) + ∙∙ joinS¹S¹→S³'Id ((S³→joinS¹S¹ ∘ flip₀₂S³ ∘ Iso.inv IsoS³S3) x) + ∙∙ Iso.leftInv (compIso (invIso IsoS³S3) + (compIso flip₀₂S³Iso (S³IsojoinS¹S¹))) x +leftInv Iso-joinS¹S¹-S³ x = + cong (S³→joinS¹S¹ ∘ flip₀₂S³ ∘ inv IsoS³S3) + (joinS¹S¹→S³'≡joinS¹S¹→S³' x ∙ joinS¹S¹→S³'Id x) + ∙ Iso.rightInv (compIso (invIso IsoS³S3) (compIso flip₀₂S³Iso (S³IsojoinS¹S¹))) x + +{- We now get the full iso Sⁿ * Sᵐ ≃ Sⁿ⁺ᵐ⁺¹ -} +IsoSphereJoin : (n m : ℕ) + → Iso (join (S₊ n) (S₊ m)) (S₊ (suc (n + m))) +IsoSphereJoin zero zero = compIso (invIso Susp-iso-joinBool) (invIso S¹IsoSuspBool) +IsoSphereJoin zero (suc m) = compIso join-comm (invIso Susp-iso-joinBool) +IsoSphereJoin (suc zero) zero = (invIso Susp-iso-joinBool) +IsoSphereJoin (suc zero) (suc zero) = Iso-joinS¹S¹-S³ +IsoSphereJoin (suc zero) (suc (suc m)) = + compIso join-comm + (compIso (compIso (Iso-joinSusp-suspJoin {A = S₊∙ (suc m)} {B = S₊∙ (suc zero)}) + (congSuspIso join-comm)) + (congSuspIso (IsoSphereJoin (suc zero) (suc m)))) +IsoSphereJoin (suc (suc n)) m = + compIso (Iso-joinSusp-suspJoin {A = S₊∙ (suc n)} {B = S₊∙ m}) (congSuspIso (IsoSphereJoin (suc n) m)) + +{- Pointedness holds by refl. This is due to the explicit definition of Iso-joinSusp-suspJoin -} -IsoSphereJoinPres∙ : (n m : ℕ) - → Iso.fun (IsoSphereJoin n m) (inl (ptSn n)) ≡ ptSn (suc (n + m)) -IsoSphereJoinPres∙ zero zero = refl -IsoSphereJoinPres∙ zero (suc m) = refl -IsoSphereJoinPres∙ (suc zero) zero = refl -IsoSphereJoinPres∙ (suc zero) (suc zero) = refl -IsoSphereJoinPres∙ (suc zero) (suc (suc m)) = refl -IsoSphereJoinPres∙ (suc (suc n)) m = refl - -IsoSphereJoin⁻Pres∙ : (n m : ℕ) - → Iso.inv (IsoSphereJoin n m) (ptSn (suc (n + m))) ≡ inl (ptSn n) -IsoSphereJoin⁻Pres∙ n m = - cong (Iso.inv (IsoSphereJoin n m)) (sym (IsoSphereJoinPres∙ n m)) - ∙ Iso.leftInv (IsoSphereJoin n m) (inl (ptSn n)) - --- Inversion on spheres -invSphere : {n : ℕ} → S₊ n → S₊ n -invSphere {n = zero} = not -invSphere {n = (suc zero)} = invLooper -invSphere {n = (suc (suc n))} = invSusp - -invSphere² : (n : ℕ) (x : S₊ n) → invSphere (invSphere x) ≡ x -invSphere² zero = notnot -invSphere² (suc zero) base = refl -invSphere² (suc zero) (loop i) = refl -invSphere² (suc (suc n)) = invSusp² - --- Interaction between σ and invSphere -σ-invSphere : (n : ℕ) (x : S₊ (suc n)) - → σSn (suc n) (invSphere x) - ≡ sym (σSn (suc n) x) -σ-invSphere zero base = - rCancel (merid base) ∙∙ refl ∙∙ cong sym (sym (rCancel (merid base))) -σ-invSphere zero (loop i) j = - hcomp (λ k → λ { (j = i0) → doubleCompPath-filler - (sym (rCancel (merid base))) - (λ i → (σSn 1 (loop (~ i)))) - (rCancel (merid base)) (~ k) i - ; (j = i1) → doubleCompPath-filler - (sym (cong sym (rCancel (merid base)))) - (λ i → sym (σSn 1 (loop i))) - (cong sym (rCancel (merid base))) (~ k) i}) - (sym≡cong-sym (sym (rCancel (merid base)) - ∙∙ (λ i → (σSn 1 (loop i))) - ∙∙ (rCancel (merid base))) j i) -σ-invSphere (suc n) x = toSusp-invSusp (S₊∙ (suc n)) x - - --- Some facts about the map S¹×S¹→S² --- Todo: generalise to Sⁿ×Sᵐ→Sⁿ⁺ᵐ -S¹×S¹→S²rUnit : (a : S¹) → S¹×S¹→S² a base ≡ north -S¹×S¹→S²rUnit base = refl -S¹×S¹→S²rUnit (loop i) = refl - -S¹×S¹→S²x+x : (x : S¹) → S¹×S¹→S² x x ≡ north -S¹×S¹→S²x+x base = refl -S¹×S¹→S²x+x (loop i) k = lem k i - where - lem : cong₂ S¹×S¹→S² loop loop ≡ refl - lem = cong₂Funct S¹×S¹→S² loop loop - ∙ (λ i → rUnit (cong (λ x → S¹×S¹→S²rUnit x i) loop) (~ i)) - -S¹×S¹→S²-antiComm : (a b : S¹) → S¹×S¹→S² a b ≡ S¹×S¹→S² b (invLooper a) -S¹×S¹→S²-antiComm base base = refl -S¹×S¹→S²-antiComm base (loop i) = refl -S¹×S¹→S²-antiComm (loop i) base = refl -S¹×S¹→S²-antiComm (loop i) (loop j) k = - sym≡flipSquare (λ j i → S¹×S¹→S² (loop i) (loop j)) (~ k) i j - -private - S¹×S¹→S²-Distr-filler : (i : I) - → cong₂ (λ b c → S¹×S¹→S² ((loop i) * b) c) loop loop - ≡ cong (S¹×S¹→S² (loop i)) loop - S¹×S¹→S²-Distr-filler i = - cong₂Funct (λ b c → S¹×S¹→S² ((loop i) * b) c) loop loop - ∙∙ (λ j → cong (λ x → S¹×S¹→S²rUnit (rotLoop x i) j) loop ∙ - cong (λ c → S¹×S¹→S² (loop i) c) loop) - ∙∙ sym (lUnit _) - -S¹×S¹→S²-Distr : (a b : S¹) → S¹×S¹→S² (a * b) b ≡ S¹×S¹→S² a b -S¹×S¹→S²-Distr a base j = S¹×S¹→S² (rUnitS¹ a j) base -S¹×S¹→S²-Distr base (loop i) k = S¹×S¹→S²-Distr-filler i0 k i -S¹×S¹→S²-Distr (loop i₁) (loop i) k = S¹×S¹→S²-Distr-filler i₁ k i - -invSusp∘S¹×S¹→S² : (a b : S¹) - → S¹×S¹→S² a (invLooper b) ≡ invSusp (S¹×S¹→S² a b) -invSusp∘S¹×S¹→S² base b = merid base -invSusp∘S¹×S¹→S² (loop i) base = merid base -invSusp∘S¹×S¹→S² (loop i) (loop j) k = - hcomp (λ r → λ {(i = i0) → i-Boundary₂ r j k - ; (i = i1) → i-Boundary₂ r j k - ; (j = i0) → m-b k - ; (j = i1) → m-b k - ; (k = i0) → doubleCompPath-filler - rCancel-mb⁻¹ (cong σ₁ loop) rCancel-mb r i (~ j) - ; (k = i1) - → invSusp (doubleCompPath-filler - rCancel-mb⁻¹ (cong σ₁ loop) rCancel-mb r i j)}) - (hcomp (λ r → λ {(i = i0) → i-Boundary r (~ j) k - ; (i = i1) → i-Boundary r (~ j) k - ; (j = i0) → merid base (~ r ∨ k) - ; (j = i1) → merid base (r ∧ k) - ; (k = i0) → cp-filler (loop i) r (~ j) - ; (k = i1) → invSusp (cp-filler (loop i) r j)}) - (merid (loop i) (~ j))) - where - σ₁ = σSn 1 - m-b = merid base - rCancel-mb = rCancel m-b - rCancel-mb⁻¹ = sym (rCancel m-b) - - cp-filler : (a : S¹) (i j : I) → S₊ 2 - cp-filler a i j = compPath-filler (merid a) (sym (merid base)) i j - - i-Boundary : I → I → I → S₊ 2 - i-Boundary r j k = - hfill (λ r → λ{(j = i0) → m-b (k ∧ r) - ; (j = i1) → m-b (~ r ∨ k) - ; (k = i0) → cp-filler base r j - ; (k = i1) → invSusp (cp-filler base r (~ j))}) - (inS (m-b j)) - r - - i-Boundary₂ : I → I → I → S₊ 2 - i-Boundary₂ r j k = - hcomp (λ i → λ {(r = i0) → i-Boundary i (~ j) k - ; (r = i1) → m-b k - ; (j = i0) → m-b (k ∨ (~ i ∧ ~ r)) - ; (j = i1) → m-b (k ∧ (i ∨ r)) - ; (k = i0) → rCancel-filler m-b i r (~ j) - ; (k = i1) → invSusp (rCancel-filler m-b i r j) }) - (hcomp (λ i → λ {(r = i0) → m-b (~ j ∨ (~ i ∧ k)) - ; (r = i1) → m-b (k ∨ (~ i ∧ ~ j)) - ; (j = i0) → m-b (k ∨ (~ r ∨ ~ i)) - ; (j = i1) → m-b (k ∧ (~ i ∨ r)) - ; (k = i0) → m-b (~ j ∧ (~ r ∨ ~ i)) - ; (k = i1) → m-b ((~ j ∨ ~ i) ∨ r) }) - (m-b (~ j ∨ k))) - --- Interaction between S¹×S¹→S² and SuspS¹→S² -SuspS¹→S²-S¹×S¹→S² : (a b : S¹) - → (SuspS¹→S² (S¹×S¹→S² a b)) ≡ (S¹×S¹→S²' b a) -SuspS¹→S²-S¹×S¹→S² base base = refl -SuspS¹→S²-S¹×S¹→S² base (loop i) = refl -SuspS¹→S²-S¹×S¹→S² (loop i) base = refl -SuspS¹→S²-S¹×S¹→S² (loop i) (loop j) k = - hcomp (λ r → λ {(i = i0) → rUnit (λ _ → base) (~ r ∧ ~ k) j - ; (i = i1) → rUnit (λ _ → base) (~ r ∧ ~ k) j - ; (j = i0) → base - ; (j = i1) → base - ; (k = i0) → SuspS¹→S² (doubleCompPath-filler ( - sym (rCancel (merid base))) - ((λ i → merid (loop i) ∙ sym (merid base))) - (rCancel (merid base)) r i j ) - ; (k = i1) → surf j i}) - (hcomp (λ r → λ {(i = i0) → rUnit (λ _ → base) (r ∧ ~ k) j - ; (i = i1) → rUnit (λ _ → base) (r ∧ ~ k) j - ; (j = i0) → base - ; (j = i1) → base - ; (k = i0) → SuspS¹→S² - (compPath-filler (merid (loop i)) (sym (merid base)) r j) - ; (k = i1) → surf j i}) - (surf j i)) +IsoSphereJoinPres∙ : (n m : ℕ) + → Iso.fun (IsoSphereJoin n m) (inl (ptSn n)) ≡ ptSn (suc (n + m)) +IsoSphereJoinPres∙ zero zero = refl +IsoSphereJoinPres∙ zero (suc m) = refl +IsoSphereJoinPres∙ (suc zero) zero = refl +IsoSphereJoinPres∙ (suc zero) (suc zero) = refl +IsoSphereJoinPres∙ (suc zero) (suc (suc m)) = refl +IsoSphereJoinPres∙ (suc (suc n)) m = refl + +IsoSphereJoin⁻Pres∙ : (n m : ℕ) + → Iso.inv (IsoSphereJoin n m) (ptSn (suc (n + m))) ≡ inl (ptSn n) +IsoSphereJoin⁻Pres∙ n m = + cong (Iso.inv (IsoSphereJoin n m)) (sym (IsoSphereJoinPres∙ n m)) + ∙ Iso.leftInv (IsoSphereJoin n m) (inl (ptSn n)) + +-- Inversion on spheres +invSphere : {n : ℕ} → S₊ n → S₊ n +invSphere {n = zero} = not +invSphere {n = (suc zero)} = invLooper +invSphere {n = (suc (suc n))} = invSusp + +-- sometimes also this version is useful +invSphere' : {n : ℕ} → S₊ n → S₊ n +invSphere' {n = zero} = not +invSphere' {n = (suc zero)} = invLooper +invSphere' {n = suc (suc n)} north = north +invSphere' {n = suc (suc n)} south = north +invSphere' {n = suc (suc n)} (merid a i) = σSn (suc n) a (~ i) + +invSphere'≡ : {n : ℕ} → (x : S₊ n) → invSphere' x ≡ invSphere x +invSphere'≡ {n = zero} x = refl +invSphere'≡ {n = suc zero} x = refl +invSphere'≡ {n = suc (suc n)} north = merid (ptSn _) +invSphere'≡ {n = suc (suc n)} south = refl +invSphere'≡ {n = suc (suc n)} (merid a i) j = + compPath-filler (merid a) (sym (merid (ptSn _))) (~ j) (~ i) + +invSphere² : (n : ℕ) (x : S₊ n) → invSphere (invSphere x) ≡ x +invSphere² zero = notnot +invSphere² (suc zero) base = refl +invSphere² (suc zero) (loop i) = refl +invSphere² (suc (suc n)) = invSusp² + +-- Interaction between σ and invSphere +σ-invSphere : (n : ℕ) (x : S₊ (suc n)) + → σSn (suc n) (invSphere x) + ≡ sym (σSn (suc n) x) +σ-invSphere zero base = + rCancel (merid base) ∙∙ refl ∙∙ cong sym (sym (rCancel (merid base))) +σ-invSphere zero (loop i) j = + hcomp (λ k → λ { (j = i0) → doubleCompPath-filler + (sym (rCancel (merid base))) + (λ i → (σSn 1 (loop (~ i)))) + (rCancel (merid base)) (~ k) i + ; (j = i1) → doubleCompPath-filler + (sym (cong sym (rCancel (merid base)))) + (λ i → sym (σSn 1 (loop i))) + (cong sym (rCancel (merid base))) (~ k) i}) + (sym≡cong-sym (sym (rCancel (merid base)) + ∙∙ (λ i → (σSn 1 (loop i))) + ∙∙ (rCancel (merid base))) j i) +σ-invSphere (suc n) x = toSusp-invSusp (S₊∙ (suc n)) x + + +-- Some facts about the map S¹×S¹→S² +-- Todo: generalise to Sⁿ×Sᵐ→Sⁿ⁺ᵐ +S¹×S¹→S²rUnit : (a : S¹) → S¹×S¹→S² a base ≡ north +S¹×S¹→S²rUnit base = refl +S¹×S¹→S²rUnit (loop i) = refl + +S¹×S¹→S²x+x : (x : S¹) → S¹×S¹→S² x x ≡ north +S¹×S¹→S²x+x base = refl +S¹×S¹→S²x+x (loop i) k = lem k i + where + lem : cong₂ S¹×S¹→S² loop loop ≡ refl + lem = cong₂Funct S¹×S¹→S² loop loop + ∙ (λ i → rUnit (cong (λ x → S¹×S¹→S²rUnit x i) loop) (~ i)) + +S¹×S¹→S²-antiComm : (a b : S¹) → S¹×S¹→S² a b ≡ S¹×S¹→S² b (invLooper a) +S¹×S¹→S²-antiComm base base = refl +S¹×S¹→S²-antiComm base (loop i) = refl +S¹×S¹→S²-antiComm (loop i) base = refl +S¹×S¹→S²-antiComm (loop i) (loop j) k = + sym≡flipSquare (λ j i → S¹×S¹→S² (loop i) (loop j)) (~ k) i j + +private + S¹×S¹→S²-Distr-filler : (i : I) + → cong₂ (λ b c → S¹×S¹→S² ((loop i) * b) c) loop loop + ≡ cong (S¹×S¹→S² (loop i)) loop + S¹×S¹→S²-Distr-filler i = + cong₂Funct (λ b c → S¹×S¹→S² ((loop i) * b) c) loop loop + ∙∙ (λ j → cong (λ x → S¹×S¹→S²rUnit (rotLoop x i) j) loop ∙ + cong (λ c → S¹×S¹→S² (loop i) c) loop) + ∙∙ sym (lUnit _) + +S¹×S¹→S²-Distr : (a b : S¹) → S¹×S¹→S² (a * b) b ≡ S¹×S¹→S² a b +S¹×S¹→S²-Distr a base j = S¹×S¹→S² (rUnitS¹ a j) base +S¹×S¹→S²-Distr base (loop i) k = S¹×S¹→S²-Distr-filler i0 k i +S¹×S¹→S²-Distr (loop i₁) (loop i) k = S¹×S¹→S²-Distr-filler i₁ k i + +invSusp∘S¹×S¹→S² : (a b : S¹) + → S¹×S¹→S² a (invLooper b) ≡ invSusp (S¹×S¹→S² a b) +invSusp∘S¹×S¹→S² base b = merid base +invSusp∘S¹×S¹→S² (loop i) base = merid base +invSusp∘S¹×S¹→S² (loop i) (loop j) k = + hcomp (λ r → λ {(i = i0) → i-Boundary₂ r j k + ; (i = i1) → i-Boundary₂ r j k + ; (j = i0) → m-b k + ; (j = i1) → m-b k + ; (k = i0) → doubleCompPath-filler + rCancel-mb⁻¹ (cong σ₁ loop) rCancel-mb r i (~ j) + ; (k = i1) + → invSusp (doubleCompPath-filler + rCancel-mb⁻¹ (cong σ₁ loop) rCancel-mb r i j)}) + (hcomp (λ r → λ {(i = i0) → i-Boundary r (~ j) k + ; (i = i1) → i-Boundary r (~ j) k + ; (j = i0) → merid base (~ r ∨ k) + ; (j = i1) → merid base (r ∧ k) + ; (k = i0) → cp-filler (loop i) r (~ j) + ; (k = i1) → invSusp (cp-filler (loop i) r j)}) + (merid (loop i) (~ j))) + where + σ₁ = σSn 1 + m-b = merid base + rCancel-mb = rCancel m-b + rCancel-mb⁻¹ = sym (rCancel m-b) + + cp-filler : (a : S¹) (i j : I) → S₊ 2 + cp-filler a i j = compPath-filler (merid a) (sym (merid base)) i j + + i-Boundary : I → I → I → S₊ 2 + i-Boundary r j k = + hfill (λ r → λ{(j = i0) → m-b (k ∧ r) + ; (j = i1) → m-b (~ r ∨ k) + ; (k = i0) → cp-filler base r j + ; (k = i1) → invSusp (cp-filler base r (~ j))}) + (inS (m-b j)) + r + + i-Boundary₂ : I → I → I → S₊ 2 + i-Boundary₂ r j k = + hcomp (λ i → λ {(r = i0) → i-Boundary i (~ j) k + ; (r = i1) → m-b k + ; (j = i0) → m-b (k ∨ (~ i ∧ ~ r)) + ; (j = i1) → m-b (k ∧ (i ∨ r)) + ; (k = i0) → rCancel-filler m-b i r (~ j) + ; (k = i1) → invSusp (rCancel-filler m-b i r j) }) + (hcomp (λ i → λ {(r = i0) → m-b (~ j ∨ (~ i ∧ k)) + ; (r = i1) → m-b (k ∨ (~ i ∧ ~ j)) + ; (j = i0) → m-b (k ∨ (~ r ∨ ~ i)) + ; (j = i1) → m-b (k ∧ (~ i ∨ r)) + ; (k = i0) → m-b (~ j ∧ (~ r ∨ ~ i)) + ; (k = i1) → m-b ((~ j ∨ ~ i) ∨ r) }) + (m-b (~ j ∨ k))) + +-- Interaction between S¹×S¹→S² and SuspS¹→S² +SuspS¹→S²-S¹×S¹→S² : (a b : S¹) + → (SuspS¹→S² (S¹×S¹→S² a b)) ≡ (S¹×S¹→S²' b a) +SuspS¹→S²-S¹×S¹→S² base base = refl +SuspS¹→S²-S¹×S¹→S² base (loop i) = refl +SuspS¹→S²-S¹×S¹→S² (loop i) base = refl +SuspS¹→S²-S¹×S¹→S² (loop i) (loop j) k = + hcomp (λ r → λ {(i = i0) → rUnit (λ _ → base) (~ r ∧ ~ k) j + ; (i = i1) → rUnit (λ _ → base) (~ r ∧ ~ k) j + ; (j = i0) → base + ; (j = i1) → base + ; (k = i0) → SuspS¹→S² (doubleCompPath-filler ( + sym (rCancel (merid base))) + ((λ i → merid (loop i) ∙ sym (merid base))) + (rCancel (merid base)) r i j ) + ; (k = i1) → surf j i}) + (hcomp (λ r → λ {(i = i0) → rUnit (λ _ → base) (r ∧ ~ k) j + ; (i = i1) → rUnit (λ _ → base) (r ∧ ~ k) j + ; (j = i0) → base + ; (j = i1) → base + ; (k = i0) → SuspS¹→S² + (compPath-filler (merid (loop i)) (sym (merid base)) r j) + ; (k = i1) → surf j i}) + (surf j i)) \ No newline at end of file diff --git a/Cubical.HITs.SphereBouquet.Degree.html b/Cubical.HITs.SphereBouquet.Degree.html index 74d9a26f0..12408a20c 100644 --- a/Cubical.HITs.SphereBouquet.Degree.html +++ b/Cubical.HITs.SphereBouquet.Degree.html @@ -204,14 +204,14 @@ ∙ λ i → degree 1 (λ z → help y a z i))) where help : (y : _) (a : _) (z : _) - → suspFunS∙ (λ x → pickPetal a (f (inr (y , x)))) .fst z + → suspFunS∙ (λ x → pickPetal a (f (inr (y , x)))) .fst z ≡ pickPetal a (bouquetSusp→ f (inr (y , z))) help y a base = refl help y a (loop i) j = help' j i where main : (ft ff : SphereBouquet zero (Fin (suc k))) - → cong SuspBool→S¹ (merid (pickPetal a ff)) - ∙ cong SuspBool→S¹ (sym (merid (pickPetal a ft))) + → cong SuspBool→S¹ (merid (pickPetal a ff)) + ∙ cong SuspBool→S¹ (sym (merid (pickPetal a ft))) ≡ cong (pickPetal a) (cong sphereBouquetSuspFun (merid ff) ∙ sym (cong sphereBouquetSuspFun (merid ft))) main = @@ -226,7 +226,7 @@ where merid-lem : (x : Fin (suc k)) (y : Bool) → cong (sphereBouquetSuspIso .Iso.fun) (merid (inr (x , y))) - ≡ push x ∙∙ (λ i → inr (x , SuspBool→S¹ (merid y i))) ∙∙ sym (push x) + ≡ push x ∙∙ (λ i → inr (x , SuspBool→S¹ (merid y i))) ∙∙ sym (push x) merid-lem x y = cong-∙∙ (Iso.fun sphereBouquetSuspIso₀) (push x) (λ i → inr (x , (merid y ∙ sym (merid true)) i)) @@ -237,9 +237,9 @@ ∙ sym (rUnit _)) pre-final : (y : Bool) (x : Fin (suc k)) - → cong SuspBool→S¹ (merid (pickPetal a (inr (x , y)))) + → cong SuspBool→S¹ (merid (pickPetal a (inr (x , y)))) ≡ cong (pickPetal a) (push x) - ∙∙ cong (pickPetal a) (λ i → inr (x , SuspBool→S¹ (merid y i))) + ∙∙ cong (pickPetal a) (λ i → inr (x , SuspBool→S¹ (merid y i))) ∙∙ cong (pickPetal a) (sym (push x)) pre-final y x with (fst a ≟ᵗ fst x) ... | lt x₁ = rUnit refl @@ -247,24 +247,24 @@ ... | gt x₁ = rUnit refl final : (y : Bool) (x : Fin (suc k)) - → cong SuspBool→S¹ (merid (pickPetal a (inr (x , y)))) + → cong SuspBool→S¹ (merid (pickPetal a (inr (x , y)))) ≡ cong (pickPetal a) ((push x) - ∙∙ (λ i → inr (x , SuspBool→S¹ (merid y i))) + ∙∙ (λ i → inr (x , SuspBool→S¹ (merid y i))) ∙∙ sym (push x)) final y x = pre-final y x ∙ cong-∙∙ (pickPetal a) (push x) - (λ i → inr (x , SuspBool→S¹ (merid y i))) + (λ i → inr (x , SuspBool→S¹ (merid y i))) (sym (push x)) - help' : cong (suspFunS∙ (λ x → pickPetal a (f (inr (y , x)))) .fst) loop + help' : cong (suspFunS∙ (λ x → pickPetal a (f (inr (y , x)))) .fst) loop ≡ cong (pickPetal a) λ i → bouquetSusp→ f (inr (y , loop i)) help' = - (λ j i → Iso.inv S¹IsoSuspBool + (λ j i → Iso.inv S¹IsoSuspBool (cong-∙ (suspFun λ x → pickPetal a (f (inr (y , x)))) (merid false) (sym (merid true)) j i)) - ∙ cong-∙ (Iso.inv S¹IsoSuspBool) + ∙ cong-∙ (Iso.inv S¹IsoSuspBool) (merid (pickPetal a (f (inr (y , false))))) (sym (merid (pickPetal a (f (inr (y , true)))))) ∙ main (f (inr (y , true))) ((f (inr (y , false)))) @@ -313,19 +313,19 @@ ∙ cong (ΩKn+1→Kn (suc n)) (cong (cong ∣_∣ₕ) (sym (cong-∙∙ (pickPetal {n = 2 +ℕ n} b) - (push x) (λ i → inr (x , σSn (suc n) y i)) (sym (push x))))) + (push x) (λ i → inr (x , σSn (suc n) y i)) (sym (push x))))) where main' : f₁ b .fst (inr (x , y)) ≡ ΩKn+1→Kn (suc n) (cong ∣_∣ₕ (cong (pickPetal {n = 2 +ℕ n} b) (push x) ∙∙ (λ i → pickPetal {n = 2 +ℕ n} b - (inr (x , σSn (suc n) y i))) + (inr (x , σSn (suc n) y i))) ∙∙ cong (pickPetal {n = 2 +ℕ n} b) (sym (push x)))) main' with (fst b ≟ᵗ fst x) ... | lt x = sym (cong (ΩKn+1→Kn (suc n)) (sym (rUnit refl)) ∙ ΩKn+1→Kn-refl (suc n)) ... | eq x = sym (cong (ΩKn+1→Kn (suc n)) - (cong (cong ∣_∣ₕ) (sym (rUnit (σSn (suc n) y)))) + (cong (cong ∣_∣ₕ) (sym (rUnit (σSn (suc n) y)))) ∙ Iso.leftInv (Iso-Kn-ΩKn+1 (suc n)) ∣ y ∣) ... | gt x = sym (cong (ΩKn+1→Kn (suc n)) (sym (rUnit refl)) ∙ ΩKn+1→Kn-refl (suc n)) diff --git a/Cubical.HITs.SphereBouquet.Properties.html b/Cubical.HITs.SphereBouquet.Properties.html index 2f10d5d8e..2827162a0 100644 --- a/Cubical.HITs.SphereBouquet.Properties.html +++ b/Cubical.HITs.SphereBouquet.Properties.html @@ -52,7 +52,7 @@ (x : SphereBouquet (suc n) A) → ∥ x ≡ inl tt ∥₁ isConnectedSphereBouquet {n = n} {A} = elimProp (λ x → ∥ x ≡ inl tt ∥₁) (λ x → squash₁) (λ x → ∣ refl ∣₁) - (λ (a , s) → sphereToPropElim n {A = λ x → ∥ inr (a , x) ≡ inl tt ∥₁} + (λ (a , s) → sphereToPropElim n {A = λ x → ∥ inr (a , x) ≡ inl tt ∥₁} (λ x → squash₁) ∣ sym (push a) ∣₁ s) sphereBouquetSuspIso₀ : {A : Type ℓ} @@ -60,19 +60,19 @@ (SphereBouquet 1 A) Iso.fun sphereBouquetSuspIso₀ (inl x) = inl x Iso.fun sphereBouquetSuspIso₀ (inr (a , b)) = - inr (a , Iso.inv (IsoSucSphereSusp 0) b) + inr (a , Iso.inv (IsoSucSphereSusp 0) b) Iso.fun sphereBouquetSuspIso₀ (push a i) = push a i Iso.inv sphereBouquetSuspIso₀ (inl x) = inl x Iso.inv sphereBouquetSuspIso₀ (inr (a , b)) = - inr (a , Iso.fun (IsoSucSphereSusp 0) b) + inr (a , Iso.fun (IsoSucSphereSusp 0) b) Iso.inv sphereBouquetSuspIso₀ (push a i) = push a i Iso.rightInv sphereBouquetSuspIso₀ (inl x) = refl Iso.rightInv sphereBouquetSuspIso₀ (inr (a , y)) i = - inr (a , Iso.leftInv (IsoSucSphereSusp 0) y i) + inr (a , Iso.leftInv (IsoSucSphereSusp 0) y i) Iso.rightInv sphereBouquetSuspIso₀ (push a i) = refl Iso.leftInv sphereBouquetSuspIso₀ (inl x) = refl Iso.leftInv sphereBouquetSuspIso₀ (inr (a , y)) i = - inr (a , Iso.rightInv (IsoSucSphereSusp 0) y i) + inr (a , Iso.rightInv (IsoSucSphereSusp 0) y i) Iso.leftInv sphereBouquetSuspIso₀ (push a i) = refl --a sphere bouquet is the wedge sum of A n-dimensional spheres @@ -160,7 +160,7 @@ Pushout→Bouquet zero mₙ αₙ e (inr x) = inr (x , false) Pushout→Bouquet (suc n) mₙ αₙ e (inr x) = inr (x , ptSn (suc n)) Pushout→Bouquet (suc n) mₙ αₙ e (push a i) = - (push (a .fst) ∙ λ i → inr (a .fst , σSn n (a .snd) i)) i + (push (a .fst) ∙ λ i → inr (a .fst , σSn n (a .snd) i)) i -- Maps back and forth module BouquetFuns {Cₙ Cₙ₊₁ : Type ℓ} (n mₙ : ℕ) @@ -245,7 +245,7 @@ (hcomp (λ r → λ {(i = i0) → push a j ; (i = i1) → compPath-filler' (push a) - (λ i → inr (a , σSn _ (ptSn (suc n)) i)) (~ j) (~ r) + (λ i → inr (a , σSn _ (ptSn (suc n)) i)) (~ j) (~ r) ; (j = i0) → S.CTB (suc (suc n)) αₙ (inr (compPath-filler (push (a , a₁)) (sym (push (a , ptSn (suc n)))) r i) ) @@ -253,12 +253,12 @@ (hcomp (λ r → λ {(i = i0) → push a (j ∨ ~ r) ; (i = i1) → inr (a , north) ; (j = i0) → compPath-filler' - (push a) (λ i → inr (a , σSn _ a₁ i)) r i - ; (j = i1) → inr (a , σSn _ a₁ i)}) - (inr (a , σSn _ a₁ i)))) + (push a) (λ i → inr (a , σSn _ a₁ i)) r i + ; (j = i1) → inr (a , σSn _ a₁ i)}) + (inr (a , σSn _ a₁ i)))) where - help : Square (σSn _ a₁) (σSn _ a₁) refl (sym (σSn _ (ptSn (suc n)))) - help = flipSquare ((λ i _ → σSn _ a₁ i) + help : Square (σSn _ a₁) (σSn _ a₁) refl (sym (σSn _ (ptSn (suc n)))) + help = flipSquare ((λ i _ → σSn _ a₁ i) ▷ λ i → sym (rCancel (merid (ptSn (suc n))) (~ i))) retr-main : (n : _) (αₙ : _) → section (S.CTB n αₙ) (S.BTC n αₙ) @@ -284,7 +284,7 @@ S.BTC (suc zero) αₙ (compPath-filler' (push a) - (λ i → inr (a , σSn zero false i)) r i) + (λ i → inr (a , σSn zero false i)) r i) ; (j = i1) → inr (push (a , false) i)}) (hcomp (λ r → λ {(i = i0) → push (αₙ (a , false)) (j ∨ ~ r) ; (i = i1) → @@ -302,7 +302,7 @@ ; (j = i0) → S.BTC (suc zero) αₙ (compPath-filler' (push a) - (λ i → inr (a , σSn zero true i)) r i) + (λ i → inr (a , σSn zero true i)) r i) ; (j = i1) → inr (push (a , true) (i ∧ r))}) (push (αₙ (a , true)) j) section-main (suc (suc n)) αₙ (inr (push a i)) j = @@ -312,7 +312,7 @@ ∙ (λ i₁ → inr (push (fst a , ptSn (suc n)) i₁))) j ; (j = i0) → S.BTC (suc (suc n)) αₙ (compPath-filler' (push (fst a)) - (λ i → inr (fst a , σSn (suc n) (snd a) i)) r i) + (λ i → inr (fst a , σSn (suc n) (snd a) i)) r i) ; (j = i1) → inr (push a i)}) (hcomp (λ r → λ {(i = i0) → doubleCompPath-filler (push (αₙ a)) diff --git a/Cubical.HITs.Susp.Base.html b/Cubical.HITs.Susp.Base.html index ed30c4fb8..f7729e2ae 100644 --- a/Cubical.HITs.Susp.Base.html +++ b/Cubical.HITs.Susp.Base.html @@ -38,178 +38,186 @@ suspFun f (merid a i) = merid (f a) i -- pointed version -suspFun∙ : {A B : Type ℓ} (f : A → B) - → Susp∙ A →∙ Susp∙ B -fst (suspFun∙ f) = suspFun f -snd (suspFun∙ f) = refl - -UnitIsoSuspUnit : Iso Unit (Susp Unit) -fun UnitIsoSuspUnit _ = north -inv UnitIsoSuspUnit _ = tt -rightInv UnitIsoSuspUnit north = refl -rightInv UnitIsoSuspUnit south = merid tt -rightInv UnitIsoSuspUnit (merid tt j) k = merid tt (j ∧ k) -leftInv UnitIsoSuspUnit _ = refl - -Unit≃SuspUnit : Unit ≃ Susp Unit -Unit≃SuspUnit = isoToEquiv UnitIsoSuspUnit - -BoolIsoSusp⊥ : Iso Bool (Susp ⊥) -fun BoolIsoSusp⊥ = λ {true → north; false → south} -inv BoolIsoSusp⊥ = λ {north → true; south → false} -rightInv BoolIsoSusp⊥ = λ {north → refl; south → refl} -leftInv BoolIsoSusp⊥ = λ {true → refl; false → refl} - -Bool≃Susp⊥ : Bool ≃ Susp ⊥ -Bool≃Susp⊥ = isoToEquiv BoolIsoSusp⊥ - -SuspBool : Type₀ -SuspBool = Susp Bool - -SuspBool→S¹ : SuspBool → S¹ -SuspBool→S¹ north = base -SuspBool→S¹ south = base -SuspBool→S¹ (merid false i) = loop i -SuspBool→S¹ (merid true i) = base - -S¹→SuspBool : S¹ → SuspBool -S¹→SuspBool base = north -S¹→SuspBool (loop i) = (merid false ∙ sym (merid true)) i - -SuspBool→S¹→SuspBool : (x : SuspBool) → Path _ (S¹→SuspBool (SuspBool→S¹ x)) x -SuspBool→S¹→SuspBool north = refl -SuspBool→S¹→SuspBool south = merid true -SuspBool→S¹→SuspBool (merid false i) j = hcomp (λ k → (λ { (j = i1) → merid false i - ; (i = i0) → north - ; (i = i1) → merid true (j ∨ ~ k)})) - (merid false i) -SuspBool→S¹→SuspBool (merid true i) j = merid true (i ∧ j) - -S¹→SuspBool→S¹ : (x : S¹) → SuspBool→S¹ (S¹→SuspBool x) ≡ x -S¹→SuspBool→S¹ base = refl -S¹→SuspBool→S¹ (loop i) j = hfill (λ k → λ { (i = i0) → base - ; (i = i1) → base }) - (inS (loop i)) (~ j) - -S¹IsoSuspBool : Iso S¹ SuspBool -fun S¹IsoSuspBool = S¹→SuspBool -inv S¹IsoSuspBool = SuspBool→S¹ -rightInv S¹IsoSuspBool = SuspBool→S¹→SuspBool -leftInv S¹IsoSuspBool = S¹→SuspBool→S¹ - -S¹≃SuspBool : S¹ ≃ SuspBool -S¹≃SuspBool = isoToEquiv S¹IsoSuspBool - -S¹≡SuspBool : S¹ ≡ SuspBool -S¹≡SuspBool = ua S¹≃SuspBool - --- Now the sphere - -SuspS¹ : Type₀ -SuspS¹ = Susp S¹ - -SuspS¹→S² : SuspS¹ → S² -SuspS¹→S² north = base -SuspS¹→S² south = base -SuspS¹→S² (merid base i) = base -SuspS¹→S² (merid (loop j) i) = surf i j - -meridian-contraction : I → I → I → SuspS¹ -meridian-contraction i j l = hfill (λ k → λ { (i = i0) → north - ; (i = i1) → merid base (~ k) - ; (j = i0) → merid base (~ k ∧ i) - ; (j = i1) → merid base (~ k ∧ i) }) - (inS (merid (loop j) i)) l - -S²→SuspS¹ : S² → SuspS¹ -S²→SuspS¹ base = north -S²→SuspS¹ (surf i j) = meridian-contraction i j i1 - -S²→SuspS¹→S² : ∀ x → SuspS¹→S² (S²→SuspS¹ x) ≡ x -S²→SuspS¹→S² base k = base -S²→SuspS¹→S² (surf i j) k = SuspS¹→S² (meridian-contraction i j (~ k)) - -SuspS¹→S²→SuspS¹ : ∀ x → S²→SuspS¹ (SuspS¹→S² x) ≡ x -SuspS¹→S²→SuspS¹ north k = north -SuspS¹→S²→SuspS¹ south k = merid base k -SuspS¹→S²→SuspS¹ (merid base j) k = merid base (k ∧ j) -SuspS¹→S²→SuspS¹ (merid (loop j) i) k = meridian-contraction i j (~ k) - -S²IsoSuspS¹ : Iso S² SuspS¹ -fun S²IsoSuspS¹ = S²→SuspS¹ -inv S²IsoSuspS¹ = SuspS¹→S² -rightInv S²IsoSuspS¹ = SuspS¹→S²→SuspS¹ -leftInv S²IsoSuspS¹ = S²→SuspS¹→S² - -S²≃SuspS¹ : S² ≃ SuspS¹ -S²≃SuspS¹ = isoToEquiv S²IsoSuspS¹ - -S²≡SuspS¹ : S² ≡ SuspS¹ -S²≡SuspS¹ = ua S²≃SuspS¹ - --- And the 3-sphere - -SuspS² : Type₀ -SuspS² = Susp S² - -SuspS²→S³ : SuspS² → S³ -SuspS²→S³ north = base -SuspS²→S³ south = base -SuspS²→S³ (merid base i) = base -SuspS²→S³ (merid (surf j k) i) = surf i j k - -meridian-contraction-2 : I → I → I → I → SuspS² -meridian-contraction-2 i j k l = hfill (λ m → λ { (i = i0) → north - ; (i = i1) → merid base (~ m) - ; (j = i0) → merid base (~ m ∧ i) - ; (j = i1) → merid base (~ m ∧ i) - ; (k = i0) → merid base (~ m ∧ i) - ; (k = i1) → merid base (~ m ∧ i) }) - (inS (merid (surf j k) i)) l - -S³→SuspS² : S³ → SuspS² -S³→SuspS² base = north -S³→SuspS² (surf i j k) = meridian-contraction-2 i j k i1 - -S³→SuspS²→S³ : ∀ x → SuspS²→S³ (S³→SuspS² x) ≡ x -S³→SuspS²→S³ base l = base -S³→SuspS²→S³ (surf i j k) l = SuspS²→S³ (meridian-contraction-2 i j k (~ l)) - -SuspS²→S³→SuspS² : ∀ x → S³→SuspS² (SuspS²→S³ x) ≡ x -SuspS²→S³→SuspS² north l = north -SuspS²→S³→SuspS² south l = merid base l -SuspS²→S³→SuspS² (merid base j) l = merid base (l ∧ j) -SuspS²→S³→SuspS² (merid (surf j k) i) l = meridian-contraction-2 i j k (~ l) - -S³IsoSuspS² : Iso S³ SuspS² -fun S³IsoSuspS² = S³→SuspS² -inv S³IsoSuspS² = SuspS²→S³ -rightInv S³IsoSuspS² = SuspS²→S³→SuspS² -leftInv S³IsoSuspS² = S³→SuspS²→S³ - -S³≃SuspS² : S³ ≃ SuspS² -S³≃SuspS² = isoToEquiv S³IsoSuspS² - -S³≡SuspS² : S³ ≡ SuspS² -S³≡SuspS² = ua S³≃SuspS² - -IsoType→IsoSusp : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → Iso A B → Iso (Susp A) (Susp B) -fun (IsoType→IsoSusp is) north = north -fun (IsoType→IsoSusp is) south = south -fun (IsoType→IsoSusp is) (merid a i) = merid (fun is a) i -inv (IsoType→IsoSusp is) north = north -inv (IsoType→IsoSusp is) south = south -inv (IsoType→IsoSusp is) (merid a i) = merid (inv is a) i -rightInv (IsoType→IsoSusp is) north = refl -rightInv (IsoType→IsoSusp is) south = refl -rightInv (IsoType→IsoSusp is) (merid a i) j = merid (rightInv is a j) i -leftInv (IsoType→IsoSusp is) north = refl -leftInv (IsoType→IsoSusp is) south = refl -leftInv (IsoType→IsoSusp is) (merid a i) j = merid (leftInv is a j) i - -IsoSuspS²SuspSuspS¹ : Iso (Susp S²) (Susp (Susp S¹)) -IsoSuspS²SuspSuspS¹ = IsoType→IsoSusp S²IsoSuspS¹ - -IsoS³S3 : Iso S³ (Susp (Susp S¹)) -IsoS³S3 = compIso S³IsoSuspS² IsoSuspS²SuspSuspS¹ +suspFun∙ : {A : Type ℓ} {B : Type ℓ'} (f : A → B) + → Susp∙ A →∙ Susp∙ B +fst (suspFun∙ f) = suspFun f +snd (suspFun∙ f) = refl + +suspFun↑ : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} + → (b : B) + → ((a : A) → Path B b b) + → Susp A → B +suspFun↑ b f north = b +suspFun↑ b f south = b +suspFun↑ b f (merid a i) = f a i + +UnitIsoSuspUnit : Iso Unit (Susp Unit) +fun UnitIsoSuspUnit _ = north +inv UnitIsoSuspUnit _ = tt +rightInv UnitIsoSuspUnit north = refl +rightInv UnitIsoSuspUnit south = merid tt +rightInv UnitIsoSuspUnit (merid tt j) k = merid tt (j ∧ k) +leftInv UnitIsoSuspUnit _ = refl + +Unit≃SuspUnit : Unit ≃ Susp Unit +Unit≃SuspUnit = isoToEquiv UnitIsoSuspUnit + +BoolIsoSusp⊥ : Iso Bool (Susp ⊥) +fun BoolIsoSusp⊥ = λ {true → north; false → south} +inv BoolIsoSusp⊥ = λ {north → true; south → false} +rightInv BoolIsoSusp⊥ = λ {north → refl; south → refl} +leftInv BoolIsoSusp⊥ = λ {true → refl; false → refl} + +Bool≃Susp⊥ : Bool ≃ Susp ⊥ +Bool≃Susp⊥ = isoToEquiv BoolIsoSusp⊥ + +SuspBool : Type₀ +SuspBool = Susp Bool + +SuspBool→S¹ : SuspBool → S¹ +SuspBool→S¹ north = base +SuspBool→S¹ south = base +SuspBool→S¹ (merid false i) = loop i +SuspBool→S¹ (merid true i) = base + +S¹→SuspBool : S¹ → SuspBool +S¹→SuspBool base = north +S¹→SuspBool (loop i) = (merid false ∙ sym (merid true)) i + +SuspBool→S¹→SuspBool : (x : SuspBool) → Path _ (S¹→SuspBool (SuspBool→S¹ x)) x +SuspBool→S¹→SuspBool north = refl +SuspBool→S¹→SuspBool south = merid true +SuspBool→S¹→SuspBool (merid false i) j = hcomp (λ k → (λ { (j = i1) → merid false i + ; (i = i0) → north + ; (i = i1) → merid true (j ∨ ~ k)})) + (merid false i) +SuspBool→S¹→SuspBool (merid true i) j = merid true (i ∧ j) + +S¹→SuspBool→S¹ : (x : S¹) → SuspBool→S¹ (S¹→SuspBool x) ≡ x +S¹→SuspBool→S¹ base = refl +S¹→SuspBool→S¹ (loop i) j = hfill (λ k → λ { (i = i0) → base + ; (i = i1) → base }) + (inS (loop i)) (~ j) + +S¹IsoSuspBool : Iso S¹ SuspBool +fun S¹IsoSuspBool = S¹→SuspBool +inv S¹IsoSuspBool = SuspBool→S¹ +rightInv S¹IsoSuspBool = SuspBool→S¹→SuspBool +leftInv S¹IsoSuspBool = S¹→SuspBool→S¹ + +S¹≃SuspBool : S¹ ≃ SuspBool +S¹≃SuspBool = isoToEquiv S¹IsoSuspBool + +S¹≡SuspBool : S¹ ≡ SuspBool +S¹≡SuspBool = ua S¹≃SuspBool + +-- Now the sphere + +SuspS¹ : Type₀ +SuspS¹ = Susp S¹ + +SuspS¹→S² : SuspS¹ → S² +SuspS¹→S² north = base +SuspS¹→S² south = base +SuspS¹→S² (merid base i) = base +SuspS¹→S² (merid (loop j) i) = surf i j + +meridian-contraction : I → I → I → SuspS¹ +meridian-contraction i j l = hfill (λ k → λ { (i = i0) → north + ; (i = i1) → merid base (~ k) + ; (j = i0) → merid base (~ k ∧ i) + ; (j = i1) → merid base (~ k ∧ i) }) + (inS (merid (loop j) i)) l + +S²→SuspS¹ : S² → SuspS¹ +S²→SuspS¹ base = north +S²→SuspS¹ (surf i j) = meridian-contraction i j i1 + +S²→SuspS¹→S² : ∀ x → SuspS¹→S² (S²→SuspS¹ x) ≡ x +S²→SuspS¹→S² base k = base +S²→SuspS¹→S² (surf i j) k = SuspS¹→S² (meridian-contraction i j (~ k)) + +SuspS¹→S²→SuspS¹ : ∀ x → S²→SuspS¹ (SuspS¹→S² x) ≡ x +SuspS¹→S²→SuspS¹ north k = north +SuspS¹→S²→SuspS¹ south k = merid base k +SuspS¹→S²→SuspS¹ (merid base j) k = merid base (k ∧ j) +SuspS¹→S²→SuspS¹ (merid (loop j) i) k = meridian-contraction i j (~ k) + +S²IsoSuspS¹ : Iso S² SuspS¹ +fun S²IsoSuspS¹ = S²→SuspS¹ +inv S²IsoSuspS¹ = SuspS¹→S² +rightInv S²IsoSuspS¹ = SuspS¹→S²→SuspS¹ +leftInv S²IsoSuspS¹ = S²→SuspS¹→S² + +S²≃SuspS¹ : S² ≃ SuspS¹ +S²≃SuspS¹ = isoToEquiv S²IsoSuspS¹ + +S²≡SuspS¹ : S² ≡ SuspS¹ +S²≡SuspS¹ = ua S²≃SuspS¹ + +-- And the 3-sphere + +SuspS² : Type₀ +SuspS² = Susp S² + +SuspS²→S³ : SuspS² → S³ +SuspS²→S³ north = base +SuspS²→S³ south = base +SuspS²→S³ (merid base i) = base +SuspS²→S³ (merid (surf j k) i) = surf i j k + +meridian-contraction-2 : I → I → I → I → SuspS² +meridian-contraction-2 i j k l = hfill (λ m → λ { (i = i0) → north + ; (i = i1) → merid base (~ m) + ; (j = i0) → merid base (~ m ∧ i) + ; (j = i1) → merid base (~ m ∧ i) + ; (k = i0) → merid base (~ m ∧ i) + ; (k = i1) → merid base (~ m ∧ i) }) + (inS (merid (surf j k) i)) l + +S³→SuspS² : S³ → SuspS² +S³→SuspS² base = north +S³→SuspS² (surf i j k) = meridian-contraction-2 i j k i1 + +S³→SuspS²→S³ : ∀ x → SuspS²→S³ (S³→SuspS² x) ≡ x +S³→SuspS²→S³ base l = base +S³→SuspS²→S³ (surf i j k) l = SuspS²→S³ (meridian-contraction-2 i j k (~ l)) + +SuspS²→S³→SuspS² : ∀ x → S³→SuspS² (SuspS²→S³ x) ≡ x +SuspS²→S³→SuspS² north l = north +SuspS²→S³→SuspS² south l = merid base l +SuspS²→S³→SuspS² (merid base j) l = merid base (l ∧ j) +SuspS²→S³→SuspS² (merid (surf j k) i) l = meridian-contraction-2 i j k (~ l) + +S³IsoSuspS² : Iso S³ SuspS² +fun S³IsoSuspS² = S³→SuspS² +inv S³IsoSuspS² = SuspS²→S³ +rightInv S³IsoSuspS² = SuspS²→S³→SuspS² +leftInv S³IsoSuspS² = S³→SuspS²→S³ + +S³≃SuspS² : S³ ≃ SuspS² +S³≃SuspS² = isoToEquiv S³IsoSuspS² + +S³≡SuspS² : S³ ≡ SuspS² +S³≡SuspS² = ua S³≃SuspS² + +IsoType→IsoSusp : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → Iso A B → Iso (Susp A) (Susp B) +fun (IsoType→IsoSusp is) north = north +fun (IsoType→IsoSusp is) south = south +fun (IsoType→IsoSusp is) (merid a i) = merid (fun is a) i +inv (IsoType→IsoSusp is) north = north +inv (IsoType→IsoSusp is) south = south +inv (IsoType→IsoSusp is) (merid a i) = merid (inv is a) i +rightInv (IsoType→IsoSusp is) north = refl +rightInv (IsoType→IsoSusp is) south = refl +rightInv (IsoType→IsoSusp is) (merid a i) j = merid (rightInv is a j) i +leftInv (IsoType→IsoSusp is) north = refl +leftInv (IsoType→IsoSusp is) south = refl +leftInv (IsoType→IsoSusp is) (merid a i) j = merid (leftInv is a j) i + +IsoSuspS²SuspSuspS¹ : Iso (Susp S²) (Susp (Susp S¹)) +IsoSuspS²SuspSuspS¹ = IsoType→IsoSusp S²IsoSuspS¹ + +IsoS³S3 : Iso S³ (Susp (Susp S¹)) +IsoS³S3 = compIso S³IsoSuspS² IsoSuspS²SuspSuspS¹ \ No newline at end of file diff --git a/Cubical.HITs.Susp.Properties.html b/Cubical.HITs.Susp.Properties.html index 2fe788efa..4e8f3d203 100644 --- a/Cubical.HITs.Susp.Properties.html +++ b/Cubical.HITs.Susp.Properties.html @@ -42,24 +42,24 @@ suspFunIdFun i south = south suspFunIdFun i (merid a j) = merid a j -Susp-iso-joinBool : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (join A Bool) -fun Susp-iso-joinBool north = inr true -fun Susp-iso-joinBool south = inr false -fun Susp-iso-joinBool (merid a i) = (sym (push a true) ∙ push a false) i -inv Susp-iso-joinBool (inr true ) = north -inv Susp-iso-joinBool (inr false) = south -inv Susp-iso-joinBool (inl _) = north -inv Susp-iso-joinBool (push a true i) = north -inv Susp-iso-joinBool (push a false i) = merid a i -rightInv Susp-iso-joinBool (inr true ) = refl -rightInv Susp-iso-joinBool (inr false) = refl -rightInv Susp-iso-joinBool (inl a) = sym (push a true) -rightInv Susp-iso-joinBool (push a true i) j = push a true (i ∨ ~ j) -rightInv Susp-iso-joinBool (push a false i) j - = hcomp (λ k → λ { (i = i0) → push a true (~ j) - ; (i = i1) → push a false k - ; (j = i1) → push a false (i ∧ k) }) - (push a true (~ i ∧ ~ j)) +Susp-iso-joinBool : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (join A Bool) +fun Susp-iso-joinBool north = inr true +fun Susp-iso-joinBool south = inr false +fun Susp-iso-joinBool (merid a i) = (sym (push a true) ∙ push a false) i +inv Susp-iso-joinBool (inr true ) = north +inv Susp-iso-joinBool (inr false) = south +inv Susp-iso-joinBool (inl _) = north +inv Susp-iso-joinBool (push a true i) = north +inv Susp-iso-joinBool (push a false i) = merid a i +rightInv Susp-iso-joinBool (inr true ) = refl +rightInv Susp-iso-joinBool (inr false) = refl +rightInv Susp-iso-joinBool (inl a) = sym (push a true) +rightInv Susp-iso-joinBool (push a true i) j = push a true (i ∨ ~ j) +rightInv Susp-iso-joinBool (push a false i) j + = hcomp (λ k → λ { (i = i0) → push a true (~ j) + ; (i = i1) → push a false k + ; (j = i1) → push a false (i ∧ k) }) + (push a true (~ i ∧ ~ j)) leftInv Susp-iso-joinBool north = refl leftInv Susp-iso-joinBool south = refl leftInv (Susp-iso-joinBool {A = A}) (merid a i) j @@ -68,10 +68,10 @@ ; (j = i1) → merid a (i ∧ k) }) (transp (λ _ → Susp A) j north) -Susp≃joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≃ join A Bool +Susp≃joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≃ join A Bool Susp≃joinBool = isoToEquiv Susp-iso-joinBool -Susp≡joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≡ join A Bool +Susp≡joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≡ join A Bool Susp≡joinBool = isoToPath Susp-iso-joinBool congSuspIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → Iso A B → Iso (Susp A) (Susp B) @@ -219,61 +219,61 @@ module _ {A B : Pointed ℓ} where private -- some useful fillers - rinv-filler : (b : typ B) → I → I → I → join (Susp (typ A)) (typ B) + rinv-filler : (b : typ B) → I → I → I → join (Susp (typ A)) (typ B) rinv-filler b i j k = - hfill (λ k → λ {(i = i0) → push south b (~ k) - ; (i = i1) → push north b (~ k ∨ j) - ; (j = i0) → push (merid (pt A) (~ i)) b (~ k) - ; (j = i1) → push south b (~ k ∨ i)}) - (inS (inr b)) + hfill (λ k → λ {(i = i0) → push south b (~ k) + ; (i = i1) → push north b (~ k ∨ j) + ; (j = i0) → push (merid (pt A) (~ i)) b (~ k) + ; (j = i1) → push south b (~ k ∨ i)}) + (inS (inr b)) k suspJoin→joinSuspFiller : - I → I → I → (a : typ A) (b : typ B) → join (Susp (typ A)) (typ B) + I → I → I → (a : typ A) (b : typ B) → join (Susp (typ A)) (typ B) suspJoin→joinSuspFiller i j k a b = - hfill (λ k → λ {(i = i0) → push north b (~ k) - ; (i = i1) → push south b (~ k) - ; (j = i0) → push (merid a i) b (~ k) - ; (j = i1) → push (merid (pt A) i) b (~ k)}) - (inS (inr b)) + hfill (λ k → λ {(i = i0) → push north b (~ k) + ; (i = i1) → push south b (~ k) + ; (j = i0) → push (merid a i) b (~ k) + ; (j = i1) → push (merid (pt A) i) b (~ k)}) + (inS (inr b)) k joinSuspFiller : - I → I → I → (a : typ A) (b : typ B) → Susp (join (typ A) (typ B)) + I → I → I → (a : typ A) (b : typ B) → Susp (join (typ A) (typ B)) joinSuspFiller i j k a b = - hfill (λ k → λ {(i = i0) → merid (push a b (~ k)) j + hfill (λ k → λ {(i = i0) → merid (push a b (~ k)) j ; (i = i1) → north ; (j = i0) → north - ; (j = i1) → merid (push (pt A) b (~ k)) (~ i)}) - (inS (merid (inr b) (~ i ∧ j))) + ; (j = i1) → merid (push (pt A) b (~ k)) (~ i)}) + (inS (merid (inr b) (~ i ∧ j))) k - suspJoin→joinSusp : Susp (join (typ A) (typ B)) → join (Susp (typ A)) (typ B) - suspJoin→joinSusp north = inl north - suspJoin→joinSusp south = inl south - suspJoin→joinSusp (merid (inl x) i) = inl ((merid x) i) - suspJoin→joinSusp (merid (inr x) i) = inl (merid (pt A) i) - suspJoin→joinSusp (merid (push a b j) i) = suspJoin→joinSuspFiller i j i1 a b + suspJoin→joinSusp : Susp (join (typ A) (typ B)) → join (Susp (typ A)) (typ B) + suspJoin→joinSusp north = inl north + suspJoin→joinSusp south = inl south + suspJoin→joinSusp (merid (inl x) i) = inl ((merid x) i) + suspJoin→joinSusp (merid (inr x) i) = inl (merid (pt A) i) + suspJoin→joinSusp (merid (push a b j) i) = suspJoin→joinSuspFiller i j i1 a b - joinSusp→suspJoin : join (Susp (typ A)) (typ B) → Susp (join (typ A) (typ B)) - joinSusp→suspJoin (inl north) = north - joinSusp→suspJoin (inl south) = south - joinSusp→suspJoin (inl (merid a i)) = merid (inl a) i - joinSusp→suspJoin (inr x) = north - joinSusp→suspJoin (push north b i) = north - joinSusp→suspJoin (push south b i) = merid (inl (pt A)) (~ i) - joinSusp→suspJoin (push (merid a j) b i) = joinSuspFiller i j i1 a b + joinSusp→suspJoin : join (Susp (typ A)) (typ B) → Susp (join (typ A) (typ B)) + joinSusp→suspJoin (inl north) = north + joinSusp→suspJoin (inl south) = south + joinSusp→suspJoin (inl (merid a i)) = merid (inl a) i + joinSusp→suspJoin (inr x) = north + joinSusp→suspJoin (push north b i) = north + joinSusp→suspJoin (push south b i) = merid (inl (pt A)) (~ i) + joinSusp→suspJoin (push (merid a j) b i) = joinSuspFiller i j i1 a b - suspJoin→joinSusp→suspJoin : (x : Susp (join (typ A) (typ B))) + suspJoin→joinSusp→suspJoin : (x : Susp (join (typ A) (typ B))) → joinSusp→suspJoin (suspJoin→joinSusp x) ≡ x suspJoin→joinSusp→suspJoin north = refl suspJoin→joinSusp→suspJoin south = refl - suspJoin→joinSusp→suspJoin (merid (inl x) i) = refl - suspJoin→joinSusp→suspJoin (merid (inr x) i) j = merid (push (pt A) x j) i - suspJoin→joinSusp→suspJoin (merid (push a b j) i) k = + suspJoin→joinSusp→suspJoin (merid (inl x) i) = refl + suspJoin→joinSusp→suspJoin (merid (inr x) i) j = merid (push (pt A) x j) i + suspJoin→joinSusp→suspJoin (merid (push a b j) i) k = hcomp (λ r → λ {(i = i0) → north - ; (i = i1) → merid (push (snd A) b (k ∧ (~ r ∨ j))) r + ; (i = i1) → merid (push (snd A) b (k ∧ (~ r ∨ j))) r ; (j = i0) → joinSuspFiller (~ r) i (~ k ∨ r) a b ; (j = i1) → joinSuspFiller (~ r) i (~ k) (pt A) b ; (k = i0) → joinSusp→suspJoin (suspJoin→joinSuspFiller i j r a b) @@ -283,60 +283,60 @@ k=i1 : Cube (λ j r → north) - (λ j r → merid (push (snd A) b (~ r ∨ j)) r) + (λ j r → merid (push (snd A) b (~ r ∨ j)) r) (λ i r → joinSuspFiller (~ r) i r a b) - (λ i r → merid (inr b) (r ∧ i)) + (λ i r → merid (inr b) (r ∧ i)) refl - λ i j → merid (push a b j) i + λ i j → merid (push a b j) i k=i1 i j r = hcomp (λ k → λ {(i = i0) → north - ; (i = i1) → merid (push (snd A) b (~ r ∨ ~ k ∨ j)) r + ; (i = i1) → merid (push (snd A) b (~ r ∨ ~ k ∨ j)) r ; (j = i0) → joinSuspFiller (~ r) i (r ∧ k) a b - ; (j = i1) → merid (inr b) (r ∧ i) + ; (j = i1) → merid (inr b) (r ∧ i) ; (r = i0) → north - ; (r = i1) → merid (push a b (~ k ∨ j)) i}) - (merid (inr b) (i ∧ r)) + ; (r = i1) → merid (push a b (~ k ∨ j)) i}) + (merid (inr b) (i ∧ r)) - joinSusp→suspJoin→joinSusp : (x : join (Susp (typ A)) (typ B)) + joinSusp→suspJoin→joinSusp : (x : join (Susp (typ A)) (typ B)) → suspJoin→joinSusp (joinSusp→suspJoin x) ≡ x - joinSusp→suspJoin→joinSusp (inl north) = refl - joinSusp→suspJoin→joinSusp (inl south) = refl - joinSusp→suspJoin→joinSusp (inl (merid a i)) = refl - joinSusp→suspJoin→joinSusp (inr x) = push north x - joinSusp→suspJoin→joinSusp (push north b i) j = push north b (j ∧ i) - joinSusp→suspJoin→joinSusp (push south b i) j = rinv-filler b i j i1 - joinSusp→suspJoin→joinSusp (push (merid a j) b i) k = - hcomp (λ r → λ { (j = i0) → push north b (k ∧ i) + joinSusp→suspJoin→joinSusp (inl north) = refl + joinSusp→suspJoin→joinSusp (inl south) = refl + joinSusp→suspJoin→joinSusp (inl (merid a i)) = refl + joinSusp→suspJoin→joinSusp (inr x) = push north x + joinSusp→suspJoin→joinSusp (push north b i) j = push north b (j ∧ i) + joinSusp→suspJoin→joinSusp (push south b i) j = rinv-filler b i j i1 + joinSusp→suspJoin→joinSusp (push (merid a j) b i) k = + hcomp (λ r → λ { (j = i0) → push north b (k ∧ i) ; (j = i1) → lem i k r ; (i = i0) → suspJoin→joinSuspFiller j (~ r ∧ ~ k) i1 a b - ; (i = i1) → push north b k + ; (i = i1) → push north b k ; (k = i0) → suspJoin→joinSusp (joinSuspFiller i j r a b) - ; (k = i1) → push (merid a j) b i}) - (hcomp (λ r → λ { (j = i0) → push north b (~ r ∨ (k ∧ i)) + ; (k = i1) → push (merid a j) b i}) + (hcomp (λ r → λ { (j = i0) → push north b (~ r ∨ (k ∧ i)) ; (j = i1) → rinv-filler b i k r ; (i = i0) → suspJoin→joinSuspFiller j (~ k) r a b - ; (i = i1) → push north b (~ r ∨ k) - ; (k = i0) → push (merid (snd A) (~ i ∧ j)) b (~ r) - ; (k = i1) → push (merid a j) b (~ r ∨ i)}) - (inr b)) + ; (i = i1) → push north b (~ r ∨ k) + ; (k = i0) → push (merid (snd A) (~ i ∧ j)) b (~ r) + ; (k = i1) → push (merid a j) b (~ r ∨ i)}) + (inr b)) where - lem : Cube (λ k r → inl south) - (λ k r → push north b k) + lem : Cube (λ k r → inl south) + (λ k r → push north b k) (λ i r → suspJoin→joinSuspFiller (~ i) r i1 (pt A) b) - (λ i r → push south b i) + (λ i r → push south b i) (λ i k → rinv-filler b i k i1) λ i k → rinv-filler b i k i1 lem i k r = hcomp (λ j → λ { (r = i0) → rinv-filler b i k j ; (r = i1) → rinv-filler b i k j - ; (i = i0) → push south b (~ j) - ; (i = i1) → push north b (k ∨ ~ j) + ; (i = i0) → push south b (~ j) + ; (i = i1) → push north b (k ∨ ~ j) ; (k = i0) → suspJoin→joinSuspFiller (~ i) r j (pt A) b - ; (k = i1) → push south b (i ∨ ~ j)}) - (inr b) + ; (k = i1) → push south b (i ∨ ~ j)}) + (inr b) Iso-joinSusp-suspJoin : - Iso (join (Susp (typ A)) (typ B)) (Susp (join (typ A) (typ B))) + Iso (join (Susp (typ A)) (typ B)) (Susp (join (typ A) (typ B))) Iso.fun Iso-joinSusp-suspJoin = joinSusp→suspJoin Iso.inv Iso-joinSusp-suspJoin = suspJoin→joinSusp Iso.rightInv Iso-joinSusp-suspJoin = suspJoin→joinSusp→suspJoin diff --git a/Cubical.Homotopy.Connected.html b/Cubical.Homotopy.Connected.html index c201654b7..23ca6c1c4 100644 --- a/Cubical.Homotopy.Connected.html +++ b/Cubical.Homotopy.Connected.html @@ -575,7 +575,7 @@ → isConnected (suc n) (Susp X) isConnectedSusp {X = X} n h = isConnectedFun→isConnected (suc n) $ isConnectedComp _ (suspFun (λ (x : X) → tt)) (suc n) - (isEquiv→isConnected _ (equivIsEquiv (invEquiv Unit≃SuspUnit)) (suc n)) + (isEquiv→isConnected _ (equivIsEquiv (invEquiv Unit≃SuspUnit)) (suc n)) (isConnectedSuspFun _ n (isConnected→isConnectedFun n h)) -- See also `sphereConnected` for S₊ @@ -806,8 +806,8 @@ (m n : HLevel) {A : Type ℓ} {A' : Type ℓ'} {v : A → A'} {B : Type ℓ''} (hA : isConnectedFun m v) (hB : isConnected n B) where - private module _ {ℓ''' : Level} (P : join A' B → TypeOfHLevel ℓ''' (m + n)) where - module _ (k : (x : join A B) → P (join→ v (idfun B) x) .fst) where + private module _ {ℓ''' : Level} (P : join A' B → TypeOfHLevel ℓ''' (m + n)) where + module _ (k : (x : join A B) → P (join→ v (idfun B) x) .fst) where -- We encode k as a section f of the family -- A -- v ↓ X @@ -817,40 +817,40 @@ X : A' → Type _ X a' = - Σ[ x ∈ P (inl a') .fst ] - ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) x (k (inr b)) + Σ[ x ∈ P (inl a') .fst ] + ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) x (k (inr b)) f : (a : A) → X (v a) - fst (f a) = k (inl a) - snd (f a) = λ b i → k (push a b i) + fst (f a) = k (inl a) + snd (f a) = λ b i → k (push a b i) -- Equivalent type to X, whose h-level we can estimate. X' : A' → Type _ X' a' = - Σ[ x' ∈ (Unit → P (inl a') .fst) ] + Σ[ x' ∈ (Unit → P (inl a') .fst) ] (λ (b : B) → x' tt) ≡ - (λ (b : B) → subst⁻ (λ y → P y .fst) (push a' b) (k (inr b))) + (λ (b : B) → subst⁻ (λ y → P y .fst) (push a' b) (k (inr b))) X≃X' : (a' : A') → X a' ≃ X' a' X≃X' a' = - (Σ[ x ∈ P (inl a') .fst ] - ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) x (k (inr b))) + (Σ[ x ∈ P (inl a') .fst ] + ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) x (k (inr b))) ≃⟨ invEquiv (Σ-cong-equiv-fst (UnitToType≃ _)) ⟩ - (Σ[ x' ∈ (Unit → P (inl a') .fst) ] - ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) (x' tt) (k (inr b))) + (Σ[ x' ∈ (Unit → P (inl a') .fst) ] + ∀ (b : B) → PathP (λ i → P (push a' b i) .fst) (x' tt) (k (inr b))) ≃⟨ Σ-cong-equiv-snd (λ x' → equivΠCod (λ b → pathToEquiv (PathP≡Path⁻ _ _ _))) ⟩ - (Σ[ x' ∈ (Unit → P (inl a') .fst) ] - ∀ (b : B) → x' tt ≡ subst⁻ (λ y → P y .fst) (push a' b) (k (inr b))) + (Σ[ x' ∈ (Unit → P (inl a') .fst) ] + ∀ (b : B) → x' tt ≡ subst⁻ (λ y → P y .fst) (push a' b) (k (inr b))) ≃⟨ Σ-cong-equiv-snd (λ x' → funExtEquiv) ⟩ - (Σ[ x' ∈ (Unit → P (inl a') .fst) ] + (Σ[ x' ∈ (Unit → P (inl a') .fst) ] (λ (b : B) → x' tt) ≡ - (λ (b : B) → subst⁻ (λ y → P y .fst) (push a' b) (k (inr b)))) + (λ (b : B) → subst⁻ (λ y → P y .fst) (push a' b) (k (inr b)))) ■ X'level : (a' : A') → isOfHLevel m (X' a') X'level a' = isOfHLevelPrecomposeConnected m n - (λ (_ : Unit) → P (inl a')) (λ (b : B) → tt) + (λ (_ : Unit) → P (inl a')) (λ (b : B) → tt) (λ _ → isConnectedRetractFromIso _ fiberUnitIso hB) _ Xl : (a' : A') → TypeOfHLevel _ m @@ -866,18 +866,18 @@ hf' : (a : A) → f' (v a) ≡ f a hf' = funExt⁻ (Iso.rightInv H f) - k' : (x : join A' B) → P x .fst - k' (inl a') = f' a' .fst - k' (inr b) = k (inr b) - k' (push a' b i) = f' a' .snd b i + k' : (x : join A' B) → P x .fst + k' (inl a') = f' a' .fst + k' (inr b) = k (inr b) + k' (push a' b i) = f' a' .snd b i - hk' : (x : join A B) → k' (join→ v (idfun B) x) ≡ k x - hk' (inl a) j = hf' a j .fst - hk' (inr b) j = k (inr b) - hk' (push a b i) j = hf' a j .snd b i + hk' : (x : join A B) → k' (join→ v (idfun B) x) ≡ k x + hk' (inl a) j = hf' a j .fst + hk' (inr b) j = k (inr b) + hk' (push a b i) j = hf' a j .snd b i joinConnectedAux : - hasSection (λ (k : (x : join A' B) → P x .fst) → k ∘ join→ v (idfun B)) + hasSection (λ (k : (x : join A' B) → P x .fst) → k ∘ join→ v (idfun B)) fst joinConnectedAux k = k' k snd joinConnectedAux k = funExt (hk' k) diff --git a/Cubical.Homotopy.Everything.html b/Cubical.Homotopy.Everything.html index 07681c62b..db53bb593 100644 --- a/Cubical.Homotopy.Everything.html +++ b/Cubical.Homotopy.Everything.html @@ -16,27 +16,28 @@ import Cubical.Homotopy.EilenbergSteenrod import Cubical.Homotopy.Freudenthal import Cubical.Homotopy.Group.Base -import Cubical.Homotopy.Group.LES -import Cubical.Homotopy.Group.Pi3S2 -import Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments -import Cubical.Homotopy.Group.Pi4S3.BrunerieNumber -import Cubical.Homotopy.Group.Pi4S3.DirectProof -import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso -import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2 -import Cubical.Homotopy.Group.Pi4S3.Summary -import Cubical.Homotopy.Group.PinSn -import Cubical.Homotopy.Group.SuspensionMap -import Cubical.Homotopy.HSpace -import Cubical.Homotopy.Hopf -import Cubical.Homotopy.HopfInvariant.Base -import Cubical.Homotopy.HopfInvariant.Brunerie -import Cubical.Homotopy.HopfInvariant.Homomorphism -import Cubical.Homotopy.HopfInvariant.HopfMap -import Cubical.Homotopy.Loopspace -import Cubical.Homotopy.MayerVietorisCofiber -import Cubical.Homotopy.Prespectrum -import Cubical.Homotopy.Spectrum -import Cubical.Homotopy.WedgeConnectivity -import Cubical.Homotopy.Whitehead -import Cubical.Homotopy.WhiteheadsLemma +import Cubical.Homotopy.Group.Join +import Cubical.Homotopy.Group.LES +import Cubical.Homotopy.Group.Pi3S2 +import Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments +import Cubical.Homotopy.Group.Pi4S3.BrunerieNumber +import Cubical.Homotopy.Group.Pi4S3.DirectProof +import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso +import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2 +import Cubical.Homotopy.Group.Pi4S3.Summary +import Cubical.Homotopy.Group.PinSn +import Cubical.Homotopy.Group.SuspensionMap +import Cubical.Homotopy.HSpace +import Cubical.Homotopy.Hopf +import Cubical.Homotopy.HopfInvariant.Base +import Cubical.Homotopy.HopfInvariant.Brunerie +import Cubical.Homotopy.HopfInvariant.Homomorphism +import Cubical.Homotopy.HopfInvariant.HopfMap +import Cubical.Homotopy.Loopspace +import Cubical.Homotopy.MayerVietorisCofiber +import Cubical.Homotopy.Prespectrum +import Cubical.Homotopy.Spectrum +import Cubical.Homotopy.WedgeConnectivity +import Cubical.Homotopy.Whitehead +import Cubical.Homotopy.WhiteheadsLemma \ No newline at end of file diff --git a/Cubical.Homotopy.Group.Join.html b/Cubical.Homotopy.Group.Join.html new file mode 100644 index 000000000..9c274fb1f --- /dev/null +++ b/Cubical.Homotopy.Group.Join.html @@ -0,0 +1,328 @@ + +Cubical.Homotopy.Group.Join
{-# OPTIONS --safe --lossy-unification #-}
+{-
+This file contains definition of homotopy groups in terms of joins:
+π*ₙₘ(A) := ∥ Sⁿ * Sᵐ →∙ A ∥₀
+and the fact that it agrees with the usual definition of homotopy groups.
+-}
+module Cubical.Homotopy.Group.Join where
+
+open import Cubical.Homotopy.Loopspace
+open import Cubical.Homotopy.Group.Base
+
+open import Cubical.Foundations.Prelude
+open import Cubical.Foundations.Pointed
+open import Cubical.Foundations.GroupoidLaws
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Function
+
+open import Cubical.Data.Sigma
+open import Cubical.Data.Nat
+open import Cubical.Data.Bool
+
+open import Cubical.HITs.SetTruncation as ST
+open import Cubical.HITs.Sn
+open import Cubical.HITs.Susp renaming (toSusp to σ)
+open import Cubical.HITs.S1
+open import Cubical.HITs.Join
+open import Cubical.HITs.Sn.Multiplication
+
+open import Cubical.Algebra.Group
+open import Cubical.Algebra.Group.Morphisms
+open import Cubical.Algebra.Group.MorphismProperties
+open import Cubical.Algebra.Group.GroupPath
+
+open Iso
+open GroupStr
+
+-- Standard loop in Ω (join A B)
+ℓ* : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ')
+  → fst A → fst B → Ω (join∙ A B) .fst
+ℓ* A B a b = push (pt A) (pt B)
+           ∙ (push a (pt B) ⁻¹ ∙∙ push a b ∙∙ (push (pt A) b ⁻¹))
+
+ℓS : {n m : ℕ} → S₊ n → S₊ m → Ω (join∙ (S₊∙ n) (S₊∙ m)) .fst
+ℓS {n = n} {m} = ℓ* (S₊∙ n) (S₊∙ m)
+
+-- Addition of functions join A B → C
+_+*_ : ∀ {ℓ ℓ' ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''}
+  (f g : join∙ A B →∙ C) → join∙ A B →∙ C
+fst (_+*_ {C = C} f g) (inl x) = pt C
+fst (_+*_ {C = C} f g) (inr x) = pt C
+fst (_+*_ {A = A} {B = B} f g) (push a b i) =
+  (Ω→ f .fst (ℓ* A B a b) ∙ Ω→ g .fst (ℓ* A B a b)) i
+snd (f +* g) = refl
+
+-- Inversion
+-* : ∀ {ℓ ℓ' ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''}
+      (f : join∙ A B →∙ C) → join∙ A B →∙ C
+fst (-* {C = C} f) (inl x) = pt C
+fst (-* {C = C} f) (inr x) = pt C
+fst (-* {A = A} {B} f) (push a b i) = Ω→ f .fst (ℓ* A B a b) (~ i)
+snd (-* f) = refl
+
+-- -Π is the same as -*
+-Π≡-* : ∀ {ℓ} {A : Pointed ℓ} {n m : ℕ}
+    (f : S₊∙ (suc (n + m)) →∙ A)
+  → (-Π f) ∘∙ join→Sphere∙ n m
+   ≡ -* (f ∘∙ join→Sphere∙ n m)
+fst (-Π≡-* f i) (inl x) = snd (-Π f) i
+fst (-Π≡-* f i) (inr x) = snd (-Π f) i
+fst (-Π≡-* {A = A} {n = n} {m = m} f i) (push a b j) = main i j
+  where
+  lem : (n : ℕ) (f : S₊∙ (suc n) →∙ A) (a : S₊ n)
+    → Square (cong (fst (-Π f)) (σS a))
+              (sym (snd f) ∙∙ cong (fst f) (sym (σS a)) ∙∙ snd f)
+              (snd (-Π f)) (snd (-Π f))
+  lem zero f false =
+    doubleCompPath-filler (sym (snd f)) (cong (fst f) (sym loop)) (snd f)
+  lem zero f true = doubleCompPath-filler (sym (snd f)) refl (snd f)
+  lem (suc n) f a =
+    (cong-∙ (fst (-Π f)) (merid a) (sym (merid (ptSn (suc n))))
+      ∙ cong₂ _∙_ refl (cong (cong (fst f)) (rCancel _))
+      ∙ sym (rUnit _))
+    ◁ doubleCompPath-filler
+      (sym (snd f)) (cong (fst f) (sym (σS a))) (snd f)
+
+  main : Square (cong (fst (-Π f)) (σS (a ⌣S b)))
+                (sym (Ω→ (f ∘∙ join→Sphere∙ n m) .fst (ℓS a b)))
+                (snd (-Π f)) (snd (-Π f))
+  main = lem _ f (a ⌣S b)
+    ▷ sym ((λ j → (sym (lUnit (snd f) (~ j))
+             ∙∙ sym (cong (fst f) (cong-∙ (join→Sphere n m)
+                       (push (ptSn n) (ptSn m))
+                       ((push a (ptSn m) ⁻¹)
+                     ∙∙ push a b
+                     ∙∙ (push (ptSn n) b ⁻¹)) j))
+             ∙∙ lUnit (snd f) (~ j)))
+      ∙ cong (sym (snd f) ∙∙_∙∙ snd f)
+             (cong (cong (fst f))
+                (congS sym
+                  ((cong₂ _∙_
+                    (cong σS (IdL⌣S _) ∙ σS∙)
+                    (cong-∙∙ (join→Sphere n m)
+                      (push a (ptSn m) ⁻¹) (push a b) (push (ptSn n) b ⁻¹)
+                  ∙ (cong₂ (λ p q → p ⁻¹ ∙∙ σS (a ⌣S b) ∙∙ q ⁻¹)
+                          (cong σS (IdL⌣S _) ∙ σS∙)
+                          (cong σS (IdR⌣S _) ∙ σS∙))
+                  ∙ sym (rUnit (σS (a ⌣S b)))))
+                ∙ sym (lUnit _)))))
+snd (-Π≡-* f i) j = lem i j
+  where
+  lem : Square (refl ∙ snd (-Π f)) refl (snd (-Π f)) refl
+  lem = sym (lUnit (snd (-Π f))) ◁ λ i j → (snd (-Π f)) (i ∨ j)
+
+-- ·Π is the same as +*
+·Π≡+* : ∀ {ℓ} {A : Pointed ℓ} {n m : ℕ}
+    (f g : S₊∙ (suc (n + m)) →∙ A)
+  → (∙Π f g ∘∙ join→Sphere∙ n m)
+   ≡ ((f ∘∙ join→Sphere∙ n m)
+   +* (g ∘∙ join→Sphere∙ n m))
+fst (·Π≡+* {A = A} f g i) (inl x) = snd (∙Π f g) i
+fst (·Π≡+* {A = A} f g i) (inr x) = snd (∙Π f g) i
+fst (·Π≡+* {A = A} {n = n} {m} f g i) (push a b j) = main i j
+  where
+  help : (n : ℕ) (f g : S₊∙ (suc n) →∙ A) (a : S₊ n)
+    → Square (cong (fst (∙Π f g)) (σS a))
+              (Ω→ f .fst (σS a) ∙ Ω→ g .fst (σS a))
+              (snd (∙Π f g)) (snd (∙Π f g))
+  help zero f g false = refl
+  help zero f g true =
+      rUnit refl
+    ∙ cong₂ _∙_ (sym (∙∙lCancel (snd f))) (sym (∙∙lCancel (snd g)))
+  help (suc n) f g a =
+      cong-∙ (fst (∙Π f g)) (merid a) (sym (merid (ptSn (suc n))))
+    ∙ cong (cong (fst (∙Π f g)) (merid a) ∙_)
+        (congS sym
+          (cong₂ _∙_
+            (cong (sym (snd f) ∙∙_∙∙ snd f)
+              (cong (cong (fst f)) (rCancel (merid (ptSn (suc n)))))
+              ∙ Ω→ f .snd)
+            (cong (sym (snd g) ∙∙_∙∙ snd g)
+              (cong (cong (fst g)) (rCancel (merid (ptSn (suc n)))))
+              ∙ Ω→ g .snd)
+           ∙ sym (rUnit refl)))
+    ∙ sym (rUnit _)
+
+  Ω→σ : ∀ {ℓ} {A : Pointed ℓ} (f : S₊∙ (suc (n + m)) →∙ A)
+    → Ω→ f .fst (σS (a ⌣S b))
+     ≡ Ω→ (f ∘∙ join→Sphere∙ n m) .fst (ℓS a b)
+  Ω→σ f =
+      cong (sym (snd f) ∙∙_∙∙ snd f)
+        (cong (cong (fst f))
+          (sym main))
+    ∙ λ i → Ω→ (lem (~ i)) .fst (ℓS a b)
+    where
+    main : cong (join→Sphere n m) (ℓS a b) ≡ σS (a ⌣S b)
+    main = cong-∙ (join→Sphere n m) _ _
+         ∙ cong₂ _∙_
+             (cong σS (IdL⌣S _) ∙ σS∙)
+             (cong-∙∙ (join→Sphere n m) _ _ _
+           ∙ (λ i → sym ((cong σS (IdL⌣S a) ∙ σS∙) i)
+                  ∙∙ σS (a ⌣S b)
+                  ∙∙ sym ((cong σS (IdR⌣S b) ∙ σS∙) i))
+           ∙ sym (rUnit (σS (a ⌣S b))) )
+         ∙ sym (lUnit (σS (a ⌣S b)))
+    lem : f ∘∙ join→Sphere∙ n m ≡ (fst f ∘ join→Sphere n m , snd f)
+    lem = ΣPathP (refl , (sym (lUnit _)))
+
+  main : Square (cong (fst (∙Π f g)) (σS (a ⌣S b)))
+                (Ω→ (f ∘∙ join→Sphere∙ n m) .fst (ℓS a b)
+               ∙ Ω→ (g ∘∙ join→Sphere∙ n m) .fst (ℓS a b))
+                (snd (∙Π f g)) (snd (∙Π f g))
+  main = help _ f g (a ⌣S b) ▷ cong₂ _∙_ (Ω→σ f) (Ω→σ g)
+snd (·Π≡+* {A = A} f g i) j = lem i j
+  where
+  lem : Square (refl ∙ snd (∙Π f g)) refl (snd (∙Π f g)) refl
+  lem = sym (lUnit (snd (∙Π f g))) ◁ λ i j → (snd (∙Π f g)) (i ∨ j)
+
+-- Homotopy groups in terms of joins
+π* : ∀ {ℓ} (n m : ℕ) (A : Pointed ℓ) → Type ℓ
+π* n m A = ∥ join∙ (S₊∙ n) (S₊∙ m) →∙ A ∥₂
+
+-- multiplication
+·π* : ∀ {ℓ} {n m : ℕ} {A : Pointed ℓ} (f g : π* n m A) → π* n m A
+·π* = ST.rec2 squash₂ λ f g → ∣ f +* g ∣₂
+
+-π* : ∀ {ℓ} {n m : ℕ} {A : Pointed ℓ} (f : π* n m A) → π* n m A
+-π* = ST.map -*
+
+1π* : ∀ {ℓ} {n m : ℕ} {A : Pointed ℓ} → π* n m A
+1π* = ∣ const∙ _ _ ∣₂
+
+Iso-JoinMap-SphereMap : ∀ {ℓ} {A : Pointed ℓ} (n m : ℕ)
+  → Iso (join∙ (S₊∙ n) (S₊∙ m) →∙ A)
+         (S₊∙ (suc (n + m)) →∙ A)
+Iso-JoinMap-SphereMap n m = post∘∙equiv (joinSphereEquiv∙ n m)
+
+Iso-π*-π' : ∀ {ℓ} {A : Pointed ℓ} (n m : ℕ)
+  → Iso ∥ (join∙ (S₊∙ n) (S₊∙ m) →∙ A) ∥₂
+         ∥ (S₊∙ (suc (n + m)) →∙ A) ∥₂
+Iso-π*-π' n m = setTruncIso (Iso-JoinMap-SphereMap n m)
+
+private
+  J≃∙map : ∀ {ℓ ℓ' ℓ''} {A1 A2 : Pointed ℓ} {A : Pointed ℓ'}
+         → (e : A1 ≃∙ A2) {P : A1 →∙ A → Type ℓ''}
+       → ((f : A2 →∙ A) → P (f ∘∙ ≃∙map e))
+       → (f : _) → P f
+  J≃∙map  {ℓ'' = ℓ''} {A2 = A2} {A = A} =
+    Equiv∙J (λ A1 e → {P : A1 →∙ A → Type ℓ''}
+         → ((f : A2 →∙ A) → P (f ∘∙ ≃∙map e))
+          → (f : _) → P f)
+      λ {P} ind f
+      → subst P (ΣPathP (refl , sym (lUnit (snd f)))) (ind f)
+
+π*≡π' : ∀ {ℓ} {A : Pointed ℓ} {n m : ℕ}
+  (f g : π* n m A)
+  → Iso.fun (Iso-π*-π' n m) (·π* f g)
+  ≡ ·π' _ (Iso.fun (Iso-π*-π' n m) f) (Iso.fun (Iso-π*-π' n m) g)
+π*≡π' {A = A} {n} {m} = ST.elim2 (λ _ _ → isSetPathImplicit)
+  (J≃∙map (joinSphereEquiv∙ n m)
+    λ f → J≃∙map (joinSphereEquiv∙ n m)
+      λ g → cong ∣_∣₂
+        (cong (fun (Iso-JoinMap-SphereMap n m)) (sym (·Π≡+* f g))
+        ∙ ∘∙-assoc _ _ _
+        ∙ cong (∙Π f g ∘∙_) ret
+        ∙ ∘∙-idˡ (∙Π f g)
+        ∙ cong₂ ∙Π
+              ((sym (∘∙-idˡ f) ∙ cong (f ∘∙_) (sym ret)) ∙ sym (∘∙-assoc _ _ _))
+              (sym (∘∙-idˡ g) ∙ cong (g ∘∙_) (sym ret) ∙ sym (∘∙-assoc _ _ _))))
+  where
+  ret = ≃∙→ret/sec∙ {B = _ , ptSn (suc (n + m))}
+          (joinSphereEquiv∙ n m) .snd
+
+-π*≡-π' : ∀ {ℓ} {A : Pointed ℓ} {n m : ℕ}
+  (f : π* n m A)
+  → Iso.fun (Iso-π*-π' n m) (-π* f)
+  ≡ -π' _ (Iso.fun (Iso-π*-π' n m) f)
+-π*≡-π' {n = n} {m} =
+  ST.elim (λ _ → isSetPathImplicit)
+   (J≃∙map (joinSphereEquiv∙ n m)
+    λ f → cong ∣_∣₂
+      (cong (_∘∙ (≃∙map (invEquiv∙ (joinSphereEquiv∙ n m))))
+            (sym (-Π≡-* f))
+    ∙ ∘∙-assoc _ _ _
+    ∙ cong (-Π f ∘∙_) ret
+    ∙ ∘∙-idˡ (-Π f)
+    ∙ cong -Π (sym (∘∙-assoc _ _ _ ∙ cong (f ∘∙_) ret ∙ ∘∙-idˡ f))))
+  where
+  ret = ≃∙→ret/sec∙ {B = _ , ptSn (suc (n + m))}
+          (joinSphereEquiv∙ n m) .snd
+
+-- Homotopy groups in terms of joins
+π*Gr : ∀ {ℓ} (n m : ℕ) (A : Pointed ℓ) → Group ℓ
+fst (π*Gr n m A) = π* n m A
+1g (snd (π*Gr n m A)) = 1π*
+GroupStr._·_ (snd (π*Gr n m A)) = ·π*
+inv (snd (π*Gr n m A)) = -π*
+isGroup (snd (π*Gr n m A)) =
+  transport (λ i → IsGroup (p1 (~ i)) (p2 (~ i)) (p3 (~ i)))
+            (isGroup (π'Gr (n + m) A .snd))
+  where
+  p1 : PathP (λ i → isoToPath (Iso-π*-π' {A = A} n m) i)
+             1π* (1π' (suc (n + m)))
+  p1 = toPathP (cong ∣_∣₂ (transportRefl _ ∙ ΣPathP (refl , sym (rUnit refl))))
+
+  p2 : PathP (λ i → (f g : isoToPath (Iso-π*-π' {A = A} n m) i)
+                  → isoToPath (Iso-π*-π' {A = A} n m) i)
+              ·π* (·π' _)
+  p2 = toPathP (funExt λ f
+    → funExt λ g → transportRefl _
+    ∙ π*≡π' _ _
+    ∙ cong₂ (·π' (n + m))
+            (Iso.rightInv (Iso-π*-π' n m) _ ∙ transportRefl f)
+            (Iso.rightInv (Iso-π*-π' n m) _ ∙ transportRefl g))
+
+  p3 : PathP (λ i → isoToPath (Iso-π*-π' {A = A} n m) i
+                   → isoToPath (Iso-π*-π' {A = A} n m) i)
+             -π* (-π' _)
+  p3 = toPathP (funExt λ f → transportRefl _
+    ∙ -π*≡-π' _
+    ∙ cong (-π' (n + m))
+           (Iso.rightInv (Iso-π*-π' n m) _ ∙ transportRefl f))
+
+-- Homotopy groups in terms of joins agrees with usual definition
+π*Gr≅π'Gr : ∀ {ℓ} (n m : ℕ) (A : Pointed ℓ)
+  → GroupIso (π*Gr n m A) (π'Gr (n + m) A)
+fst (π*Gr≅π'Gr n m A) = Iso-π*-π' {A = A} n m
+snd (π*Gr≅π'Gr n m A) = makeIsGroupHom π*≡π'
+
+-- Functoriality
+π*∘∙fun : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
+  (n m : ℕ) (f : A →∙ B)
+   → π* n m A → π* n m B
+π*∘∙fun n m f  = ST.map (f ∘∙_)
+
+π*∘∙Hom : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
+  (n m : ℕ) (f : A →∙ B)
+  → GroupHom (π*Gr n m A) (π*Gr n m B)
+fst (π*∘∙Hom {A = A} {B = B} n m f) = π*∘∙fun n m f
+snd (π*∘∙Hom {A = A} {B = B} n m f) =
+  subst (λ ϕ → IsGroupHom (π*Gr n m A .snd) ϕ (π*Gr n m B .snd))
+        π*∘∙Hom'≡
+        (snd π*∘∙Hom')
+  where
+  GroupHomπ≅π*PathP : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') (n m : ℕ)
+    → GroupHom (π'Gr (n + m) A) (π'Gr (n + m) B)
+     ≡ GroupHom (π*Gr n m A) (π*Gr n m B)
+  GroupHomπ≅π*PathP A B n m i =
+    GroupHom (fst (GroupPath _ _) (GroupIso→GroupEquiv (π*Gr≅π'Gr n m A)) (~ i))
+             (fst (GroupPath _ _) (GroupIso→GroupEquiv (π*Gr≅π'Gr n m B)) (~ i))
+
+  π*∘∙Hom' : _
+  π*∘∙Hom' = transport (λ i → GroupHomπ≅π*PathP A B n m i)
+                       (π'∘∙Hom (n + m) f)
+
+  π*∘∙Hom'≡ : π*∘∙Hom' .fst ≡ π*∘∙fun n m f
+  π*∘∙Hom'≡ =
+    funExt (ST.elim (λ _ → isSetPathImplicit)
+           λ g → cong ∣_∣₂ (cong (inv (Iso-JoinMap-SphereMap n m))
+                   (transportRefl _
+                   ∙ cong (f ∘∙_) (transportRefl _))
+                 ∙ ∘∙-assoc _ _ _
+                 ∙ cong (f ∘∙_ )
+                        (∘∙-assoc _ _ _ ∙ cong (g ∘∙_)
+                         (≃∙→ret/sec∙ {B = _ , ptSn (suc (n + m))}
+                          (joinSphereEquiv∙ n m) .fst)
+                       ∙ ∘∙-idˡ g)))
+
\ No newline at end of file diff --git a/Cubical.Homotopy.Group.Pi3S2.html b/Cubical.Homotopy.Group.Pi3S2.html index 79a656a67..07f6c2653 100644 --- a/Cubical.Homotopy.Group.Pi3S2.html +++ b/Cubical.Homotopy.Group.Pi3S2.html @@ -46,7 +46,7 @@ snd TotalHopf→∙S² = refl IsoTotalSpaceJoin' : Iso (Σ (S₊ 2) S¹Hopf) (S₊ 3) -IsoTotalSpaceJoin' = compIso hopfS¹.IsoTotalSpaceJoin (IsoSphereJoin 1 1) +IsoTotalSpaceJoin' = compIso hopfS¹.IsoTotalSpaceJoin (IsoSphereJoin 1 1) IsoFiberTotalHopfS¹ : Iso (fiber (fst TotalHopf→∙S²) north) S¹ fun IsoFiberTotalHopfS¹ ((x , y) , z) = subst S¹Hopf z y @@ -106,7 +106,7 @@ (invIso (compIso (hopfS¹.IsoTotalSpaceJoin) - (IsoSphereJoin 1 1)))) + (IsoSphereJoin 1 1)))) , refl) π₃S²≅ℤ : GroupEquiv (π'Gr 2 (S₊∙ 2)) ℤGroup @@ -119,18 +119,18 @@ -- We prove that the generator is the Hopf map π₃TotalHopf-gen' : π' 3 (Σ (Susp S¹) S¹Hopf , north , base) π₃TotalHopf-gen' = - ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ + ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ πS³≅πTotalHopf-gen : fst (fst (πS³≅πTotalHopf 2)) ∣ idfun∙ _ ∣₂ ≡ π₃TotalHopf-gen' πS³≅πTotalHopf-gen = cong ∣_∣₂ (∘∙-idʳ (inv (compIso (hopfS¹.IsoTotalSpaceJoin) - (IsoSphereJoin 1 1)) , refl)) + (IsoSphereJoin 1 1)) , refl)) πTotalHopf-gen : gen₁-by (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base)) - ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ + ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ πTotalHopf-gen = subst (gen₁-by (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base))) πS³≅πTotalHopf-gen @@ -151,7 +151,7 @@ π₂S³-gen-by-HopfMap' = subst (gen₁-by (π'Gr 2 (S₊∙ 2))) πTotalHopf≅πS²-gen (Iso-pres-gen₁ (π'Gr 2 (Σ (S₊ 2) S¹Hopf , north , base)) (π'Gr 2 (S₊∙ 2)) - ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ + ∣ inv (compIso (hopfS¹.IsoTotalSpaceJoin) (IsoSphereJoin 1 1)) , refl ∣₂ πTotalHopf-gen (GroupEquiv→GroupIso π'₃S²≅π'₃TotalHopf)) diff --git a/Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments.html b/Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments.html index 6e0f39bb3..f41edb494 100644 --- a/Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments.html +++ b/Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments.html @@ -22,251 +22,251 @@ open import Cubical.HITs.S1 hiding (encode) open import Cubical.HITs.S2 open import Cubical.HITs.S3 -open import Cubical.HITs.Join -open import Cubical.HITs.SetTruncation as SetTrunc -open import Cubical.HITs.GroupoidTruncation as GroupoidTrunc -open import Cubical.HITs.2GroupoidTruncation as 2GroupoidTrunc -open import Cubical.HITs.Truncation as Trunc -open import Cubical.HITs.Susp renaming (toSusp to σ) - -open import Cubical.Homotopy.Loopspace -open import Cubical.Homotopy.Hopf -open S¹Hopf - -Bool∙ S¹∙ S³∙ : Pointed₀ -Bool∙ = (Bool , true) -S¹∙ = (S¹ , base) -S³∙ = (S³ , base) - -∥_∥₃∙ ∥_∥₄∙ : Pointed₀ → Pointed₀ -∥ A , a ∥₃∙ = ∥ A ∥₃ , ∣ a ∣₃ -∥ A , a ∥₄∙ = ∥ A ∥₄ , ∣ a ∣₄ - -join∙ : Pointed₀ → Type₀ → Pointed₀ -join∙ (A , a) B = join A B , inl a - -Ω² Ω³ : Pointed₀ → Pointed₀ -Ω² = Ω^ 2 -Ω³ = Ω^ 3 - -mapΩrefl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω A .fst → Ω (B , f (pt A)) .fst -mapΩrefl f p i = f (p i) - -mapΩ²refl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω² A .fst → Ω² (B , f (pt A)) .fst -mapΩ²refl f p i j = f (p i j) - -mapΩ³refl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω³ A .fst → Ω³ (B , f (pt A)) .fst -mapΩ³refl f p i j k = f (p i j k) - -meridS² : S¹ → Path S² base base -meridS² base _ = base -meridS² (loop i) j = surf i j - -alpha : join S¹ S¹ → S² -alpha (inl x) = base -alpha (inr y) = base -alpha (push x y i) = (meridS² y ∙ meridS² x) i - -connectionBoth : {A : Type₀} {a : A} (p : Path A a a) → PathP (λ i → Path A (p i) (p i)) p p -connectionBoth {a = a} p i j = - hcomp - (λ k → λ - { (i = i0) → p (j ∨ ~ k) - ; (i = i1) → p (j ∧ k) - ; (j = i0) → p (i ∨ ~ k) - ; (j = i1) → p (i ∧ k) - }) - a - -data PostTotalHopf : Type₀ where - base : S¹ → PostTotalHopf - loop : (x : S¹) → PathP (λ i → Path PostTotalHopf (base x) (base (rotLoop x (~ i)))) refl refl - -tee12 : (x : S²) → HopfS² x → PostTotalHopf -tee12 base y = base y -tee12 (surf i j) y = - hcomp - (λ k → λ - { (i = i0) → base y - ; (i = i1) → base y - ; (j = i0) → base y - ; (j = i1) → base (rotLoopInv y (~ i) k) - }) - (loop (unglue (i ∨ ~ i ∨ j ∨ ~ j) y) i j) - -tee34 : PostTotalHopf → join S¹ S¹ -tee34 (base x) = inl x -tee34 (loop x i j) = - hcomp - (λ k → λ - { (i = i0) → push x x (j ∧ ~ k) - ; (i = i1) → push x x (j ∧ ~ k) - ; (j = i0) → inl x - ; (j = i1) → push (rotLoop x (~ i)) x (~ k) - }) - (push x x j) - -tee : (x : S²) → HopfS² x → join S¹ S¹ -tee x y = tee34 (tee12 x y) - -fibΩ : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω B .fst → Type₀ -fibΩ P f p = PathP (λ i → P (p i)) f f - -fibΩ² : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω² B .fst → Type₀ -fibΩ² P f = fibΩ (fibΩ P f) refl - -fibΩ³ : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω³ B .fst → Type₀ -fibΩ³ P f = fibΩ² (fibΩ P f) refl - -Ω³Hopf : Ω³ S²∙ .fst → Type₀ -Ω³Hopf = fibΩ³ HopfS² base - -fibContrΩ³Hopf : ∀ p → Ω³Hopf p -fibContrΩ³Hopf p i j k = - hcomp - (λ m → λ - { (i = i0) → base - ; (i = i1) → base - ; (j = i0) → base - ; (j = i1) → base - ; (k = i0) → base - ; (k = i1) → - isSetΩS¹ refl refl - (λ i j → transp (λ n → HopfS² (p i j n)) (i ∨ ~ i ∨ j ∨ ~ j) base) - (λ _ _ → base) - m i j - }) - (transp (λ n → HopfS² (p i j (k ∧ n))) (i ∨ ~ i ∨ j ∨ ~ j ∨ ~ k) base) - -h : Ω³ S²∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst -h p i j k = tee (p i j k) (fibContrΩ³Hopf p i j k) - -multTwoAux : (x : S²) → Path (Path ∥ S² ∥₄ ∣ x ∣₄ ∣ x ∣₄) refl refl -multTwoAux base i j = ∣ surf i j ∣₄ -multTwoAux (surf k l) i j = - hcomp - (λ m → λ - { (i = i0) → ∣ surf k l ∣₄ - ; (i = i1) → ∣ surf k l ∣₄ - ; (j = i0) → ∣ surf k l ∣₄ - ; (j = i1) → ∣ surf k l ∣₄ - ; (k = i0) → ∣ surf i j ∣₄ - ; (k = i1) → ∣ surf i j ∣₄ - ; (l = i0) → ∣ surf i j ∣₄ - ; (l = i1) → squash₄ _ _ _ _ _ _ (λ k i j → step₁ k i j) refl m k i j - }) - (step₁ k i j) - - where - step₁ : I → I → I → ∥ S² ∥₄ - step₁ k i j = - hcomp {A = ∥ S² ∥₄} - (λ m → λ - { (i = i0) → ∣ surf k (l ∧ m) ∣₄ - ; (i = i1) → ∣ surf k (l ∧ m) ∣₄ - ; (j = i0) → ∣ surf k (l ∧ m) ∣₄ - ; (j = i1) → ∣ surf k (l ∧ m) ∣₄ - ; (k = i0) → ∣ surf i j ∣₄ - ; (k = i1) → ∣ surf i j ∣₄ - ; (l = i0) → ∣ surf i j ∣₄ - }) - ∣ surf i j ∣₄ - -multTwoTildeAux : (t : ∥ S² ∥₄) → Path (Path ∥ S² ∥₄ t t) refl refl -multTwoTildeAux ∣ x ∣₄ = multTwoAux x -multTwoTildeAux (squash₄ _ _ _ _ _ _ t u k l m n) i j = - squash₄ _ _ _ _ _ _ - (λ k l m → multTwoTildeAux (t k l m) i j) - (λ k l m → multTwoTildeAux (u k l m) i j) - k l m n - -multTwoEquivAux : Path (Path (∥ S² ∥₄ ≃ ∥ S² ∥₄) (idEquiv _) (idEquiv _)) refl refl -multTwoEquivAux i j = - ( f i j - , hcomp - (λ l → λ - { (i = i0) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l - ; (i = i1) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l - ; (j = i0) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l - ; (j = i1) → - isPropIsEquiv _ - (transp (λ k → isEquiv (f i k)) (i ∨ ~ i) (idIsEquiv _)) - (idIsEquiv _) - l - }) - (transp (λ k → isEquiv (f i (j ∧ k))) (i ∨ ~ i ∨ ~ j) (idIsEquiv _)) - ) - where - f : I → I → ∥ S² ∥₄ → ∥ S² ∥₄ - f i j t = multTwoTildeAux t i j - -tHopf³ : S³ → Type₀ -tHopf³ base = ∥ S² ∥₄ -tHopf³ (surf i j k) = - Glue ∥ S² ∥₄ - (λ { (i = i0) → (∥ S² ∥₄ , idEquiv _) - ; (i = i1) → (∥ S² ∥₄ , idEquiv _) - ; (j = i0) → (∥ S² ∥₄ , idEquiv _) - ; (j = i1) → (∥ S² ∥₄ , idEquiv _) - ; (k = i0) → (∥ S² ∥₄ , multTwoEquivAux i j) - ; (k = i1) → (∥ S² ∥₄ , idEquiv _) - }) - -π₃S³ : Ω³ S³∙ .fst → Ω² ∥ S²∙ ∥₄∙ .fst -π₃S³ p i j = transp (λ k → tHopf³ (p j k i)) i0 ∣ base ∣₄ - -codeS² : S² → hGroupoid _ -codeS² s = ∥ HopfS² s ∥₃ , squash₃ - -codeTruncS² : ∥ S² ∥₄ → hGroupoid _ -codeTruncS² = 2GroupoidTrunc.rec (isOfHLevelTypeOfHLevel 3) codeS² - -encodeTruncS² : Ω ∥ S²∙ ∥₄∙ .fst → ∥ S¹ ∥₃ -encodeTruncS² p = transp (λ i → codeTruncS² (p i) .fst) i0 ∣ base ∣₃ - -codeS¹ : S¹ → hSet _ -codeS¹ s = ∥ helix s ∥₂ , squash₂ - -codeTruncS¹ : ∥ S¹ ∥₃ → hSet _ -codeTruncS¹ = GroupoidTrunc.rec (isOfHLevelTypeOfHLevel 2) codeS¹ - -encodeTruncS¹ : Ω ∥ S¹∙ ∥₃∙ .fst → ∥ ℤ ∥₂ -encodeTruncS¹ p = transp (λ i → codeTruncS¹ (p i) .fst) i0 ∣ pos zero ∣₂ - - --- THE BIG GAME - -f3 : Ω³ S³∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst -f3 = mapΩ³refl S³→joinS¹S¹ - -f4 : Ω³ (join∙ S¹∙ S¹) .fst → Ω³ S²∙ .fst -f4 = mapΩ³refl alpha - -f5 : Ω³ S²∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst -f5 = h - -f6 : Ω³ (join∙ S¹∙ S¹) .fst → Ω³ S³∙ .fst -f6 = mapΩ³refl joinS¹S¹→S³ - -f7 : Ω³ S³∙ .fst → Ω² ∥ S²∙ ∥₄∙ .fst -f7 = π₃S³ - -g8 : Ω² ∥ S²∙ ∥₄∙ .fst → Ω ∥ S¹∙ ∥₃∙ .fst -g8 = mapΩrefl encodeTruncS² - -g9 : Ω ∥ S¹∙ ∥₃∙ .fst → ∥ ℤ ∥₂ -g9 = encodeTruncS¹ - -g10 : ∥ ℤ ∥₂ → ℤ -g10 = SetTrunc.rec isSetℤ (idfun ℤ) - --- don't run me -brunerie : ℤ -brunerie = g10 (g9 (g8 (f7 (f6 (f5 (f4 (f3 (λ i j k → surf i j k)))))))) - - +open import Cubical.HITs.Join hiding (join∙) +open import Cubical.HITs.SetTruncation as SetTrunc +open import Cubical.HITs.GroupoidTruncation as GroupoidTrunc +open import Cubical.HITs.2GroupoidTruncation as 2GroupoidTrunc +open import Cubical.HITs.Truncation as Trunc +open import Cubical.HITs.Susp renaming (toSusp to σ) + +open import Cubical.Homotopy.Loopspace +open import Cubical.Homotopy.Hopf +open S¹Hopf + +Bool∙ S¹∙ S³∙ : Pointed₀ +Bool∙ = (Bool , true) +S¹∙ = (S¹ , base) +S³∙ = (S³ , base) + +∥_∥₃∙ ∥_∥₄∙ : Pointed₀ → Pointed₀ +∥ A , a ∥₃∙ = ∥ A ∥₃ , ∣ a ∣₃ +∥ A , a ∥₄∙ = ∥ A ∥₄ , ∣ a ∣₄ + +join∙ : Pointed₀ → Type₀ → Pointed₀ +join∙ (A , a) B = join A B , inl a + +Ω² Ω³ : Pointed₀ → Pointed₀ +Ω² = Ω^ 2 +Ω³ = Ω^ 3 + +mapΩrefl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω A .fst → Ω (B , f (pt A)) .fst +mapΩrefl f p i = f (p i) + +mapΩ²refl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω² A .fst → Ω² (B , f (pt A)) .fst +mapΩ²refl f p i j = f (p i j) + +mapΩ³refl : {A : Pointed₀} {B : Type₀} (f : A .fst → B) → Ω³ A .fst → Ω³ (B , f (pt A)) .fst +mapΩ³refl f p i j k = f (p i j k) + +meridS² : S¹ → Path S² base base +meridS² base _ = base +meridS² (loop i) j = surf i j + +alpha : join S¹ S¹ → S² +alpha (inl x) = base +alpha (inr y) = base +alpha (push x y i) = (meridS² y ∙ meridS² x) i + +connectionBoth : {A : Type₀} {a : A} (p : Path A a a) → PathP (λ i → Path A (p i) (p i)) p p +connectionBoth {a = a} p i j = + hcomp + (λ k → λ + { (i = i0) → p (j ∨ ~ k) + ; (i = i1) → p (j ∧ k) + ; (j = i0) → p (i ∨ ~ k) + ; (j = i1) → p (i ∧ k) + }) + a + +data PostTotalHopf : Type₀ where + base : S¹ → PostTotalHopf + loop : (x : S¹) → PathP (λ i → Path PostTotalHopf (base x) (base (rotLoop x (~ i)))) refl refl + +tee12 : (x : S²) → HopfS² x → PostTotalHopf +tee12 base y = base y +tee12 (surf i j) y = + hcomp + (λ k → λ + { (i = i0) → base y + ; (i = i1) → base y + ; (j = i0) → base y + ; (j = i1) → base (rotLoopInv y (~ i) k) + }) + (loop (unglue (i ∨ ~ i ∨ j ∨ ~ j) y) i j) + +tee34 : PostTotalHopf → join S¹ S¹ +tee34 (base x) = inl x +tee34 (loop x i j) = + hcomp + (λ k → λ + { (i = i0) → push x x (j ∧ ~ k) + ; (i = i1) → push x x (j ∧ ~ k) + ; (j = i0) → inl x + ; (j = i1) → push (rotLoop x (~ i)) x (~ k) + }) + (push x x j) + +tee : (x : S²) → HopfS² x → join S¹ S¹ +tee x y = tee34 (tee12 x y) + +fibΩ : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω B .fst → Type₀ +fibΩ P f p = PathP (λ i → P (p i)) f f + +fibΩ² : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω² B .fst → Type₀ +fibΩ² P f = fibΩ (fibΩ P f) refl + +fibΩ³ : {B : Pointed₀} (P : B .fst → Type₀) → P (pt B) → Ω³ B .fst → Type₀ +fibΩ³ P f = fibΩ² (fibΩ P f) refl + +Ω³Hopf : Ω³ S²∙ .fst → Type₀ +Ω³Hopf = fibΩ³ HopfS² base + +fibContrΩ³Hopf : ∀ p → Ω³Hopf p +fibContrΩ³Hopf p i j k = + hcomp + (λ m → λ + { (i = i0) → base + ; (i = i1) → base + ; (j = i0) → base + ; (j = i1) → base + ; (k = i0) → base + ; (k = i1) → + isSetΩS¹ refl refl + (λ i j → transp (λ n → HopfS² (p i j n)) (i ∨ ~ i ∨ j ∨ ~ j) base) + (λ _ _ → base) + m i j + }) + (transp (λ n → HopfS² (p i j (k ∧ n))) (i ∨ ~ i ∨ j ∨ ~ j ∨ ~ k) base) + +h : Ω³ S²∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst +h p i j k = tee (p i j k) (fibContrΩ³Hopf p i j k) + +multTwoAux : (x : S²) → Path (Path ∥ S² ∥₄ ∣ x ∣₄ ∣ x ∣₄) refl refl +multTwoAux base i j = ∣ surf i j ∣₄ +multTwoAux (surf k l) i j = + hcomp + (λ m → λ + { (i = i0) → ∣ surf k l ∣₄ + ; (i = i1) → ∣ surf k l ∣₄ + ; (j = i0) → ∣ surf k l ∣₄ + ; (j = i1) → ∣ surf k l ∣₄ + ; (k = i0) → ∣ surf i j ∣₄ + ; (k = i1) → ∣ surf i j ∣₄ + ; (l = i0) → ∣ surf i j ∣₄ + ; (l = i1) → squash₄ _ _ _ _ _ _ (λ k i j → step₁ k i j) refl m k i j + }) + (step₁ k i j) + + where + step₁ : I → I → I → ∥ S² ∥₄ + step₁ k i j = + hcomp {A = ∥ S² ∥₄} + (λ m → λ + { (i = i0) → ∣ surf k (l ∧ m) ∣₄ + ; (i = i1) → ∣ surf k (l ∧ m) ∣₄ + ; (j = i0) → ∣ surf k (l ∧ m) ∣₄ + ; (j = i1) → ∣ surf k (l ∧ m) ∣₄ + ; (k = i0) → ∣ surf i j ∣₄ + ; (k = i1) → ∣ surf i j ∣₄ + ; (l = i0) → ∣ surf i j ∣₄ + }) + ∣ surf i j ∣₄ + +multTwoTildeAux : (t : ∥ S² ∥₄) → Path (Path ∥ S² ∥₄ t t) refl refl +multTwoTildeAux ∣ x ∣₄ = multTwoAux x +multTwoTildeAux (squash₄ _ _ _ _ _ _ t u k l m n) i j = + squash₄ _ _ _ _ _ _ + (λ k l m → multTwoTildeAux (t k l m) i j) + (λ k l m → multTwoTildeAux (u k l m) i j) + k l m n + +multTwoEquivAux : Path (Path (∥ S² ∥₄ ≃ ∥ S² ∥₄) (idEquiv _) (idEquiv _)) refl refl +multTwoEquivAux i j = + ( f i j + , hcomp + (λ l → λ + { (i = i0) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l + ; (i = i1) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l + ; (j = i0) → isPropIsEquiv _ (idIsEquiv _) (idIsEquiv _) l + ; (j = i1) → + isPropIsEquiv _ + (transp (λ k → isEquiv (f i k)) (i ∨ ~ i) (idIsEquiv _)) + (idIsEquiv _) + l + }) + (transp (λ k → isEquiv (f i (j ∧ k))) (i ∨ ~ i ∨ ~ j) (idIsEquiv _)) + ) + where + f : I → I → ∥ S² ∥₄ → ∥ S² ∥₄ + f i j t = multTwoTildeAux t i j + +tHopf³ : S³ → Type₀ +tHopf³ base = ∥ S² ∥₄ +tHopf³ (surf i j k) = + Glue ∥ S² ∥₄ + (λ { (i = i0) → (∥ S² ∥₄ , idEquiv _) + ; (i = i1) → (∥ S² ∥₄ , idEquiv _) + ; (j = i0) → (∥ S² ∥₄ , idEquiv _) + ; (j = i1) → (∥ S² ∥₄ , idEquiv _) + ; (k = i0) → (∥ S² ∥₄ , multTwoEquivAux i j) + ; (k = i1) → (∥ S² ∥₄ , idEquiv _) + }) + +π₃S³ : Ω³ S³∙ .fst → Ω² ∥ S²∙ ∥₄∙ .fst +π₃S³ p i j = transp (λ k → tHopf³ (p j k i)) i0 ∣ base ∣₄ + +codeS² : S² → hGroupoid _ +codeS² s = ∥ HopfS² s ∥₃ , squash₃ + +codeTruncS² : ∥ S² ∥₄ → hGroupoid _ +codeTruncS² = 2GroupoidTrunc.rec (isOfHLevelTypeOfHLevel 3) codeS² + +encodeTruncS² : Ω ∥ S²∙ ∥₄∙ .fst → ∥ S¹ ∥₃ +encodeTruncS² p = transp (λ i → codeTruncS² (p i) .fst) i0 ∣ base ∣₃ + +codeS¹ : S¹ → hSet _ +codeS¹ s = ∥ helix s ∥₂ , squash₂ + +codeTruncS¹ : ∥ S¹ ∥₃ → hSet _ +codeTruncS¹ = GroupoidTrunc.rec (isOfHLevelTypeOfHLevel 2) codeS¹ + +encodeTruncS¹ : Ω ∥ S¹∙ ∥₃∙ .fst → ∥ ℤ ∥₂ +encodeTruncS¹ p = transp (λ i → codeTruncS¹ (p i) .fst) i0 ∣ pos zero ∣₂ + + +-- THE BIG GAME + +f3 : Ω³ S³∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst +f3 = mapΩ³refl S³→joinS¹S¹ + +f4 : Ω³ (join∙ S¹∙ S¹) .fst → Ω³ S²∙ .fst +f4 = mapΩ³refl alpha + +f5 : Ω³ S²∙ .fst → Ω³ (join∙ S¹∙ S¹) .fst +f5 = h + +f6 : Ω³ (join∙ S¹∙ S¹) .fst → Ω³ S³∙ .fst +f6 = mapΩ³refl joinS¹S¹→S³ + +f7 : Ω³ S³∙ .fst → Ω² ∥ S²∙ ∥₄∙ .fst +f7 = π₃S³ + +g8 : Ω² ∥ S²∙ ∥₄∙ .fst → Ω ∥ S¹∙ ∥₃∙ .fst +g8 = mapΩrefl encodeTruncS² + +g9 : Ω ∥ S¹∙ ∥₃∙ .fst → ∥ ℤ ∥₂ +g9 = encodeTruncS¹ + +g10 : ∥ ℤ ∥₂ → ℤ +g10 = SetTrunc.rec isSetℤ (idfun ℤ) + +-- don't run me +brunerie : ℤ +brunerie = g10 (g9 (g8 (f7 (f6 (f5 (f4 (f3 (λ i j k → surf i j k)))))))) + + -{- +{- Computation of an alternative definition of the Brunerie number based on https://github.com/agda/cubical/pull/741. One should note that this @@ -275,61 +275,61 @@ -} --- The brunerie element can be shown to correspond to the following map -η₃ : (join S¹ S¹ , inl base) →∙ (Susp S² , north) -fst η₃ (inl x) = north -fst η₃ (inr x) = north -fst η₃ (push a b i) = - (σ (S² , base) (S¹×S¹→S² a b) ∙ σ (S² , base) (S¹×S¹→S² a b)) i -snd η₃ = refl - -K₂ = ∥ S² ∥₄ --- We will need a map Ω (Susp S²) → K₂. It turns out that the --- following map is fast. It need a bit of work, however. It's --- esentially the same map as you find in ZCohomology from ΩKₙ₊₁ to --- Kₙ. This gives another definition of f7 which appears to work better. - -module f7stuff where - _+₂_ : K₂ → K₂ → K₂ - _+₂_ = 2GroupoidTrunc.elim (λ _ → isOfHLevelΠ 4 λ _ → squash₄) - λ { base x → x - ; (surf i j) x → surfc x i j} - where - surfc : (x : K₂) → typ ((Ω^ 2) (K₂ , x)) - surfc = - 2GroupoidTrunc.elim - (λ _ → isOfHLevelPath 4 (isOfHLevelPath 4 squash₄ _ _) _ _) - (S²ToSetElim (λ _ → squash₄ _ _ _ _) λ i j → ∣ surf i j ∣₄) - - K₂≃K₂ : (x : S²) → K₂ ≃ K₂ - fst (K₂≃K₂ x) y = ∣ x ∣₄ +₂ y - snd (K₂≃K₂ x) = help x - where - help : (x : _) → isEquiv (λ y → ∣ x ∣₄ +₂ y) - help = S²ToSetElim (λ _ → isProp→isSet (isPropIsEquiv _)) - (idEquiv _ .snd) - - Code : Susp S² → Type ℓ-zero - Code north = K₂ - Code south = K₂ - Code (merid a i) = ua (K₂≃K₂ a) i - - encode : (x : Susp S²) → north ≡ x → Code x - encode x = J (λ x p → Code x) ∣ base ∣₄ - --- We now get an alternative definition of f7 -f7' : typ (Ω (Susp∙ S²)) → K₂ -f7' = f7stuff.encode north - --- We can define the Brunerie number by -brunerie' : ℤ -brunerie' = g10 (g9 (g8 λ i j → f7' λ k → η₃ .fst (push (loop i) (loop j) k))) - --- Computing it takes ~1s -brunerie'≡-2 : brunerie' ≡ -2 -brunerie'≡-2 = refl - --- Proving that this indeed corresponds to the Brunerie number --- requires us to phrase things slightly more carefully. For this, see --- the second part of the Cubical.Homotopy.Group.Pi4S3.DirectProof. +-- The brunerie element can be shown to correspond to the following map +η₃ : (join S¹ S¹ , inl base) →∙ (Susp S² , north) +fst η₃ (inl x) = north +fst η₃ (inr x) = north +fst η₃ (push a b i) = + (σ (S² , base) (S¹×S¹→S² a b) ∙ σ (S² , base) (S¹×S¹→S² a b)) i +snd η₃ = refl + +K₂ = ∥ S² ∥₄ +-- We will need a map Ω (Susp S²) → K₂. It turns out that the +-- following map is fast. It need a bit of work, however. It's +-- esentially the same map as you find in ZCohomology from ΩKₙ₊₁ to +-- Kₙ. This gives another definition of f7 which appears to work better. + +module f7stuff where + _+₂_ : K₂ → K₂ → K₂ + _+₂_ = 2GroupoidTrunc.elim (λ _ → isOfHLevelΠ 4 λ _ → squash₄) + λ { base x → x + ; (surf i j) x → surfc x i j} + where + surfc : (x : K₂) → typ ((Ω^ 2) (K₂ , x)) + surfc = + 2GroupoidTrunc.elim + (λ _ → isOfHLevelPath 4 (isOfHLevelPath 4 squash₄ _ _) _ _) + (S²ToSetElim (λ _ → squash₄ _ _ _ _) λ i j → ∣ surf i j ∣₄) + + K₂≃K₂ : (x : S²) → K₂ ≃ K₂ + fst (K₂≃K₂ x) y = ∣ x ∣₄ +₂ y + snd (K₂≃K₂ x) = help x + where + help : (x : _) → isEquiv (λ y → ∣ x ∣₄ +₂ y) + help = S²ToSetElim (λ _ → isProp→isSet (isPropIsEquiv _)) + (idEquiv _ .snd) + + Code : Susp S² → Type ℓ-zero + Code north = K₂ + Code south = K₂ + Code (merid a i) = ua (K₂≃K₂ a) i + + encode : (x : Susp S²) → north ≡ x → Code x + encode x = J (λ x p → Code x) ∣ base ∣₄ + +-- We now get an alternative definition of f7 +f7' : typ (Ω (Susp∙ S²)) → K₂ +f7' = f7stuff.encode north + +-- We can define the Brunerie number by +brunerie' : ℤ +brunerie' = g10 (g9 (g8 λ i j → f7' λ k → η₃ .fst (push (loop i) (loop j) k))) + +-- Computing it takes ~1s +brunerie'≡-2 : brunerie' ≡ -2 +brunerie'≡-2 = refl + +-- Proving that this indeed corresponds to the Brunerie number +-- requires us to phrase things slightly more carefully. For this, see +-- the second part of the Cubical.Homotopy.Group.Pi4S3.DirectProof. \ No newline at end of file diff --git a/Cubical.Homotopy.Group.Pi4S3.BrunerieNumber.html b/Cubical.Homotopy.Group.Pi4S3.BrunerieNumber.html index 5c6b24f60..15c59a13d 100644 --- a/Cubical.Homotopy.Group.Pi4S3.BrunerieNumber.html +++ b/Cubical.Homotopy.Group.Pi4S3.BrunerieNumber.html @@ -65,11 +65,11 @@ -- The Brunerie number (see Corollary 3.4.5 in Brunerie's PhD thesis) Brunerie : ℕ Brunerie = - abs (HopfInvariant-π' 0 [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π') + 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) +W = joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1} ∘ Iso.inv (IsoSphereJoin 1 1) fold∘W : S₊ 3 → S₊ 2 fold∘W = fold⋁ ∘ W @@ -116,7 +116,7 @@ (∣ north , refl ∣ , (trElim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _) (uncurry - (sphereElim 2 + (sphereElim 2 (λ _ → isOfHLevelΠ 3 λ _ → isOfHLevelPath 3 (isOfHLevelSuc 2 (isOfHLevelTrunc 2)) _ _) @@ -124,10 +124,10 @@ (λ r → cong ∣_∣ₕ (ΣPathP (refl , r))) (fun (PathIdTruncIso 1) (isContr→isProp - (isConnectedPath 2 (sphereConnected 2) + (isConnectedPath 2 (sphereConnected 2) (f north) (f north)) ∣ refl ∣ ∣ p ∣))))))) (fun (PathIdTruncIso 2) - (isContr→isProp (sphereConnected 2) ∣ f north ∣ ∣ p ∣)) + (isContr→isProp (sphereConnected 2) ∣ f north ∣ ∣ p ∣)) -- We get our square module BM-inst = @@ -135,7 +135,7 @@ (λ _ → tt) fold∘W 3 1 (λ _ → subst (isConnected 4) (isoToPath (invIso fiberUnitIso)) - (sphereConnected 3)) + (sphereConnected 3)) (isConnectedS3→S2 fold∘W) open BM-inst @@ -232,9 +232,9 @@ isContrπ₂S³ : isContr (π 2 (hLevelTrunc∙ 4 (S₊∙ 3))) isContrπ₂S³ = subst (λ x → isContr (π 2 x)) - (λ i → ((sym (isContr→≡Unit (sphereConnected 3))) i) + (λ i → ((sym (isContr→≡Unit (sphereConnected 3))) i) , transp (λ j → isContr→≡Unit - (sphereConnected 3) (~ i ∧ j)) i ∣ north ∣) + (sphereConnected 3) (~ i ∧ j)) i ∣ north ∣) (∣ refl ∣₂ , sElim (λ _ → isSetPathImplicit) λ p → cong ∣_∣₂ (isProp→isSet @@ -351,9 +351,9 @@ (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))) + 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 @@ -365,9 +365,9 @@ Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ = pushoutEquiv inl _ ⋁↪ fold⋁ (idEquiv _) (compEquiv coFibW≅coFibW' - (isoToEquiv (invIso (Iso-Susp×Susp-cofibJoinTo⋁ S¹ S¹ base base)))) + (isoToEquiv (invIso (Iso-Susp×Susp-cofibJoinTo⋁ S¹ S¹ base base)))) (idEquiv _) - (Susp×Susp→cofibW≡ S¹ S¹ base base) + (Susp×Susp→cofibW≡ S¹ S¹ base base) refl Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ : @@ -399,7 +399,7 @@ -- first need the following: fold∘W≡Whitehead : fst (π'∘∙Hom 2 (fold∘W , refl)) ∣ idfun∙ (S₊∙ 3) ∣₂ - ≡ ∣ [ idfun∙ (S₊∙ 2) ∣ idfun∙ (S₊∙ 2) ]₂ ∣₂ + ≡ ∣ [ idfun∙ (S₊∙ 2) ∣ idfun∙ (S₊∙ 2) ]₂ ∣₂ fold∘W≡Whitehead = pRec (squash₂ _ _) (cong ∣_∣₂) @@ -413,7 +413,7 @@ trRec squash₁ (λ r → ∣ ΣPathP (p , r) ∣₁) (isConnectedPathP 1 {A = (λ i → p i (snd A) ≡ north)} - (isConnectedPathSⁿ 1 (fst g (pt A)) north) (snd f) (snd g) .fst ) + (isConnectedPathSⁿ 1 (fst g (pt A)) north) (snd f) (snd g) .fst ) BrunerieIsoAbstract : GroupEquiv (π'Gr 3 (S₊∙ 3)) (abstractℤGroup/ Brunerie) BrunerieIsoAbstract = @@ -430,13 +430,13 @@ mainPath : fst (π'∘∙Hom 2 (fold∘W , refl)) (Iso.inv (fst (πₙ'Sⁿ≅ℤ 2)) 1) - ≡ [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π' + ≡ [ ∣ 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.leftInv (fst (πₙ'Sⁿ≅ℤ 2)) ∣ idfun∙ (S₊∙ 3) ∣₂)) ∙ fold∘W≡Whitehead - ∙ cong ∣_∣₂ (sym ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2)))) + ∙ cong ∣_∣₂ (sym ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2)))) main : _ ≡ Brunerie main i = abs (HopfInvariant-π' 0 (mainPath i)) diff --git a/Cubical.Homotopy.Group.Pi4S3.DirectProof.html b/Cubical.Homotopy.Group.Pi4S3.DirectProof.html index 96cc37d55..139ea7c6d 100644 --- a/Cubical.Homotopy.Group.Pi4S3.DirectProof.html +++ b/Cubical.Homotopy.Group.Pi4S3.DirectProof.html @@ -64,7 +64,7 @@ open import Cubical.Homotopy.Group.Pi3S2 open import Cubical.Homotopy.Group.PinSn open import Cubical.Homotopy.Hopf -open import Cubical.Homotopy.Whitehead using (joinTo⋁) +open import Cubical.Homotopy.Whitehead using (joinTo⋁) open import Cubical.Homotopy.Connected open import Cubical.Homotopy.HopfInvariant.HopfMap using (hopfMap≡HopfMap') -- Only imports a simple equality of two constructions of the Hopf map. @@ -72,7 +72,7 @@ using (fold∘W ; coFib-fold∘W∙ ; π₄S³≅π₃coFib-fold∘W∙ ; S³→S²→Pushout→Unit) -- Only imports definitions/proofs from chapter 1-3 in Brunerie's thesis open import Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments - using (K₂ ; f7' ; S¹∙ ; encodeTruncS²) + using (K₂ ; f7' ; S¹∙ ; encodeTruncS²) -- For computation (alternative proof) open import Cubical.Data.Sigma @@ -84,7 +84,7 @@ open import Cubical.HITs.S2 renaming (S¹×S¹→S² to S¹×S¹→S²') open import Cubical.HITs.Sn open import Cubical.HITs.Susp renaming (toSusp to σ) -open import Cubical.HITs.Join hiding (joinS¹S¹→S³) +open import Cubical.HITs.Join hiding (joinS¹S¹→S³) open import Cubical.HITs.Wedge open import Cubical.HITs.Pushout open import Cubical.HITs.SetTruncation @@ -135,13 +135,13 @@ connS³ : isConnected 3 (S₊ 3) connS³ = - isConnectedSubtr 3 1 (sphereConnected 3) + isConnectedSubtr 3 1 (sphereConnected 3) - con-joinS¹S¹ : isConnected 3 (join S¹ S¹) + con-joinS¹S¹ : isConnected 3 (join S¹ S¹) con-joinS¹S¹ = (isConnectedRetractFromIso 3 - (IsoSphereJoin 1 1) - (isConnectedSubtr 3 1 (sphereConnected 3))) + (IsoSphereJoin 1 1) + (isConnectedSubtr 3 1 (sphereConnected 3))) -- Key goal: prove that the following element of π₃(S²) gets mapped to -2 η : π' 3 (S₊∙ 2) @@ -149,29 +149,29 @@ {- Step 1. Define an addition on π₃*(A) := ∥ S¹ * S¹ →∙ A ∥₀ -} -- On the underlying function spaces. -_+join_ : (f g : (join S¹ S¹ , inl base) →∙ A) - → (join S¹ S¹ , inl base) →∙ A -fst (f +join g) (inl x) = fst f (inl x) -fst (f +join g) (inr x) = fst g (inr x) -fst (f +join g) (push a b i) = - (cong (fst f) (push a b ∙ sym (push base b)) +_+join_ : (f g : (join S¹ S¹ , inl base) →∙ A) + → (join S¹ S¹ , inl base) →∙ A +fst (f +join g) (inl x) = fst f (inl x) +fst (f +join g) (inr x) = fst g (inr x) +fst (f +join g) (push a b i) = + (cong (fst f) (push a b ∙ sym (push base b)) ∙∙ snd f ∙ sym (snd g) - ∙∙ cong (fst g) (push base base ∙∙ sym (push a base) ∙∙ push a b)) i + ∙∙ cong (fst g) (push base base ∙∙ sym (push a base) ∙∙ push a b)) i snd (f +join g) = snd f -- Homotopy group version -_π₃*+_ : (f g : ∥ (join S¹ S¹ , inl base) →∙ S₊∙ 2 ∥₂) - → ∥ (join S¹ S¹ , inl base) →∙ S₊∙ 2 ∥₂ +_π₃*+_ : (f g : ∥ (join S¹ S¹ , inl base) →∙ S₊∙ 2 ∥₂) + → ∥ (join S¹ S¹ , inl base) →∙ S₊∙ 2 ∥₂ _π₃*+_ = sRec2 squash₂ λ x y → ∣ x +join y ∣₂ -- transferring between π₃ and π₃* -- (homotopy groups defined in terms of S¹ * S¹) -joinify : S₊∙ 3 →∙ A → (join S¹ S¹ , inl base) →∙ A -fst (joinify f) x = fst f (joinS¹S¹→S³ x) +joinify : S₊∙ 3 →∙ A → (join S¹ S¹ , inl base) →∙ A +fst (joinify f) x = fst f (joinS¹S¹→S³ x) snd (joinify f) = snd f -disjoin : (join S¹ S¹ , inl base) →∙ A → S₊∙ 3 →∙ A -fst (disjoin f) = λ x → fst f (Iso.inv (IsoSphereJoin 1 1) x) +disjoin : (join S¹ S¹ , inl base) →∙ A → S₊∙ 3 →∙ A +fst (disjoin f) = λ x → fst f (Iso.inv (IsoSphereJoin 1 1) x) snd (disjoin f) = snd f @@ -180,9 +180,9 @@ → joinify (∙Π f g) ≡ (joinify f +join joinify g) +join≡∙Π f' g' = - ΣPathP ((funExt (λ { (inl x) → sym fp - ; (inr x) → sym gp ∙ cong g (merid north) - ; (push a b i) j → main a b j i})) + ΣPathP ((funExt (λ { (inl x) → sym fp + ; (inr x) → sym gp ∙ cong g (merid north) + ; (push a b i) j → main a b j i})) , λ i j → fp (j ∨ ~ i)) where f = fst f' @@ -202,80 +202,80 @@ ∙ sym (doubleCompPath≡compPath p (q ∙ r) s) main-helper : (a b : S¹) - → Square ((refl ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) ∙∙ fp) - ∙ (sym gp ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) ∙∙ refl)) - ((cong f (merid (S¹×S¹→S² a b)) + → Square ((refl ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) ∙∙ fp) + ∙ (sym gp ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) ∙∙ refl)) + ((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) ∙∙ (fp ∙ sym gp) - ∙∙ cong g (merid (S¹×S¹→S² a b))) + ∙∙ cong g (merid (S¹×S¹→S² a b))) (λ _ → f north) (cong g (merid north)) main-helper a b = - path-lem (cong f (σ₂ (S¹×S¹→S² a b))) fp (sym gp) - (cong g (σ₂ (S¹×S¹→S² a b))) + path-lem (cong f (σ₂ (S¹×S¹→S² a b))) fp (sym gp) + (cong g (σ₂ (S¹×S¹→S² a b))) ◁ lem where lem : PathP (λ i → f north ≡ cong g (merid north) i) - ((λ i → f (σ₂ (S¹×S¹→S² a b) i)) + ((λ i → f (σ₂ (S¹×S¹→S² a b) i)) ∙∙ fp ∙ (sym gp) ∙∙ - (cong g (σ₂ (S¹×S¹→S² a b)))) - ((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) + (cong g (σ₂ (S¹×S¹→S² a b)))) + ((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) ∙∙ fp ∙ sym gp - ∙∙ cong g (merid (S¹×S¹→S² a b))) + ∙∙ cong g (merid (S¹×S¹→S² a b))) lem i j = hcomp (λ k → λ { (i = i0) → - (cong-∙ f (merid (S¹×S¹→S² a b)) + (cong-∙ f (merid (S¹×S¹→S² a b)) (sym (merid north)) (~ k) ∙∙ fp ∙ sym gp - ∙∙ (λ i → g (σ-filler (S¹×S¹→S² a b) north k i))) j - ; (i = i1) → ((cong f (merid (S¹×S¹→S² a b)) + ∙∙ (λ i → g (σ-filler (S¹×S¹→S² a b) north k i))) j + ; (i = i1) → ((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) ∙∙ (fp ∙ sym gp) - ∙∙ cong g (merid (S¹×S¹→S² a b))) j + ∙∙ cong g (merid (S¹×S¹→S² a b))) j ; (j = i0) → f north ; (j = i1) → g (merid north (~ k ∨ i))}) - (((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) + (((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) ∙∙ (fp ∙ sym gp) - ∙∙ cong g (merid (S¹×S¹→S² a b))) j) + ∙∙ cong g (merid (S¹×S¹→S² a b))) j) main-helper₂ : (a b : S¹) - → cong (fst (joinify g')) (push base base ∙∙ sym (push a base) ∙∙ push a b) - ≡ cong g (merid (S¹×S¹→S² a b)) + → cong (fst (joinify g')) (push base base ∙∙ sym (push a base) ∙∙ push a b) + ≡ cong g (merid (S¹×S¹→S² a b)) main-helper₂ a b = cong-∙∙ (fst (joinify g')) - (push base base) (sym (push a base)) (push a b) - ∙ cong (cong g (merid north) ∙∙_∙∙ cong g (merid (S¹×S¹→S² a b))) - (cong (cong g) (cong sym (cong merid (S¹×S¹→S²rUnit a)))) + (push base base) (sym (push a base)) (push a b) + ∙ cong (cong g (merid north) ∙∙_∙∙ cong g (merid (S¹×S¹→S² a b))) + (cong (cong g) (cong sym (cong merid (S¹×S¹→S²rUnit a)))) ∙ ((λ i → (cong g (λ j → merid north (j ∧ ~ i))) ∙∙ (cong g (λ j → merid north (~ j ∧ ~ i))) - ∙∙ cong g (merid (S¹×S¹→S² a b))) - ∙ sym (lUnit (cong g (merid (S¹×S¹→S² a b))))) + ∙∙ cong g (merid (S¹×S¹→S² a b))) + ∙ sym (lUnit (cong g (merid (S¹×S¹→S² a b))))) main : (a b : S¹) → PathP (λ i → fp (~ i) ≡ (sym gp ∙ cong g (merid north)) i) - ((sym fp ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) ∙∙ fp) - ∙ (sym gp ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) ∙∙ gp)) - ((cong (fst (joinify f')) (push a b ∙ sym (push base b)) + ((sym fp ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) ∙∙ fp) + ∙ (sym gp ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) ∙∙ gp)) + ((cong (fst (joinify f')) (push a b ∙ sym (push base b)) ∙∙ fp ∙ sym gp ∙∙ cong (fst (joinify g')) - (push base base ∙∙ sym (push a base) ∙∙ push a b))) + (push base base ∙∙ sym (push a base) ∙∙ push a b))) main a b = ((λ i j → hcomp (λ k → λ {(i = i0) → (((λ j → fp (~ j ∧ k)) - ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) + ∙∙ cong f (σ₂ (S¹×S¹→S² a b)) ∙∙ fp) ∙ (sym gp - ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) + ∙∙ cong g (σ₂ (S¹×S¹→S² a b)) ∙∙ λ j → gp (j ∧ k))) j - ; (i = i1) → ((cong f (merid (S¹×S¹→S² a b)) + ; (i = i1) → ((cong f (merid (S¹×S¹→S² a b)) ∙ sym (cong f (merid north))) ∙∙ fp ∙ sym gp - ∙∙ cong g (merid (S¹×S¹→S² a b))) j + ∙∙ cong g (merid (S¹×S¹→S² a b))) j ; (j = i0) → fp (~ i ∧ k) ; (j = i1) → compPath-filler' (sym gp) (cong g (merid north)) k i}) (main-helper a b i j))) ▷ λ i → - cong-∙ (fst (joinify f')) (push a b) (sym (push base b)) (~ i) + cong-∙ (fst (joinify f')) (push a b) (sym (push base b)) (~ i) ∙∙ fp ∙ sym gp ∙∙ main-helper₂ a b (~ i) @@ -284,17 +284,17 @@ -- Group structure on π₃* -- todo: remove connectivity assumption module _ (A : Pointed ℓ) (con : (isConnected 3 (typ A))) where - π₃*Iso : Iso (typ (π'Gr 2 A)) ∥ (join S¹ S¹ , inl base) →∙ A ∥₂ + π₃*Iso : Iso (typ (π'Gr 2 A)) ∥ (join S¹ S¹ , inl base) →∙ A ∥₂ fun π₃*Iso = sMap joinify inv π₃*Iso = sMap disjoin rightInv π₃*Iso = sElim (λ _ → isSetPathImplicit) λ f → to3ConnectedId - con (funExt λ x → cong (fst f) (Iso.leftInv (IsoSphereJoin 1 1) x)) + con (funExt λ x → cong (fst f) (Iso.leftInv (IsoSphereJoin 1 1) x)) leftInv π₃*Iso = sElim (λ _ → isSetPathImplicit) λ f → to3ConnectedId - con (funExt (λ x → cong (fst f) (Iso.rightInv (IsoSphereJoin 1 1) x))) + con (funExt (λ x → cong (fst f) (Iso.rightInv (IsoSphereJoin 1 1) x))) π₃* : Group ℓ π₃* = InducedGroupFromPres· @@ -320,20 +320,20 @@ makeIsGroupHom (sElim2 (λ _ _ → isSetPathImplicit) λ h g → to3ConnectedId conB - (funExt λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) j → + (funExt λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) j → (cong-∙∙ (fst f) - (cong (fst h) ((push a b ∙ (sym (push base b))))) + (cong (fst h) ((push a b ∙ (sym (push base b))))) (snd h ∙ (sym (snd g))) - (cong (fst g) ((push base base - ∙∙ (sym (push a base)) - ∙∙ push a b))) + (cong (fst g) ((push base base + ∙∙ (sym (push a base)) + ∙∙ push a b))) ∙ cong (cong (fst f) - (cong (fst h) (push a b ∙ (sym (push base b)))) + (cong (fst h) (push a b ∙ (sym (push base b)))) ∙∙_∙∙ cong (fst f ∘ fst g) - ((push base base ∙∙ (sym (push a base)) ∙∙ push a b))) + ((push base base ∙∙ (sym (push a base)) ∙∙ push a b))) (cong-∙ (fst f) (snd h) (sym (snd g)) ∙ λ j → compPath-filler (cong (fst f) (snd h)) (snd f) j ∙ sym (compPath-filler @@ -360,9 +360,9 @@ -- The relevant groups (in order of the iso π₃(S²) ≅ ℤ) π₃S² = π'Gr 2 (S₊∙ 2) -π₃*S² = π₃* (S₊∙ 2) (sphereConnected 2) +π₃*S² = π₃* (S₊∙ 2) (sphereConnected 2) -π₃*joinS¹S¹ = π₃* (join S¹ S¹ , inl base) con-joinS¹S¹ +π₃*joinS¹S¹ = π₃* (join S¹ S¹ , inl base) con-joinS¹S¹ π₃*S³ = π₃* (S₊∙ 3) connS³ @@ -384,25 +384,25 @@ -} -- Underlying functions of (some of) the ηs -η₁-raw : (join S¹ S¹ , inl base) →∙ S₊∙ 2 -fst η₁-raw (inl x) = north -fst η₁-raw (inr x) = north -fst η₁-raw (push a b i) = (σ₁ b ∙ σ₁ a) i +η₁-raw : (join S¹ S¹ , inl base) →∙ S₊∙ 2 +fst η₁-raw (inl x) = north +fst η₁-raw (inr x) = north +fst η₁-raw (push a b i) = (σ₁ b ∙ σ₁ a) i snd η₁-raw = refl -η₂-raw : (join S¹ S¹ , inl base) →∙ (join S¹ S¹ , inl base) -fst η₂-raw (inl x) = inr (invLooper x) -fst η₂-raw (inr x) = inr x -fst η₂-raw (push a b i) = - (sym (push (b * invLooper a) (invLooper a)) - ∙ push (b * invLooper a) b) i -snd η₂-raw = sym (push base base) - -η₃-raw : (join S¹ S¹ , inl base) →∙ S₊∙ 3 -fst η₃-raw (inl x) = north -fst η₃-raw (inr x) = north -fst η₃-raw (push a b i) = - (sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b))) i +η₂-raw : (join S¹ S¹ , inl base) →∙ (join S¹ S¹ , inl base) +fst η₂-raw (inl x) = inr (invLooper x) +fst η₂-raw (inr x) = inr x +fst η₂-raw (push a b i) = + (sym (push (b * invLooper a) (invLooper a)) + ∙ push (b * invLooper a) b) i +snd η₂-raw = sym (push base base) + +η₃-raw : (join S¹ S¹ , inl base) →∙ S₊∙ 3 +fst η₃-raw (inl x) = north +fst η₃-raw (inr x) = north +fst η₃-raw (push a b i) = + (sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b))) i snd η₃-raw = refl -- Homotopy group versions @@ -421,21 +421,21 @@ -- π₃S²≅π₃*S² π₃S²→π₃*S² : GroupEquiv π₃S² π₃*S² -π₃S²→π₃*S² = π₃≅π₃* (S₊∙ 2) (sphereConnected 2) +π₃S²→π₃*S² = π₃≅π₃* (S₊∙ 2) (sphereConnected 2) -- Time for π₃*(S¹ * S¹) ≅ π₃*S². -- We have this iso already, but slightly differently stated, -- so the following proof becomes a bit technical. -- We define it in terms a slight variation of the Hopf map -Hopfσ : join S¹ S¹ → S₊ 2 -Hopfσ (inl x) = north -Hopfσ (inr x) = north -Hopfσ (push a b i) = σ₁ (invLooper a * b) i +Hopfσ : join S¹ S¹ → S₊ 2 +Hopfσ (inl x) = north +Hopfσ (inr x) = north +Hopfσ (push a b i) = σ₁ (invLooper a * b) i π₃*joinS¹S¹→π₃*S² : GroupHom π₃*joinS¹S¹ π₃*S² π₃*joinS¹S¹→π₃*S² = - postCompπ₃* con-joinS¹S¹ (sphereConnected 2) + postCompπ₃* con-joinS¹S¹ (sphereConnected 2) (Hopfσ , refl) π₃*joinS¹S¹≅π₃*S² : GroupEquiv π₃*joinS¹S¹ π₃*S² @@ -445,7 +445,7 @@ where π₃*joinS¹S¹→π₃*S²' : GroupHom π₃*joinS¹S¹ π₃*S² π₃*joinS¹S¹→π₃*S²' = - postCompπ₃* con-joinS¹S¹ (sphereConnected 2) + postCompπ₃* con-joinS¹S¹ (sphereConnected 2) (fst ∘ JoinS¹S¹→TotalHopf , refl) isEquivπ₃*joinS¹S¹→π₃*S²' : isEquiv (fst π₃*joinS¹S¹→π₃*S²') @@ -459,10 +459,10 @@ (λ i → GroupHom (GroupPath π₃*joinS¹S¹ π₃S³ .fst (compGroupEquiv - (invGroupEquiv (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹)) - (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl))) i) + (invGroupEquiv (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹)) + (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl))) i) (GroupPath π₃*S² π₃S² .fst - (invGroupEquiv (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) i)) + (invGroupEquiv (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) i)) π₃*joinS¹S¹→π₃*S²' (fst (fst GrEq) , snd GrEq) help = @@ -470,39 +470,39 @@ (funExt λ f → (λ i → transportRefl - ((invGroupEquiv (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) .fst .fst + ((invGroupEquiv (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) .fst .fst (fst π₃*joinS¹S¹→π₃*S²' ( - ((fst (fst (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹))) - (invEq (fst (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl))) + ((fst (fst (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹))) + (invEq (fst (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl))) (transportRefl f i)))))) i) ∙ main f)) where - main : (f : _) → invEquiv (fst (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) .fst + main : (f : _) → invEquiv (fst (π₃≅π₃* (S₊∙ 2) (sphereConnected 2))) .fst (fst π₃*joinS¹S¹→π₃*S²' (invEq - (invEquiv (fst (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹))) - (invEq (fst (π'Iso 2 (isoToEquiv Iso-joinS¹S¹-S³ , (λ _ → north)))) + (invEquiv (fst (π₃≅π₃* (join S¹ S¹ , inl base) con-joinS¹S¹))) + (invEq (fst (π'Iso 2 (isoToEquiv Iso-joinS¹S¹-S³ , (λ _ → north)))) f))) ≡ fst GrEq .fst f main = sElim (λ _ → isSetPathImplicit) - λ f → to3ConnectedId (sphereConnected 2) + λ f → to3ConnectedId (sphereConnected 2) (funExt λ x - → (λ i → fst (JoinS¹S¹→TotalHopf (Iso.inv (IsoSphereJoin 1 1) - (fst f (Iso.rightInv (IsoSphereJoin 1 1) x i))))) + → (λ i → fst (JoinS¹S¹→TotalHopf (Iso.inv (IsoSphereJoin 1 1) + (fst f (Iso.rightInv (IsoSphereJoin 1 1) x i))))) ∙ sym (funExt⁻ (sym (cong fst hopfMap≡HopfMap')) (fst f x))) idLem : fst π₃*joinS¹S¹→π₃*S²' ≡ fst π₃*joinS¹S¹→π₃*S² idLem = funExt (sElim (λ _ → isSetPathImplicit) - λ f → to3ConnectedId (sphereConnected 2) + λ f → to3ConnectedId (sphereConnected 2) (funExt λ x → lem (fst f x))) where lem : (x : _) → fst (JoinS¹S¹→TotalHopf x) ≡ Hopfσ x - lem (inl x) = refl - lem (inr x) = sym (merid base) - lem (push a b i) j = + lem (inl x) = refl + lem (inr x) = sym (merid base) + lem (push a b i) j = compPath-filler (merid (invLooper a * b)) (sym (merid base)) j i snd π₃*joinS¹S¹≅π₃*S² = snd π₃*joinS¹S¹→π₃*S² @@ -512,27 +512,27 @@ π₃*S³≅π₃*joinS¹S¹ = postCompπ₃*Equiv connS³ con-joinS¹S¹ - (isoToEquiv (invIso (IsoSphereJoin 1 1)) , refl) + (isoToEquiv (invIso (IsoSphereJoin 1 1)) , refl) -- π₃(S³)≅π₃*(S³) π₃S³≅π₃*S³ : GroupEquiv π₃S³ π₃*S³ π₃S³≅π₃*S³ = π₃≅π₃* (S₊∙ 3) connS³ η↦η₁ : fst (fst π₃S²→π₃*S²) η ≡ η₁ -η↦η₁ = to3ConnectedId (sphereConnected 2) +η↦η₁ = to3ConnectedId (sphereConnected 2) (funExt λ x → (funExt⁻ lem₁ x) ∙ sym (lem₂ x)) where - lem₁ : fold∘W ∘ joinS¹S¹→S³ ≡ fold⋁ ∘ (joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1}) + lem₁ : fold∘W ∘ joinS¹S¹→S³ ≡ fold⋁ ∘ (joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1}) lem₁ = funExt λ x - → cong (fold⋁ ∘ (joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1})) - (leftInv (IsoSphereJoin 1 1) x) + → cong (fold⋁ ∘ (joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1})) + (leftInv (IsoSphereJoin 1 1) x) - lem₂ : (x : join S¹ S¹) → fst η₁-raw x ≡ (fold⋁ ∘ joinTo⋁) x - lem₂ (inl x) = refl - lem₂ (inr x) = refl - lem₂ (push a b i) j = help j i + lem₂ : (x : join S¹ S¹) → fst η₁-raw x ≡ (fold⋁ ∘ joinTo⋁) x + lem₂ (inl x) = refl + lem₂ (inr x) = refl + lem₂ (push a b i) j = help j i where - help : (σ₁ b ∙ σ₁ a) ≡ cong (fold⋁ ∘ joinTo⋁) (push a b) + help : (σ₁ b ∙ σ₁ a) ≡ cong (fold⋁ ∘ joinTo⋁) (push a b) help = sym (cong-∙∙ fold⋁ (λ j → inr (σ₁ b j)) (sym (push tt)) (λ j → inl (σ₁ a j)) ∙ λ i → (λ j → σ₁ b (j ∧ ~ i)) @@ -542,35 +542,35 @@ -- We show that η₂ ↦ η₁ (this is easier than η₁ ↦ η₂) η₂↦η₁ : fst (fst π₃*joinS¹S¹≅π₃*S²) η₂ ≡ η₁ η₂↦η₁ = - to3ConnectedId (sphereConnected 2) - (funExt λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) j → main a b j i}) + to3ConnectedId (sphereConnected 2) + (funExt λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) j → main a b j i}) where lem : (a b : S¹) → (sym (σ₁ (invLooper (b * invLooper a) * invLooper a)) ≡ σ₁ b) × (σ₁ (invLooper (b * invLooper a) * b) ≡ σ₁ a) fst (lem a b) = - cong sym (cong σ₁ (sym (invLooperDistr (b * invLooper a) a)) - ∙ σ-invSphere 0 (b * invLooper a * a)) - ∙ cong σ₁ (sym (assocS¹ b (invLooper a) a) - ∙ cong (b *_) (commS¹ _ _ ∙ sym (rCancelS¹ a)) - ∙ rUnitS¹ b) + cong sym (cong σ₁ (sym (invLooperDistr (b * invLooper a) a)) + ∙ σ-invSphere 0 (b * invLooper a * a)) + ∙ cong σ₁ (sym (assocS¹ b (invLooper a) a) + ∙ cong (b *_) (commS¹ _ _ ∙ sym (rCancelS¹ a)) + ∙ rUnitS¹ b) snd (lem a b) = - cong σ₁ (cong (_* b) (invLooperDistr b (invLooper a) - ∙ cong (invLooper b *_) (invSphere² 1 a) - ∙ commS¹ (invLooper b) a) - ∙ sym (assocS¹ a (invLooper b) b) - ∙ cong (a *_) (commS¹ _ _ ∙ sym (rCancelS¹ b)) - ∙ rUnitS¹ a) + cong σ₁ (cong (_* b) (invLooperDistr b (invLooper a) + ∙ cong (invLooper b *_) (invSphere² 1 a) + ∙ commS¹ (invLooper b) a) + ∙ sym (assocS¹ a (invLooper b) b) + ∙ cong (a *_) (commS¹ _ _ ∙ sym (rCancelS¹ b)) + ∙ rUnitS¹ a) main : (a b : S¹) - → cong Hopfσ ((sym (push (b * invLooper a) (invLooper a)) - ∙ push (b * invLooper a) b)) + → cong Hopfσ ((sym (push (b * invLooper a) (invLooper a)) + ∙ push (b * invLooper a) b)) ≡ σ₁ b ∙ σ₁ a main a b = - cong-∙ Hopfσ (sym (push (b * invLooper a) (invLooper a))) - (push (b * invLooper a) b) + cong-∙ Hopfσ (sym (push (b * invLooper a) (invLooper a))) + (push (b * invLooper a) b) ∙ cong₂ _∙_ (fst (lem a b)) (snd (lem a b)) -- We show that η₂ ↦ η₃ @@ -580,41 +580,41 @@ (funExt λ x → sym (joinS¹S¹→S³σ≡ (fst η₂-raw x)) ∙ lem x) where - joinS¹S¹→S³σ : join S¹ S¹ → S₊ 3 - joinS¹S¹→S³σ (inl x) = north - joinS¹S¹→S³σ (inr x) = north - joinS¹S¹→S³σ (push a b i) = σ₂ (S¹×S¹→S² a b) i + joinS¹S¹→S³σ : join S¹ S¹ → S₊ 3 + joinS¹S¹→S³σ (inl x) = north + joinS¹S¹→S³σ (inr x) = north + joinS¹S¹→S³σ (push a b i) = σ₂ (S¹×S¹→S² a b) i - joinS¹S¹→S³σ≡ : (x : _) → joinS¹S¹→S³σ x ≡ joinS¹S¹→S³ x - joinS¹S¹→S³σ≡ (inl x) = refl - joinS¹S¹→S³σ≡ (inr x) = merid north - joinS¹S¹→S³σ≡ (push a b i) j = - compPath-filler (merid (S¹×S¹→S² a b)) (sym (merid north)) (~ j) i + joinS¹S¹→S³σ≡ : (x : _) → joinS¹S¹→S³σ x ≡ joinS¹S¹→S³ x + joinS¹S¹→S³σ≡ (inl x) = refl + joinS¹S¹→S³σ≡ (inr x) = merid north + joinS¹S¹→S³σ≡ (push a b i) j = + compPath-filler (merid (S¹×S¹→S² a b)) (sym (merid north)) (~ j) i lem : (x : _) → joinS¹S¹→S³σ (fst η₂-raw x) ≡ fst η₃-raw x - lem (inl x) = refl - lem (inr x) = refl - lem (push a b i) j = main j i + lem (inl x) = refl + lem (inr x) = refl + lem (push a b i) j = main j i where - left-lem : σ₂ (S¹×S¹→S² (b * invLooper a) (invLooper a)) - ≡ σ₂ (S¹×S¹→S² a b) - left-lem = cong σ₂ (S¹×S¹→S²-Distr b (invLooper a) - ∙ sym (S¹×S¹→S²-antiComm a b)) + left-lem : σ₂ (S¹×S¹→S² (b * invLooper a) (invLooper a)) + ≡ σ₂ (S¹×S¹→S² a b) + left-lem = cong σ₂ (S¹×S¹→S²-Distr b (invLooper a) + ∙ sym (S¹×S¹→S²-antiComm a b)) - right-lem : σ₂ (S¹×S¹→S² (b * invLooper a) b) ≡ sym (σ₂ (S¹×S¹→S² a b)) + right-lem : σ₂ (S¹×S¹→S² (b * invLooper a) b) ≡ sym (σ₂ (S¹×S¹→S² a b)) right-lem = - cong σ₂ ((cong (λ x → S¹×S¹→S² x b) (commS¹ b (invLooper a)) - ∙ S¹×S¹→S²-Distr (invLooper a) b) - ∙∙ S¹×S¹→S²-antiComm (invLooper a) b - ∙∙ invSusp∘S¹×S¹→S² b (invLooper a)) - ∙∙ σ-invSphere 1 (S¹×S¹→S² b (invLooper a)) - ∙∙ cong (sym ∘ σ₂) (sym (S¹×S¹→S²-antiComm a b)) - - main : cong (joinS¹S¹→S³σ ∘ fst η₂-raw) (push a b) - ≡ sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b)) + cong σ₂ ((cong (λ x → S¹×S¹→S² x b) (commS¹ b (invLooper a)) + ∙ S¹×S¹→S²-Distr (invLooper a) b) + ∙∙ S¹×S¹→S²-antiComm (invLooper a) b + ∙∙ invSusp∘S¹×S¹→S² b (invLooper a)) + ∙∙ σ-invSphere 1 (S¹×S¹→S² b (invLooper a)) + ∙∙ cong (sym ∘ σ₂) (sym (S¹×S¹→S²-antiComm a b)) + + main : cong (joinS¹S¹→S³σ ∘ fst η₂-raw) (push a b) + ≡ sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b)) main = cong-∙ joinS¹S¹→S³σ - (sym (push (b * invLooper a) (invLooper a))) - (push (b * invLooper a) b) + (sym (push (b * invLooper a) (invLooper a))) + (push (b * invLooper a) b) ∙ cong₂ _∙_ (cong sym left-lem) right-lem -- We show that η₄ ↦ η₃ (this is easier than η₃ ↦ η₄) @@ -627,10 +627,10 @@ _+π₃*_ : fst π₃*S³ → fst π₃*S³ → fst π₃*S³ _+π₃*_ = GroupStr._·_ (snd π₃*S³) - η₃-raw/2 : (join S¹ S¹ , inl base) →∙ S₊∙ 3 - fst η₃-raw/2 (inl x) = north - fst η₃-raw/2 (inr x) = north - fst η₃-raw/2 (push a b i) = σ₂ (S¹×S¹→S² a b) (~ i) + η₃-raw/2 : (join S¹ S¹ , inl base) →∙ S₊∙ 3 + fst η₃-raw/2 (inl x) = north + fst η₃-raw/2 (inr x) = north + fst η₃-raw/2 (push a b i) = σ₂ (S¹×S¹→S² a b) (~ i) snd η₃-raw/2 = refl η₃/2 : π₃*S³ .fst @@ -639,34 +639,34 @@ gen↦η₃/2 : fst (fst π₃S³≅π₃*S³) (-π' 2 ∣ idfun∙ (S₊∙ 3) ∣₂) ≡ η₃/2 gen↦η₃/2 = to3ConnectedId connS³ - (funExt λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) → refl}) + (funExt λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) → refl}) η₃/2+η₃/2≡η₃ : η₃/2 +π₃* η₃/2 ≡ η₃ η₃/2+η₃/2≡η₃ = to3ConnectedId connS³ - (funExt λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) → λ j → lem a b j i}) + (funExt λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) → λ j → lem a b j i}) where - lem : (a b : S¹) → cong (fst (η₃-raw/2 +join η₃-raw/2)) (push a b) - ≡ cong (fst η₃-raw) (push a b) - lem a b = (λ i → cong-∙ (fst η₃-raw/2) (push a b) (sym (push base b)) i + lem : (a b : S¹) → cong (fst (η₃-raw/2 +join η₃-raw/2)) (push a b) + ≡ cong (fst η₃-raw) (push a b) + lem a b = (λ i → cong-∙ (fst η₃-raw/2) (push a b) (sym (push base b)) i ∙∙ rUnit refl (~ i) ∙∙ cong-∙∙ (fst η₃-raw/2) - (push base base) (sym (push a base)) (push a b) i) - ∙∙ (λ i → (sym (σ₂ (S¹×S¹→S² a b)) ∙ rCancel (merid north) i) + (push base base) (sym (push a base)) (push a b) i) + ∙∙ (λ i → (sym (σ₂ (S¹×S¹→S² a b)) ∙ rCancel (merid north) i) ∙∙ refl ∙∙ (sym (rCancel (merid north) i) - ∙∙ (cong σ₂ (S¹×S¹→S²rUnit a) ∙ rCancel (merid north)) i - ∙∙ sym (σ₂ (S¹×S¹→S² a b)))) - ∙∙ ((λ i → rUnit (sym (σ₂ (S¹×S¹→S² a b))) (~ i) + ∙∙ (cong σ₂ (S¹×S¹→S²rUnit a) ∙ rCancel (merid north)) i + ∙∙ sym (σ₂ (S¹×S¹→S² a b)))) + ∙∙ ((λ i → rUnit (sym (σ₂ (S¹×S¹→S² a b))) (~ i) ∙∙ refl - ∙∙ lUnit (sym (σ₂ (S¹×S¹→S² a b))) (~ i)) - ∙ λ i → (λ j → σ₂ (S¹×S¹→S² a b) (i ∨ ~ j)) - ∙∙ (λ j → σ₂ (S¹×S¹→S² a b) (i ∧ ~ j)) - ∙∙ sym (σ₂ (S¹×S¹→S² a b))) + ∙∙ lUnit (sym (σ₂ (S¹×S¹→S² a b))) (~ i)) + ∙ λ i → (λ j → σ₂ (S¹×S¹→S² a b) (i ∨ ~ j)) + ∙∙ (λ j → σ₂ (S¹×S¹→S² a b) (i ∧ ~ j)) + ∙∙ sym (σ₂ (S¹×S¹→S² a b))) -- Agda is very keen on expanding things, so we make an abstract -- summary of the main lemmas above @@ -793,10 +793,10 @@ π₃*S³' = π₃* (Susp∙ S²) (isConnectedSubtr 3 1 connSuspS²) -- The version of η₃ we have been able to compute lies in π₃*S³' -η₃'-raw : (join S¹ S¹ , inl base) →∙ (Susp S² , north) -fst η₃'-raw (inl x) = north -fst η₃'-raw (inr x) = north -fst η₃'-raw (push a b i) = +η₃'-raw : (join S¹ S¹ , inl base) →∙ (Susp S² , north) +fst η₃'-raw (inl x) = north +fst η₃'-raw (inr x) = north +fst η₃'-raw (push a b i) = (σ (S² , base) (S¹×S¹→S²' a b) ∙ σ (S² , base) (S¹×S¹→S²' a b)) i snd η₃'-raw = refl @@ -806,28 +806,28 @@ -- We first have to show (manually) that the following iso sends η₃ to η₃' π₃*S³≅π₃*S³' : GroupEquiv π₃*S³ π₃*S³' π₃*S³≅π₃*S³' = postCompπ₃*Equiv _ _ - (isoToEquiv (congSuspIso (invIso S²IsoSuspS¹)) + (isoToEquiv (congSuspIso (invIso S²IsoSuspS¹)) , refl) π₃*S³≅π₃*S³'-pres-η₃ : fst (fst π₃*S³≅π₃*S³') η₃ ≡ η₃' π₃*S³≅π₃*S³'-pres-η₃ = cong ∣_∣₂ - (ΣPathP ((funExt (λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) j → lem a b j i})) + (ΣPathP ((funExt (λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) j → lem a b j i})) , sym (rUnit refl))) where lem : (a b : S¹) - → cong (suspFun SuspS¹→S²) - (sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b))) + → cong (suspFun SuspS¹→S²) + (sym (σ₂ (S¹×S¹→S² a b)) ∙ sym (σ₂ (S¹×S¹→S² a b))) ≡ (σ (S² , base) (S¹×S¹→S²' a b) ∙ σ (S² , base) (S¹×S¹→S²' a b)) lem a b = - cong-∙ (suspFun SuspS¹→S²) - (sym (σ₂ (S¹×S¹→S² a b))) (sym (σ₂ (S¹×S¹→S² a b))) + cong-∙ (suspFun SuspS¹→S²) + (sym (σ₂ (S¹×S¹→S² a b))) (sym (σ₂ (S¹×S¹→S² a b))) ∙ cong (λ x → x ∙ x) (cong sym (cong-∙ - (suspFun SuspS¹→S²) (merid (S¹×S¹→S² a b)) (sym (merid north))) - ∙ cong sym (cong (σ S²∙) (SuspS¹→S²-S¹×S¹→S² a b)) + (suspFun SuspS¹→S²) (merid (S¹×S¹→S² a b)) (sym (merid north))) + ∙ cong sym (cong (σ S²∙) (SuspS¹→S²-S¹×S¹→S² a b)) ∙ sym (S¹×S¹→S²-sym a b)) -- After this, we want to establish an iso π₃*S³'≅ℤ which is nice enough to compute. @@ -836,33 +836,33 @@ -- First iso: π₃*(Susp S²) ≅ π₁(S¹ →∙ Ω(Susp S²)) private map← : S₊∙ 1 →∙ (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙) - → (join S¹ S¹ , inl base) →∙ Susp∙ S² - fst (map← f) (inl x) = north - fst (map← f) (inr x) = north - fst (map← f) (push a b i) = fst f a .fst b i + → (join S¹ S¹ , inl base) →∙ Susp∙ S² + fst (map← f) (inl x) = north + fst (map← f) (inr x) = north + fst (map← f) (push a b i) = fst f a .fst b i snd (map← f) = refl - map→ : (join S¹ S¹ , inl base) →∙ Susp∙ S² + map→ : (join S¹ S¹ , inl base) →∙ Susp∙ S² → S₊∙ 1 →∙ (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙) fst (fst (map→ f) x) y = sym (snd f) ∙∙ cong (fst f) - ((push base base ∙ sym (push x base)) ∙∙ push x y ∙∙ sym (push base y)) + ((push base base ∙ sym (push x base)) ∙∙ push x y ∙∙ sym (push base y)) ∙∙ snd f snd (fst (map→ f) x) = cong (sym (snd f) ∙∙_∙∙ snd f) (cong (cong (fst f)) - ((λ j → (push base base ∙ (λ i → push x base (~ i ∨ j))) - ∙∙ (λ i → push x base (i ∨ j)) ∙∙ sym (push base base)) - ∙ cong (_∙∙ refl ∙∙ sym (push base base)) (sym (rUnit (push base base))) - ∙ ∙∙lCancel (sym (push base base)))) + ((λ j → (push base base ∙ (λ i → push x base (~ i ∨ j))) + ∙∙ (λ i → push x base (i ∨ j)) ∙∙ sym (push base base)) + ∙ cong (_∙∙ refl ∙∙ sym (push base base)) (sym (rUnit (push base base))) + ∙ ∙∙lCancel (sym (push base base)))) ∙ ∙∙lCancel (snd f) snd (map→ f) = coherence _ λ x → cong (sym (snd f) ∙∙_∙∙ snd f) (cong (cong (fst f)) - (cong (_∙∙ push base x ∙∙ sym (push base x)) - (rCancel (push base base)) - ∙ rCancel (push base x))) + (cong (_∙∙ push base x ∙∙ sym (push base x)) + (rCancel (push base base)) + ∙ rCancel (push base x))) ∙ ∙∙lCancel (snd f) where abstract @@ -888,13 +888,13 @@ (funExt λ y → sym (rUnit ((cong (fst (map← f))) - ((push base base - ∙ sym (push x base)) ∙∙ push x y ∙∙ sym (push base y)))) + ((push base base + ∙ sym (push x base)) ∙∙ push x y ∙∙ sym (push base y)))) ∙∙ cong-∙∙ (fst (map← f)) - (push base base - ∙ sym (push x base)) (push x y) (sym (push base y)) + (push base base + ∙ sym (push x base)) (push x y) (sym (push base y)) ∙∙ (λ i → cong-∙ (fst (map← f)) - (push base base) (sym (push x base)) i + (push base base) (sym (push x base)) i ∙∙ f .fst x .fst y ∙∙ sym (snd f i .fst y)) ∙∙ cong (_∙∙ f .fst x .fst y ∙∙ refl) @@ -905,33 +905,33 @@ sElim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP ((funExt - (λ { (inl x) → sym (snd f) - ∙ cong (fst f) (push base base ∙ sym (push x base)) - ; (inr x) → sym (snd f) - ∙ cong (fst f) (push base x) - ; (push a b i) j + (λ { (inl x) → sym (snd f) + ∙ cong (fst f) (push base base ∙ sym (push x base)) + ; (inr x) → sym (snd f) + ∙ cong (fst f) (push base x) + ; (push a b i) j → hcomp (λ k → λ {(i = i0) → compPath-filler' (sym (snd f)) (cong (fst f) - (push base base ∙ sym (push a base))) k j + (push base base ∙ sym (push a base))) k j ; (i = i1) → compPath-filler' (sym (snd f)) (cong (fst f) - (push base b)) k j - ; (j = i1) → fst f (push a b i) }) + (push base b)) k j + ; (j = i1) → fst f (push a b i) }) (fst f (doubleCompPath-filler - (push base base ∙ sym (push a base)) - (push a b) - (sym (push base b)) (~ j) i))})) + (push base base ∙ sym (push a base)) + (push a b) + (sym (push base b)) (~ j) i))})) , help f)) where - help : (f : (join S¹ S¹ , inl base) →∙ Susp∙ S²) + help : (f : (join S¹ S¹ , inl base) →∙ Susp∙ S²) → PathP (λ i → (sym (snd f) - ∙ cong (fst f) (push base base ∙ sym (push base base))) i + ∙ cong (fst f) (push base base ∙ sym (push base base))) i ≡ north) refl (snd f) help f = flipSquare ((cong (sym (snd f) ∙_) (cong (cong (fst f)) - (rCancel (push base base))) ∙ sym (rUnit (sym (snd f)))) + (rCancel (push base base))) ∙ sym (rUnit (sym (snd f)))) ◁ λ i j → snd f (i ∨ ~ j)) -- the iso @@ -941,28 +941,28 @@ makeIsGroupHom (sElim2 (λ _ _ → isSetPathImplicit) λ f g → cong ∣_∣₂ - (ΣPathP ((funExt (λ { (inl x) → refl - ; (inr x) → refl - ; (push a b i) j → main f g a b j i})) + (ΣPathP ((funExt (λ { (inl x) → refl + ; (inr x) → refl + ; (push a b i) j → main f g a b j i})) , refl))) where main : (f g : S₊∙ 1 →∙ (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) (a b : S¹) - → cong (fst (map← (∙Π f g))) (push a b) - ≡ cong (fst (map← f +join map← g)) (push a b) + → cong (fst (map← (∙Π f g))) (push a b) + ≡ cong (fst (map← f +join map← g)) (push a b) main f g a b = (main-lem a b ∙ (λ i → (λ j → fst f a .fst b (j ∧ i)) ∙∙ ((λ j → fst f a .fst b (j ∨ i))) ∙∙ fst g a .fst b)) ∙ λ i → (rUnit (fst f a .fst b) ∙ cong (fst f a .fst b ∙_) (cong sym (sym (funExt⁻ (cong fst (snd f)) b))) - ∙ sym (cong-∙ (map← f .fst) (push a b) (sym (push base b)))) i + ∙ sym (cong-∙ (map← f .fst) (push a b) (sym (push base b)))) i ∙∙ rUnit refl i ∙∙ ((lUnit (fst g a .fst b) ∙ (λ i → fst g base .snd (~ i) ∙∙ sym (fst g a .snd (~ i)) - ∙∙ cong (map← g .fst) (push a b))) + ∙∙ cong (map← g .fst) (push a b))) ∙ (sym (cong-∙∙ (map← g .fst) - (push base base) (sym (push a base)) (push a b)))) i + (push base base) (sym (push a base)) (push a b)))) i where JLem : ∀ {ℓ} {A : Type ℓ} (* : A) (fab : * ≡ *) (fabrefl : refl ≡ fab) @@ -986,7 +986,7 @@ pp b i = fst (snd f (~ i)) b ∙ fst (snd g (~ i)) b main-lem : (a b : S¹) - → cong (fst (map← (∙Π f g))) (push a b) + → cong (fst (map← (∙Π f g))) (push a b) ≡ (fst f a .fst b ∙ fst g a .fst b) main-lem base b = rUnit refl ∙ pp b main-lem (loop i) b j = @@ -1001,7 +1001,7 @@ (λ i → fst f (loop i) .fst b) (λ i → fst g (loop i) .fst b) j i) where - lem : cong (λ l → cong (fst (map← (∙Π f g))) (push l b)) loop + lem : cong (λ l → cong (fst (map← (∙Π f g))) (push l b)) loop ≡ ((λ i → fst (snd f (~ i)) b) ∙∙ funExt⁻ (cong fst (cong (f .fst) loop)) b ∙∙ (λ i → fst (snd f i) b)) @@ -1022,7 +1022,7 @@ -- We first introduce the following base change map defined via pattern -- matching for better computational behaviour -ΩK₂-basechange : (x : K₂) → Ω (K₂ , x) →∙ Ω (K₂ , ∣ base ∣₄) +ΩK₂-basechange : (x : K₂) → Ω (K₂ , x) →∙ Ω (K₂ , ∣ base ∣₄) ΩK₂-basechange = 2GroupoidTrunc.elim (λ _ → isOfHLevelΣ 4 @@ -1031,46 +1031,46 @@ λ { base → idfun∙ _ ; (surf i j) → coherence i j} where - K₂≃coHomK2 : Iso K₂ (coHomK 2) - K₂≃coHomK2 = compIso 2GroupoidTruncTrunc4Iso (mapCompIso S²IsoSuspS¹) + K₂≃coHomK2 : Iso K₂ (coHomK 2) + K₂≃coHomK2 = compIso 2GroupoidTruncTrunc4Iso (mapCompIso S²IsoSuspS¹) - ΩK₂≡S¹ : Ω (K₂ , ∣ base ∣₄) ≡ S¹∙ + ΩK₂≡S¹ : Ω (K₂ , ∣ base ∣₄) ≡ S¹∙ ΩK₂≡S¹ = ua∙ (isoToEquiv (compIso (congIso K₂≃coHomK2) (compIso (invIso (Iso-Kn-ΩKn+1 1)) (truncIdempotentIso 3 isGroupoidS¹)))) refl coherence : - SquareP (λ i j → Ω (K₂ , ∣ surf i j ∣₄) →∙ Ω (K₂ , ∣ base ∣₄)) - (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) - (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) - (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) - λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄)) + SquareP (λ i j → Ω (K₂ , ∣ surf i j ∣₄) →∙ Ω (K₂ , ∣ base ∣₄)) + (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) + (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) + (λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄))) + λ _ → idfun∙ (Ω (K₂ , ∣ base ∣₄)) coherence = toPathP - (isOfHLevelPath' 1 (subst isSet (λ i → ΩK₂≡S¹ (~ i) →∙ Ω (K₂ , ∣ base ∣₄)) + (isOfHLevelPath' 1 (subst isSet (λ i → ΩK₂≡S¹ (~ i) →∙ Ω (K₂ , ∣ base ∣₄)) (subst isSet (isoToPath - (equivToIso (Ω→SphereMap 1 {A = Ω (K₂ , ∣ base ∣₄) } + (equivToIso (Ω→SphereMap 1 {A = Ω (K₂ , ∣ base ∣₄) } , isEquiv-Ω→SphereMap 1))) (squash₄ _ _ _ _))) _ _ _ _) -- The three homomorphisms π₁S¹→∙ΩS³'→π₁S¹→∙K₂ : GroupHom (π'Gr 0 (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) - (π'Gr 0 (S₊∙ 1 →∙ (K₂ , ∣ base ∣₄ ) ∙)) + (π'Gr 0 (S₊∙ 1 →∙ (K₂ , ∣ base ∣₄ ) ∙)) π₁S¹→∙ΩS³'→π₁S¹→∙K₂ = - π'∘∙Hom 0 ((λ f → (λ x → f7' (fst f x)) , (cong f7' (snd f))) , refl) + π'∘∙Hom 0 ((λ f → (λ x → f7' (fst f x)) , (cong f7' (snd f))) , refl) π₁S¹→∙K₂→π₁S¹ : - GroupHom (π'Gr 0 (S₊∙ 1 →∙ (K₂ , ∣ base ∣₄ ) ∙)) (π'Gr 0 (S₊∙ 1)) + GroupHom (π'Gr 0 (S₊∙ 1 →∙ (K₂ , ∣ base ∣₄ ) ∙)) (π'Gr 0 (S₊∙ 1)) π₁S¹→∙K₂→π₁S¹ = π'∘∙Hom 0 mainMap∙ where - mainMap : (S¹ → K₂) → S¹ + mainMap : (S¹ → K₂) → S¹ mainMap f = GroupoidTrunc.rec isGroupoidS¹ (λ x → x) - (encodeTruncS² (ΩK₂-basechange _ .fst (cong f loop))) + (encodeTruncS² (ΩK₂-basechange _ .fst (cong f loop))) - mainMap∙ : ((S₊∙ 1 →∙ (K₂ , ∣ base ∣₄) ∙) →∙ S₊∙ 1) + mainMap∙ : ((S₊∙ 1 →∙ (K₂ , ∣ base ∣₄) ∙) →∙ S₊∙ 1) fst mainMap∙ f = mainMap (fst f) snd mainMap∙ = refl @@ -1099,9 +1099,9 @@ -- It's witnessed by the following element: 1∈π₃*S³' : π₃*S³' .fst 1∈π₃*S³' = - ∣ (λ { (inl x) → north - ; (inr x) → north - ; (push a b i) → σ S²∙ (S¹×S¹→S²' b a) i}) , refl ∣₂ + ∣ (λ { (inl x) → north + ; (inr x) → north + ; (push a b i) → σ S²∙ (S¹×S¹→S²' b a) i}) , refl ∣₂ -- By computation, it maps to 1 1∈π₃*S³'↦1 : fst computer 1∈π₃*S³' ≡ 1 diff --git a/Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2.html b/Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2.html index d3a056f03..6dd169f90 100644 --- a/Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2.html +++ b/Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2.html @@ -49,7 +49,7 @@ π₄S³≅π₃PushS² = compGroupIso (GroupEquiv→GroupIso - (∙≃→π≅ 3 (compEquiv (isoToEquiv (invIso IsoS³S3)) S³≃SuspS²) refl)) + (∙≃→π≅ 3 (compEquiv (isoToEquiv (invIso IsoS³S3)) S³≃SuspS²) refl)) (compGroupIso (invGroupIso (GrIso-πΩ-π 2)) (compGroupIso @@ -62,7 +62,7 @@ (invGroupIso (πTruncGroupIso 2)) (GroupEquiv→GroupIso (invEq (GroupPath _ _) (cong (πGr 2) - (cong Pushout⋁↪fold⋁∙ (ua∙ S²≃SuspS¹ refl))))))))) + (cong Pushout⋁↪fold⋁∙ (ua∙ S²≃SuspS¹ refl))))))))) where encode∙ : encode ∣ north ∣ refl ≡ ∣ inl (base , base) ∣ encode∙ = transportRefl _ diff --git a/Cubical.Homotopy.Group.PinSn.html b/Cubical.Homotopy.Group.PinSn.html index 78f83729c..795062f49 100644 --- a/Cubical.Homotopy.Group.PinSn.html +++ b/Cubical.Homotopy.Group.PinSn.html @@ -347,10 +347,10 @@ makePted : (n : ℕ) (fn : S₊ (2 + n)) → ∥ fn ≡ north ∥₂ makePted n fn = TR.rec (isOfHLevelPlus' 2 squash₂) ∣_∣₂ - (isConnectedPathSⁿ (suc n) fn north .fst) + (isConnectedPathSⁿ (suc n) fn north .fst) makePted-eq : (n : ℕ) (fn : S₊ (2 + n)) (p : fn ≡ north) → makePted n fn ≡ ∣ p ∣₂ makePted-eq n fn p j = - TR.rec (isOfHLevelPlus' 2 squash₂) ∣_∣₂ (isConnectedPathSⁿ (suc n) fn north .snd ∣ p ∣ j) + TR.rec (isOfHLevelPlus' 2 squash₂) ∣_∣₂ (isConnectedPathSⁿ (suc n) fn north .snd ∣ p ∣ j) -- Forgetting pointedness gives iso πₙSⁿ-unpoint : (n : ℕ) → (π'Gr n (S₊∙ (suc n)) .fst) → ∥ (S₊ (suc n) → S₊ (suc n)) ∥₂ @@ -359,24 +359,24 @@ isIso-πₙSⁿ-unpointIso : (n : ℕ) → isIso (πₙSⁿ-unpoint n) fst (isIso-πₙSⁿ-unpointIso zero) = ST.map λ f → (λ x → f x * (invLooper (f base))) - , sym (rCancelS¹ (f base)) + , sym (rCancelS¹ (f base)) fst (snd (isIso-πₙSⁿ-unpointIso zero)) = ST.elim (λ _ → isSetPathImplicit) λ f → PT.rec (squash₂ _ _) (λ q → cong ∣_∣₂ (funExt λ x → cong (f x *_) - (cong invLooper (sym q)) ∙ rUnitS¹ (f x))) + (cong invLooper (sym q)) ∙ rUnitS¹ (f x))) (isConnectedS¹ (f base)) snd (snd (isIso-πₙSⁿ-unpointIso zero)) = ST.elim (λ _ → isSetPathImplicit) λ f → cong ∣_∣₂ (ΣPathP ((funExt (λ r → cong (fst f r *_) (cong invLooper (snd f)) - ∙ rUnitS¹ (fst f r))) + ∙ rUnitS¹ (fst f r))) , help _ (sym (snd f)))) where help : (x : _) (p : base ≡ x) - → PathP (λ i → ((λ j → x * invLooper (p (~ j))) ∙ rUnitS¹ x) i ≡ base) - (sym (rCancelS¹ x)) (sym p) + → PathP (λ i → ((λ j → x * invLooper (p (~ j))) ∙ rUnitS¹ x) i ≡ base) + (sym (rCancelS¹ x)) (sym p) help = J> λ i j → rCancel (λ _ → base) j i fst (isIso-πₙSⁿ-unpointIso (suc n)) = ST.rec squash₂ λ f → ST.map (λ p → f , p) (makePted n (f north)) @@ -412,7 +412,7 @@ Susp⊣Ω-Sn←-σ : (f : S₊∙ (suc n) →∙ Ω (S₊∙ (suc (suc n)))) → (x : _) - → cong (Susp⊣Ω-Sn← (fst f)) (σSn (suc n) x) ≡ fst f x + → cong (Susp⊣Ω-Sn← (fst f)) (σSn (suc n) x) ≡ fst f x Susp⊣Ω-Sn←-σ f x = cong-∙ (Susp⊣Ω-Sn← (fst f)) (merid x) (sym (merid _)) ∙ cong (λ z → fst f x ∙ sym z) (snd f) @@ -443,7 +443,7 @@ (uncurry (λ g q → TR.rec (isProp→isOfHLevelSuc n squash₁) (λ r → ∣ g , ΣPathP (q , (sym r ◁ (λ i j → q (i ∨ j) north))) ∣₁) (isConnectedPath _ - (isConnectedPathSⁿ (suc n) (fst f north) north) + (isConnectedPathSⁿ (suc n) (fst f north) north) (funExt⁻ q north) (snd f) .fst ))) (Susp⊣Ω-Sn←≡ (fst f)) diff --git a/Cubical.Homotopy.Group.SuspensionMap.html b/Cubical.Homotopy.Group.SuspensionMap.html index e095e16ed..39eac15c7 100644 --- a/Cubical.Homotopy.Group.SuspensionMap.html +++ b/Cubical.Homotopy.Group.SuspensionMap.html @@ -587,7 +587,7 @@ isConnectedSuspMap : (n m : ℕ) → isConnectedFun ((m + suc m) ∸ n) (suspMap {A = S₊∙ (suc m)} n) isConnectedSuspMap n m = - isConnectedPres _ _ (suspMapΩ-connected m (suc n) (sphereConnected (suc m))) + isConnectedPres _ _ (suspMapΩ-connected m (suc n) (sphereConnected (suc m))) isSurjectiveSuspMap : (n : ℕ) → isSurjective (suspMapπ'Hom {A = S₊∙ (2 + n)} (2 + n)) diff --git a/Cubical.Homotopy.HSpace.html b/Cubical.Homotopy.HSpace.html index 424e1e7b3..b6aca8b16 100644 --- a/Cubical.Homotopy.HSpace.html +++ b/Cubical.Homotopy.HSpace.html @@ -139,7 +139,7 @@ μ-assoc S1-AssocHSpace (loop i) x y j = h x y j i where h : (x y : S₊ 1) → cong (_· y) (rotLoop x) ≡ rotLoop (x · y) - h = wedgeconFun _ _ (λ _ _ → isOfHLevelPath 2 (isGroupoidS¹ _ _) _ _) + h = wedgeconFun _ _ (λ _ _ → isOfHLevelPath 2 (isGroupoidS¹ _ _) _ _) (λ x → refl) (λ { base → refl ; (loop i) → refl}) refl diff --git a/Cubical.Homotopy.Hopf.html b/Cubical.Homotopy.Hopf.html index a58d8e7d2..0657ac660 100644 --- a/Cubical.Homotopy.Hopf.html +++ b/Cubical.Homotopy.Hopf.html @@ -20,7 +20,7 @@ open import Cubical.HITs.Pushout.Flattening open import Cubical.HITs.Pushout -open import Cubical.HITs.Sn hiding (joinS¹S¹→S³) +open import Cubical.HITs.Sn hiding (joinS¹S¹→S³) open import Cubical.HITs.Susp open import Cubical.HITs.S1 open import Cubical.HITs.S2 @@ -80,35 +80,35 @@ TotalSpaceHopfPush→TotalSpace (push (x , y) i₁) = merid y i₁ , ua-gluePt (μ-eq y) i₁ x - joinIso₁ : Iso (TotalSpaceHopfPush) (join (typ A) (typ A)) + joinIso₁ : Iso (TotalSpaceHopfPush) (join (typ A) (typ A)) joinIso₁ = theIso where - F : TotalSpaceHopfPush → join (typ A) (typ A) - F (inl x) = inl x - F (inr x) = inr x - F (push (a , x) i) = push a (μ e a x) i - - G : join (typ A) (typ A) → TotalSpaceHopfPush - G (inl x) = inl x - G (inr x) = inr x - G (push a b i) = + F : TotalSpaceHopfPush → join (typ A) (typ A) + F (inl x) = inl x + F (inr x) = inr x + F (push (a , x) i) = push a (μ e a x) i + + G : join (typ A) (typ A) → TotalSpaceHopfPush + G (inl x) = inl x + G (inr x) = inr x + G (push a b i) = (push (a , invEq (μ-eq' a) b) ∙ cong inr (secEq (μ-eq' a) b)) i s : section F G - s (inl x) = refl - s (inr x) = refl - s (push a b i) j = - hcomp (λ k → λ { (i = i0) → inl a - ; (i = i1) → inr (secEq (μ-eq' a) b (j ∨ k)) + s (inl x) = refl + s (inr x) = refl + s (push a b i) j = + hcomp (λ k → λ { (i = i0) → inl a + ; (i = i1) → inr (secEq (μ-eq' a) b (j ∨ k)) ; (j = i0) → F (compPath-filler (push (a , invEq (μ-eq' a) b)) (cong inr (secEq (μ-eq' a) b)) k i) - ; (j = i1) → push a b i}) - (hcomp (λ k → λ { (i = i0) → inl a - ; (i = i1) → inr (secEq (μ-eq' a) b (~ k ∨ j)) - ; (j = i0) → push a (secEq (μ-eq' a) b (~ k)) i - ; (j = i1) → push a b i}) - (push a b i)) + ; (j = i1) → push a b i}) + (hcomp (λ k → λ { (i = i0) → inl a + ; (i = i1) → inr (secEq (μ-eq' a) b (~ k ∨ j)) + ; (j = i0) → push a (secEq (μ-eq' a) b (~ k)) i + ; (j = i1) → push a b i}) + (push a b i)) r : retract F G r (inl x) = refl @@ -124,7 +124,7 @@ ; (j = i1) → push (x , retEq (μ-eq' x) y k) i}) ((push (x , invEq (μ-eq' x) (μ e x y))) i)) - theIso : Iso TotalSpaceHopfPush (join (typ A) (typ A)) + theIso : Iso TotalSpaceHopfPush (join (typ A) (typ A)) fun theIso = F inv theIso = G rightInv theIso = s @@ -193,7 +193,7 @@ rightInv theIso = sect leftInv theIso = retr - IsoTotalSpaceJoin : Iso (Σ[ x ∈ Susp (typ A) ] Hopf x) (join (typ A) (typ A)) + IsoTotalSpaceJoin : Iso (Σ[ x ∈ Susp (typ A) ] Hopf x) (join (typ A) (typ A)) IsoTotalSpaceJoin = compIso (equivToIso (invEquiv (_ , isEquivTotalSpaceHopfPush→TotalSpace))) joinIso₁ @@ -374,12 +374,12 @@ (push (x , retEq (Push→TotalSpaceHopf x , Push→TotalSpaceHopf-equiv x) y j) i)) - joinIso₂ : Iso TotalSpacePush² (join (typ A) (join (typ A) (typ A))) + joinIso₂ : Iso TotalSpacePush² (join (typ A) (join (typ A) (typ A))) joinIso₂ = compIso IsoTotalSpacePush²TotalSpacePush²' (compIso IsoTotalSpacePush²'ΣPush (compIso (equivToIso (joinPushout≃join _ _)) - (pathToIso (cong (join (typ A)) + (pathToIso (cong (join (typ A)) (isoToPath IsoTotalSpaceJoin))))) @@ -390,7 +390,7 @@ Border x j (j = i1) = S¹ , idEquiv S¹ -- Hopf fibration using SuspS¹ - HopfSuspS¹ : SuspS¹ → Type₀ + HopfSuspS¹ : SuspS¹ → Type₀ HopfSuspS¹ north = S¹ HopfSuspS¹ south = S¹ HopfSuspS¹ (merid x j) = Glue S¹ (Border x j) @@ -415,24 +415,24 @@ -- Total space of the fibration TotalHopf : Type₀ - TotalHopf = Σ SuspS¹ HopfSuspS¹ + TotalHopf = Σ SuspS¹ HopfSuspS¹ -- Forward direction - filler-1 : I → (j : I) → (y : S¹) → Glue S¹ (Border y j) → join S¹ S¹ - filler-1 i j y x = hfill (λ t → λ { (j = i0) → inl (rotInv-1 x y t) - ; (j = i1) → inr x }) - (inS (push ((unglue (j ∨ ~ j) x) · invLooper y) (unglue (j ∨ ~ j) x) j)) i - - TotalHopf→JoinS¹S¹ : TotalHopf → join S¹ S¹ - TotalHopf→JoinS¹S¹ (north , x) = inl x - TotalHopf→JoinS¹S¹ (south , x) = inr x + filler-1 : I → (j : I) → (y : S¹) → Glue S¹ (Border y j) → join S¹ S¹ + filler-1 i j y x = hfill (λ t → λ { (j = i0) → inl (rotInv-1 x y t) + ; (j = i1) → inr x }) + (inS (push ((unglue (j ∨ ~ j) x) · invLooper y) (unglue (j ∨ ~ j) x) j)) i + + TotalHopf→JoinS¹S¹ : TotalHopf → join S¹ S¹ + TotalHopf→JoinS¹S¹ (north , x) = inl x + TotalHopf→JoinS¹S¹ (south , x) = inr x TotalHopf→JoinS¹S¹ (merid y j , x) = filler-1 i1 j y x -- Backward direction - JoinS¹S¹→TotalHopf : join S¹ S¹ → TotalHopf - JoinS¹S¹→TotalHopf (inl x) = (north , x) - JoinS¹S¹→TotalHopf (inr x) = (south , x) - JoinS¹S¹→TotalHopf (push y x j) = + JoinS¹S¹→TotalHopf : join S¹ S¹ → TotalHopf + JoinS¹S¹→TotalHopf (inl x) = (north , x) + JoinS¹S¹→TotalHopf (inr x) = (south , x) + JoinS¹S¹→TotalHopf (push y x j) = (merid (invLooper y · x) j , glue (λ { (j = i0) → y ; (j = i1) → x }) (rotInv-2 x y j)) @@ -535,20 +535,20 @@ ; (j = i1) → assocConst-3 x y t i }) (assocFiller-3 x y j i) - filler-3 : I → I → S¹ → S¹ → join S¹ S¹ + filler-3 : I → I → S¹ → S¹ → join S¹ S¹ filler-3 i j y x = hcomp (λ t → λ { (i = i0) → filler-1 t j (invLooper y · x) (glue (λ { (j = i0) → y ; (j = i1) → x }) (rotInv-2 x y j)) - ; (i = i1) → push (rotInv-3 y x t) x j - ; (j = i0) → inl (assocSquare-3 i t x y) - ; (j = i1) → inr x }) - (push ((rotInv-2 x y (i ∨ j)) · (invLooper (invLooper y · x))) (rotInv-2 x y (i ∨ j)) j) + ; (i = i1) → push (rotInv-3 y x t) x j + ; (j = i0) → inl (assocSquare-3 i t x y) + ; (j = i1) → inr x }) + (push ((rotInv-2 x y (i ∨ j)) · (invLooper (invLooper y · x))) (rotInv-2 x y (i ∨ j)) j) JoinS¹S¹→TotalHopf→JoinS¹S¹ : ∀ x → TotalHopf→JoinS¹S¹ (JoinS¹S¹→TotalHopf x) ≡ x - JoinS¹S¹→TotalHopf→JoinS¹S¹ (inl x) i = inl x - JoinS¹S¹→TotalHopf→JoinS¹S¹ (inr x) i = inr x - JoinS¹S¹→TotalHopf→JoinS¹S¹ (push y x j) i = filler-3 i j y x + JoinS¹S¹→TotalHopf→JoinS¹S¹ (inl x) i = inl x + JoinS¹S¹→TotalHopf→JoinS¹S¹ (inr x) i = inr x + JoinS¹S¹→TotalHopf→JoinS¹S¹ (push y x j) i = filler-3 i j y x -- Second homotopy @@ -679,28 +679,28 @@ TotalHopf→JoinS¹S¹→TotalHopf (merid y j , x) i = filler-4-5 i j y x - JoinS¹S¹≡TotalHopf : join S¹ S¹ ≡ TotalHopf + JoinS¹S¹≡TotalHopf : join S¹ S¹ ≡ TotalHopf JoinS¹S¹≡TotalHopf = isoToPath (iso JoinS¹S¹→TotalHopf TotalHopf→JoinS¹S¹ TotalHopf→JoinS¹S¹→TotalHopf JoinS¹S¹→TotalHopf→JoinS¹S¹) S³≡TotalHopf : S³ ≡ TotalHopf - S³≡TotalHopf = S³≡joinS¹S¹ ∙ JoinS¹S¹≡TotalHopf + S³≡TotalHopf = S³≡joinS¹S¹ ∙ JoinS¹S¹≡TotalHopf open Iso IsoS³TotalHopf : Iso (S₊ 3) TotalHopf - fun IsoS³TotalHopf x = JoinS¹S¹→TotalHopf (S³→joinS¹S¹ (inv IsoS³S3 x)) - inv IsoS³TotalHopf x = fun IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x)) + fun IsoS³TotalHopf x = JoinS¹S¹→TotalHopf (S³→joinS¹S¹ (inv IsoS³S3 x)) + inv IsoS³TotalHopf x = fun IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x)) rightInv IsoS³TotalHopf x = - cong (JoinS¹S¹→TotalHopf ∘ S³→joinS¹S¹) - (leftInv IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x))) + cong (JoinS¹S¹→TotalHopf ∘ S³→joinS¹S¹) + (leftInv IsoS³S3 (joinS¹S¹→S³ (TotalHopf→JoinS¹S¹ x))) ∙∙ cong JoinS¹S¹→TotalHopf - (joinS¹S¹→S³→joinS¹S¹ (TotalHopf→JoinS¹S¹ x)) + (joinS¹S¹→S³→joinS¹S¹ (TotalHopf→JoinS¹S¹ x)) ∙∙ TotalHopf→JoinS¹S¹→TotalHopf x leftInv IsoS³TotalHopf x = - cong (fun IsoS³S3 ∘ joinS¹S¹→S³) - (JoinS¹S¹→TotalHopf→JoinS¹S¹ (S³→joinS¹S¹ (inv IsoS³S3 x))) - ∙∙ cong (fun IsoS³S3) (S³→joinS¹S¹→S³ (inv IsoS³S3 x)) - ∙∙ Iso.rightInv IsoS³S3 x + cong (fun IsoS³S3 ∘ joinS¹S¹→S³) + (JoinS¹S¹→TotalHopf→JoinS¹S¹ (S³→joinS¹S¹ (inv IsoS³S3 x))) + ∙∙ cong (fun IsoS³S3) (S³→joinS¹S¹→S³ (inv IsoS³S3 x)) + ∙∙ Iso.rightInv IsoS³S3 x \ No newline at end of file diff --git a/Cubical.Homotopy.HopfInvariant.Base.html b/Cubical.Homotopy.HopfInvariant.Base.html index ea49af14a..1ec8918e8 100644 --- a/Cubical.Homotopy.HopfInvariant.Base.html +++ b/Cubical.Homotopy.HopfInvariant.Base.html @@ -67,7 +67,7 @@ ; (push a i) → help a (~ i)}) ∣₂ where help : (a : S₊ (3 +ℕ n +ℕ n)) → ∣ fst f a ∣ ≡ 0ₖ (2 +ℕ n) - help = sphereElim _ (λ _ → isOfHLevelPlus' {n = n} (3 +ℕ n) + help = sphereElim _ (λ _ → isOfHLevelPlus' {n = n} (3 +ℕ n) (isOfHLevelPath' (3 +ℕ n) (isOfHLevelTrunc (4 +ℕ n)) _ _)) (cong ∣_∣ₕ (snd f)) @@ -192,7 +192,7 @@ lem : (a : S₊ (suc (suc (suc (n +ℕ n))))) → 0ₖ (suc (suc n)) ≡ g (fst f a) -ₖ g north lem = - sphereElim _ + sphereElim _ (λ x → isOfHLevelPlus' {n = n} (3 +ℕ n) (isOfHLevelTrunc (4 +ℕ n) _ _)) (sym (rCancelₖ _ (g north)) @@ -228,7 +228,7 @@ ; (inr x) → (λ i → g (inr x) -ₖ gn i) ∙ rUnitₖ _ (g (inr x)) ; (push a i) - → sphereElim _ + → sphereElim _ {A = λ a → PathP (λ i → preSphere→H (λ x → g (inr x)) (push a i) @@ -307,8 +307,8 @@ help : (a : Susp (Susp (S₊ (suc (n +ℕ n))))) → PathP (λ i → P (push a i)) e (g (f a)) help = - sphereElim _ - (sphereElim _ + sphereElim _ + (sphereElim _ (λ _ → isProp→isOfHLevelSuc (suc (suc (n +ℕ n))) (isPropIsOfHLevel _)) (isOfHLevelPathP' (suc (suc (suc (n +ℕ n)))) diff --git a/Cubical.Homotopy.HopfInvariant.Brunerie.html b/Cubical.Homotopy.HopfInvariant.Brunerie.html index d402ffd81..cb9e0ec87 100644 --- a/Cubical.Homotopy.HopfInvariant.Brunerie.html +++ b/Cubical.Homotopy.HopfInvariant.Brunerie.html @@ -272,7 +272,7 @@ λ f p → Cubical.HITs.PropositionalTruncation.rec (squash₂ _ _) (λ r → cong ∣_∣₂ (funExt (uncurry - (wedgeconFun 1 1 (λ _ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _) + (wedgeconFun 1 1 (λ _ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _) (λ x → cong f (push (inr x)) ∙∙ funExt⁻ r x ∙∙ refl) ((λ x → cong f (push (inl x)) ∙∙ funExt⁻ r x ∙∙ sym (rUnitₖ 2 ∣ x ∣ₕ))) (cong (_∙∙ funExt⁻ r north ∙∙ refl) @@ -390,9 +390,9 @@ -- We rewrite the it slightly, to get the definition of the Brunerie -- number in Brunerie (2016) -Brunerie'≡Brunerie : [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π' ≡ ∣ fold∘W , refl ∣₂ +Brunerie'≡Brunerie : [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π' ≡ ∣ fold∘W , refl ∣₂ Brunerie'≡Brunerie = - cong ∣_∣₂ ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2)) ) + cong ∣_∣₂ ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2)) ) ∙ sym fold∘W≡Whitehead ∙ cong ∣_∣₂ (∘∙-idˡ (fold∘W , refl)) diff --git a/Cubical.Homotopy.HopfInvariant.Homomorphism.html b/Cubical.Homotopy.HopfInvariant.Homomorphism.html index 8a08b04ea..ddf7dfb34 100644 --- a/Cubical.Homotopy.HopfInvariant.Homomorphism.html +++ b/Cubical.Homotopy.HopfInvariant.Homomorphism.html @@ -110,11 +110,11 @@ → P (inl north) → (x : _) → P x WedgeElim n {P = P} x s (inl x₁) = - sphereElim _ {A = P ∘ inl} + sphereElim _ {A = P ∘ inl} (λ _ → isOfHLevelPlus' {n = n} (3 +ℕ n) (x _)) s x₁ WedgeElim n {P = P} x s (inr x₁) = - sphereElim _ {A = P ∘ inr} - (sphereElim _ (λ _ → isProp→isOfHLevelSuc ((suc (suc (n +ℕ n)))) + sphereElim _ {A = P ∘ inr} + (sphereElim _ (λ _ → isProp→isOfHLevelSuc ((suc (suc (n +ℕ n)))) (isPropIsOfHLevel (suc (suc (suc (n +ℕ n)))))) (subst (isOfHLevel ((3 +ℕ n) +ℕ n)) (cong P (push tt)) (isOfHLevelPlus' {n = n} (3 +ℕ n) (x _)))) diff --git a/Cubical.Homotopy.HopfInvariant.HopfMap.html b/Cubical.Homotopy.HopfInvariant.HopfMap.html index 4b3076faf..3c534ff8e 100644 --- a/Cubical.Homotopy.HopfInvariant.HopfMap.html +++ b/Cubical.Homotopy.HopfInvariant.HopfMap.html @@ -59,12 +59,12 @@ renaming (rec to pRec) HopfMap : S₊∙ 3 →∙ S₊∙ 2 -fst HopfMap x = JoinS¹S¹→TotalHopf (Iso.inv (IsoSphereJoin 1 1) x) .fst +fst HopfMap x = JoinS¹S¹→TotalHopf (Iso.inv (IsoSphereJoin 1 1) x) .fst snd HopfMap = refl -- We use the Hopf fibration in order to connect it to the Gysin Sequence module hopfS¹ = - Hopf S1-AssocHSpace (sphereElim2 _ (λ _ _ → squash₁) ∣ refl ∣₁) + Hopf S1-AssocHSpace (sphereElim2 _ (λ _ _ → squash₁) ∣ refl ∣₁) S¹Hopf = hopfS¹.Hopf E* = hopfS¹.TotalSpacePush²' @@ -76,8 +76,8 @@ TotalHopf' : Type _ TotalHopf' = Σ (S₊ 2) S¹Hopf -IsoJoins : (join S¹ (join S¹ S¹)) ≡ join S¹ (S₊ 3) -IsoJoins = cong (join S¹) (isoToPath (IsoSphereJoin 1 1)) +IsoJoins : (join S¹ (join S¹ S¹)) ≡ join S¹ (S₊ 3) +IsoJoins = cong (join S¹) (isoToPath (IsoSphereJoin 1 1)) -- CP² is 1-connected conCP² : (x y : CP²) → ∥ x ≡ y ∥₂ @@ -85,7 +85,7 @@ where conCP²' : (x : CP²) → ∥ x ≡ inl tt ∥₂ conCP²' (inl x) = ∣ refl ∣₂ - conCP²' (inr x) = sphereElim 1 {A = λ x → ∥ inr x ≡ inl tt ∥₂} + conCP²' (inr x) = sphereElim 1 {A = λ x → ∥ inr x ≡ inl tt ∥₂} (λ _ → squash₂) ∣ sym (push (inl base)) ∣₂ x conCP²' (push a i) = main a i where @@ -95,8 +95,8 @@ → ((a : hopfS¹.TotalSpaceHopfPush) → A a) indLem {A = A} p b = Pushout.elimProp _ p - (sphereElim 0 (λ _ → p _) b) - (sphereElim 0 (λ _ → p _) (subst A (push (base , base)) b)) + (sphereElim 0 (λ _ → p _) b) + (sphereElim 0 (λ _ → p _) (subst A (push (base , base)) b)) main : (a : hopfS¹.TotalSpaceHopfPush) → PathP (λ i → ∥ Path CP² (push a i) (inl tt) ∥₂) @@ -109,8 +109,8 @@ E'S⁴Iso : Iso GysinS².E' (S₊ 5) E'S⁴Iso = compIso IsoE*join - (compIso (Iso→joinIso idIso (IsoSphereJoin 1 1)) - (IsoSphereJoin 1 3)) + (compIso (Iso→joinIso idIso (IsoSphereJoin 1 1)) + (IsoSphereJoin 1 3)) isContrH³E : isContr (coHom 3 (GysinS².E')) isContrH³E = @@ -129,14 +129,14 @@ isContrUnit -- We will need a bunch of elimination principles -joinS¹S¹→Groupoid : ∀ {ℓ} (P : join S¹ S¹ → Type ℓ) +joinS¹S¹→Groupoid : ∀ {ℓ} (P : join S¹ S¹ → Type ℓ) → ((x : _) → isGroupoid (P x)) → P (inl base) → (x : _) → P x joinS¹S¹→Groupoid P grp b = - transport (λ i → (x : (isoToPath (invIso (IsoSphereJoin 1 1))) i) - → P (transp (λ j → isoToPath (invIso (IsoSphereJoin 1 1)) (i ∨ j)) i x)) - (sphereElim _ (λ _ → grp _) b) + transport (λ i → (x : (isoToPath (invIso (IsoSphereJoin 1 1))) i) + → P (transp (λ j → isoToPath (invIso (IsoSphereJoin 1 1)) (i ∨ j)) i x)) + (sphereElim _ (λ _ → grp _) b) TotalHopf→Gpd : ∀ {ℓ} (P : hopfS¹.TotalSpaceHopfPush → Type ℓ) → ((x : _) → isGroupoid (P x)) @@ -295,9 +295,9 @@ → (invEq (hopfS¹.μ-eq a) x) * a ≡ (invLooper a * x) * a invLooperLem₁ a x = secEq (hopfS¹.μ-eq a) x - ∙∙ cong (_* x) (rCancelS¹ a) + ∙∙ cong (_* x) (rCancelS¹ a) ∙∙ AssocHSpace.μ-assoc S1-AssocHSpace a (invLooper a) x - ∙ commS¹ _ _ + ∙ commS¹ _ _ invLooperLem₂ : (a x : S¹) → invEq (hopfS¹.μ-eq a) x ≡ invLooper a * x invLooperLem₂ a x = sym (retEq (hopfS¹.μ-eq a) (invEq (hopfS¹.μ-eq a) x)) @@ -306,7 +306,7 @@ rotLoop² : (a : S¹) → Path (a ≡ a) (λ i → rotLoop (rotLoop a i) (~ i)) refl rotLoop² = - sphereElim 0 (λ _ → isGroupoidS¹ _ _ _ _) + sphereElim 0 (λ _ → isGroupoidS¹ _ _ _ _) λ i j → hcomp (λ {k → λ { (i = i1) → base ; (j = i0) → base ; (j = i1) → base}}) @@ -348,14 +348,14 @@ ∙∙ cong ((cong ∣_∣ₕ) (sym (merid a)) ∙_) (cong (cong ∣_∣ₕ) (cong sym (symDistr (merid base) (sym (merid (invLooper a * x))))) - ∙ cong sym (SuspS¹-hom (invLooper a) x) + ∙ cong sym (SuspS¹-hom (invLooper a) x) ∙ symDistr ((cong ∣_∣ₕ) (merid (invLooper a) ∙ sym (merid base))) ((cong ∣_∣ₕ) (merid x ∙ sym (merid base))) ∙ isCommΩK 2 (sym (λ i₁ → ∣ (merid x ∙ (λ i₂ → merid base (~ i₂))) i₁ ∣)) (sym (λ i₁ → ∣ (merid (invLooper a) ∙ (λ i₂ → merid base (~ i₂))) i₁ ∣)) - ∙ cong₂ _∙_ (cong sym (SuspS¹-inv a) + ∙ cong₂ _∙_ (cong sym (SuspS¹-inv a) ∙ cong-∙ ∣_∣ₕ (merid a) (sym (merid base))) (cong (cong ∣_∣ₕ) (symDistr (merid x) (sym (merid base))) ∙ cong-∙ ∣_∣ₕ (merid base) (sym (merid x)))) @@ -399,11 +399,11 @@ setHelp : (x : S₊ 2) → isSet (preThom.Q (CP² , inl tt) fibr (inr x) →∙ coHomK-ptd 2) - setHelp = sphereElim _ (λ _ → isProp→isOfHLevelSuc 1 (isPropIsOfHLevel 2)) + setHelp = sphereElim _ (λ _ → isProp→isOfHLevelSuc 1 (isPropIsOfHLevel 2)) (isOfHLevel↑∙' 0 1) main : (x : S₊ 2) → (GysinS².c (inr x) ≡ gen' x) - main = sphereElim _ (λ x → isOfHLevelPath 2 (setHelp x) _ _) + main = sphereElim _ (λ x → isOfHLevelPath 2 (setHelp x) _ _) (→∙Homogeneous≡ (isHomogeneousKn _) gen'Id) isGenerator≃ℤ : ∀ {ℓ} (G : Group ℓ) (g : fst G) → Type ℓ @@ -420,16 +420,16 @@ HopfMap' x = hopfS¹.TotalSpaceHopfPush→TotalSpace (Iso.inv IsoTotalHopf' - (Iso.inv (IsoSphereJoin 1 1) x)) .fst + (Iso.inv (IsoSphereJoin 1 1) x)) .fst hopfMap≡HopfMap' : HopfMap ≡ (HopfMap' , refl) hopfMap≡HopfMap' = ΣPathP ((funExt (λ x → cong (λ x → JoinS¹S¹→TotalHopf x .fst) (sym (Iso.rightInv IsoTotalHopf' - (Iso.inv (IsoSphereJoin 1 1) x))) + (Iso.inv (IsoSphereJoin 1 1) x))) ∙ sym (lem (Iso.inv IsoTotalHopf' - (Iso.inv (IsoSphereJoin 1 1) x))))) + (Iso.inv (IsoSphereJoin 1 1) x))))) , flipSquare (sym (rUnit refl) ◁ λ _ _ → north)) where lem : (x : _) → hopfS¹.TotalSpaceHopfPush→TotalSpace x .fst @@ -451,7 +451,7 @@ CP2≡CP²' : CP²' ≡ CP² CP2≡CP²' = PushoutReplaceBase - (isoToEquiv (compIso (invIso (IsoSphereJoin 1 1)) (invIso IsoTotalHopf'))) + (isoToEquiv (compIso (invIso (IsoSphereJoin 1 1)) (invIso IsoTotalHopf'))) -- packaging everything up: ⌣equiv→pres1 : ∀ {ℓ} {G H : Type ℓ} → (G ≡ H) diff --git a/Cubical.Homotopy.Whitehead.html b/Cubical.Homotopy.Whitehead.html index b42863abb..321fe2565 100644 --- a/Cubical.Homotopy.Whitehead.html +++ b/Cubical.Homotopy.Whitehead.html @@ -21,392 +21,495 @@ open import Cubical.HITs.SetTruncation open import Cubical.Homotopy.Group.Base - -open Iso -open 3x3-span - -joinTo⋁ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'} - → join (typ A) (typ B) - → (Susp (typ A) , north) ⋁ (Susp (typ B) , north) -joinTo⋁ (inl x) = inr north -joinTo⋁ (inr x) = inl north -joinTo⋁ {A = A} {B = B} (push a b i) = - ((λ i → inr (σ B b i)) - ∙∙ sym (push tt) - ∙∙ λ i → inl (σ A a i)) i - --- Whitehead product (main definition) -[_∣_] : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} - → (S₊∙ (suc n) →∙ X) - → (S₊∙ (suc m) →∙ X) - → S₊∙ (suc (n + m)) →∙ X -fst ([_∣_] {X = X} {n = n} {m = m} f g) x = - _∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n)) - (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m)) - (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m} - (inv (IsoSphereJoin n m) x)) -snd ([_∣_] {n = n} {m = m} f g) = - cong (_∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n)) - (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m))) - (cong (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m}) (IsoSphereJoin⁻Pres∙ n m)) - ∙ cong (fst g) (IsoSucSphereSusp∙ m) - ∙ snd g - --- For Sⁿ, Sᵐ with n, m ≥ 2, we can avoid some bureaucracy. We make --- a separate definition and prove it equivalent. -[_∣_]-pre : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} - → (S₊∙ (suc (suc n)) →∙ X) - → (S₊∙ (suc (suc m)) →∙ X) - → join (typ (S₊∙ (suc n))) (typ (S₊∙ (suc m))) → fst X -[_∣_]-pre {n = n} {m = m} f g x = - _∨→_ f g - (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} - x) - -[_∣_]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} - → (S₊∙ (suc (suc n)) →∙ X) - → (S₊∙ (suc (suc m)) →∙ X) - → S₊∙ (suc ((suc n) + (suc m))) →∙ X -fst ([_∣_]₂ {n = n} {m = m} f g) x = - [ f ∣ g ]-pre (inv (IsoSphereJoin (suc n) (suc m)) x) -snd ([_∣_]₂ {n = n} {m = m} f g) = - cong ([ f ∣ g ]-pre) (IsoSphereJoin⁻Pres∙ (suc n) (suc m)) - ∙ snd g - -[]≡[]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} - → (f : (S₊∙ (suc (suc n)) →∙ X)) - → (g : (S₊∙ (suc (suc m)) →∙ X)) - → [ f ∣ g ] ≡ [ f ∣ g ]₂ -[]≡[]₂ {n = n} {m = m} f g = - ΣPathP ( - (λ i x → _∨→_ (∘∙-idˡ f i) - (∘∙-idˡ g i) - (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} - (inv (IsoSphereJoin (suc n) (suc m)) x))) - , (cong (cong (_∨→_ (f ∘∙ idfun∙ _) - (g ∘∙ idfun∙ _)) - (cong (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)}) - (IsoSphereJoin⁻Pres∙ (suc n) (suc m))) ∙_) - (sym (lUnit (snd g))) - ◁ λ j → (λ i → _∨→_ (∘∙-idˡ f j) - (∘∙-idˡ g j) - ( joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} - ((IsoSphereJoin⁻Pres∙ (suc n) (suc m)) i))) ∙ snd g)) - --- Homotopy group version -[_∣_]π' : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} - → π' (suc n) X → π' (suc m) X - → π' (suc (n + m)) X -[_∣_]π' = elim2 (λ _ _ → squash₂) λ f g → ∣ [ f ∣ g ] ∣₂ - --- We prove that the function joinTo⋁ used in the definition of the whitehead --- product gives an equivalence between (Susp A × Susp B) and the --- appropriate cofibre of joinTo⋁ (last two theorems in the following --- module). - -module _ (A B : Type) (a₀ : A) (b₀ : B) where - private - W = joinTo⋁ {A = (A , a₀)} {B = (B , b₀)} - - A∨B = (Susp A , north) ⋁ (Susp B , north) - - σB = σ (B , b₀) - σA = σ (A , a₀) - - cofibW = Pushout W λ _ → tt - - whitehead3x3 : 3x3-span - A00 whitehead3x3 = Susp A - A02 whitehead3x3 = B - A04 whitehead3x3 = Unit - A20 whitehead3x3 = B - A22 whitehead3x3 = A × B - A24 whitehead3x3 = A - A40 whitehead3x3 = B - A42 whitehead3x3 = B - A44 whitehead3x3 = Unit - f10 whitehead3x3 _ = south - f12 whitehead3x3 = snd - f14 whitehead3x3 _ = tt - f30 whitehead3x3 = idfun B - f32 whitehead3x3 = snd - f34 whitehead3x3 _ = tt - f01 whitehead3x3 _ = north - f21 whitehead3x3 = snd - f41 whitehead3x3 = idfun B - f03 whitehead3x3 _ = tt - f23 whitehead3x3 = fst - f43 whitehead3x3 _ = tt - H11 whitehead3x3 x = merid (fst x) - H13 whitehead3x3 _ = refl - H31 whitehead3x3 _ = refl - H33 whitehead3x3 _ = refl - - A0□→A∨B : A0□ whitehead3x3 → A∨B - A0□→A∨B (inl x) = inl x - A0□→A∨B (inr x) = inr north - A0□→A∨B (push a i) = (push tt ∙ λ i → inr (σB a (~ i))) i - - A∨B→A0□ : A∨B → A0□ whitehead3x3 - A∨B→A0□ (inl x) = inl x - A∨B→A0□ (inr north) = inl north - A∨B→A0□ (inr south) = inl north - A∨B→A0□ (inr (merid b i)) = (push b₀ ∙ sym (push b)) i - A∨B→A0□ (push a i) = inl north - - Iso-A0□-⋁ : Iso (A0□ whitehead3x3) A∨B - fun Iso-A0□-⋁ = A0□→A∨B - inv Iso-A0□-⋁ = A∨B→A0□ - rightInv Iso-A0□-⋁ (inl x) = refl - rightInv Iso-A0□-⋁ (inr north) = push tt - rightInv Iso-A0□-⋁ (inr south) = push tt ∙ λ i → inr (merid b₀ i) - rightInv Iso-A0□-⋁ (inr (merid a i)) j = lem j i - where - lem : PathP (λ i → push tt i ≡ (push tt ∙ (λ i → inr (merid b₀ i))) i) - (cong A0□→A∨B (cong A∨B→A0□ λ i → inr (merid a i))) - (λ i → inr (merid a i)) - lem = (cong-∙ A0□→A∨B (push b₀) (sym (push a)) - ∙ cong₂ _∙_ (cong (push tt ∙_) - (λ j i → inr (rCancel (merid b₀) j (~ i))) - ∙ sym (rUnit (push tt))) - (symDistr (push tt) (λ i → inr (σB a (~ i))))) - ◁ λ i j → hcomp (λ k → - λ { (i = i0) → compPath-filler' (push tt) - (compPath-filler (λ i → inr (σB a i)) - (sym (push tt)) k) k j - ; (i = i1) → inr (merid a j) - ; (j = i0) → push tt (i ∨ ~ k) - ; (j = i1) → compPath-filler' (push tt) - (λ i → inr (merid b₀ i)) k i}) - (inr (compPath-filler (merid a) - (sym (merid b₀)) (~ i) j)) - - rightInv Iso-A0□-⋁ (push a i) j = push tt (i ∧ j) - leftInv Iso-A0□-⋁ (inl x) = refl - leftInv Iso-A0□-⋁ (inr tt) = push b₀ - leftInv Iso-A0□-⋁ (push b i) j = help j i - where - help : PathP (λ i → inl north ≡ push b₀ i) - (cong A∨B→A0□ (cong A0□→A∨B (push b))) - (push b) - help = (cong-∙ A∨B→A0□ (push tt) (λ i → inr (σB b (~ i))) - ∙ (λ i → lUnit (sym (cong-∙ (A∨B→A0□ ∘ inr) - (merid b) (sym (merid b₀)) i)) (~ i)) - ∙ cong sym (cong ((push b₀ ∙ sym (push b)) ∙_) - (cong sym (rCancel (push b₀)))) - ∙ cong sym (sym (rUnit (push b₀ ∙ sym (push b))))) - ◁ λ i j → compPath-filler' (push b₀) (sym (push b)) (~ i) (~ j) - - Iso-A2□-join : Iso (A2□ whitehead3x3) (join A B) - fun Iso-A2□-join (inl x) = inr x - fun Iso-A2□-join (inr x) = inl x - fun Iso-A2□-join (push (a , b) i) = push a b (~ i) - inv Iso-A2□-join (inl x) = inr x - inv Iso-A2□-join (inr x) = inl x - inv Iso-A2□-join (push a b i) = push (a , b) (~ i) - rightInv Iso-A2□-join (inl x) = refl - rightInv Iso-A2□-join (inr x) = refl - rightInv Iso-A2□-join (push a b i) = refl - leftInv Iso-A2□-join (inl x) = refl - leftInv Iso-A2□-join (inr x) = refl - leftInv Iso-A2□-join (push a i) = refl - - isContrA4□ : isContr (A4□ whitehead3x3) - fst isContrA4□ = inr tt - snd isContrA4□ (inl x) = sym (push x) - snd isContrA4□ (inr x) = refl - snd isContrA4□ (push a i) j = push a (i ∨ ~ j) - - A4□≃Unit : A4□ whitehead3x3 ≃ Unit - A4□≃Unit = isContr→≃Unit isContrA4□ - - Iso-A□0-Susp : Iso (A□0 whitehead3x3) (Susp A) - fun Iso-A□0-Susp (inl x) = x - fun Iso-A□0-Susp (inr x) = north - fun Iso-A□0-Susp (push a i) = merid a₀ (~ i) - inv Iso-A□0-Susp x = inl x - rightInv Iso-A□0-Susp x = refl - leftInv Iso-A□0-Susp (inl x) = refl - leftInv Iso-A□0-Susp (inr x) = (λ i → inl (merid a₀ i)) ∙ push x - leftInv Iso-A□0-Susp (push a i) j = - hcomp (λ k → λ { (i = i0) → inl (merid a₀ (k ∨ j)) - ; (i = i1) → compPath-filler - (λ i₁ → inl (merid a₀ i₁)) - (push (idfun B a)) k j - ; (j = i0) → inl (merid a₀ (~ i ∧ k)) - ; (j = i1) → push a (i ∧ k)}) - (inl (merid a₀ j)) - - Iso-A□2-Susp× : Iso (A□2 whitehead3x3) (Susp A × B) - fun Iso-A□2-Susp× (inl x) = north , x - fun Iso-A□2-Susp× (inr x) = south , x - fun Iso-A□2-Susp× (push a i) = merid (fst a) i , (snd a) - inv Iso-A□2-Susp× (north , y) = inl y - inv Iso-A□2-Susp× (south , y) = inr y - inv Iso-A□2-Susp× (merid a i , y) = push (a , y) i - rightInv Iso-A□2-Susp× (north , snd₁) = refl - rightInv Iso-A□2-Susp× (south , snd₁) = refl - rightInv Iso-A□2-Susp× (merid a i , snd₁) = refl - leftInv Iso-A□2-Susp× (inl x) = refl - leftInv Iso-A□2-Susp× (inr x) = refl - leftInv Iso-A□2-Susp× (push a i) = refl - - Iso-A□4-Susp : Iso (A□4 whitehead3x3) (Susp A) - fun Iso-A□4-Susp (inl x) = north - fun Iso-A□4-Susp (inr x) = south - fun Iso-A□4-Susp (push a i) = merid a i - inv Iso-A□4-Susp north = inl tt - inv Iso-A□4-Susp south = inr tt - inv Iso-A□4-Susp (merid a i) = push a i - rightInv Iso-A□4-Susp north = refl - rightInv Iso-A□4-Susp south = refl - rightInv Iso-A□4-Susp (merid a i) = refl - leftInv Iso-A□4-Susp (inl x) = refl - leftInv Iso-A□4-Susp (inr x) = refl - leftInv Iso-A□4-Susp (push a i) = refl - - Iso-PushSusp×-Susp×Susp : - Iso (Pushout {A = Susp A × B} fst fst) (Susp A × Susp B) - Iso-PushSusp×-Susp×Susp = theIso - where - F : Pushout {A = Susp A × B} fst fst - → Susp A × Susp B - F (inl x) = x , north - F (inr x) = x , north - F (push (x , b) i) = x , σB b i - - G : Susp A × Susp B → Pushout {A = Susp A × B} fst fst - G (a , north) = inl a - G (a , south) = inr a - G (a , merid b i) = push (a , b) i - - retr : retract F G - retr (inl x) = refl - retr (inr x) = push (x , b₀) - retr (push (a , b) i) j = help j i - where - help : PathP (λ i → Path (Pushout fst fst) (inl a) (push (a , b₀) i)) - (cong G (λ i → a , σB b i)) - (push (a , b)) - help = cong-∙ (λ x → G (a , x)) (merid b) (sym (merid b₀)) - ◁ λ i j → compPath-filler - (push (a , b)) - (sym (push (a , b₀))) - (~ i) j - - theIso : Iso (Pushout fst fst) (Susp A × Susp B) - fun theIso = F - inv theIso = G - rightInv theIso (a , north) = refl - rightInv theIso (a , south) = ΣPathP (refl , merid b₀) - rightInv theIso (a , merid b i) j = - a , compPath-filler (merid b) (sym (merid b₀)) (~ j) i - leftInv theIso = retr - - Iso-A□○-PushSusp× : - Iso (A□○ whitehead3x3) (Pushout {A = Susp A × B} fst fst) - Iso-A□○-PushSusp× = - pushoutIso _ _ fst fst - (isoToEquiv Iso-A□2-Susp×) - (isoToEquiv Iso-A□0-Susp) - (isoToEquiv Iso-A□4-Susp) - (funExt (λ { (inl x) → refl - ; (inr x) → merid a₀ - ; (push a i) j → help₁ a j i})) - (funExt λ { (inl x) → refl - ; (inr x) → refl - ; (push a i) j - → fun Iso-A□4-Susp (rUnit (push (fst a)) (~ j) i)}) - where - help₁ : (a : A × B) - → PathP (λ i → north ≡ merid a₀ i) - (cong (fun Iso-A□0-Susp) - (cong (f□1 whitehead3x3) (push a))) - (merid (fst a)) - help₁ a = - (cong-∙∙ (fun Iso-A□0-Susp) - (λ i → inl (merid (fst a) i)) - (push (snd a)) - refl) - ◁ (λ i j → hcomp (λ k → λ {(i = i1) → merid (fst a) (j ∨ ~ k) - ; (j = i0) → merid (fst a) (~ k) - ; (j = i1) → merid a₀ i}) - (merid a₀ (i ∨ ~ j))) - - Iso-A□○-Susp×Susp : Iso (A□○ whitehead3x3) (Susp A × Susp B) - Iso-A□○-Susp×Susp = compIso Iso-A□○-PushSusp× Iso-PushSusp×-Susp×Susp - - Iso-A○□-cofibW : Iso (A○□ whitehead3x3) cofibW - Iso-A○□-cofibW = - pushoutIso _ _ - W (λ _ → tt) - (isoToEquiv Iso-A2□-join) (isoToEquiv Iso-A0□-⋁) - A4□≃Unit - (funExt lem) - λ _ _ → tt - where - lem : (x : A2□ whitehead3x3) - → A0□→A∨B (f1□ whitehead3x3 x) ≡ W (fun Iso-A2□-join x) - lem (inl x) = (λ i → inl (merid a₀ (~ i))) - lem (inr x) = refl - lem (push (a , b) i) j = help j i - where - help : PathP (λ i → Path (Pushout (λ _ → north) (λ _ → north)) - ((inl (merid a₀ (~ i)))) - (inr north)) - (cong A0□→A∨B (cong (f1□ whitehead3x3) (push (a , b)))) - (cong W (cong (fun Iso-A2□-join) (push (a , b)))) - help = (cong-∙∙ A0□→A∨B (λ i → inl (merid a (~ i))) (push b) refl - ∙ λ j → (λ i₂ → inl (merid a (~ i₂))) - ∙∙ compPath-filler (push tt) (λ i → inr (σB b (~ i))) (~ j) - ∙∙ λ i → inr (σB b (~ i ∧ j))) - ◁ (λ j → (λ i → inl (sym (compPath-filler - (merid a) (sym (merid a₀)) j) i)) - ∙∙ push tt - ∙∙ λ i → inr (σB b (~ i))) - - Iso₁-Susp×Susp-cofibW : Iso (Susp A × Susp B) cofibW - Iso₁-Susp×Susp-cofibW = - compIso (invIso Iso-A□○-Susp×Susp) - (compIso (3x3-Iso whitehead3x3) Iso-A○□-cofibW) - - -- Main iso - Iso-Susp×Susp-cofibJoinTo⋁ : Iso (Susp A × Susp B) cofibW - Iso-Susp×Susp-cofibJoinTo⋁ = - compIso (Σ-cong-iso-snd (λ _ → invSuspIso)) - Iso₁-Susp×Susp-cofibW - - -- The induced function A ∨ B → Susp A × Susp B satisfies - -- the following identity - Susp×Susp→cofibW≡ : Path (A∨B → Susp A × Susp B) - (Iso.inv Iso-Susp×Susp-cofibJoinTo⋁ ∘ inl) - ⋁↪ - Susp×Susp→cofibW≡ = - funExt λ { (inl x) → ΣPathP (refl , (sym (merid b₀))) - ; (inr north) → ΣPathP (refl , (sym (merid b₀))) - ; (inr south) → refl - ; (inr (merid a i)) j → lem₂ a j i - ; (push a i) j → north , (merid b₀ (~ j))} - where - f₁ = fun Iso-PushSusp×-Susp×Susp - f₂ = fun Iso-A□○-PushSusp× - f₃ = backward-l whitehead3x3 - f₄ = fun (Σ-cong-iso-snd (λ _ → invSuspIso)) - - lem : (b : B) - → cong (f₁ ∘ f₂ ∘ f₃) (push b) - ≡ (λ i → north , σB b i) - lem b = cong (cong f₁) (sym (rUnit (push (north , b)))) - - lem₂ : (a : B) - → PathP (λ i → (north , merid b₀ (~ i)) ≡ (north , south)) - (cong (f₄ ∘ f₁ ∘ f₂ ∘ f₃ ∘ A∨B→A0□ ∘ inr) (merid a)) - λ i → north , merid a i - lem₂ a = - cong (cong f₄) (cong-∙ (f₁ ∘ f₂ ∘ f₃) (push b₀) (sym (push a)) - ∙∙ cong₂ _∙_ (lem b₀ ∙ (λ j i → north , rCancel (merid b₀) j i)) - (cong sym (lem a)) - ∙∙ sym (lUnit (λ i₁ → north , σB a (~ i₁)))) - ∙ (λ i j → north , cong-∙ invSusp (merid a) (sym (merid b₀)) i (~ j) ) - ◁ λ i j → north , compPath-filler (sym (merid a)) (merid b₀) (~ i) (~ j) +open import Cubical.Homotopy.Loopspace + +open Iso +open 3x3-span + +joinTo⋁ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'} + → join (typ A) (typ B) + → (Susp (typ A) , north) ⋁ (Susp (typ B) , north) +joinTo⋁ (inl x) = inr north +joinTo⋁ (inr x) = inl north +joinTo⋁ {A = A} {B = B} (push a b i) = + ((λ i → inr (σ B b i)) + ∙∙ sym (push tt) + ∙∙ λ i → inl (σ A a i)) i + +-- Whitehead product (main definition) +[_∣_] : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} + → (S₊∙ (suc n) →∙ X) + → (S₊∙ (suc m) →∙ X) + → S₊∙ (suc (n + m)) →∙ X +fst ([_∣_] {X = X} {n = n} {m = m} f g) x = + _∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n)) + (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m)) + (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m} + (inv (IsoSphereJoin n m) x)) +snd ([_∣_] {n = n} {m = m} f g) = + cong (_∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n)) + (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m))) + (cong (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m}) (IsoSphereJoin⁻Pres∙ n m)) + ∙ cong (fst g) (IsoSucSphereSusp∙ m) + ∙ snd g + +-- For Sⁿ, Sᵐ with n, m ≥ 2, we can avoid some bureaucracy. We make +-- a separate definition and prove it equivalent. +[_∣_]-pre : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} + → (S₊∙ (suc (suc n)) →∙ X) + → (S₊∙ (suc (suc m)) →∙ X) + → join (typ (S₊∙ (suc n))) (typ (S₊∙ (suc m))) → fst X +[_∣_]-pre {n = n} {m = m} f g x = + _∨→_ f g + (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} + x) + +[_∣_]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} + → (S₊∙ (suc (suc n)) →∙ X) + → (S₊∙ (suc (suc m)) →∙ X) + → S₊∙ (suc ((suc n) + (suc m))) →∙ X +fst ([_∣_]₂ {n = n} {m = m} f g) x = + [ f ∣ g ]-pre (inv (IsoSphereJoin (suc n) (suc m)) x) +snd ([_∣_]₂ {n = n} {m = m} f g) = + cong ([ f ∣ g ]-pre) (IsoSphereJoin⁻Pres∙ (suc n) (suc m)) + ∙ snd g + +[]≡[]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} + → (f : (S₊∙ (suc (suc n)) →∙ X)) + → (g : (S₊∙ (suc (suc m)) →∙ X)) + → [ f ∣ g ] ≡ [ f ∣ g ]₂ +[]≡[]₂ {n = n} {m = m} f g = + ΣPathP ( + (λ i x → _∨→_ (∘∙-idˡ f i) + (∘∙-idˡ g i) + (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} + (inv (IsoSphereJoin (suc n) (suc m)) x))) + , (cong (cong (_∨→_ (f ∘∙ idfun∙ _) + (g ∘∙ idfun∙ _)) + (cong (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)}) + (IsoSphereJoin⁻Pres∙ (suc n) (suc m))) ∙_) + (sym (lUnit (snd g))) + ◁ λ j → (λ i → _∨→_ (∘∙-idˡ f j) + (∘∙-idˡ g j) + ( joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)} + ((IsoSphereJoin⁻Pres∙ (suc n) (suc m)) i))) ∙ snd g)) + +-- Homotopy group version +[_∣_]π' : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ} + → π' (suc n) X → π' (suc m) X + → π' (suc (n + m)) X +[_∣_]π' = elim2 (λ _ _ → squash₂) λ f g → ∣ [ f ∣ g ] ∣₂ + +-- We prove that the function joinTo⋁ used in the definition of the whitehead +-- product gives an equivalence between (Susp A × Susp B) and the +-- appropriate cofibre of joinTo⋁ (last two theorems in the following +-- module). + +module _ (A B : Type) (a₀ : A) (b₀ : B) where + private + W = joinTo⋁ {A = (A , a₀)} {B = (B , b₀)} + + A∨B = (Susp A , north) ⋁ (Susp B , north) + + σB = σ (B , b₀) + σA = σ (A , a₀) + + cofibW = Pushout W λ _ → tt + + whitehead3x3 : 3x3-span + A00 whitehead3x3 = Susp A + A02 whitehead3x3 = B + A04 whitehead3x3 = Unit + A20 whitehead3x3 = B + A22 whitehead3x3 = A × B + A24 whitehead3x3 = A + A40 whitehead3x3 = B + A42 whitehead3x3 = B + A44 whitehead3x3 = Unit + f10 whitehead3x3 _ = south + f12 whitehead3x3 = snd + f14 whitehead3x3 _ = tt + f30 whitehead3x3 = idfun B + f32 whitehead3x3 = snd + f34 whitehead3x3 _ = tt + f01 whitehead3x3 _ = north + f21 whitehead3x3 = snd + f41 whitehead3x3 = idfun B + f03 whitehead3x3 _ = tt + f23 whitehead3x3 = fst + f43 whitehead3x3 _ = tt + H11 whitehead3x3 x = merid (fst x) + H13 whitehead3x3 _ = refl + H31 whitehead3x3 _ = refl + H33 whitehead3x3 _ = refl + + A0□→A∨B : A0□ whitehead3x3 → A∨B + A0□→A∨B (inl x) = inl x + A0□→A∨B (inr x) = inr north + A0□→A∨B (push a i) = (push tt ∙ λ i → inr (σB a (~ i))) i + + A∨B→A0□ : A∨B → A0□ whitehead3x3 + A∨B→A0□ (inl x) = inl x + A∨B→A0□ (inr north) = inl north + A∨B→A0□ (inr south) = inl north + A∨B→A0□ (inr (merid b i)) = (push b₀ ∙ sym (push b)) i + A∨B→A0□ (push a i) = inl north + + Iso-A0□-⋁ : Iso (A0□ whitehead3x3) A∨B + fun Iso-A0□-⋁ = A0□→A∨B + inv Iso-A0□-⋁ = A∨B→A0□ + rightInv Iso-A0□-⋁ (inl x) = refl + rightInv Iso-A0□-⋁ (inr north) = push tt + rightInv Iso-A0□-⋁ (inr south) = push tt ∙ λ i → inr (merid b₀ i) + rightInv Iso-A0□-⋁ (inr (merid a i)) j = lem j i + where + lem : PathP (λ i → push tt i ≡ (push tt ∙ (λ i → inr (merid b₀ i))) i) + (cong A0□→A∨B (cong A∨B→A0□ λ i → inr (merid a i))) + (λ i → inr (merid a i)) + lem = (cong-∙ A0□→A∨B (push b₀) (sym (push a)) + ∙ cong₂ _∙_ (cong (push tt ∙_) + (λ j i → inr (rCancel (merid b₀) j (~ i))) + ∙ sym (rUnit (push tt))) + (symDistr (push tt) (λ i → inr (σB a (~ i))))) + ◁ λ i j → hcomp (λ k → + λ { (i = i0) → compPath-filler' (push tt) + (compPath-filler (λ i → inr (σB a i)) + (sym (push tt)) k) k j + ; (i = i1) → inr (merid a j) + ; (j = i0) → push tt (i ∨ ~ k) + ; (j = i1) → compPath-filler' (push tt) + (λ i → inr (merid b₀ i)) k i}) + (inr (compPath-filler (merid a) + (sym (merid b₀)) (~ i) j)) + + rightInv Iso-A0□-⋁ (push a i) j = push tt (i ∧ j) + leftInv Iso-A0□-⋁ (inl x) = refl + leftInv Iso-A0□-⋁ (inr tt) = push b₀ + leftInv Iso-A0□-⋁ (push b i) j = help j i + where + help : PathP (λ i → inl north ≡ push b₀ i) + (cong A∨B→A0□ (cong A0□→A∨B (push b))) + (push b) + help = (cong-∙ A∨B→A0□ (push tt) (λ i → inr (σB b (~ i))) + ∙ (λ i → lUnit (sym (cong-∙ (A∨B→A0□ ∘ inr) + (merid b) (sym (merid b₀)) i)) (~ i)) + ∙ cong sym (cong ((push b₀ ∙ sym (push b)) ∙_) + (cong sym (rCancel (push b₀)))) + ∙ cong sym (sym (rUnit (push b₀ ∙ sym (push b))))) + ◁ λ i j → compPath-filler' (push b₀) (sym (push b)) (~ i) (~ j) + + Iso-A2□-join : Iso (A2□ whitehead3x3) (join A B) + fun Iso-A2□-join (inl x) = inr x + fun Iso-A2□-join (inr x) = inl x + fun Iso-A2□-join (push (a , b) i) = push a b (~ i) + inv Iso-A2□-join (inl x) = inr x + inv Iso-A2□-join (inr x) = inl x + inv Iso-A2□-join (push a b i) = push (a , b) (~ i) + rightInv Iso-A2□-join (inl x) = refl + rightInv Iso-A2□-join (inr x) = refl + rightInv Iso-A2□-join (push a b i) = refl + leftInv Iso-A2□-join (inl x) = refl + leftInv Iso-A2□-join (inr x) = refl + leftInv Iso-A2□-join (push a i) = refl + + isContrA4□ : isContr (A4□ whitehead3x3) + fst isContrA4□ = inr tt + snd isContrA4□ (inl x) = sym (push x) + snd isContrA4□ (inr x) = refl + snd isContrA4□ (push a i) j = push a (i ∨ ~ j) + + A4□≃Unit : A4□ whitehead3x3 ≃ Unit + A4□≃Unit = isContr→≃Unit isContrA4□ + + Iso-A□0-Susp : Iso (A□0 whitehead3x3) (Susp A) + fun Iso-A□0-Susp (inl x) = x + fun Iso-A□0-Susp (inr x) = north + fun Iso-A□0-Susp (push a i) = merid a₀ (~ i) + inv Iso-A□0-Susp x = inl x + rightInv Iso-A□0-Susp x = refl + leftInv Iso-A□0-Susp (inl x) = refl + leftInv Iso-A□0-Susp (inr x) = (λ i → inl (merid a₀ i)) ∙ push x + leftInv Iso-A□0-Susp (push a i) j = + hcomp (λ k → λ { (i = i0) → inl (merid a₀ (k ∨ j)) + ; (i = i1) → compPath-filler + (λ i₁ → inl (merid a₀ i₁)) + (push (idfun B a)) k j + ; (j = i0) → inl (merid a₀ (~ i ∧ k)) + ; (j = i1) → push a (i ∧ k)}) + (inl (merid a₀ j)) + + Iso-A□2-Susp× : Iso (A□2 whitehead3x3) (Susp A × B) + fun Iso-A□2-Susp× (inl x) = north , x + fun Iso-A□2-Susp× (inr x) = south , x + fun Iso-A□2-Susp× (push a i) = merid (fst a) i , (snd a) + inv Iso-A□2-Susp× (north , y) = inl y + inv Iso-A□2-Susp× (south , y) = inr y + inv Iso-A□2-Susp× (merid a i , y) = push (a , y) i + rightInv Iso-A□2-Susp× (north , snd₁) = refl + rightInv Iso-A□2-Susp× (south , snd₁) = refl + rightInv Iso-A□2-Susp× (merid a i , snd₁) = refl + leftInv Iso-A□2-Susp× (inl x) = refl + leftInv Iso-A□2-Susp× (inr x) = refl + leftInv Iso-A□2-Susp× (push a i) = refl + + Iso-A□4-Susp : Iso (A□4 whitehead3x3) (Susp A) + fun Iso-A□4-Susp (inl x) = north + fun Iso-A□4-Susp (inr x) = south + fun Iso-A□4-Susp (push a i) = merid a i + inv Iso-A□4-Susp north = inl tt + inv Iso-A□4-Susp south = inr tt + inv Iso-A□4-Susp (merid a i) = push a i + rightInv Iso-A□4-Susp north = refl + rightInv Iso-A□4-Susp south = refl + rightInv Iso-A□4-Susp (merid a i) = refl + leftInv Iso-A□4-Susp (inl x) = refl + leftInv Iso-A□4-Susp (inr x) = refl + leftInv Iso-A□4-Susp (push a i) = refl + + Iso-PushSusp×-Susp×Susp : + Iso (Pushout {A = Susp A × B} fst fst) (Susp A × Susp B) + Iso-PushSusp×-Susp×Susp = theIso + where + F : Pushout {A = Susp A × B} fst fst + → Susp A × Susp B + F (inl x) = x , north + F (inr x) = x , north + F (push (x , b) i) = x , σB b i + + G : Susp A × Susp B → Pushout {A = Susp A × B} fst fst + G (a , north) = inl a + G (a , south) = inr a + G (a , merid b i) = push (a , b) i + + retr : retract F G + retr (inl x) = refl + retr (inr x) = push (x , b₀) + retr (push (a , b) i) j = help j i + where + help : PathP (λ i → Path (Pushout fst fst) (inl a) (push (a , b₀) i)) + (cong G (λ i → a , σB b i)) + (push (a , b)) + help = cong-∙ (λ x → G (a , x)) (merid b) (sym (merid b₀)) + ◁ λ i j → compPath-filler + (push (a , b)) + (sym (push (a , b₀))) + (~ i) j + + theIso : Iso (Pushout fst fst) (Susp A × Susp B) + fun theIso = F + inv theIso = G + rightInv theIso (a , north) = refl + rightInv theIso (a , south) = ΣPathP (refl , merid b₀) + rightInv theIso (a , merid b i) j = + a , compPath-filler (merid b) (sym (merid b₀)) (~ j) i + leftInv theIso = retr + + Iso-A□○-PushSusp× : + Iso (A□○ whitehead3x3) (Pushout {A = Susp A × B} fst fst) + Iso-A□○-PushSusp× = + pushoutIso _ _ fst fst + (isoToEquiv Iso-A□2-Susp×) + (isoToEquiv Iso-A□0-Susp) + (isoToEquiv Iso-A□4-Susp) + (funExt (λ { (inl x) → refl + ; (inr x) → merid a₀ + ; (push a i) j → help₁ a j i})) + (funExt λ { (inl x) → refl + ; (inr x) → refl + ; (push a i) j + → fun Iso-A□4-Susp (rUnit (push (fst a)) (~ j) i)}) + where + help₁ : (a : A × B) + → PathP (λ i → north ≡ merid a₀ i) + (cong (fun Iso-A□0-Susp) + (cong (f□1 whitehead3x3) (push a))) + (merid (fst a)) + help₁ a = + (cong-∙∙ (fun Iso-A□0-Susp) + (λ i → inl (merid (fst a) i)) + (push (snd a)) + refl) + ◁ (λ i j → hcomp (λ k → λ {(i = i1) → merid (fst a) (j ∨ ~ k) + ; (j = i0) → merid (fst a) (~ k) + ; (j = i1) → merid a₀ i}) + (merid a₀ (i ∨ ~ j))) + + Iso-A□○-Susp×Susp : Iso (A□○ whitehead3x3) (Susp A × Susp B) + Iso-A□○-Susp×Susp = compIso Iso-A□○-PushSusp× Iso-PushSusp×-Susp×Susp + + Iso-A○□-cofibW : Iso (A○□ whitehead3x3) cofibW + Iso-A○□-cofibW = + pushoutIso _ _ + W (λ _ → tt) + (isoToEquiv Iso-A2□-join) (isoToEquiv Iso-A0□-⋁) + A4□≃Unit + (funExt lem) + λ _ _ → tt + where + lem : (x : A2□ whitehead3x3) + → A0□→A∨B (f1□ whitehead3x3 x) ≡ W (fun Iso-A2□-join x) + lem (inl x) = (λ i → inl (merid a₀ (~ i))) + lem (inr x) = refl + lem (push (a , b) i) j = help j i + where + help : PathP (λ i → Path (Pushout (λ _ → north) (λ _ → north)) + ((inl (merid a₀ (~ i)))) + (inr north)) + (cong A0□→A∨B (cong (f1□ whitehead3x3) (push (a , b)))) + (cong W (cong (fun Iso-A2□-join) (push (a , b)))) + help = (cong-∙∙ A0□→A∨B (λ i → inl (merid a (~ i))) (push b) refl + ∙ λ j → (λ i₂ → inl (merid a (~ i₂))) + ∙∙ compPath-filler (push tt) (λ i → inr (σB b (~ i))) (~ j) + ∙∙ λ i → inr (σB b (~ i ∧ j))) + ◁ (λ j → (λ i → inl (sym (compPath-filler + (merid a) (sym (merid a₀)) j) i)) + ∙∙ push tt + ∙∙ λ i → inr (σB b (~ i))) + + Iso₁-Susp×Susp-cofibW : Iso (Susp A × Susp B) cofibW + Iso₁-Susp×Susp-cofibW = + compIso (invIso Iso-A□○-Susp×Susp) + (compIso (3x3-Iso whitehead3x3) Iso-A○□-cofibW) + + -- Main iso + Iso-Susp×Susp-cofibJoinTo⋁ : Iso (Susp A × Susp B) cofibW + Iso-Susp×Susp-cofibJoinTo⋁ = + compIso (Σ-cong-iso-snd (λ _ → invSuspIso)) + Iso₁-Susp×Susp-cofibW + + -- The induced function A ∨ B → Susp A × Susp B satisfies + -- the following identity + Susp×Susp→cofibW≡ : Path (A∨B → Susp A × Susp B) + (Iso.inv Iso-Susp×Susp-cofibJoinTo⋁ ∘ inl) + ⋁↪ + Susp×Susp→cofibW≡ = + funExt λ { (inl x) → ΣPathP (refl , (sym (merid b₀))) + ; (inr north) → ΣPathP (refl , (sym (merid b₀))) + ; (inr south) → refl + ; (inr (merid a i)) j → lem₂ a j i + ; (push a i) j → north , (merid b₀ (~ j))} + where + f₁ = fun Iso-PushSusp×-Susp×Susp + f₂ = fun Iso-A□○-PushSusp× + f₃ = backward-l whitehead3x3 + f₄ = fun (Σ-cong-iso-snd (λ _ → invSuspIso)) + + lem : (b : B) + → cong (f₁ ∘ f₂ ∘ f₃) (push b) + ≡ (λ i → north , σB b i) + lem b = cong (cong f₁) (sym (rUnit (push (north , b)))) + + lem₂ : (a : B) + → PathP (λ i → (north , merid b₀ (~ i)) ≡ (north , south)) + (cong (f₄ ∘ f₁ ∘ f₂ ∘ f₃ ∘ A∨B→A0□ ∘ inr) (merid a)) + λ i → north , merid a i + lem₂ a = + cong (cong f₄) (cong-∙ (f₁ ∘ f₂ ∘ f₃) (push b₀) (sym (push a)) + ∙∙ cong₂ _∙_ (lem b₀ ∙ (λ j i → north , rCancel (merid b₀) j i)) + (cong sym (lem a)) + ∙∙ sym (lUnit (λ i₁ → north , σB a (~ i₁)))) + ∙ (λ i j → north , cong-∙ invSusp (merid a) (sym (merid b₀)) i (~ j) ) + ◁ λ i j → north , compPath-filler (sym (merid a)) (merid b₀) (~ i) (~ j) + +-- Generalised Whitehead products +module _ {ℓ ℓ' ℓ''} {A : Pointed ℓ} + {B : Pointed ℓ'} {C : Pointed ℓ''} + (f : Susp∙ (typ A) →∙ C) (g : Susp∙ (typ B) →∙ C) where + + _·w_ : join∙ A B →∙ C + fst _·w_ (inl x) = pt C + fst _·w_ (inr x) = pt C + fst _·w_ (push a b i) = (Ω→ g .fst (σ B b) ∙ Ω→ f .fst (σ A a)) i + snd _·w_ = refl + + -- The generalised Whitehead product vanishes under suspension + isConst-Susp·w : suspFun∙ (_·w_ .fst) ≡ const∙ _ _ + isConst-Susp·w = Susp·w∙ + ∙ cong suspFun∙ (cong fst isConst-const*) + ∙ ΣPathP ((suspFunConst (pt C)) , refl) + where + const* : join∙ A B →∙ C + fst const* (inl x) = pt C + fst const* (inr x) = pt C + fst const* (push a b i) = + (Ω→ f .fst (σ A a) ∙ Ω→ g .fst (σ B b)) i + snd const* = refl + + isConst-const* : const* ≡ const∙ _ _ + fst (isConst-const* i) (inl x) = Ω→ f .fst (σ A x) i + fst (isConst-const* i) (inr x) = Ω→ g .fst (σ B x) (~ i) + fst (isConst-const* i) (push a b j) = + compPath-filler'' (Ω→ f .fst (σ A a)) (Ω→ g .fst (σ B b)) (~ i) j + snd (isConst-const* i) j = + (cong (Ω→ f .fst) (rCancel (merid (pt A))) ∙ Ω→ f .snd) j i + + Susp·w : suspFun (fst _·w_) ≡ suspFun (fst const*) + Susp·w i north = north + Susp·w i south = south + Susp·w i (merid (inl x) j) = merid (pt C) j + Susp·w i (merid (inr x) j) = merid (pt C) j + Susp·w i (merid (push a b k) j) = + hcomp (λ r → + λ {(i = i0) → fill₁ k (~ r) j + ; (i = i1) → fill₂ k (~ r) j + ; (j = i0) → north + ; (j = i1) → merid (pt C) r + ; (k = i0) → compPath-filler (merid (snd C)) (merid (pt C) ⁻¹) (~ r) j + ; (k = i1) → compPath-filler (merid (snd C)) (merid (pt C) ⁻¹) (~ r) j}) + (hcomp (λ r → + λ {(i = i0) → doubleCompPath-filler + (sym (rCancel (merid (pt C)))) + (λ k → fill₁ k i1) + (rCancel (merid (pt C))) (~ r) k j + ; (i = i1) → doubleCompPath-filler + (sym (rCancel (merid (pt C)))) + (λ k → fill₂ k i1) + (rCancel (merid (pt C))) (~ r) k j + ; (j = i0) → north + ; (j = i1) → north + ; (k = i0) → rCancel (merid (pt C)) (~ r) j + ; (k = i1) → rCancel (merid (pt C)) (~ r) j}) + (main i k j)) + where + F : Ω C .fst → (Ω^ 2) (Susp∙ (fst C)) .fst + F p = sym (rCancel (merid (pt C))) + ∙∙ cong (σ C) p + ∙∙ rCancel (merid (pt C)) + + F-hom : (p q : _) → F (p ∙ q) ≡ F p ∙ F q + F-hom p q = + cong (sym (rCancel (merid (pt C))) + ∙∙_∙∙ rCancel (merid (pt C))) + (cong-∙ (σ C) p q) + ∙ doubleCompPath≡compPath (sym (rCancel (merid (pt C)))) _ _ + ∙ cong (sym (rCancel (merid (pt C))) ∙_) + (sym (assoc _ _ _)) + ∙ assoc _ _ _ + ∙ (λ i → (sym (rCancel (merid (pt C))) + ∙ compPath-filler (cong (σ C) p) (rCancel (merid (pt C))) i) + ∙ compPath-filler' (sym (rCancel (merid (pt C)))) + (cong (σ C) q ∙ rCancel (merid (pt C))) i) + ∙ cong₂ _∙_ (sym (doubleCompPath≡compPath _ _ _)) + (sym (doubleCompPath≡compPath _ _ _)) + + main : F ((Ω→ g .fst (σ B b) ∙ Ω→ f .fst (σ A a))) + ≡ F ((Ω→ f .fst (σ A a) ∙ Ω→ g .fst (σ B b))) + main = F-hom (Ω→ g .fst (σ B b)) (Ω→ f .fst (σ A a)) + ∙ EH 0 _ _ + ∙ sym (F-hom (Ω→ f .fst (σ A a)) (Ω→ g .fst (σ B b))) + + fill₁ : (k : I) → _ + fill₁ k = compPath-filler + (merid ((Ω→ g .fst (σ B b) + ∙ Ω→ f .fst (σ A a)) k)) + (merid (pt C) ⁻¹) + + fill₂ : (k : I) → _ + fill₂ k = compPath-filler + (merid ((Ω→ f .fst (σ A a) + ∙ Ω→ g .fst (σ B b)) k)) + (merid (pt C) ⁻¹) + + Susp·w∙ : suspFun∙ (_·w_ .fst) ≡ suspFun∙ (fst const*) + Susp·w∙ = ΣPathP (Susp·w , refl) \ No newline at end of file diff --git a/Cubical.Modalities.Instances.Closed.html b/Cubical.Modalities.Instances.Closed.html index a195d14dc..29071fae1 100644 --- a/Cubical.Modalities.Instances.Closed.html +++ b/Cubical.Modalities.Instances.Closed.html @@ -19,23 +19,23 @@ open Modality closedModality - Modality.◯ closedModality A = join ⟨ X ⟩ A - Modality.η closedModality = inr + Modality.◯ closedModality A = join ⟨ X ⟩ A + Modality.η closedModality = inr Modality.isModal closedModality A = ⟨ X ⟩ → isContr A Modality.isPropIsModal closedModality = isProp→ isPropIsContr Modality.◯-isModal closedModality {A = A} x = - subst (λ t → isContr (join t A)) (sym ⟨X⟩≡Unit*) joinAnnihilL + subst (λ t → isContr (join t A)) (sym ⟨X⟩≡Unit*) joinAnnihilL where ⟨X⟩≡Unit* : ⟨ X ⟩ ≡ Unit* ⟨X⟩≡Unit* = isContr→≡Unit* (inhProp→isContr x (snd X)) - Modality.◯-elim closedModality {B = B} B-modal f (inl x) = fst (B-modal (inl x) x) - Modality.◯-elim closedModality {B = B} B-modal f (inr a) = f a - Modality.◯-elim closedModality {B = B} B-modal f (push x a i) = - isProp→PathP (λ i → isContr→isProp (B-modal (push x a i) x)) - (B-modal (inl x) x .fst) (f a) i + Modality.◯-elim closedModality {B = B} B-modal f (inl x) = fst (B-modal (inl x) x) + Modality.◯-elim closedModality {B = B} B-modal f (inr a) = f a + Modality.◯-elim closedModality {B = B} B-modal f (push x a i) = + isProp→PathP (λ i → isContr→isProp (B-modal (push x a i) x)) + (B-modal (inl x) x .fst) (f a) i Modality.◯-elim-β closedModality {B = B} B-modal f a = refl diff --git a/Cubical.Papers.Everything.html b/Cubical.Papers.Everything.html index 2ddd4916d..5dd173d53 100644 --- a/Cubical.Papers.Everything.html +++ b/Cubical.Papers.Everything.html @@ -7,8 +7,9 @@ import Cubical.Papers.ComputationalSyntheticCohomology import Cubical.Papers.FunctorialQcQsSchemes import Cubical.Papers.Pi4S3 -import Cubical.Papers.RepresentationIndependence -import Cubical.Papers.SmashProducts -import Cubical.Papers.Synthetic -import Cubical.Papers.ZCohomology +import Cubical.Papers.Pi4S3-JournalVersion +import Cubical.Papers.RepresentationIndependence +import Cubical.Papers.SmashProducts +import Cubical.Papers.Synthetic +import Cubical.Papers.ZCohomology \ No newline at end of file diff --git a/Cubical.Papers.Pi4S3-JournalVersion.html b/Cubical.Papers.Pi4S3-JournalVersion.html new file mode 100644 index 000000000..20d13e316 --- /dev/null +++ b/Cubical.Papers.Pi4S3-JournalVersion.html @@ -0,0 +1,399 @@ + +Cubical.Papers.Pi4S3-JournalVersion
{-
+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:
+
+  Formalising and computing the fourth homotopy group of the 3-sphere in Cubical Agda
+-}
+
+-- The "--safe" flag ensures that there are no postulates or
+-- unfinished goals
+{-# OPTIONS --safe --cubical #-}
+
+module Cubical.Papers.Pi4S3-JournalVersion where
+
+-- Misc.
+open import Cubical.Foundations.Equiv
+open import Cubical.Foundations.Isomorphism
+open import Cubical.Foundations.Pointed
+open import Cubical.Foundations.HLevels
+
+open import Cubical.Data.Nat
+open import Cubical.Data.Nat.Order
+
+-- 2
+open import Cubical.Data.Bool as Boolean
+open import Cubical.Data.Unit as UnitType
+
+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.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.Foundations.Univalence                   as Univ
+open import Cubical.Homotopy.Loopspace                       as Loopy
+
+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.HITs.SmashProduct.Base                   as SmashProd
+open import Cubical.HITs.Sn.Multiplication                   as SMult
+open import Cubical.Homotopy.Group.Join                      as JoinGroup
+open import Cubical.Homotopy.Group.Pi4S3.DirectProof         as Direct
+
+
+------ 2. HOMOTOPY TYPE THEORY IN Cubical Agda ------
+
+--- 2.1 Elementary HoTT notions and Cubical Agda notations ---
+
+-- Booleans
+open Boolean using (Bool)
+
+-- Unit
+open UnitType renaming (Unit to 𝟙)
+
+-- S¹
+open Circle using (S¹)
+
+-- Non-dependent paths and refl
+open Prelude using (_≡_ ; refl)
+
+-- funExt, funExt⁻, cong
+open Prelude using (funExt; funExt⁻; cong)
+
+-- PathP
+open Prelude using (PathP)
+
+-- cirlce-indution
+open Circle using (elim)
+
+--- 2.2 More higher inductive types ---
+
+-- 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∨ = ⋁↪
+
+--- 2.3 Truncation levels and n-truncations  ---
+
+-- propositional and general truncation
+-- note that the indexing is off by 2!
+open PT using (∥_∥₁)
+open Trunc using (∥_∥_)
+
+--- 2.4 Univalence, loop spaces, and H-spaces ---
+
+-- Univalence, ua
+open Univ using (univalence ; ua)
+
+-- Loop spaces
+open Loopy using (Ω)
+
+-- H-spaces
+open H-Spaces using (HSpace)
+
+------ 3. First results on homotopy groups of spheres ------
+
+-- homotopy groups (function and loop space definition, respectively)
+-- Note that the indexing is off by 1.
+open HomotopyGroups using (π'Gr ; πGr)
+
+-- Proposition 3.2 - Long exact sequence of homotoy groups
+module ExactSeq = πLES
+
+-- σ (definition 3.3)
+open Suspensions renaming (toSusp to σ)
+
+-- Proposition 3.4: Sⁿ * Sᵐ ≃ Sⁿ⁺ᵐ⁺¹
+open Spheres using (IsoSphereJoin)
+
+-- Definition 3.5 and Proposition 3.6 (Hopf map),
+-- Phrased somewhat differently in the paper.
+open HopfMap using (HopfMap)
+open S¹Hopf using (IsoS³TotalHopf)
+
+-- Lemma 3.7 (connectedness of spheres)
+-- Note that the indexing is off by 2.
+open Spheres using (sphereConnected)
+
+-- Proposition 3.8 (πₙ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
+  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 3.9 (Freudenthal Suspension Theorem)
+open Freudenthal using (isConnectedσ) -- formalized by Evan Cavallo
+
+-- Corollary 3.10 (πₙSⁿ≅ℤ with identity as generator)
+open Stable using (πₙ'Sⁿ≅ℤ ; πₙ'Sⁿ≅ℤ-idfun∙)
+
+-- Proposition 3.11 and Corollary 3.12 (π₃S²≅ℤ with Hopf map as generator)
+open π₃S² using (π₃S²≅ℤ ; π₂S³-gen-by-HopfMap)
+
+------ 4. THE BRUNERIE NUMBER ------
+{- The formalisation of this part does not
+follow the paper exactly. For this reason, we only give
+the crucial results here -}
+
+--- 4.1 The James construction ---
+-- Expository section only. No formalisation following this part of
+-- the paper.
+
+--- 4.2 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 ----
+
+-- Definition 4.4: J₂S²
+open James₁ using (Pushout⋁↪fold⋁S₊2)
+
+-- S²-HIT
+open Sphere using (S²)
+
+-- Lemma 4.5
+-- Omitted (used implicitly)
+
+-- Lemma 4.6 (the family of automorphisms on ∥J₂S²∥₃
+open James₁ using (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅)
+
+-- Proposition 4.7: Ω ∥S³∥₄ ≃ ∥J₂S²∥₃
+open James₁ using (IsoΩ∥SuspS²∥₅∥Pushout⋁↪fold⋁S²∥₅)
+
+
+--- 4.3. Definition of the Brunerie number ---
+
+-- Definition 4.8: W + whitehead product
+W = joinTo⋁
+open Whitehead using ([_∣_]₂)
+
+-- Theorem 4.9 is omitted as it is used implicitly in the proof of the main result
+
+-- Theorem 4.10 Blakers-Massey
+open BM using (isConnected-toPullback) -- formalized primarily (in a different form) by Kang Rongji
+
+-- Definition 4.11: 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 4.12: π₄S³ ≅ ℤ/βℤ
+open BNumber using (BrunerieIso)
+
+
+------ 5. BRUNERIE'S PROOF THAT |β| ≡ 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"
+
+--- 5.1 Cohomology and the Hopf invariant ---
+
+-- 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 5.1 (cohomology of cofibers S³ → S²)
+open HI using (Hopfβ-Iso)
+
+-- Definition 5.2 (Hopf Invariant)
+open HI using (HopfInvariant-π')
+
+-- Proposition 5.3 (The Hopf invariant is a homomorphism)
+open HI-hom using (GroupHom-HopfInvariant-π')
+
+-- Proposition 5.4 (The Hopf invariant of the Brunerie element is ±2)
+open HI-β using (Brunerie'≡2)
+
+-- Lemma 5.5 -- only included for presentation, omitted from frmalization
+
+--- 5.1 The Gysin sequence ---
+
+-- Proposition 5.6 (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 5.7 : CP² fibration
+-- Indirect, but see in particular
+open HopfMap using (fibr)
+
+-- Proposition 5.8 : Iterated Hopf Construction.
+-- Indirect, but see in particular:
+open Hopf using (joinIso₂)
+
+-- Proposition 5.9 : ∣ HI hopf ∣ ≡ 1
+open HopfMap using (HopfInvariant-HopfMap)
+
+-- Theorem 5.10: π₄S³≅ℤ/2ℤ
+open π₄S³ using (π₄S³≃ℤ/2ℤ)
+
+--- Formalisation of the Gysin sequence. ---
+-- Lemma 5.11: (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)
+
+------ 6. THE SIMPLIFIED NEW PROOF AND NORMALISATION OF A BRUNERIE NUMBER ------
+
+--- 6.1. Interlude: joins and smash products of spheres ---
+
+-- Smash product (not defined as an implicit HIT)
+open SmashProd using (_⋀_)
+
+-- Lemmas 6.1 and 6.2
+-- Omitted (included for presentation purposes, not used explicitly in
+-- formalisation)
+
+-- Definition of pinch map
+open SmashProd renaming (Join→SuspSmash to pinch)
+
+-- Proposition 6.3 (pinch is an equivalence)
+open SmashProd using (SmashJoinIso)
+
+-- Definition of Fₙₘ
+open SMult renaming (join→Sphere to F)
+
+-- Proposition 6.4 (Fₙ,ₘ is an equivalence)
+open SMult using (IsoSphereJoin)
+
+-- Propositions 6.5 & 6.6 (graded commutativity and associativity)
+open SMult using (comm⌣S ; assoc⌣S)
+
+--- 6.2. Homotopy groups in terms of joins.
+
+-- Definition 6.7
+open JoinGroup using (π*)
+
+-- Addition +*
+open JoinGroup using (_+*_)
+
+-- Proposition 6.8
+open JoinGroup using (·Π≡+*)
+
+-- Proposition 6.9
+open JoinGroup using (π*Gr≅π'Gr)
+
+-- Proposition 6.10
+open JoinGroup using (π*∘∙Hom)
+
+--- 6.3. The new synthetic proof that π₄(S³) ≅ ℤ/2ℤ
+-- A relatively detailed accound of the proof is given in the formalisation:
+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η₃)
+
+--- 6.4. A stand-alone proof of Brunerie’s theorem?
+-- Theorem 6.18
+-- Not formalised explicitly
+
+-- Definition of generalised Whitehead products ·w
+open Whitehead using (_·w_)
+
+-- Proposition 6.22 (including Lemmas 19 and 20 and Proposition 6.21)
+open Whitehead using (isConst-Susp·w)
+
+-- Theorem 6.23
+-- Follows directly from above but not formalised explicitly (awaiting
+-- refactoring of some code in the library)
+
\ No newline at end of file diff --git a/Cubical.Papers.Pi4S3.html b/Cubical.Papers.Pi4S3.html index e7e7be973..657f73165 100644 --- a/Cubical.Papers.Pi4S3.html +++ b/Cubical.Papers.Pi4S3.html @@ -113,7 +113,7 @@ open Wedges using (_⋁_) -- joins -open Joins using (join) +open Joins using (join) -- cofibres open Pushouts using (cofib) @@ -149,7 +149,7 @@ -- Lemma 1 (connectedness of spheres) -- Note that the indexing is off by 2. -open Spheres using (sphereConnected) +open Spheres using (sphereConnected) -- Proposition 3 (πₙSᵐ vanishishing for n < m) isContr-πₙSᵐ-low : (n m : ℕ) → n < m → isContr (π n (S₊∙ m)) @@ -167,7 +167,7 @@ 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)) + (sphereConnected m)) h : π n (S₊∙ m) ≃ π' n (Unit , tt) h = compEquiv (isoToEquiv (πTruncIso n)) @@ -213,11 +213,11 @@ ---- C. Formalization of the James construction ---- -- Proposition 8: Sⁿ * Sᵐ ≃ Sⁿ⁺ᵐ⁺¹ -open Spheres using (IsoSphereJoin) +open Spheres using (IsoSphereJoin) -- Definition 6: W + whitehead product -W = joinTo⋁ -open Whitehead using ([_∣_]₂) +W = joinTo⋁ +open Whitehead using ([_∣_]₂) -- Theorem 3 is omitted as it is used implicitly in the proof of the main result diff --git a/Cubical.Papers.SmashProducts.html b/Cubical.Papers.SmashProducts.html index 57dea6840..ad3c106b3 100644 --- a/Cubical.Papers.SmashProducts.html +++ b/Cubical.Papers.SmashProducts.html @@ -49,29 +49,29 @@ -- library. E.g. the ⟨ x , y ⟩ constructor here is simply -- inr(x,y). Also note that pushₗ and pushᵣ are inverted with this -- definition.) -open Smash using (_⋀_) +open Smash using (_⋀_) -- Definition 6 (Functorial action of ⋀) -open Smash using (_⋀→_) +open Smash using (_⋀→_) -- Proposition 7 (Commutativity of ⋀) -- Postponed -- stated as part of Theorem 21 ---- 3 Associativity ---- -- Definition 8 (Double smash product) -open Smash using (⋀×2) +open Smash using (⋀×2) -- Equivalence between smash product and double smash -open Smash using (Iso-⋀-⋀×2) +open Smash using (Iso-⋀-⋀×2) -- Proposition 9 (Associativity of ⋀) -- Postponed -- stated as part of Theorem 21 ---- 4 The Heuristic ---- -- Lemma 10 (first induction principle for smash products) -open Smash using (⋀-fun≡) +open Smash using (⋀-fun≡) -- Definition 10 -open Smash using (⋀-fun≡) +open Smash using (⋀-fun≡) -- Definition 11 (version using ≡ instead of ≃⋆ is used here) open Hom using (isHomogeneous) @@ -80,16 +80,16 @@ open Hom using (→∙Homogeneous≡) -- Lemma 13 (Evan's trick for smash products) -open Smash using (⋀→∙Homogeneous≡) +open Smash using (⋀→∙Homogeneous≡) -- Lemma 14 (Evan's trick smash products, v2) -open Smash using (⋀→Homogeneous≡) +open Smash using (⋀→Homogeneous≡) -- Definition 15 -open Smash.⋀-fun≡' renaming (Fₗ to L ; Fᵣ to R) +open Smash.⋀-fun≡' renaming (Fₗ to L ; Fᵣ to R) -- Lemma 16 -open Smash.⋀-fun≡' using (main) +open Smash.⋀-fun≡' using (main) -- Lemmas 17/18 -- Omitted (used implicitly in formalisation) diff --git a/Cubical.Papers.Synthetic.html b/Cubical.Papers.Synthetic.html index f5302e367..9776b153e 100644 --- a/Cubical.Papers.Synthetic.html +++ b/Cubical.Papers.Synthetic.html @@ -130,9 +130,9 @@ -- 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 +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 @@ -199,7 +199,7 @@ 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 Join renaming (join to Join) using (S³≡joinS¹S¹) public open JoinProp using (join-assoc) public -------------------------------------------------------------------------------- diff --git a/Cubical.Papers.ZCohomology.html b/Cubical.Papers.ZCohomology.html index 6d5069054..83f23701a 100644 --- a/Cubical.Papers.ZCohomology.html +++ b/Cubical.Papers.ZCohomology.html @@ -190,10 +190,10 @@ open coHom using (K ; K∙) -- Proposition 7 -open S using (sphereConnected) +open S using (sphereConnected) -- Lemma 8 -open S using (wedgeconFun; wedgeconLeft ; wedgeconRight) +open S using (wedgeconFun; wedgeconLeft ; wedgeconRight) -- restated to match the formulation in the paper wedgeConSn' : ∀ {ℓ} (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ} @@ -206,18 +206,18 @@ × ((x : S₊ (suc m)) → fᵣ x ≡ F (ptSn (suc n)) x) ] p ≡ left (ptSn (suc n)) ∙ (right (ptSn (suc m))) ⁻¹) wedgeConSn' zero zero hlev fₗ fᵣ p = - (wedgeconFun 0 0 hlev fᵣ fₗ p) - , ((λ x → sym (wedgeconRight 0 0 hlev fᵣ fₗ p x)) + (wedgeconFun 0 0 hlev fᵣ fₗ p) + , ((λ x → sym (wedgeconRight 0 0 hlev fᵣ fₗ p x)) , λ _ → refl) -- right holds by refl , rUnit _ wedgeConSn' zero (suc m) hlev fₗ fᵣ p = - (wedgeconFun 0 (suc m) hlev fᵣ fₗ p) + (wedgeconFun 0 (suc m) hlev fᵣ fₗ p) , ((λ _ → refl) -- left holds by refl - , (λ x → sym (wedgeconLeft 0 (suc m) hlev fᵣ fₗ p x))) + , (λ x → sym (wedgeconLeft 0 (suc m) hlev fᵣ fₗ p x))) , lUnit _ wedgeConSn' (suc n) m hlev fₗ fᵣ p = - (wedgeconFun (suc n) m hlev fᵣ fₗ p) - , ((λ x → sym (wedgeconRight (suc n) m hlev fᵣ fₗ p x)) + (wedgeconFun (suc n) m hlev fᵣ fₗ p) + , ((λ x → sym (wedgeconRight (suc n) m hlev fᵣ fₗ p x)) , λ _ → refl) -- right holds by refl , rUnit _ diff --git a/Cubical.ZCohomology.GroupStructure.html b/Cubical.ZCohomology.GroupStructure.html index e66534703..e4468e2bf 100644 --- a/Cubical.ZCohomology.GroupStructure.html +++ b/Cubical.ZCohomology.GroupStructure.html @@ -60,7 +60,7 @@ → (x y : _) → comp1 x y ≡ comp2 x y +ₖ-unique n comp1 comp2 rUnit1 lUnit1 rUnit2 lUnit2 unId1 unId2 = T.elim2 (λ _ _ → isOfHLevelPath (3 + n) (isOfHLevelTrunc (3 + n)) _ _) - (wedgeconFun _ _ + (wedgeconFun _ _ (λ _ _ → help _ _) (λ x → lUnit1 ∣ x ∣ ∙ sym (lUnit2 ∣ x ∣)) (λ x → rUnit1 ∣ x ∣ ∙ sym (rUnit2 ∣ x ∣)) @@ -86,7 +86,7 @@ -- addition for n ≥ 2 together with the left- and right-unit laws (modulo truncations) preAdd : (n : ℕ) → (S₊ (2 + n) → S₊ (2 + n) → coHomK (2 + n)) preAdd n = - wedgeconFun _ _ + wedgeconFun _ _ (λ _ _ → wedgeConHLev n) ∣_∣ ∣_∣ @@ -97,7 +97,7 @@ preAdd-r : (n : ℕ) → (x : (S₊ (2 + n))) → preAdd n x north ≡ ∣ x ∣ preAdd-r n = - wedgeconRight _ (suc n) + wedgeconRight _ (suc n) (λ _ _ → wedgeConHLev n) ∣_∣ ∣_∣ @@ -200,14 +200,14 @@ commₖ zero = +Comm commₖ (suc zero) = T.elim2 (λ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) - (wedgeconFun _ _ + (wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 3 _ _) (λ {base → refl ; (loop i) → refl}) (λ {base → refl ; (loop i) → refl}) refl) commₖ (suc (suc n)) = T.elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (4 + n)) _ _) - (wedgeconFun _ _ + (wedgeconFun _ _ (λ x y → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev n) _ _) (λ x → preAdd-l n x ∙ sym (preAdd-r n x)) (λ x → preAdd-r n x ∙ sym (preAdd-l n x)) @@ -287,7 +287,7 @@ assocₖ zero = +Assoc assocₖ (suc zero) = T.elim3 (λ _ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) - λ x → wedgeconFun _ _ + λ x → wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 3 _ _) (λ y i → rUnitₖ 1 ∣ x ∣ (~ i) +ₖ ∣ y ∣) (λ z → cong (∣ x ∣ +ₖ_) (rUnitₖ 1 ∣ z ∣) ∙ sym (rUnitₖ 1 (∣ x ∣ +ₖ ∣ z ∣))) @@ -311,10 +311,10 @@ → (f (ptSn _) (ptSn _) ≡ g (ptSn _) (ptSn _)) → (x y z : S₊ (2 + n)) → ∣ x ∣ +ₖ (∣ y ∣ +ₖ ∣ z ∣) ≡ (∣ x ∣ +ₖ ∣ y ∣) +ₖ ∣ z ∣ wedgeConSn-×3 n f g d x = - wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev n) _ _) + wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev n) _ _) (f x) (g x) - (sphereElim _ {A = λ x → g x (ptSn (suc (suc n))) ≡ f x (ptSn (suc (suc n))) } + (sphereElim _ {A = λ x → g x (ptSn (suc (suc n))) ≡ f x (ptSn (suc (suc n))) } (λ _ → isOfHLevelTrunc (4 + n) _ _ _ _) (sym d) x) {- @@ -378,13 +378,13 @@ ∙ sym (cong₂ _+ℤ_ (sym (pos0+ _)) (sym (pos0+ _))) -distrₖ (suc zero) = T.elim2 (λ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) - (wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 3 _ _) + (wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 3 _ _) (λ x → sym (lUnitₖ 1 (-[ 1 ]ₖ ∣ x ∣))) (λ x → cong (λ x → -[ 1 ]ₖ x) (rUnitₖ 1 ∣ x ∣) ∙ sym (rUnitₖ 1 (-[ 1 ]ₖ ∣ x ∣))) (sym (rUnit refl))) -distrₖ (suc (suc n)) = T.elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (4 + n)) _ _) - (wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev n) _ _) + (wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev n) _ _) (λ x → sym (lUnitₖ (2 + n) (-[ (2 + n) ]ₖ ∣ x ∣))) (λ x → cong (λ x → -[ (2 + n) ]ₖ x) (rUnitₖ (2 + n) ∣ x ∣ ) ∙ sym (rUnitₖ (2 + n) (-[ (2 + n) ]ₖ ∣ x ∣))) (sym (rUnit refl))) @@ -395,13 +395,13 @@ ∙∙ cong (y +ℤ_) (minusPlus x (pos 0)) -cancelRₖ (suc zero) = T.elim2 (λ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) - (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath 0 _ _) + (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath 0 _ _) (λ x → cong (_+ₖ ∣ base ∣) (rUnitₖ 1 ∣ x ∣) ∙ rUnitₖ 1 ∣ x ∣) (λ x → rCancelₖ 1 ∣ x ∣) (rUnit refl)) -cancelRₖ (suc (suc n)) = T.elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (4 + n)) _ _) - (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath (suc n) _ _) + (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath (suc n) _ _) (λ x → cong (_+ₖ ∣ north ∣) (rUnitₖ (2 + n) ∣ x ∣) ∙ rUnitₖ (2 + n) ∣ x ∣) (λ x → rCancelₖ (2 + n) ∣ x ∣) (sym (rUnit _))) @@ -413,13 +413,13 @@ -+cancelₖ zero x y = sym (+Assoc x (0 - y) y) ∙ cong (x +ℤ_) (minusPlus y (pos 0)) -+cancelₖ (suc zero) = T.elim2 (λ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) - (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath 0 _ _) + (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath 0 _ _) (λ x → cong (_+ₖ ∣ x ∣) (lUnitₖ 1 (-ₖ ∣ x ∣)) ∙ lCancelₖ 1 ∣ x ∣) (λ x → cong (_+ₖ ∣ base ∣) (rUnitₖ 1 ∣ x ∣) ∙ rUnitₖ 1 ∣ x ∣) refl) -+cancelₖ (suc (suc n)) = T.elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (4 + n)) _ _) - (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath (suc n) _ _) + (wedgeconFun _ _ (λ _ _ → wedgeConHLevPath (suc n) _ _) (λ x → cong (_+ₖ ∣ x ∣) (lUnitₖ (2 + n) (-ₖ ∣ x ∣)) ∙ lCancelₖ (2 + n) ∣ x ∣) (λ x → cong (_+ₖ ∣ north ∣) (rUnitₖ (2 + n) ∣ x ∣) ∙ rUnitₖ (2 + n) ∣ x ∣) refl) @@ -752,7 +752,7 @@ ∙∙ sym (rUnit _) ∙∙ λ k i → lUnitₖ _ (p i) k ind-helper (suc n) = - sphereElim (suc n) (λ _ → isOfHLevelΠ (2 + n) λ _ → isOfHLevelTrunc (4 + n) _ _ _ _) + sphereElim (suc n) (λ _ → isOfHLevelΠ (2 + n) λ _ → isOfHLevelTrunc (4 + n) _ _ _ _) λ p → cong (f (suc n) (0ₖ (2 + n))) ((λ k → (sym (rUnit (refl ∙ refl)) ∙ sym (rUnit refl)) k ∙∙ (λ i → p i +ₖ 0ₖ (2 + n)) ∙∙ (sym (rUnit (refl ∙ refl)) ∙ sym (rUnit refl)) k) @@ -771,7 +771,7 @@ λ p → cong (g zero (0ₖ 1)) (λ k → rUnit (λ i → lUnitₖ _ (p i) k) (~ k)) ∙ (λ k → rUnit (λ i → rUnitₖ _ (p i) k) (~ k)) ind-helper (suc n) = - sphereElim (suc n) (λ _ → isOfHLevelΠ (2 + n) λ _ → isOfHLevelTrunc (4 + n) _ _ _ _) + sphereElim (suc n) (λ _ → isOfHLevelΠ (2 + n) λ _ → isOfHLevelTrunc (4 + n) _ _ _ _) λ p → cong (g (suc n) (0ₖ (2 + n))) (λ k → rUnit (λ i → lUnitₖ _ (p i) k) (~ k)) ∙∙ (λ k → (sym (rUnit (refl ∙ refl)) ∙ sym (rUnit refl)) k diff --git a/Cubical.ZCohomology.Groups.CP2.html b/Cubical.ZCohomology.Groups.CP2.html index 110877a6e..5f311ea3d 100644 --- a/Cubical.ZCohomology.Groups.CP2.html +++ b/Cubical.ZCohomology.Groups.CP2.html @@ -74,7 +74,7 @@ H⁰CP²≅ℤ = H⁰-connected (inr tt) (Pushout.elimProp _ (λ _ → squash₁) - (sphereElim _ (λ _ → isOfHLevelSuc 1 squash₁) + (sphereElim _ (λ _ → isOfHLevelSuc 1 squash₁) ∣ sym (push (north , base)) ∣₁) λ _ → ∣ refl ∣₁) @@ -157,7 +157,7 @@ transport (λ i → (B : isoToPath IsoS³TotalHopf i → Type) → ((x : _) → isOfHLevel 3 (B x)) → B (transp (λ j → isoToPath IsoS³TotalHopf (i ∨ ~ j)) i (north , base)) → (x : _) → B x) - λ B hLev elim-TotalHopf → sphereElim _ (λ _ → hLev _) elim-TotalHopf + λ B hLev elim-TotalHopf → sphereElim _ (λ _ → hLev _) elim-TotalHopf H¹-CP²≅0 : GroupIso (coHomGr 1 CP²) UnitGroup₀ H¹-CP²≅0 = @@ -265,7 +265,7 @@ CP²≡CP2 : Iso CP² CP2 CP²≡CP2 = compIso (equivToIso (symPushout fst (λ _ → tt))) (invIso CP²-iso) where - module m = Hopf S1-AssocHSpace (sphereElim2 0 (λ _ _ → squash₁) ∣ (λ _ → base) ∣₁) + module m = Hopf S1-AssocHSpace (sphereElim2 0 (λ _ _ → squash₁) ∣ (λ _ → base) ∣₁) F : (x : S₊ 2) → (m.Hopf x) → (HopfSuspS¹ (fun idIso x)) F north y = y F south y = y @@ -274,7 +274,7 @@ lem : transport (λ i → m.Hopf (merid x i) → Glue S¹ (Border x i)) (λ x → x) ≡ λ x → x - lem = funExt λ z → commS¹ x (invEq (m.μ-eq x) z) ∙ secEq (m.μ-eq x) z + lem = funExt λ z → commS¹ x (invEq (m.μ-eq x) z) ∙ secEq (m.μ-eq x) z F-eq : (x : S₊ 2) → isEquiv (F x) F-eq = suspToPropElim base (λ _ → isPropIsEquiv _) (idIsEquiv _) diff --git a/Cubical.ZCohomology.Groups.KleinBottle.html b/Cubical.ZCohomology.Groups.KleinBottle.html index d45b7e408..9784e1158 100644 --- a/Cubical.ZCohomology.Groups.KleinBottle.html +++ b/Cubical.ZCohomology.Groups.KleinBottle.html @@ -218,7 +218,7 @@ fun Iso-H²-𝕂²₁ = ST.rec isSetSetTrunc (uncurry (T.elim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 2} 2 isSetSetTrunc) - (sphereElim _ (λ _ → isSetΠ λ _ → isSetSetTrunc) + (sphereElim _ (λ _ → isSetΠ λ _ → isSetSetTrunc) λ y → ∣ fst y , snd (snd y) ∣₂))) inv Iso-H²-𝕂²₁ = ST.map λ p → (0ₖ 2) , ((fst p) , (refl , (snd p))) @@ -228,7 +228,7 @@ leftInv Iso-H²-𝕂²₁ = ST.elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) (uncurry (T.elim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 1} 3 (isSetSetTrunc _ _)) - (sphereToPropElim _ + (sphereToPropElim _ (λ _ → isPropΠ λ _ → isSetSetTrunc _ _) λ {(p , (q , sq)) → T.rec (isSetSetTrunc _ _) @@ -303,7 +303,7 @@ *' : (x y : coHomK 1) (p : x +ₖ x ≡ 0ₖ 1) (q : y +ₖ y ≡ 0ₖ 1) → ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂ *' = T.elim2 (λ _ _ → isGroupoidΠ2 λ _ _ → isOfHLevelSuc 2 isSetSetTrunc) - (wedgeconFun _ _ + (wedgeconFun _ _ (λ _ _ → isSetΠ2 λ _ _ → isSetSetTrunc) (λ x p q → ∣ ∣ x ∣ , cong₂ _+ₖ_ p q ∣₂) (λ y p q → ∣ ∣ y ∣ , sym (rUnitₖ 1 (∣ y ∣ +ₖ ∣ y ∣)) ∙ cong₂ _+ₖ_ p q ∣₂) @@ -428,7 +428,7 @@ ∣ 0ₖ _ , refl , refl , sym (rUnit refl) ∣₂ helper = T.elim (λ _ → isProp→isOfHLevelSuc (4 + n) (isPropΠ4 λ _ _ _ _ → isPropΠ λ _ → isSetSetTrunc _ _)) - (sphereToPropElim _ (λ _ → isPropΠ4 λ _ _ _ _ → isPropΠ λ _ → isSetSetTrunc _ _) + (sphereToPropElim _ (λ _ → isPropΠ4 λ _ _ _ _ → isPropΠ λ _ → isSetSetTrunc _ _) λ p → J (λ p _ → (q : 0ₖ _ ≡ 0ₖ _) → (refl ≡ q) → (P : p ∙∙ q ∙∙ p ≡ q) → Path ∥ (Σ[ x ∈ coHomK (3 + n) ] Σ[ p ∈ x ≡ x ] Σ[ q ∈ x ≡ x ] p ∙∙ q ∙∙ p ≡ q) ∥₂ diff --git a/Cubical.ZCohomology.Groups.RP2.html b/Cubical.ZCohomology.Groups.RP2.html index 423e94a87..df00f941b 100644 --- a/Cubical.ZCohomology.Groups.RP2.html +++ b/Cubical.ZCohomology.Groups.RP2.html @@ -115,7 +115,7 @@ ST.rec isSetSetTrunc (uncurry (T.elim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 2} 2 isSetSetTrunc) - (sphereElim _ (λ _ → isSetΠ (λ _ → isSetSetTrunc)) + (sphereElim _ (λ _ → isSetΠ (λ _ → isSetSetTrunc)) λ p → ∣ fst p , snd p ∣₂))) Iso.inv Iso-H²-RP²₁ = ST.map λ p → (0ₖ 2) , p Iso.rightInv Iso-H²-RP²₁ = ST.elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) @@ -123,7 +123,7 @@ Iso.leftInv Iso-H²-RP²₁ = ST.elim (λ _ → isOfHLevelPath 2 isSetSetTrunc _ _) (uncurry (T.elim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 1} 3 (isSetSetTrunc _ _)) - (sphereToPropElim _ (λ _ → isPropΠ (λ _ → isSetSetTrunc _ _)) + (sphereToPropElim _ (λ _ → isPropΠ (λ _ → isSetSetTrunc _ _)) λ p → refl))) Iso-H²-RP²₂ : Iso ∥ Σ[ p ∈ 0ₖ 2 ≡ 0ₖ 2 ] p ≡ sym p ∥₂ Bool diff --git a/Cubical.ZCohomology.Groups.Sn.html b/Cubical.ZCohomology.Groups.Sn.html index 6c00330fa..145779e4e 100644 --- a/Cubical.ZCohomology.Groups.Sn.html +++ b/Cubical.ZCohomology.Groups.Sn.html @@ -126,7 +126,7 @@ S1Iso : Iso S¹ (Pushout {A = Bool} (λ _ → tt) λ _ → tt) -S1Iso = S¹IsoSuspBool ⋄ invIso PushoutSuspIsoSusp +S1Iso = S¹IsoSuspBool ⋄ invIso PushoutSuspIsoSusp coHomPushout≅coHomSn : (n m : ℕ) → GroupIso (coHomGr m (S₊ (suc n))) (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt)) @@ -213,7 +213,7 @@ where helper4 : isConnected (n + 3) (hLevelTrunc (4 + n) (S₊ (2 + n))) helper4 = subst (λ m → isConnected m (hLevelTrunc (4 + n) (S₊ (2 + n)))) (+-comm 3 n) - (isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (3 + n) 1)) (sphereConnected (2 + n))) + (isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (3 + n) 1)) (sphereConnected (2 + n))) helper3 : isContr ∥ ∣ north ∣ ≡ ∣ north ∣ ∥₂ helper3 = isOfHLevelRetractFromIso 0 setTruncTrunc2Iso diff --git a/Cubical.ZCohomology.Groups.Unit.html b/Cubical.ZCohomology.Groups.Unit.html index f2dcf83a5..e0f46b292 100644 --- a/Cubical.ZCohomology.Groups.Unit.html +++ b/Cubical.ZCohomology.Groups.Unit.html @@ -51,7 +51,7 @@ ∙∙ sym propTrunc≡Trunc2 ∙∙ λ i → ∥ hLevelTrunc (suc (+-comm n 2 i)) (S₊ (1 + n)) ∥₂) (isConnectedSubtr 2 (helper2 n .fst) - (subst (λ x → isConnected x (S₊ (suc n))) (sym (helper2 n .snd)) (sphereConnected (suc n))) ) + (subst (λ x → isConnected x (S₊ (suc n))) (sym (helper2 n .snd)) (sphereConnected (suc n))) ) where helper2 : (n : ℕ) → Σ[ m ∈ ℕ ] m + 2 ≡ 2 + n helper2 zero = 0 , refl diff --git a/Cubical.ZCohomology.Groups.Wedge.html b/Cubical.ZCohomology.Groups.Wedge.html index 2b2fecd6d..18d6ebf98 100644 --- a/Cubical.ZCohomology.Groups.Wedge.html +++ b/Cubical.ZCohomology.Groups.Wedge.html @@ -138,7 +138,7 @@ → ∥ f ≡ wedgeFun⁻ 0 (λ x → f (inl x)) (λ x → f (inr x)) ∥₁ helper f = T.elim (λ _ → isProp→isOfHLevelSuc 2 (isPropΠ λ _ → isPropPropTrunc)) - (sphereElim 0 (λ _ → isPropΠ λ _ → isPropPropTrunc) + (sphereElim 0 (λ _ → isPropΠ λ _ → isPropPropTrunc) λ inlId → ∣ funExt (λ { (inl x) → sym (rUnitₖ 1 (f (inl x))) ∙∙ cong ((f (inl x)) +ₖ_) (sym inlId) ∙∙ cong ((f (inl x)) +ₖ_) (cong f (push tt)) @@ -186,7 +186,7 @@ → ∥ f ≡ wedgeFun⁻ (suc n) (λ x → f (inl x)) (λ x → f (inr x)) ∥₁ helper f = T.elim (λ _ → isProp→isOfHLevelSuc (3 + n) (isPropΠ λ _ → isPropPropTrunc)) - (sphereToPropElim (suc n) (λ _ → isPropΠ λ _ → isPropPropTrunc) + (sphereToPropElim (suc n) (λ _ → isPropΠ λ _ → isPropPropTrunc) λ inlId → (∣ funExt (λ { (inl x) → sym (rUnitₖ (2 + n) (f (inl x))) ∙∙ cong ((f (inl x)) +ₖ_) (sym inlId) ∙∙ cong ((f (inl x)) +ₖ_) (cong f (push tt)) diff --git a/Cubical.ZCohomology.Properties.html b/Cubical.ZCohomology.Properties.html index 873124f29..1de2857fb 100644 --- a/Cubical.ZCohomology.Properties.html +++ b/Cubical.ZCohomology.Properties.html @@ -70,13 +70,13 @@ (suspToPropElim (ptSn (suc n)) (λ _ → isOfHLevelTrunc 2 _ _) refl)) isConnectedKn : (n : ℕ) → isConnected (2 + n) (coHomK (suc n)) -isConnectedKn n = isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (2 + n) 1)) (sphereConnected (suc n)) +isConnectedKn n = isOfHLevelRetractFromIso 0 (invIso (truncOfTruncIso (2 + n) 1)) (sphereConnected (suc n)) -- direct proof of connectedness of ΩKₙ₊₁ not relying on the equivalence ∥ a ≡ b ∥ₙ ≃ (∣ a ∣ₙ₊₁ ≡ ∣ b ∣ₙ₊₁) isConnectedPathKn : (n : ℕ) (x y : (coHomK (suc n))) → isConnected (suc n) (x ≡ y) isConnectedPathKn n = T.elim (λ _ → isProp→isOfHLevelSuc (2 + n) (isPropΠ λ _ → isPropIsContr)) - (sphereElim _ (λ _ → isProp→isOfHLevelSuc n (isPropΠ λ _ → isPropIsContr)) + (sphereElim _ (λ _ → isProp→isOfHLevelSuc n (isPropΠ λ _ → isPropIsContr)) λ y → isContrRetractOfConstFun {B = (hLevelTrunc (suc n) (ptSn (suc n) ≡ ptSn (suc n)))} ∣ refl ∣ (fun⁻ n y @@ -88,7 +88,7 @@ → hLevelTrunc (suc n) (∣ ptSn (suc n) ∣ ≡ y) fun⁻ n = T.elim (λ _ → isOfHLevelΠ (3 + n) λ _ → isOfHLevelSuc (2 + n) (isOfHLevelSuc (suc n) (isOfHLevelTrunc (suc n)))) - (sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) λ _ → ∣ refl ∣) + (sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → isOfHLevelTrunc (suc n)) λ _ → ∣ refl ∣) fun⁻Id : (n : ℕ) → fun⁻ n ∣ ptSn (suc n) ∣ ≡ λ _ → ∣ refl ∣ fun⁻Id zero = refl @@ -161,7 +161,7 @@ → (x : _) → B x coHomK-elim n {B = B } hlev b = T.elim (λ _ → isOfHLevelPlus {n = (suc n)} 2 (hlev _)) - (sphereElim _ (hlev ∘ ∣_∣) b) + (sphereElim _ (hlev ∘ ∣_∣) b) {- Equivalence between cohomology of A and reduced cohomology of (A + 1) -} coHomRed+1Equiv : (n : ℕ) → @@ -278,7 +278,7 @@ σ-hom : {n : ℕ} (x y : coHomK (suc n)) → σ (x +ₖ y) ≡ σ x ∙ σ y σ-hom {n = zero} = T.elim2 (λ _ _ → isOfHLevelPath 3 (isOfHLevelTrunc 4 _ _) _ _) - (wedgeconFun _ _ + (wedgeconFun _ _ (λ _ _ → isOfHLevelTrunc 4 _ _ _ _) (λ x → lUnit _ ∙ cong (_∙ σ ∣ x ∣) (cong (cong ∣_∣) (sym (rCancel (merid base))))) @@ -288,7 +288,7 @@ (sym (σ-hom-helper (σ ∣ base ∣) (cong (cong ∣_∣) (sym (rCancel (merid base))))))) σ-hom {n = suc n} = T.elim2 (λ _ _ → isOfHLevelPath (4 + n) (isOfHLevelTrunc (5 + n) _ _) _ _) - (wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev' n) _ _) + (wedgeconFun _ _ (λ _ _ → isOfHLevelPath ((2 + n) + (2 + n)) (wedgeConHLev' n) _ _) (λ x → lUnit _ ∙ cong (_∙ σ ∣ x ∣) (cong (cong ∣_∣) (sym (rCancel (merid north))))) (λ y → cong σ (rUnitₖ (2 + n) ∣ y ∣) @@ -379,7 +379,7 @@ hLevCode : {n : ℕ} (x : coHomK (2 + n)) → isOfHLevel (3 + n) (Code n x) hLevCode {n = n} = T.elim (λ _ → isProp→isOfHLevelSuc (3 + n) (isPropIsOfHLevel (3 + n))) - (sphereToPropElim _ + (sphereToPropElim _ (λ _ → (isPropIsOfHLevel (3 + n))) (isOfHLevelTrunc (3 + n))) Code-add' : {n : ℕ} (x : _) → Code n ∣ north ∣ → Code n ∣ x ∣ → Code n ∣ x ∣ @@ -554,7 +554,7 @@ fst (snd (isContr-↓∙ (suc n)) f i) x = T.elim {B = λ x → 0ₖ (suc n) ≡ fst f x} (λ _ → isOfHLevelPath (4 + n) (isOfHLevelSuc (3 + n) (isOfHLevelTrunc (3 + n))) _ _) - (sphereElim _ (λ _ → isOfHLevelTrunc (3 + n) _ _) + (sphereElim _ (λ _ → isOfHLevelTrunc (3 + n) _ _) (sym (snd f))) x i snd (snd (isContr-↓∙ (suc n)) f i) j = snd f (~ i ∨ j) @@ -565,7 +565,7 @@ (funExt (toPropElim (λ _ → isSetℤ _ _) (sym p))) fst (isContr-↓∙' (suc n)) = (λ _ → 0ₖ _) , refl fst (snd (isContr-↓∙' (suc n)) f i) x = - sphereElim _ {A = λ x → 0ₖ (suc n) ≡ fst f x} + sphereElim _ {A = λ x → 0ₖ (suc n) ≡ fst f x} (λ _ → isOfHLevelTrunc (3 + n) _ _) (sym (snd f)) x i snd (snd (isContr-↓∙' (suc n)) f i) j = snd f (~ i ∨ j) @@ -616,7 +616,7 @@ T.elim (λ _ → isOfHLevelPath (3 + n) (subst (λ x → isOfHLevel x (coHomK-ptd (suc m) →∙ coHomK-ptd (suc (n + m)))) (λ i → suc (suc (+-comm n 1 i))) (isOfHLevelPlus' {n = 1} (2 + n) (isOfHLevel↑∙ n m))) _ _) - (sphereElim _ (λ _ → isOfHLevel↑∙ n m _ _) p) + (sphereElim _ (λ _ → isOfHLevel↑∙ n m _ _) p) isOfHLevel↑∙∙ : ∀ n m l → isOfHLevel (2 + l) (coHomK-ptd (suc n) diff --git a/Cubical.ZCohomology.RingStructure.RingLaws.html b/Cubical.ZCohomology.RingStructure.RingLaws.html index 95a3bc66e..021376a50 100644 --- a/Cubical.ZCohomology.RingStructure.RingLaws.html +++ b/Cubical.ZCohomology.RingStructure.RingLaws.html @@ -146,7 +146,7 @@ ⌣ₖ-distrFun (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ ≡ ⌣ₖ-distrFun2 (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ main = - wedgeconFun n n + wedgeconFun n n (λ x y → subst (λ l → isOfHLevel l ((⌣ₖ-distrFun (suc n) (suc m) ∣ x ∣ ∣ y ∣) ≡ ⌣ₖ-distrFun2 (suc n) (suc m) ∣ x ∣ ∣ y ∣)) (+-suc n (suc n)) @@ -261,7 +261,7 @@ ⌣ₖ-distrFun-r (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ ≡ ⌣ₖ-distrFun2-r (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ main = - wedgeconFun n n + wedgeconFun n n (λ x y → subst (λ l → isOfHLevel l ((⌣ₖ-distrFun-r (suc n) (suc m) ∣ x ∣ ∣ y ∣) ≡ ⌣ₖ-distrFun2-r (suc n) (suc m) ∣ x ∣ ∣ y ∣)) (+-suc n (suc n))