michael/Spectral
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

simplify smash proof

Browse source
This commit is contained in:
Floris van Doorn 2017-03-09 16:13:24 -05:00
parent 0b55cc6b7c
commit b781de8473
4 changed files with 101 additions and 254 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
homotopy/smash.hlean
View file

@ -347,6 +347,10 @@ namespace smash
{ reflexivity }
end
definition smash_functor_split (f : A →* C) (g : B →* D) :
f ∧→ g ~* (pid C) ∧→ g ∘* f ∧→ (pid B) :=
smash_functor_phomotopy !pid_pcompose⁻¹* !pcompose_pid⁻¹* ⬝* !smash_functor_pcompose
/- An alternative proof which doesn't start by applying inductions, so which is more explicit -/
-- definition smash_functor_pcompose_homotopy [unfold 11] (f' : C →* E) (f : A →* C) (g' : D →* F)
-- (g : B →* D) : (f' ∘* f) ∧→ (g' ∘* g) ~ (f' ∧→ g') ∘* (f ∧→ g) :=
@ -660,6 +664,7 @@ namespace smash
(!smash_functor_phomotopy_refl ◾** idp ⬝ !refl_trans) ⬝pv**
smash_functor_pconst_pcompose (pid A) (pid A) g
/- these lemmas are use to show that smash_functor_right is natural in all arguments -/
definition smash_functor_right_natural_right (f : C →* C') :
psquare (smash_functor_right A B C) (smash_functor_right A B C')
(ppcompose_left f) (ppcompose_left (pid A ∧→ f)) :=
@ -674,40 +679,38 @@ namespace smash
apply smash_functor_pid_pcompose_pconst }
end
/- a lemma using both these rules -/
definition smash_psquare_lemma (f : A →* A') (g : B →* B')
: phsquare (smash_functor_psquare (pvrefl g) (pid_pcompose (pconst A' C ∘* f))⁻¹*)
(pconst_pcompose (g ∧→ f))
(pwhisker_right (g ∧→ f) (smash_functor_pconst_right (pid B')))
(pwhisker_left (g ∧→ pid C)
(smash_functor_phomotopy phomotopy.rfl (pconst_pcompose f) ⬝*
smash_functor_pconst_right (pid B)) ⬝*
pcompose_pconst (g ∧→ pid C)) :=
definition smash_functor_right_natural_middle (f : B' →* B) :
psquare (smash_functor_right A B C) (smash_functor_right A B' C)
(ppcompose_right f) (ppcompose_right (pid A ∧→ f)) :=
begin
refine !trans_assoc ⬝pv** _,
apply phmove_top_of_left',
refine _ ⬝ (!trans_assoc ⬝ !smash_functor_pconst_pcompose)⁻¹,
refine !trans_assoc⁻¹ ⬝ trans_eq_of_eq_trans_symm _,
refine _ ⬝hp** !pwhisker_left_trans⁻¹,
refine (smash_functor_phomotopy_phsquare (phvrfl ⬝hp** !pcompose2_refl⁻¹)
(!pcompose2_refl_left ⬝ph** !pid_pconst_pcompose)⁻¹ʰ** ⬝h**
!smash_functor_pcompose_phomotopy ⬝hp**
(!smash_functor_phomotopy_refl ◽* idp ⬝ !pcompose2_refl_left)) ⬝v** _,
refine ((!smash_functor_phomotopy_trans⁻¹ ⬝
ap011 smash_functor_phomotopy !trans_refl !refl_trans) ◾** idp) ⬝ph** idp ⬝ _,
refine !trans_assoc ⬝ !trans_assoc ⬝ _,
apply trans_eq_of_eq_symm_trans,
refine _ ⬝ !trans_assoc ⬝ (ap (smash_functor_phomotopy _) !refl_symm⁻¹ ⬝
!smash_functor_phomotopy_symm) ◾** idp,
refine _ ⬝ !smash_functor_pconst_right_phomotopy⁻¹ ◾** idp,
apply trans_eq_of_eq_symm_trans,
refine _ ⬝ !trans_assoc ⬝ (ap011 smash_functor_phomotopy !refl_symm⁻¹ !refl_symm⁻¹ ⬝
!smash_functor_phomotopy_symm) ◾** idp,
apply eq_trans_symm_of_trans_eq, refine !trans_assoc ⬝ _,
apply smash_functor_pcompose_pconst
refine _⁻¹*,
fapply phomotopy_mk_ppmap,
{ intro g, exact smash_functor_pid_pcompose A g f },
{ refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_right_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy) ⬝ _ ,
refine _ ⬝ (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !smash_functor_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy)⁻¹,
apply smash_functor_pid_pconst_pcompose }
end
definition smash_functor_right_natural_left (f : A →* A') :
psquare (smash_functor_right A B C) (ppcompose_right (f ∧→ (pid B)))
(smash_functor_right A' B C) (ppcompose_left (f ∧→ (pid C))) :=
begin
refine _⁻¹*,
fapply phomotopy_mk_ppmap,
{ intro g, exact smash_functor_psquare proof phomotopy.rfl qed proof phomotopy.rfl qed },
{ esimp,
refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_left_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy) ⬝ _ ,
refine _ ⬝ (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_right_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy)⁻¹,
apply eq_of_phsquare,
refine (phmove_bot_of_left _ !smash_functor_pconst_pcompose⁻¹ʰ**) ⬝h**
(!smash_functor_phomotopy_refl ⬝pv** !phhrfl) ⬝h** !smash_functor_pcompose_pconst ⬝vp** _,
refine !trans_assoc ⬝ !trans_assoc ⬝ idp ◾** _ ⬝ !trans_refl,
refine idp ◾** !refl_trans ⬝ !trans_left_inv }
end
/- f ∧ g is a pointed equivalence if f and g are -/
definition smash_functor_using_pushout [unfold 7] (f : A →* C) (g : B →* D) : A ∧ B → C ∧ D :=

116
homotopy/smash2.hlean
View file

@ -1,116 +0,0 @@
import .smash_adjoint
-- Authors: Floris van Doorn
import homotopy.smash ..pointed .pushout homotopy.red_susp
open bool pointed eq equiv is_equiv sum bool prod unit circle cofiber prod.ops wedge is_trunc
function red_susp unit
/- To prove: Σ(X × Y) ≃ ΣX ∨ ΣY ∨ Σ(X ∧ Y) (?) (notation means suspension, wedge, smash) -/
/- To prove: Σ(X ∧ Y) ≃ X ★ Y (?) (notation means suspension, smash, join) -/
/- To prove: A ∧ S¹ ≃ ΣA -/
/- associativity is proven in smash_adjoint -/
variables {A A' B B' C C' D E F : Type*}
namespace smash
definition smash_pelim2 [constructor] (A B C : Type*) : ppmap A (ppmap B C) →* ppmap (B ∧ A) C :=
ppcompose_left (smash_pmap_counit B C) ∘* smash_functor_right B A (ppmap B C)
definition smash_pelim2_natural (f : C →* C') :
psquare (smash_pelim2 A B C) (smash_pelim2 A B C')
(ppcompose_left (ppcompose_left f)) (ppcompose_left f) :=
smash_functor_right_natural_right (ppcompose_left f) ⬝h*
ppcompose_left_psquare (smash_pmap_counit_natural f)
--ppmap B C →* ppmap (A ∧ B) (A ∧ C)
definition smash_functor_right_natural_middle (f : B' →* B) :
psquare (smash_functor_right A B C) (smash_functor_right A B' C)
(ppcompose_right f) (ppcompose_right (pid A ∧→ f)) :=
begin
refine _⁻¹*,
fapply phomotopy_mk_ppmap,
{ intro g, exact smash_functor_pid_pcompose A g f },
{ refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_right_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy) ⬝ _ ,
refine _ ⬝ (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !smash_functor_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy)⁻¹,
apply smash_functor_pid_pconst_pcompose }
end
definition smash_functor_right_natural_left_lemma (f : A →* A')
: phsquare (smash_functor_psquare (phomotopy.rfl : psquare f f !pid !pid)
(phomotopy.rfl : psquare !pid !pid (pconst B C) (pconst B C)))
(pconst_pcompose (f ∧→ pid B))
(pwhisker_right (f ∧→ pid B) (smash_functor_pconst_right (pid A')))
(pwhisker_right (f ∧→ pid B) (smash_functor_pconst_right (pid A')) ⬝*
pconst_pcompose (f ∧→ pid B)) :=
begin
-- refine !trans_assoc ⬝pv** _,
-- apply phmove_top_of_left',
-- refine _ ⬝ (!trans_assoc ⬝ !smash_functor_pconst_pcompose)⁻¹,
-- refine !trans_assoc⁻¹ ⬝ trans_eq_of_eq_trans_symm _,
-- refine _ ⬝hp** !pwhisker_left_trans⁻¹,
-- refine (smash_functor_phomotopy_phsquare (phvrfl ⬝hp** !pcompose2_refl⁻¹)
-- (!pcompose2_refl_left ⬝ph** !pid_pconst_pcompose)⁻¹ʰ** ⬝h**
-- !smash_functor_pcompose_phomotopy ⬝hp**
-- (!smash_functor_phomotopy_refl ◽* idp ⬝ !pcompose2_refl_left)) ⬝v** _,
-- refine ((!smash_functor_phomotopy_trans⁻¹ ⬝
-- ap011 smash_functor_phomotopy !trans_refl !refl_trans) ◾** idp) ⬝ph** idp ⬝ _,
-- refine !trans_assoc ⬝ !trans_assoc ⬝ _,
-- apply trans_eq_of_eq_symm_trans,
-- refine _ ⬝ !trans_assoc ⬝ (ap (smash_functor_phomotopy _) !refl_symm⁻¹ ⬝
-- !smash_functor_phomotopy_symm) ◾** idp,
-- refine _ ⬝ !smash_functor_pconst_right_phomotopy⁻¹ ◾** idp,
-- apply trans_eq_of_eq_symm_trans,
-- refine _ ⬝ !trans_assoc ⬝ (ap011 smash_functor_phomotopy !refl_symm⁻¹ !refl_symm⁻¹ ⬝
-- !smash_functor_phomotopy_symm) ◾** idp,
-- apply eq_trans_symm_of_trans_eq, refine !trans_assoc ⬝ _,
-- apply smash_functor_pcompose_pconst
end
definition smash_functor_right_natural_left (f : A →* A') :
psquare (smash_functor_right A B C) (ppcompose_right (f ∧→ (pid B)))
(smash_functor_right A' B C) (ppcompose_left (f ∧→ (pid C))) :=
begin
refine _⁻¹*,
fapply phomotopy_mk_ppmap,
{ intro g, exact smash_functor_psquare proof phomotopy.rfl qed proof phomotopy.rfl qed },
{ esimp,
refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_left_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy) ⬝ _ ,
refine _ ⬝ (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_right_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy)⁻¹,
-- apply smash_functor_pid_pcompose_pconst
}
end
definition smash_pelim2_natural_left (B C : Type*) (f : A' →* A) :
psquare (smash_pelim2 A B C) (smash_pelim2 A' B C)
(ppcompose_right f) (ppcompose_right (pid B ∧→ f)) :=
smash_functor_right_natural_middle f ⬝h* !ppcompose_left_ppcompose_right
definition smash_pelim2_natural_middle (A C : Type*) (g : B' →* B) :
psquare (smash_pelim2 A B C) (smash_pelim2 A B' C)
(ppcompose_left (ppcompose_right g)) (ppcompose_right (g ∧→ pid A)) :=
pwhisker_tl _ !ppcompose_left_ppcompose_right ⬝*
(!smash_functor_right_natural_left⁻¹* ⬝pv*
smash_functor_right_natural_right (ppcompose_right g) ⬝h*
ppcompose_left_psquare !smash_pmap_counit_natural_left)
definition smash_functor_split (f : A →* C) (g : B →* D) :
f ∧→ g ~* (pid C) ∧→ g ∘* f ∧→ (pid B) :=
smash_functor_phomotopy !pid_pcompose⁻¹* !pcompose_pid⁻¹* ⬝* !smash_functor_pcompose
definition smash_pelim2_natural_lm (C : Type*) (f : A' →* A) (g : B' →* B) :
psquare (smash_pelim2 A B C) (smash_pelim2 A' B' C)
(ppcompose_left (ppcompose_right g) ∘* ppcompose_right f) (ppcompose_right (g ∧→ f)) :=
smash_pelim2_natural_left B C f ⬝v* smash_pelim2_natural_middle A' C g ⬝hp*
ppcompose_right_phomotopy proof !smash_functor_split qed ⬝* !ppcompose_right_pcompose
end smash

170
homotopy/smash_adjoint.hlean
View file

@ -121,7 +121,7 @@ namespace smash
end
/- The counit is natural in both arguments -/
definition smash_pmap_counit_natural (g : B →* C) : g ∘* smash_pmap_counit A B ~*
definition smash_pmap_counit_natural_right (g : B →* C) : g ∘* smash_pmap_counit A B ~*
smash_pmap_counit A C ∘* smash_functor (pid A) (ppcompose_left g) :=
begin
symmetry,
@ -245,7 +245,7 @@ namespace smash
begin
refine !pwhisker_left !smash_functor_pid_pcompose ⬝* _,
refine !passoc⁻¹* ⬝* _,
refine !pwhisker_right !smash_pmap_counit_natural⁻¹* ⬝* _,
refine !pwhisker_right !smash_pmap_counit_natural_right⁻¹* ⬝* _,
refine !passoc ⬝* _,
refine !pwhisker_left !smash_pmap_unit_counit ⬝* _,
apply pcompose_pid
@ -268,15 +268,15 @@ namespace smash
apply pconst_pcompose_phomotopy_pconst }
end
definition smash_elim_natural {A B C C' : Type*} (f : C →* C')
definition smash_elim_natural_right {A B C C' : Type*} (f : C →* C')
(g : B →* ppmap A C) : f ∘* smash_elim g ~* smash_elim (ppcompose_left f ∘* g) :=
begin
refine _ ⬝* pwhisker_left _ !smash_functor_pid_pcompose⁻¹*,
refine !passoc⁻¹* ⬝* pwhisker_right _ _ ⬝* !passoc,
apply smash_pmap_counit_natural
apply smash_pmap_counit_natural_right
end
definition smash_elim_inv_natural {A B C C' : Type*} (f : C →* C')
definition smash_elim_inv_natural_right {A B C C' : Type*} (f : C →* C')
(g : A ∧ B →* C) : ppcompose_left f ∘* smash_elim_inv g ~* smash_elim_inv (f ∘* g) :=
begin
refine !passoc⁻¹* ⬝* pwhisker_right _ _,
@ -326,86 +326,42 @@ namespace smash
/- The pointed maps of the equivalence A →* (B →* C) ≃* A ∧ B →* C -/
definition smash_pelim [constructor] (A B C : Type*) : ppmap A (ppmap B C) →* ppmap (B ∧ A) C :=
pmap.mk smash_elim (eq_of_phomotopy !smash_elim_pconst)
ppcompose_left (smash_pmap_counit B C) ∘* smash_functor_right B A (ppmap B C)
definition smash_pelim_inv [constructor] (A B C : Type*) :
ppmap (B ∧ A) C →* ppmap A (ppmap B C) :=
pmap.mk smash_elim_inv (eq_of_phomotopy !smash_elim_inv_pconst)
/- The forward function is natural in all three arguments -/
theorem smash_elim_natural_pconst (f : C →* C') :
smash_elim_natural f (pconst A (ppmap B C)) ⬝*
(smash_elim_phomotopy (pcompose_pconst (ppcompose_left f)) ⬝*
smash_elim_pconst B A C') =
pwhisker_left f (smash_elim_pconst B A C) ⬝*
pcompose_pconst f :=
begin
refine idp ◾** (!trans_assoc⁻¹ ⬝ (!pwhisker_left_trans⁻¹ ◾** idp)) ⬝ _,
refine !trans_assoc⁻¹ ⬝ _,
refine (!trans_assoc ⬝ (idp ◾** (!pwhisker_left_trans⁻¹ ⬝
ap (pwhisker_left _) (smash_functor_pid_pcompose_pconst' (ppcompose_left f))⁻¹ ⬝
!pwhisker_left_trans))) ◾** idp ⬝ _,
refine (!trans_assoc⁻¹ ⬝ (!passoc_phomotopy_right⁻¹ʰ** ⬝h**
!pwhisker_right_pwhisker_left ⬝h** !passoc_phomotopy_right) ◾** idp) ◾** idp ⬝ _,
refine !trans_assoc ⬝ !trans_assoc ⬝ idp ◾**_ ⬝ !trans_assoc⁻¹ ⬝ !pwhisker_left_trans⁻¹ ◾** idp,
refine !trans_assoc ⬝ !trans_assoc ⬝ (eq_symm_trans_of_trans_eq _)⁻¹,
refine !passoc_pconst_right ⬝ _,
refine _ ⬝ idp ◾** !passoc_pconst_right⁻¹,
refine !pcompose_pconst_phomotopy⁻¹
end
definition smash_pelim_natural_right (f : C →* C') :
psquare (smash_pelim A B C) (smash_pelim A B C')
(ppcompose_left (ppcompose_left f)) (ppcompose_left f) :=
smash_functor_right_natural_right (ppcompose_left f) ⬝h*
ppcompose_left_psquare (smash_pmap_counit_natural_right f)
definition smash_pelim_natural (f : C →* C') :
ppcompose_left f ∘* smash_pelim A B C ~*
smash_pelim A B C' ∘* ppcompose_left (ppcompose_left f) :=
begin
fapply phomotopy_mk_ppmap,
{ exact smash_elim_natural f },
{ refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !smash_elim_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy) ⬝ _ ,
refine _ ⬝ (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq !pcompose_left_eq_of_phomotopy ⬝
!phomotopy_of_eq_of_phomotopy) ◾** !phomotopy_of_eq_of_phomotopy)⁻¹,
exact smash_elim_natural_pconst f }
end
definition smash_pelim_natural_left (B C : Type*) (f : A' →* A) :
psquare (smash_pelim A B C) (smash_pelim A' B C)
(ppcompose_right f) (ppcompose_right (pid B ∧→ f)) :=
smash_functor_right_natural_middle f ⬝h* !ppcompose_left_ppcompose_right
definition smash_pelim_natural_left (C : Type*) (f : A →* A') (g : B →* B') :
psquare (smash_pelim A' B' C) (smash_pelim A B C)
definition smash_pelim_natural_middle (A C : Type*) (g : B' →* B) :
psquare (smash_pelim A B C) (smash_pelim A B' C)
(ppcompose_left (ppcompose_right g)) (ppcompose_right (g ∧→ pid A)) :=
pwhisker_tl _ !ppcompose_left_ppcompose_right ⬝*
(!smash_functor_right_natural_left⁻¹* ⬝pv*
smash_functor_right_natural_right (ppcompose_right g) ⬝h*
ppcompose_left_psquare !smash_pmap_counit_natural_left)
definition smash_pelim_natural_lm (C : Type*) (f : A' →* A) (g : B' →* B) :
psquare (smash_pelim A B C) (smash_pelim A' B' C)
(ppcompose_left (ppcompose_right g) ∘* ppcompose_right f) (ppcompose_right (g ∧→ f)) :=
begin
fapply phomotopy_mk_ppmap,
{ intro h, apply smash_elim_natural_left },
{ esimp,
refine idp ◾** (!phomotopy_of_eq_con ⬝ (ap phomotopy_of_eq
(ap02 _ (whisker_right _ !pcompose_left_eq_of_phomotopy ⬝ !eq_of_phomotopy_trans⁻¹) ⬝
!smash_elim_eq_of_phomotopy) ⬝ !phomotopy_of_eq_of_phomotopy) ◾**
!phomotopy_of_eq_of_phomotopy) ⬝ _,
refine _ ⬝ (ap phomotopy_of_eq (!pcompose_right_eq_of_phomotopy ◾ idp ⬝
!eq_of_phomotopy_trans⁻¹) ⬝ !phomotopy_of_eq_of_phomotopy)⁻¹,
refine ((idp ⬝h** ((ap (pwhisker_left _) (!trans_assoc⁻¹ ⬝ !pwhisker_left_trans⁻¹ ◾** idp) ⬝
!pwhisker_left_trans)⁻¹ ⬝ph** (pwhisker_left_phsquare _
(!smash_functor_phomotopy_trans_right ⬝ph**
(!smash_functor_pid_pcompose_phomotopy_right ⬝v**
!smash_functor_pid_pcompose_pconst))⁻¹ʰ** ⬝vp** !pwhisker_left_symm))) ⬝v**
(phwhisker_rt _ idp)) ⬝ _,
refine (idp ⬝h** (!passoc_phomotopy_right ⬝v** idp)) ◾** idp ⬝ _,
refine !trans_assoc ⬝ idp ◾** (!trans_assoc ⬝ !trans_assoc ⬝ idp ◾**
!passoc_pconst_right) ⬝ _,
refine idp ⬝h** (phwhisker_br _ !pwhisker_right_pwhisker_left ⬝vp**
!pcompose_pconst_phomotopy) ⬝ _,
refine (idp ⬝h** (phwhisker_br _ !passoc_phomotopy_right⁻¹ʰ** ⬝vp**
(eq_symm_trans_of_trans_eq !passoc_pconst_right)⁻¹)) ⬝ _,
refine (idp ⬝h** ((idp ◾** !pwhisker_left_trans⁻¹ ⬝
pwhisker_left_phsquare _ !smash_psquare_lemma) ⬝v** idp ⬝hp** !trans_assoc)) ⬝ _,
refine (!passoc_phomotopy_middle ⬝v** idp ⬝v** idp) ⬝ _,
refine !trans_assoc ⬝ !trans_assoc ⬝ idp ◾** !passoc_pconst_middle ⬝ _,
refine !trans_assoc⁻¹ ⬝ _ ◾** idp,
exact !pwhisker_right_trans⁻¹ }
end
smash_pelim_natural_left B C f ⬝v* smash_pelim_natural_middle A' C g ⬝hp*
ppcompose_right_phomotopy proof !smash_functor_split qed ⬝* !ppcompose_right_pcompose
/- The equivalence (note: the forward function of smash_adjoint_pmap is smash_pelim_inv) -/
definition smash_adjoint_pmap' [constructor] (A B C : Type*) : B →* ppmap A C ≃ A ∧ B →* C :=
definition is_equiv_smash_elim [constructor] (A B C : Type*) : is_equiv (@smash_elim A B C) :=
begin
fapply equiv.MK,
{ exact smash_elim },
fapply adjointify,
{ exact smash_elim_inv },
{ intro g, apply eq_of_phomotopy, exact smash_elim_right_inv g },
{ intro f, apply eq_of_phomotopy, exact smash_elim_left_inv f }
@ -413,43 +369,43 @@ namespace smash
definition smash_adjoint_pmap_inv [constructor] (A B C : Type*) :
ppmap B (ppmap A C) ≃* ppmap (A ∧ B) C :=
pequiv_of_equiv (smash_adjoint_pmap' A B C) (eq_of_phomotopy (smash_elim_pconst A B C))
pequiv_of_pmap (smash_pelim B A C) (is_equiv_smash_elim B A C)
definition smash_adjoint_pmap [constructor] (A B C : Type*) :
ppmap (A ∧ B) C ≃* ppmap B (ppmap A C) :=
(smash_adjoint_pmap_inv A B C)⁻¹ᵉ*
/- The naturality of the equivalence is a direct consequence of the earlier naturalities -/
definition smash_adjoint_pmap_natural_pt {A B C C' : Type*} (f : C →* C') (g : A ∧ B →* C) :
definition smash_adjoint_pmap_natural_right_pt {A B C C' : Type*} (f : C →* C') (g : A ∧ B →* C) :
ppcompose_left f ∘* smash_adjoint_pmap A B C g ~* smash_adjoint_pmap A B C' (f ∘* g) :=
begin
refine !passoc⁻¹* ⬝* pwhisker_right _ _,
exact !ppcompose_left_pcompose⁻¹*
end
definition smash_adjoint_pmap_inv_natural_pt {A B C C' : Type*} (f : C →* C')
definition smash_adjoint_pmap_inv_natural_right_pt {A B C C' : Type*} (f : C →* C')
(g : B →* ppmap A C) : f ∘* (smash_adjoint_pmap A B C)⁻¹ᵉ* g ~*
(smash_adjoint_pmap A B C')⁻¹ᵉ* (ppcompose_left f ∘* g) :=
begin
refine _ ⬝* pwhisker_left _ !smash_functor_pid_pcompose⁻¹*,
refine !passoc⁻¹* ⬝* pwhisker_right _ _ ⬝* !passoc,
apply smash_pmap_counit_natural
apply smash_pmap_counit_natural_right
end
definition smash_adjoint_pmap_inv_natural [constructor] {A B C C' : Type*} (f : C →* C') :
definition smash_adjoint_pmap_inv_natural_right [constructor] {A B C C' : Type*} (f : C →* C') :
ppcompose_left f ∘* smash_adjoint_pmap_inv A B C ~*
smash_adjoint_pmap_inv A B C' ∘* ppcompose_left (ppcompose_left f) :=
smash_pelim_natural f
smash_pelim_natural_right f
definition smash_adjoint_pmap_natural [constructor] {A B C C' : Type*} (f : C →* C') :
definition smash_adjoint_pmap_natural_right [constructor] {A B C C' : Type*} (f : C →* C') :
ppcompose_left (ppcompose_left f) ∘* smash_adjoint_pmap A B C ~*
smash_adjoint_pmap A B C' ∘* ppcompose_left f :=
(smash_adjoint_pmap_inv_natural f)⁻¹ʰ*
(smash_adjoint_pmap_inv_natural_right f)⁻¹ʰ*
definition smash_adjoint_pmap_natural_left (C : Type*) (f : A →* A') (g : B →* B') :
definition smash_adjoint_pmap_natural_lm (C : Type*) (f : A →* A') (g : B →* B') :
psquare (smash_adjoint_pmap A' B' C) (smash_adjoint_pmap A B C)
(ppcompose_right (f ∧→ g)) (ppcompose_left (ppcompose_right f) ∘* ppcompose_right g) :=
(smash_pelim_natural_left C g f)⁻¹ʰ*
(smash_pelim_natural_lm C g f)⁻¹ʰ*
/- Corollary: associativity of smash -/
@ -465,49 +421,49 @@ namespace smash
(A ∧ B) ∧ C →* X :=
smash_elim (ppcompose_left (smash_adjoint_pmap A B X)⁻¹ᵉ* (smash_elim_inv (smash_elim_inv f)))
definition smash_assoc_elim_natural (A B C : Type*) (f : X →* X') :
definition smash_assoc_elim_natural_right (A B C : Type*) (f : X →* X') :
psquare (smash_assoc_elim_equiv A B C X) (smash_assoc_elim_equiv A B C X')
(ppcompose_left f) (ppcompose_left f) :=
!smash_adjoint_pmap_natural ⬝h*
!smash_adjoint_pmap_natural ⬝h*
ppcompose_left_psquare !smash_adjoint_pmap_inv_natural ⬝h*
!smash_adjoint_pmap_inv_natural
!smash_adjoint_pmap_natural_right ⬝h*
!smash_adjoint_pmap_natural_right ⬝h*
ppcompose_left_psquare !smash_adjoint_pmap_inv_natural_right ⬝h*
!smash_adjoint_pmap_inv_natural_right
/-
We could prove the following two pointed homotopies by applying smash_assoc_elim_natural to g,
We could prove the following two pointed homotopies by applying smash_assoc_elim_natural_right to g,
but we give a more explicit proof
-/
definition smash_assoc_elim_natural_pt {A B C X X' : Type*} (f : X →* X') (g : A ∧ (B ∧ C) →* X) :
definition smash_assoc_elim_natural_right_pt {A B C X X' : Type*} (f : X →* X') (g : A ∧ (B ∧ C) →* X) :
f ∘* smash_assoc_elim_equiv A B C X g ~* smash_assoc_elim_equiv A B C X' (f ∘* g) :=
begin
refine !smash_adjoint_pmap_inv_natural_pt ⬝* _,
refine !smash_adjoint_pmap_inv_natural_right_pt ⬝* _,
apply smash_elim_phomotopy,
refine !passoc⁻¹* ⬝* _,
refine pwhisker_right _ !smash_adjoint_pmap_inv_natural ⬝* _,
refine pwhisker_right _ !smash_adjoint_pmap_inv_natural_right ⬝* _,
refine !passoc ⬝* _,
apply pwhisker_left,
refine !smash_adjoint_pmap_natural_pt ⬝* _,
refine !smash_adjoint_pmap_natural_right_pt ⬝* _,
apply smash_elim_inv_phomotopy,
refine !smash_adjoint_pmap_natural_pt
refine !smash_adjoint_pmap_natural_right_pt
end
definition smash_assoc_elim_inv_natural_pt {A B C X X' : Type*} (f : X →* X')
definition smash_assoc_elim_inv_natural_right_pt {A B C X X' : Type*} (f : X →* X')
(g : (A ∧ B) ∧ C →* X) :
f ∘* (smash_assoc_elim_equiv A B C X)⁻¹ᵉ* g ~* (smash_assoc_elim_equiv A B C X')⁻¹ᵉ* (f ∘* g) :=
begin
refine !smash_adjoint_pmap_inv_natural_pt ⬝* _,
refine !smash_adjoint_pmap_inv_natural_right_pt ⬝* _,
apply smash_elim_phomotopy,
refine !passoc⁻¹* ⬝* _,
refine pwhisker_right _ !smash_pmap_counit_natural ⬝* _,
refine pwhisker_right _ !smash_pmap_counit_natural_right ⬝* _,
refine !passoc ⬝* _,
apply pwhisker_left,
refine !smash_functor_pid_pcompose⁻¹* ⬝* _,
apply smash_functor_phomotopy phomotopy.rfl,
refine !passoc⁻¹* ⬝* _,
refine pwhisker_right _ !smash_adjoint_pmap_natural ⬝* _,
refine pwhisker_right _ !smash_adjoint_pmap_natural_right ⬝* _,
refine !passoc ⬝* _,
apply pwhisker_left,
apply smash_elim_inv_natural
apply smash_elim_inv_natural_right
end
definition smash_assoc (A B C : Type*) : A ∧ (B ∧ C) ≃* (A ∧ B) ∧ C :=
@ -515,10 +471,10 @@ namespace smash
fapply pequiv.MK2,
{ exact !smash_assoc_elim_equiv⁻¹ᵉ* !pid },
{ exact !smash_assoc_elim_equiv !pid },
{ refine !smash_assoc_elim_inv_natural_pt ⬝* _,
{ refine !smash_assoc_elim_inv_natural_right_pt ⬝* _,
refine pap !smash_assoc_elim_equiv⁻¹ᵉ* !pcompose_pid ⬝* _,
apply phomotopy_of_eq, apply to_left_inv !smash_assoc_elim_equiv },
{ refine !smash_assoc_elim_natural_pt ⬝* _,
{ refine !smash_assoc_elim_natural_right_pt ⬝* _,
refine pap !smash_assoc_elim_equiv !pcompose_pid ⬝* _,
apply phomotopy_of_eq, apply to_right_inv !smash_assoc_elim_equiv }
end
@ -529,21 +485,21 @@ namespace smash
psquare (smash_assoc_elim_equiv A' B' C' X) (smash_assoc_elim_equiv A B C X)
(ppcompose_right (f ∧→ g ∧→ h)) (ppcompose_right ((f ∧→ g) ∧→ h)) :=
begin
refine !smash_adjoint_pmap_natural_left ⬝h* _ ⬝h*
(!ppcompose_left_ppcompose_right ⬝v* ppcompose_left_psquare !smash_pelim_natural_left) ⬝h*
!smash_pelim_natural_left,
refine !smash_adjoint_pmap_natural_lm ⬝h* _ ⬝h*
(!ppcompose_left_ppcompose_right ⬝v* ppcompose_left_psquare !smash_pelim_natural_lm) ⬝h*
!smash_pelim_natural_lm,
refine !ppcompose_left_ppcompose_right⁻¹* ⬝ph* _,
refine _ ⬝hp* pwhisker_right _ (ppcompose_left_phomotopy !ppcompose_left_ppcompose_right⁻¹* ⬝*
!ppcompose_left_pcompose) ⬝* !passoc ⬝* pwhisker_left _ !ppcompose_left_ppcompose_right⁻¹* ⬝*
!passoc⁻¹*,
refine _ ⬝v* !smash_adjoint_pmap_natural_left,
refine !smash_adjoint_pmap_natural
refine _ ⬝v* !smash_adjoint_pmap_natural_lm,
refine !smash_adjoint_pmap_natural_right
end
definition smash_assoc_natural (f : A →* A') (g : B →* B') (h : C →* C') :
psquare (smash_assoc A B C) (smash_assoc A' B' C') (f ∧→ (g ∧→ h)) ((f ∧→ g) ∧→ h) :=
begin
refine !smash_assoc_elim_inv_natural_pt ⬝* _,
refine !smash_assoc_elim_inv_natural_right_pt ⬝* _,
refine pap !smash_assoc_elim_equiv⁻¹ᵉ* (!pcompose_pid ⬝* !pid_pcompose⁻¹*) ⬝* _,
rexact phomotopy_of_eq ((smash_assoc_elim_equiv_natural_left _ f g h)⁻¹ʰ* !pid)⁻¹
end

4
pointed.hlean
View file

@ -499,6 +499,10 @@ namespace pointed
(q : phsquare p₁₀ p₁₂ (p ⬝* p₀₁) p₂₁) : phsquare (p⁻¹* ⬝* p₁₀) p₁₂ p₀₁ p₂₁ :=
!trans_assoc ⬝ (eq_symm_trans_of_trans_eq (q ⬝ !trans_assoc)⁻¹)⁻¹
definition phmove_bot_of_left {p₀₁ : f₀₀ ~* f} (p : f ~* f₀₂)
(q : phsquare p₁₀ p₁₂ (p₀₁ ⬝* p) p₂₁) : phsquare p₁₀ (p ⬝* p₁₂) p₀₁ p₂₁ :=
q ⬝ !trans_assoc
definition passoc_phomotopy_right {A B C D : Type*} (h : C →* D) (g : B →* C) {f f' : A →* B}
(p : f ~* f') : phsquare (passoc h g f) (passoc h g f')
(pwhisker_left (h ∘* g) p) (pwhisker_left h (pwhisker_left g p)) :=