{-# OPTIONS --safe --lossy-unification #-}
module Cubical.Homotopy.Group.Pi4S3.DirectProof where
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.Pointed.Homogeneous
open import Cubical.Foundations.Path
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Group.Base
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.Connected
open import Cubical.Homotopy.HopfInvariant.HopfMap using (hopfMap≡HopfMap')
open import Cubical.Homotopy.Group.Pi4S3.BrunerieNumber
using (fold∘W ; coFib-fold∘W∙ ; π₄S³≅π₃coFib-fold∘W∙ ; S³→S²→Pushout→Unit)
open import Cubical.Homotopy.Group.Pi4S3.BrunerieExperiments
using (K₂ ; f7' ; S¹∙ ; encodeTruncS²)
open import Cubical.Homotopy.Group.Join
open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.Int
renaming (ℤ to Z ; _·_ to _·Z_ ; _+_ to _+Z_)
open import Cubical.HITs.S1 as S1 renaming (_·_ to _*_)
open import Cubical.HITs.S2 renaming (S¹×S¹→S² to S¹×S¹→S²')
open import Cubical.HITs.Sn
open import Cubical.HITs.Sn.Multiplication
open import Cubical.HITs.Susp renaming (toSusp to σ)
open import Cubical.HITs.Join hiding (joinS¹S¹→S³)
open import Cubical.HITs.Wedge
open import Cubical.HITs.Pushout
open import Cubical.HITs.SetTruncation
renaming (rec2 to sRec2 ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.Truncation as Trunc renaming (rec to trRec)
open import Cubical.HITs.PropositionalTruncation as PropTrunc
open import Cubical.HITs.GroupoidTruncation as GroupoidTrunc
open import Cubical.HITs.2GroupoidTruncation as 2GroupoidTrunc
open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Exact
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Instances.IntMod
open import Cubical.Algebra.Group.GroupPath
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure
open S¹Hopf
open Iso
open GroupStr
private
variable
ℓ : Level
A B : Pointed ℓ
private
σ₁ = σ (S₊∙ 1)
σ₂ = σ (S₊∙ 2)
σ-filler : ∀ {ℓ} {A : Type ℓ} (x y : A) (i j : I) → Susp A
σ-filler x y i j = compPath-filler (merid x) (sym (merid y)) i j
to3ConnectedId : {f g : A →∙ B}
→ (isConnected 3 (typ B)) → fst f ≡ fst g → ∣ f ∣₂ ≡ ∣ g ∣₂
to3ConnectedId {f = f} {g = g} con p =
trRec (squash₂ _ _)
(λ q → cong ∣_∣₂ (ΣPathP (p , q)))
(fst (isConnectedPathP 1 (isConnectedPath 2 con _ _) (snd f) (snd g)))
connS³ : isConnected 3 (S₊ 3)
connS³ =
isConnectedSubtr 3 1 (sphereConnected 3)
con-joinS¹S¹ : isConnected 3 (join S¹ S¹)
con-joinS¹S¹ =
(isConnectedRetractFromIso 3
(IsoSphereJoin 1 1)
(isConnectedSubtr 3 1 (sphereConnected 3)))
joinS¹S¹→S³ = join→Sphere 1 1
S¹×S¹→S² : S¹ → S¹ → S₊ 2
S¹×S¹→S² = _⌣S_
η : π' 3 (S₊∙ 2)
η = fst (π'∘∙Hom 2 (fold∘W , refl)) ∣ id∙ (S₊∙ 3) ∣₂
π₃S² = π'Gr 2 (S₊∙ 2)
π₃*S² = π*Gr 1 1 (S₊∙ 2)
π₃*joinS¹S¹ = π*Gr 1 1 (join∙ (S₊∙ 1) (S₊∙ 1))
π₃*S³ = π*Gr 1 1 (S₊∙ 3)
π₃S³ = π'Gr 2 (S₊∙ 3)
π₃≅π₃* : {A : Pointed₀} → GroupEquiv (π'Gr 2 A) (π*Gr 1 1 A)
π₃≅π₃* {A = A} = invGroupEquiv (GroupIso→GroupEquiv (π*Gr≅π'Gr 1 1 A))
η₁-raw : join∙ S¹∙ S¹∙ →∙ 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¹∙ →∙ join∙ S¹∙ S¹∙
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¹∙ →∙ 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
η₁ : fst π₃*S²
η₁ = ∣ η₁-raw ∣₂
η₂ : fst (π₃*joinS¹S¹)
η₂ = ∣ η₂-raw ∣₂
η₃ : π₃*S³ .fst
η₃ = ∣ η₃-raw ∣₂
η₄ : fst π₃S³
η₄ = ·π' 2 (-π' 2 ∣ idfun∙ (S₊∙ 3) ∣₂) (-π' 2 ∣ idfun∙ (S₊∙ 3) ∣₂)
π₃S²→π₃*S² : GroupEquiv π₃S² π₃*S²
π₃S²→π₃*S² = GroupIso→GroupEquiv (invGroupIso (π*Gr≅π'Gr 1 1 (S₊∙ 2)))
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² = π*∘∙Hom 1 1 (Hopfσ , refl)
π₃*joinS¹S¹≅π₃*S² : GroupEquiv π₃*joinS¹S¹ π₃*S²
fst (fst π₃*joinS¹S¹≅π₃*S²) = fst π₃*joinS¹S¹→π₃*S²
snd (fst π₃*joinS¹S¹≅π₃*S²) =
subst isEquiv idLem isEquivπ₃*joinS¹S¹→π₃*S²'
where
π₃*joinS¹S¹→π₃*S²' : GroupHom π₃*joinS¹S¹ π₃*S²
π₃*joinS¹S¹→π₃*S²' =
π*∘∙Hom 1 1 (fst ∘ JoinS¹S¹→TotalHopf , refl)
isEquivπ₃*joinS¹S¹→π₃*S²' : isEquiv (fst π₃*joinS¹S¹→π₃*S²')
isEquivπ₃*joinS¹S¹→π₃*S²' =
transport (λ i → isEquiv (fst (help (~ i))))
(snd (fst GrEq))
where
GrEq = compGroupEquiv (πS³≅πTotalHopf 2) π'₃S²≅π'₃TotalHopf
help : PathP
(λ i → GroupHom
(GroupPath π₃*joinS¹S¹ π₃S³ .fst
(compGroupEquiv
(invGroupEquiv π₃≅π₃*)
(π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl))) i)
(GroupPath π₃*S² π₃S² .fst
(invGroupEquiv π₃≅π₃*) i))
π₃*joinS¹S¹→π₃*S²'
(fst (fst GrEq) , snd GrEq)
help =
toPathP (Σ≡Prop (λ _ → isPropIsGroupHom _ _)
(funExt
λ f → (λ i
→ transportRefl
((invGroupEquiv (π₃≅π₃*)) .fst .fst
(fst π₃*joinS¹S¹→π₃*S²' (
((fst (fst π₃≅π₃*))
(invEq (fst (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , refl)))
(transportRefl f i)))))) i)
∙ main f
))
where
main : (f : _) → invEquiv (fst π₃≅π₃*) .fst
(fst π₃*joinS¹S¹→π₃*S²'
(fst (fst π₃≅π₃*)
(invEq
(fst (π'Iso 2 (isoToEquiv (IsoSphereJoin 1 1) , (λ _ → north))))
f)))
≡ fst GrEq .fst f
main = sElim (λ _ → isSetPathImplicit)
λ 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)))))
∙ 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)
(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 =
compPath-filler (merid (invLooper a * b)) (sym (merid base)) j i
snd π₃*joinS¹S¹≅π₃*S² = snd π₃*joinS¹S¹→π₃*S²
π₃*S³≅π₃*joinS¹S¹ : GroupEquiv π₃*S³ π₃*joinS¹S¹
π₃*S³≅π₃*joinS¹S¹ =
π*∘∙Equiv 1 1 (isoToEquiv (invIso (IsoSphereJoin 1 1)) , refl)
π₃S³≅π₃*S³ : GroupEquiv π₃S³ π₃*S³
π₃S³≅π₃*S³ = π₃≅π₃*
η↦η₁ : fst (fst π₃S²→π₃*S²) η ≡ η₁
η↦η₁ = 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₁ = funExt λ 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
where
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))
∙∙ (λ j → σ₁ b (j ∨ ~ i))
∙∙ σ₁ a)
η₂↦η₁ : 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})
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)
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)
main : (a b : S¹)
→ 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₂ _∙_ (fst (lem a b)) (snd (lem a b))
η₂↦η₃ : invEq (fst π₃*S³≅π₃*joinS¹S¹) η₂ ≡ η₃
η₂↦η₃ =
to3ConnectedId connS³
(funExt λ x → lem x)
where
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
where
left-lem : σ₂ (S¹×S¹→S² (b * invLooper a) (invLooper a))
≡ σ₂ (S¹×S¹→S² a b)
left-lem = cong σ₂ (⌣₁,₁-distr' b (invLooper a)
∙ ⌣Sinvᵣ b a
∙ sym (transportRefl _)
∙ sym (comm⌣S a b))
right-lem : σ₂ (S¹×S¹→S² (b * invLooper a) b) ≡ sym (σ₂ (S¹×S¹→S² a b))
right-lem = cong σ₂ (⌣₁,₁-distr (invLooper a) b ∙ ⌣Sinvₗ a b)
∙ σ-invSphere 1 (a ⌣S 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)
∙ cong₂ _∙_ (cong sym left-lem) right-lem
η₄↦η₃ : fst (fst π₃S³≅π₃*S³) η₄ ≡ η₃
η₄↦η₃ = IsGroupHom.pres· (snd π₃S³≅π₃*S³)
(-π' 2 ∣ idfun∙ (S₊∙ 3) ∣₂) (-π' 2 ∣ idfun∙ (S₊∙ 3) ∣₂)
∙ cong₂ _+π₃*_ gen↦η₃/2 gen↦η₃/2
∙ η₃/2+η₃/2≡η₃
where
_+π₃*_ : 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)
snd η₃-raw/2 = refl
η₃/2 : π₃*S³ .fst
η₃/2 = ∣ η₃-raw/2 ∣₂
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) j → help a b j i
})
where
help : (a b : S¹)
→ cong (fst (inv (Iso-JoinMap-SphereMap 1 1) (-Π (idfun∙ (S₊∙ 3))))) (push a b)
≡ σS (a ⌣S b) ⁻¹
help a b = cong-∙ (fst (-Π (idfun∙ (S₊∙ 3)))) (merid (a ⌣S b)) (merid north ⁻¹)
∙ cong₂ _∙_ refl (rCancel (merid north))
∙ sym (rUnit (σS (a ⌣S b) ⁻¹))
η₃/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})
where
pre : (a b : S¹) → cong (fst η₃-raw/2) (ℓS a b) ≡ σS (a ⌣S b) ⁻¹
pre a b = cong-∙ (fst η₃-raw/2) _ _
∙ cong₂ _∙_
(cong sym (rCancel (merid north)))
(cong-∙∙ (fst η₃-raw/2) _ _ _
∙ (λ i →
(cong σ₂ (IdL⌣S {n = 1} {1} a) ∙ (rCancel (merid north))) i
∙∙ σS (a ⌣S b) ⁻¹
∙∙ rCancel (merid north) i)
∙ sym (rUnit _))
∙ sym (lUnit _)
lem : (a b : S¹) → cong (fst (η₃-raw/2 +* η₃-raw/2)) (push a b)
≡ cong (fst η₃-raw) (push a b)
lem a b = cong₂ _∙_ (sym (rUnit _) ∙ pre a b) (sym (rUnit _) ∙ pre a b)
abstract
π₃S²≅π₃*S²-abs : GroupEquiv π₃S² π₃*S²
π₃S²≅π₃*S²-abs = π₃S²→π₃*S²
π₃*S²≅π₃*joinS¹S¹-abs : GroupEquiv π₃*S² π₃*joinS¹S¹
π₃*S²≅π₃*joinS¹S¹-abs = invGroupEquiv π₃*joinS¹S¹≅π₃*S²
π₃*joinS¹S¹≅π₃*S³-abs : GroupEquiv π₃*joinS¹S¹ π₃*S³
π₃*joinS¹S¹≅π₃*S³-abs = invGroupEquiv π₃*S³≅π₃*joinS¹S¹
π₃*S³≅π₃*S³-abs : GroupEquiv π₃*S³ π₃S³
π₃*S³≅π₃*S³-abs = invGroupEquiv π₃S³≅π₃*S³
π₃'S³≅ℤ-abs : (n : ℕ) → GroupEquiv (π'Gr n (S₊∙ (suc n))) ℤGroup
π₃'S³≅ℤ-abs n = GroupIso→GroupEquiv (πₙ'Sⁿ≅ℤ n)
η↦η₁-abs : fst (fst π₃S²≅π₃*S²-abs) η ≡ η₁
η↦η₁-abs = η↦η₁
η₁↦η₂-abs : fst (fst π₃*S²≅π₃*joinS¹S¹-abs) η₁ ≡ η₂
η₁↦η₂-abs = cong (fst (fst π₃*S²≅π₃*joinS¹S¹-abs)) (sym η₂↦η₁)
∙ secEq (fst π₃*S²≅π₃*joinS¹S¹-abs) η₂
η₂↦η₃-abs : fst (fst π₃*joinS¹S¹≅π₃*S³-abs) η₂ ≡ η₃
η₂↦η₃-abs = η₂↦η₃
η₃↦η₄-abs : fst (fst π₃*S³≅π₃*S³-abs) η₃ ≡ η₄
η₃↦η₄-abs = cong (invEq (fst π₃S³≅π₃*S³)) (sym η₄↦η₃)
∙ retEq (fst π₃S³≅π₃*S³) η₄
gen↦1 : (n : ℕ) → fst (fst (π₃'S³≅ℤ-abs n)) ∣ idfun∙ (S₊∙ (suc n)) ∣₂ ≡ 1
gen↦1 = πₙ'Sⁿ≅ℤ-idfun∙
abstract
η₄↦-2 : fst (fst (π₃'S³≅ℤ-abs 2)) η₄ ≡ -2
η₄↦-2 = speedUp (∣ idfun∙ (S₊∙ 3) ∣₂) (gen↦1 2)
where
speedUp : (x : _)
→ fst (fst (π₃'S³≅ℤ-abs (suc (suc zero)))) x ≡ (pos (suc zero))
→ (fst (fst (π₃'S³≅ℤ-abs 2))) (·π' 2 (-π' 2 x) (-π' 2 x)) ≡ -2
speedUp x p =
IsGroupHom.pres· (π₃'S³≅ℤ-abs 2 .snd)
(-π' 2 x) (-π' 2 x)
∙ cong (λ x → x +Z x)
(IsGroupHom.presinv (π₃'S³≅ℤ-abs 2 .snd) x ∙ cong (inv (ℤGroup .snd)) p)
π₃'S²≅ℤ : GroupEquiv (π'Gr 2 (S₊∙ 2)) ℤGroup
π₃'S²≅ℤ =
compGroupEquiv
π₃S²≅π₃*S²-abs
(compGroupEquiv
π₃*S²≅π₃*joinS¹S¹-abs
(compGroupEquiv
π₃*joinS¹S¹≅π₃*S³-abs
(compGroupEquiv π₃*S³≅π₃*S³-abs
(π₃'S³≅ℤ-abs 2))))
η↦-2 : fst (fst π₃'S²≅ℤ) η ≡ - 2
η↦-2 =
cong (fst (fst (π₃'S³≅ℤ-abs 2)))
(cong (fst π₃*S³≅π₃*S³-abs .fst)
(cong (fst π₃*joinS¹S¹≅π₃*S³-abs .fst)
(cong (fst (fst π₃*S²≅π₃*joinS¹S¹-abs))
η↦η₁-abs
∙ η₁↦η₂-abs)
∙ η₂↦η₃-abs)
∙ η₃↦η₄-abs)
∙ η₄↦-2
BrunerieGroupEquiv : GroupEquiv (π'Gr 3 (S₊∙ 3)) (ℤGroup/ 2)
BrunerieGroupEquiv =
compGroupEquiv
(compGroupEquiv π₄S³≅π₃coFib-fold∘W∙
(invGroupEquiv
(GroupEquiv-abstractℤ/abs-gen
(π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙)
(invGroupEquiv (π₃'S³≅ℤ-abs 2))
(invGroupEquiv π₃'S²≅ℤ)
(π'∘∙Hom 2 (fold∘W , refl))
_
S³→S²→Pushout→Unit 2
(cong abs (cong (invEq (invEquiv (fst π₃'S²≅ℤ))
∘ sMap (_∘∙_ (fold∘W , refl)))
(sym (cong (invEq (fst (π₃'S³≅ℤ-abs 2))) (gen↦1 2))
∙ retEq (fst (π₃'S³≅ℤ-abs 2)) ∣ idfun∙ (S₊∙ 3) ∣₂))
∙ cong abs η↦-2))))
(abstractℤ/≅ℤ 2)
connS² : isConnected 3 S²
connS² = ∣ base ∣
, Trunc.elim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _)
(S²ToSetElim (λ _ → isOfHLevelTrunc 3 _ _)
refl)
connSuspS² : isConnected 4 (Susp S²)
fst connSuspS² = ∣ north ∣
snd connSuspS² =
Trunc.elim (λ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _)
λ { north → refl
; south → cong ∣_∣ₕ (merid base)
; (merid a i) → lem a i}
where
lem : (a : S²)
→ PathP (λ i → ∣ north ∣ₕ ≡ ∣ merid a i ∣ₕ)
refl (cong ∣_∣ₕ (merid base))
lem = S²ToSetElim (λ _ → isOfHLevelPathP' 2 (isOfHLevelTrunc 4 _ _) _ _)
λ i j → ∣ merid base (i ∧ j) ∣ₕ
π₃*S³' : Group₀
π₃*S³' = π*Gr 1 1 (Susp∙ 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) =
(σ (S² , base) (S¹×S¹→S²' a b) ∙ σ (S² , base) (S¹×S¹→S²' a b)) i
snd η₃'-raw = refl
η₃' : π₃*S³' .fst
η₃' = ∣ η₃'-raw ∣₂
altS²IsoSuspS¹ : Iso S² SuspS¹
altS²IsoSuspS¹ = compIso invS²Iso S²IsoSuspS¹
π₃*S³≅π₃*S³' : GroupEquiv π₃*S³ π₃*S³'
π₃*S³≅π₃*S³' = π*∘∙Equiv 1 1
(isoToEquiv (congSuspIso (invIso altS²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
}))
, sym (rUnit refl)))
where
lem : (a b : S¹)
→ cong (suspFun (invS² ∘ 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 (invS² ∘ SuspS¹→S²))
(sym (σ₂ (S¹×S¹→S² a b))) (sym (σ₂ (S¹×S¹→S² a b)))
∙ cong (λ x → x ∙ x)
(cong sym (cong-∙
(suspFun (invS² ∘ SuspS¹→S²)) (merid (S¹×S¹→S² a b)) (sym (merid north)))
∙ cong sym (cong (σ S²∙)
(cong invS² (SuspS¹→S²-S¹×S¹→S² a b)
∙ S¹×S¹→S²-anticomm a b))
∙ sym (S¹×S¹→S²-sym a b))
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
snd (map← f) = refl
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))
∙∙ 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))))
∙ ∙∙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)))
∙ ∙∙lCancel (snd f)
where
abstract
coherence : (f : S₊∙ 1 →∙ Ω (Susp∙ S²))
→ ((x : S¹) → fst f x ≡ refl) → f ≡ ((λ _ → refl) , refl)
coherence f p = →∙Homogeneous≡ (isHomogeneousPath _ _) (funExt p)
π₃*S³'≅π₁S¹→∙ΩS³'-raw :
Iso (π₃*S³' .fst) ((π'Gr 0 (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) .fst)
fun π₃*S³'≅π₁S¹→∙ΩS³'-raw = sMap map→
inv π₃*S³'≅π₁S¹→∙ΩS³'-raw = sMap map←
rightInv π₃*S³'≅π₁S¹→∙ΩS³'-raw =
sElim (λ _ → isSetPathImplicit)
λ f → cong ∣_∣₂
(→∙Homogeneous≡
(subst isHomogeneous
(ua∙ {A = (Ω^ 2) (Susp∙ S²)} {B = (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)}
(isoToEquiv (IsoΩSphereMap 1))
(ΣPathP ((funExt (λ { base → refl ; (loop i) → refl})) , refl)))
(isHomogeneousPath _ _))
(funExt λ x → →∙Homogeneous≡ (isHomogeneousPath _ _)
(funExt λ y
→ sym (rUnit
((cong (fst (map← f)))
((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))
∙∙ (λ i → cong-∙ (fst (map← f))
(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)
(cong₂ _∙_ (fst f base .snd) (cong sym (fst f x .snd))
∙ sym (rUnit refl))
∙∙ sym (rUnit (f .fst x .fst y)))))
leftInv π₃*S³'≅π₁S¹→∙ΩS³'-raw =
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
→ hcomp (λ k → λ {(i = i0) →
compPath-filler' (sym (snd f)) (cong (fst f)
(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) })
(fst f (doubleCompPath-filler
(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²)
→ PathP (λ i → (sym (snd f)
∙ 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))))
◁ λ i j → snd f (i ∨ ~ j))
π₁S¹→∙ΩS³'≅π₃*S³' : GroupIso (π'Gr 0 (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) π₃*S³'
fst π₁S¹→∙ΩS³'≅π₃*S³' = invIso π₃*S³'≅π₁S¹→∙ΩS³'-raw
snd π₁S¹→∙ΩS³'≅π₃*S³' =
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
}))
, refl)))
where
lem1 : (f : S₊∙ 1 →∙ (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) (a b : S¹)
→ congS (fst (map← f)) (ℓ* S¹∙ S¹∙ a b) ≡ fst f a .fst b
lem1 f a b = cong-∙ (fst (map← f)) _ _
∙ cong₂ _∙_ (fst f base .snd)
((cong-∙∙ (fst (map← f)) _ _ _)
∙ (λ j → sym (fst f a .snd j)
∙∙ fst f a .fst b
∙∙ sym (snd f j .fst b))
∙ sym (rUnit _))
∙ sym (lUnit _)
main : (f g : S₊∙ 1 →∙ (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙)) (a b : S¹)
→ cong (fst (map← (∙Π f g))) (push a b)
≡ cong (fst (_+*_ {A = S¹∙} {B = S¹∙} (map← f) (map← g))) (push a b)
main f g a b = main-lem a b
∙ cong₂ _∙_ (sym (lem1 f a b) ∙ rUnit _)
(sym (lem1 g a b) ∙ rUnit _)
where
JLem : ∀ {ℓ} {A : Type ℓ} (* : A)
(fab : * ≡ *) (fabrefl : refl ≡ fab)
(gab : * ≡ *) (gabrefl : refl ≡ gab)
→ (fl : fab ≡ fab) (gl : gab ≡ gab)
→ PathP (λ i → (rUnit refl ∙ (λ i → fabrefl i ∙ gabrefl i)) i
≡ (rUnit refl ∙ (λ i → fabrefl i ∙ gabrefl i)) i)
((fabrefl ∙∙ fl ∙∙ sym fabrefl)
∙ (gabrefl ∙∙ gl ∙∙ sym gabrefl))
(cong₂ _∙_ fl gl)
JLem * =
J> (J> λ fl gl
→ flipSquare (sym (rUnit (rUnit refl))
◁ ((flipSquare (cong₂ _∙_ (sym (rUnit fl)) (sym (rUnit gl))
◁ ((λ i → (cong (λ x → rUnit x i) fl
∙ cong (λ x → lUnit x i) gl))
▷ sym (cong₂Funct _∙_ fl gl))))
▷ rUnit (rUnit refl))))
pp : (b : S¹) → refl ∙ refl ≡ fst (fst f base) b ∙ fst (fst g base) b
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)
≡ (fst f a .fst b ∙ fst g a .fst b)
main-lem base b = rUnit refl ∙ pp b
main-lem (loop i) b j =
hcomp (λ r → λ {(i = i0) → (rUnit refl ∙ pp b) j
; (i = i1) → (rUnit refl ∙ pp b) j
; (j = i0) → lem (~ r) i
; (j = i1) →
(fst f (loop i) .fst b ∙ fst g (loop i) .fst b)})
(JLem north
(fst f base .fst b) (λ i → fst (snd f (~ i)) b)
(fst g base .fst b) (λ i → fst (snd g (~ i)) b)
(λ 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
≡ ((λ i → fst (snd f (~ i)) b)
∙∙ funExt⁻ (cong fst (cong (f .fst) loop)) b
∙∙ (λ i → fst (snd f i) b))
∙ ((λ i → fst (snd g (~ i)) b)
∙∙ funExt⁻ (cong fst (cong (g .fst) loop)) b
∙∙ (λ i → fst (snd g i) b))
lem =
(λ i → funExt⁻ (cong-∙ fst
(sym (snd f) ∙∙ cong (f .fst) loop ∙∙ snd f)
(sym (snd g) ∙∙ cong (g .fst) loop ∙∙ snd g) i) b)
∙ λ i → funExt⁻
(cong-∙∙ fst (sym (snd f)) (cong (f .fst) loop) (snd f) i
∙ cong-∙∙ fst (sym (snd g)) (cong (g .fst) loop) (snd g) i) b
ΩK₂-basechange : (x : K₂) → Ω (K₂ , x) →∙ Ω (K₂ , ∣ base ∣₄)
ΩK₂-basechange =
2GroupoidTrunc.elim
(λ _ → isOfHLevelΣ 4
(isOfHLevelΠ 4 (λ _ → isOfHLevelPath 4 squash₄ _ _))
λ _ → isOfHLevelPath 4 (isOfHLevelPath 4 squash₄ _ _) _ _)
λ { base → idfun∙ _
; (surf i j) → coherence i j}
where
K₂≃coHomK2 : Iso K₂ (coHomK 2)
K₂≃coHomK2 = compIso 2GroupoidTruncTrunc4Iso (mapCompIso S²IsoSuspS¹)
Ω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 ∣₄))
coherence =
toPathP
(isOfHLevelPath' 1 (subst isSet (λ i → ΩK₂≡S¹ (~ i) →∙ Ω (K₂ , ∣ base ∣₄))
(subst isSet
(isoToPath
(equivToIso (Ω→SphereMap 1 {A = Ω (K₂ , ∣ base ∣₄) }
, isEquiv-Ω→SphereMap 1))) (squash₄ _ _ _ _))) _ _ _ _)
π₁S¹→∙ΩS³'→π₁S¹→∙K₂ :
GroupHom (π'Gr 0 (S₊∙ 1 →∙ Ω (Susp∙ S²) ∙))
(π'Gr 0 (S₊∙ 1 →∙ (K₂ , ∣ base ∣₄ ) ∙))
π₁S¹→∙ΩS³'→π₁S¹→∙K₂ =
π'∘∙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))
π₁S¹→∙K₂→π₁S¹ = π'∘∙Hom 0 mainMap∙
where
mainMap : (S¹ → K₂) → S¹
mainMap f =
GroupoidTrunc.rec isGroupoidS¹ (λ x → x)
(encodeTruncS² (ΩK₂-basechange _ .fst (cong f loop)))
mainMap∙ : ((S₊∙ 1 →∙ (K₂ , ∣ base ∣₄) ∙) →∙ S₊∙ 1)
fst mainMap∙ f = mainMap (fst f)
snd mainMap∙ = refl
π₁S¹→ℤ : GroupHom ((π'Gr 0 (S₊∙ 1))) ℤGroup
π₁S¹→ℤ =
compGroupHom
((sMap (λ f → basechange2⁻ _ (cong (fst f) loop)))
, makeIsGroupHom (sElim2 (λ _ _ → isSetPathImplicit)
λ f g i
→ ∣ (basechange2⁻ (snd f (~ i))
(doubleCompPath-filler
(sym (snd f)) (λ i → fst f (loop i)) (snd f) (~ i))
∙ basechange2⁻ (snd g (~ i))
(doubleCompPath-filler
(sym (snd g)) (λ i → fst g (loop i)) (snd g) (~ i))) ∣₂))
(_ , πₙSⁿ≅ℤ 0 .snd)
computer : GroupHom π₃*S³' ℤGroup
computer = compGroupHom
(GroupEquiv→GroupHom (invGroupEquiv (GroupIso→GroupEquiv π₁S¹→∙ΩS³'≅π₃*S³')))
(compGroupHom (compGroupHom π₁S¹→∙ΩS³'→π₁S¹→∙K₂ π₁S¹→∙K₂→π₁S¹) π₁S¹→ℤ)
1∈π₃*S³' : π₃*S³' .fst
1∈π₃*S³' =
∣ (λ { (inl x) → north
; (inr x) → north
; (push a b i) → σ S²∙ (S¹×S¹→S²' b a) i}) , refl ∣₂
1∈π₃*S³'↦1 : fst computer 1∈π₃*S³' ≡ 1
1∈π₃*S³'↦1 = refl
computerIso : GroupEquiv π₃*S³' ℤGroup
fst (fst computerIso) = fst computer
snd (fst computerIso) =
1∈Im→isEquiv π₃*S³'
(compGroupEquiv
(compGroupEquiv
(invGroupEquiv
(GroupIso→GroupEquiv
(πₙ'Sⁿ≅ℤ 2)))
π₃S³≅π₃*S³)
π₃*S³≅π₃*S³')
computer
∣ 1∈π₃*S³' , 1∈π₃*S³'↦1 ∣₁
snd computerIso = snd computer
computerIsoη₃ : fst computer η₃' ≡ -2
computerIsoη₃ = refl
BrunerieGroupEquiv' : GroupEquiv (π'Gr 3 (S₊∙ 3)) (ℤGroup/ (abs (fst computer η₃')))
BrunerieGroupEquiv' =
compGroupEquiv
(compGroupEquiv
π₄S³≅π₃coFib-fold∘W∙
(invGroupEquiv
(GroupEquiv-abstractℤ/abs-gen
(π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙)
(invGroupEquiv (π₃'S³≅ℤ-abs 2))
(invGroupEquiv
(compGroupEquiv
(compGroupEquiv
(compGroupEquiv
π₃S²≅π₃*S²-abs
π₃*S²≅π₃*joinS¹S¹-abs)
π₃*joinS¹S¹≅π₃*S³-abs)
(fst π₃*S³≅ℤ-abs)))
(π'∘∙Hom 2 (fold∘W , refl))
_
S³→S²→Pushout→Unit
_
(cong abs ((cong (m1 ∘ m2 ∘ m3 ∘ m4)
((cong (sMap (_∘∙_ (fold∘W , refl)))
(sym (cong (invEq (fst (π₃'S³≅ℤ-abs 2))) (gen↦1 2))
∙ retEq (fst (π₃'S³≅ℤ-abs 2)) ∣ idfun∙ (S₊∙ 3) ∣₂))
∙ (λ _ → η)))
∙ cong (m1 ∘ m2 ∘ m3) η↦η₁-abs
∙ cong (m1 ∘ m2) η₁↦η₂-abs
∙ cong m1 η₂↦η₃-abs)
∙ cong abs (snd π₃*S³≅ℤ-abs)))))
(abstractℤ/≅ℤ (abs (fst computer η₃')))
where
abstract
η₃-abs : Σ[ x ∈ _ ] x ≡ η₃
η₃-abs = η₃ , refl
η₃-abs-pres : fst π₃*S³≅π₃*S³' .fst (fst η₃-abs) ≡ ∣ η₃'-raw ∣₂
η₃-abs-pres = π₃*S³≅π₃*S³'-pres-η₃
π₃*S³≅ℤ : GroupEquiv π₃*S³ ℤGroup
π₃*S³≅ℤ = compGroupEquiv π₃*S³≅π₃*S³' computerIso
π₃*S³≅ℤβ≡-2 : fst (fst π₃*S³≅ℤ) η₃ ≡ fst computer η₃'
π₃*S³≅ℤβ≡-2 = (cong (fst (fst π₃*S³≅ℤ)) (sym (snd η₃-abs))
∙ cong (fst computer) η₃-abs-pres)
∙ computerIsoη₃
abstract
π₃*S³≅ℤ-abs : Σ[ f ∈ GroupEquiv π₃*S³ ℤGroup ] (fst (fst f) η₃ ≡ fst computer η₃')
π₃*S³≅ℤ-abs = π₃*S³≅ℤ , π₃*S³≅ℤβ≡-2
m1 = fst (fst (fst π₃*S³≅ℤ-abs))
m2 = fst (fst π₃*joinS¹S¹≅π₃*S³-abs)
m3 = fst (fst π₃*S²≅π₃*joinS¹S¹-abs)
m4 = fst (fst π₃S²≅π₃*S²-abs)
BrunerieGroupEquiv'' : GroupEquiv (π'Gr 3 (S₊∙ 3)) (ℤGroup/ 2)
BrunerieGroupEquiv'' = BrunerieGroupEquiv'