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

more on pushouts, interaction with sums, and induction principle for certain cofibers

Browse source 
latter part ported from Agda
This commit is contained in:
Floris van Doorn 2017-01-08 22:46:54 +01:00
parent cb3fac2fb3
commit b7f53b90d7
2 changed files with 175 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

168
homotopy/pushout.hlean
View file

@ -6,6 +6,11 @@ open eq function is_trunc sigma prod lift is_equiv equiv pointed sum unit bool
namespace pushout
/-
WIP: proving that satisfying the universal property of the pushout is equivalent to
being equivalent to the pushout
-/
universe variables u₁ u₂ u₃ u₄
variables {A : Type.{u₁}} {B : Type.{u₂}} {C : Type.{u₃}} {D D' : Type.{u₄}}
{f : A → B} {g : A → C} {h : B → D} {k : C → D} (p : h ∘ f ~ k ∘ g)
@ -125,6 +130,8 @@ namespace pushout
-- }
-- end
/- composing pushouts -/
definition pushout_vcompose_to [unfold 8] {A B C D : Type} {f : A → B} {g : A → C} {h : B → D}
(x : pushout h (@inl _ _ _ f g)) : pushout (h ∘ f) g :=
begin
@ -207,25 +214,6 @@ namespace pushout
... ≃ pushout hg f : by exact pushout_vcompose_equiv _ (e ⬝e pushout.symm f g) p q
... ≃ pushout f hg : pushout.symm
-- is the following even true?
-- definition pushout_vcancel_right [constructor] {A B C D E : Type} {f : A → B} {g : A → C}
-- (h : B → D) (k : B → E) (e : pushout h k ≃ pushout (h ∘ f) g)
-- (p : e ∘ inl ~ inl) : E ≃ pushout f g :=
-- begin
-- fapply equiv.MK,
-- { intro x, note aux := refl (e (inr x)), revert aux,
-- refine pushout.rec (λy (p : e (inr x) = inl y), _) _ _ (e (inr x)),
-- intro d q, note r := eq_of_fn_eq_fn e (q ⬝ (p d)⁻¹), exact sorry,
-- intro c q, exact inr c,
-- intro a, exact sorry },
-- { intro x, induction x with b c a,
-- { exact k b },
-- { },
-- { }},
-- { },
-- { }
-- end
definition pushout_of_equiv_left_to [unfold 6] {A B C : Type} {f : A ≃ B} {g : A → C}
(x : pushout f g) : C :=
begin
@ -257,46 +245,50 @@ namespace pushout
pushout f g ≃ pushout g f : pushout.symm f g
... ≃ B : pushout_of_equiv_left g f
/- pushout where one map is constant is a cofiber -/
definition pushout_const_equiv_to [unfold 6] {A B C : Type} {f : A → B} {c₀ : C}
(x : pushout f (const A c₀)) : pushout (sum_functor f (const unit c₀)) (const _ ⋆) :=
(x : pushout (const A c₀) f) : cofiber (sum_functor f (const unit c₀)) :=
begin
induction x with b c a,
{ exact inl (sum.inl b) },
{ exact inl (sum.inr c) },
{ exact glue (sum.inl a) ⬝ (glue (sum.inr ⋆))⁻¹ }
induction x with c b a,
{ exact inr (sum.inr c) },
{ exact inr (sum.inl b) },
{ exact (glue (sum.inr ⋆))⁻¹ ⬝ glue (sum.inl a) }
end
definition pushout_const_equiv_from [unfold 6] {A B C : Type} {f : A → B} {c₀ : C}
(x : pushout (sum_functor f (const unit c₀)) (const _ ⋆)) : pushout f (const A c₀) :=
(x : cofiber (sum_functor f (const unit c₀))) : pushout (const A c₀) f :=
begin
induction x with v u v,
{ induction v with b c, exact inl b, exact inr c },
{ exact inr c₀ },
induction x with v v,
{ exact inl c₀ },
{ induction v with b c, exact inr b, exact inl c },
{ induction v with a u, exact glue a, reflexivity }
end
definition pushout_const_equiv [constructor] {A B C : Type} (f : A → B) (c₀ : C) :
pushout f (const A c₀) ≃ pushout (sum_functor f (const unit c₀)) (const _ ⋆) :=
pushout (const A c₀) f ≃ cofiber (sum_functor f (const unit c₀)) :=
begin
fapply equiv.MK,
{ exact pushout_const_equiv_to },
{ exact pushout_const_equiv_from },
{ intro x, induction x with v u v,
{ intro x, induction x with v v,
{ exact (glue (sum.inr ⋆))⁻¹ },
{ induction v with b c, reflexivity, reflexivity },
{ induction u, exact glue (sum.inr ⋆) },
{ apply eq_pathover_id_right,
refine ap_compose pushout_const_equiv_to _ _ ⬝ ap02 _ !elim_glue ⬝ph _,
induction v with a u,
{ refine !elim_glue ⬝ph _, apply whisker_bl, exact hrfl},
{ induction u, exact square_of_eq idp }}},
{ intro x, induction x with b c a,
{ refine !elim_glue ⬝ph _, esimp, apply whisker_tl, exact hrfl },
{ induction u, exact square_of_eq !con.left_inv }}},
{ intro x, induction x with c b a,
{ reflexivity },
{ reflexivity },
{ apply eq_pathover_id_right, apply hdeg_square,
refine ap_compose pushout_const_equiv_from _ _ ⬝ ap02 _ !elim_glue ⬝ _,
exact !ap_con ⬝ !elim_glue ◾ (!ap_inv ⬝ !elim_glue⁻²) }}
refine !ap_con ⬝ (!ap_inv ⬝ !elim_glue⁻²) ◾ !elim_glue ⬝ !idp_con }}
end
/- wedge is the cofiber of the map 2 -> A + B -/
-- move to sum
definition sum_of_bool [unfold 3] (A B : Type*) (b : bool) : A + B :=
by induction b; exact sum.inl pt; exact sum.inr pt
@ -306,18 +298,22 @@ namespace pushout
-- move to wedge
definition wedge_equiv_pushout_sum [constructor] (A B : Type*) :
wedge A B ≃ pushout (sum_of_bool A B) (const bool ⋆) :=
wedge A B ≃ cofiber (sum_of_bool A B) :=
begin
refine !pushout.symm ⬝e _,
refine pushout_const_equiv _ _ ⬝e _,
fapply pushout.equiv,
exact bool_equiv_unit_sum_unit⁻¹ᵉ,
reflexivity,
reflexivity,
intro x, induction x: reflexivity,
reflexivity
en
d
intro x, induction x with u u: induction u; reflexivity
end
section
open prod.ops
/- products preserve pushouts -/
definition pushout_prod_equiv_to [unfold 7] {A B C D : Type} {f : A → B} {g : A → C}
(xd : pushout f g × D) : pushout (prod_functor f (@id D)) (prod_functor g id) :=
begin
@ -352,7 +348,99 @@ d
{ reflexivity },
{ reflexivity },
{ apply eq_pathover, apply hdeg_square,
exact ap_compose pushout_prod_equiv_from _ _ ⬝ ap02 _ !elim_glue ⬝ !elim_glue }}
refine ap_compose (pushout_prod_equiv_from ∘ pushout_prod_equiv_to) _ _ ⬝ _,
refine ap02 _ !ap_prod_mk_left ⬝ !ap_compose ⬝ _,
refine ap02 _ (!ap_prod_elim ⬝ !idp_con ⬝ !elim_glue) ⬝ _,
refine !elim_glue ⬝ !ap_prod_mk_left⁻¹ }}
end
end
/- interaction of pushout and sums -/
definition pushout_to_sum [unfold 8] {A B C : Type} {f : A → B} {g : A → C} (D : Type) (c₀ : C)
(x : pushout f g) : pushout (sum_functor f (@id D)) (sum.rec g (λd, c₀)) :=
begin
induction x with b c a,
{ exact inl (sum.inl b) },
{ exact inr c },
{ exact glue (sum.inl a) }
end
definition pushout_from_sum [unfold 8] {A B C : Type} {f : A → B} {g : A → C} (D : Type) (c₀ : C)
(x : pushout (sum_functor f (@id D)) (sum.rec g (λd, c₀))) : pushout f g :=
begin
induction x with x c x,
{ induction x with b d, exact inl b, exact inr c₀ },
{ exact inr c },
{ induction x with a d, exact glue a, reflexivity }
end
definition pushout_sum_equiv [constructor] {A B C : Type} (f : A → B) (g : A → C) (D : Type)
(c₀ : C) : pushout f g ≃ pushout (sum_functor f (@id D)) (sum.rec g (λd, c₀)) :=
begin
fapply equiv.MK,
{ exact pushout_to_sum D c₀ },
{ exact pushout_from_sum D c₀ },
{ intro x, induction x with x c x,
{ induction x with b d, reflexivity, esimp, exact (glue (sum.inr d))⁻¹ },
{ reflexivity },
{ apply eq_pathover_id_right,
refine ap_compose (pushout_to_sum D c₀) _ _ ⬝ ap02 _ !elim_glue ⬝ph _,
induction x with a d: esimp,
{ exact hdeg_square !elim_glue },
{ exact square_of_eq !con.left_inv }}},
{ intro x, induction x with b c a,
{ reflexivity },
{ reflexivity },
{ apply eq_pathover_id_right, apply hdeg_square,
refine ap_compose (pushout_from_sum D c₀) _ _ ⬝ ap02 _ !elim_glue ⬝ !elim_glue }}
end
/- an induction principle for the cofiber of f : A → B if A is a pushout where the second map has a section.
The Pgluer is modified to get the right coherence
See https://github.com/HoTT/HoTT-Agda/blob/master/theorems/homotopy/elims/CofPushoutSection.agda
-/
open sigma.ops
definition cofiber_pushout_helper' {A : Type} {B : A → Type} {a₀₀ a₀₂ a₂₀ a₂₂ : A} {p₀₁ : a₀₀ = a₀₂}
{p₁₀ : a₀₀ = a₂₀} {p₂₁ : a₂₀ = a₂₂} {p₁₂ : a₀₂ = a₂₂} {s : square p₀₁ p₂₁ p₁₀ p₁₂}
{b₀₀ : B a₀₀} {b₂₀ b₂₀' : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂} {q₁₀ : b₀₀ =[p₁₀] b₂₀}
{q₀₁ : b₀₀ =[p₀₁] b₀₂} {q₂₁ : b₂₀' =[p₂₁] b₂₂} {q₁₂ : b₀₂ =[p₁₂] b₂₂} :
Σ(r : b₂₀' = b₂₀), squareover B s q₀₁ (r ▸ q₂₁) q₁₀ q₁₂ :=
begin
induction s,
induction q₀₁ using idp_rec_on,
induction q₂₁ using idp_rec_on,
induction q₁₀ using idp_rec_on,
induction q₁₂ using idp_rec_on,
exact ⟨idp, idso⟩
end
definition cofiber_pushout_helper {A B C D : Type} {f : A → B} {g : A → C} {h : pushout f g → D}
{P : cofiber h → Type} {Pbase : P (cofiber.base h)} {Pcod : Πd, P (cofiber.cod h d)}
(Pgluel : Π(b : B), Pbase =[cofiber.glue (inl b)] Pcod (h (inl b)))
(Pgluer : Π(c : C), Pbase =[cofiber.glue (inr c)] Pcod (h (inr c)))
(a : A) : Σ(p : Pbase = Pbase), squareover P (natural_square cofiber.glue (glue a))
(Pgluel (f a)) (p ▸ Pgluer (g a))
(pathover_ap P (λa, cofiber.base h) (apd (λa, Pbase) (glue a)))
(pathover_ap P (λa, cofiber.cod h (h a)) (apd (λa, Pcod (h a)) (glue a))) :=
!cofiber_pushout_helper'
definition cofiber_pushout_rec {A B C D : Type} {f : A → B} {g : A → C} {h : pushout f g → D}
{P : cofiber h → Type} (Pbase : P (cofiber.base h)) (Pcod : Πd, P (cofiber.cod h d))
(Pgluel : Π(b : B), Pbase =[cofiber.glue (inl b)] Pcod (h (inl b)))
(Pgluer : Π(c : C), Pbase =[cofiber.glue (inr c)] Pcod (h (inr c)))
(r : C → A) (p : Πa, r (g a) = a)
(x : cofiber h) : P x :=
begin
induction x with d x,
{ exact Pbase },
{ exact Pcod d },
{ induction x with b c a,
{ exact Pgluel b },
{ exact (cofiber_pushout_helper Pgluel Pgluer (r c)).1 ▸ Pgluer c },
{ apply pathover_pathover, rewrite [p a], exact (cofiber_pushout_helper Pgluel Pgluer a).2 }}
end
end pushout

81
homotopy/smash.hlean
View file

@ -3,21 +3,20 @@
import homotopy.smash ..move_to_lib .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
function red_susp unit
/- smash A (susp B) = susp (smash A B) <- this follows from associativity and smash with S¹ -/
/- To prove: Σ(X × Y) ≃ ΣX ∨ ΣY ∨ Σ(X ∧ Y) (?) (notation means suspension, wedge, smash) -/
/- To prove: Σ(X × Y) ≃ ΣX ∨ ΣY ∨ Σ(X ∧ Y) (notation means suspension, wedge, smash),
and both are equivalent to the reduced join -/
/- To prove: Σ(X ∧ Y) ≃ X ★ Y (?) (notation means suspension, smash, join) -/
/- To prove: associative -/
/- smash A B ≃ pcofiber (pprod_of_pwedge A B) -/
/- To prove: associative, A ∧ S¹ ≃ ΣA -/
variables {A B : Type*}
namespace smash
/- smash A B ≃ pcofiber (pprod_of_pwedge A B) -/
theorem elim_gluel' {P : Type} {Pmk : Πa b, P} {Pl Pr : P}
(Pgl : Πa : A, Pmk a pt = Pl) (Pgr : Πb : B, Pmk pt b = Pr) (a a' : A) :
ap (smash.elim Pmk Pl Pr Pgl Pgr) (gluel' a a') = Pgl a ⬝ (Pgl a')⁻¹ :=
@ -93,10 +92,10 @@ namespace pushout
A + B <-- 2 --> 1 -/
definition pushout_wedge_of_sum_equiv_unit : pushout (@wedge_of_sum A B) bool_of_sum ≃ unit :=
begin
refine pushout_hcompose_equiv (sum_of_bool A B) (wedge_equiv_pushout_sum A B ⬝e !pushout.symm)
refine pushout_hcompose_equiv (sum_of_bool A B) (wedge_equiv_pushout_sum A B)
_ _ ⬝e _,
exact erfl,
reflexivity,
intro x, induction x: esimp,
exact bool_of_sum_of_bool,
apply pushout_of_equiv_right
end
@ -106,6 +105,25 @@ end pushout open pushout
namespace smash
variables (A B)
definition smash_punit_pequiv [constructor] : smash A punit ≃* punit :=
begin
fapply pequiv_of_equiv,
{ fapply equiv.MK,
{ exact λx, ⋆ },
{ exact λx, pt },
{ intro x, induction x, reflexivity },
{ exact abstract begin intro x, induction x,
{ induction b, exact gluel' pt a },
{ exact gluel pt },
{ exact gluer pt },
{ apply eq_pathover_constant_left_id_right, apply square_of_eq_top,
exact whisker_right _ !idp_con⁻¹ },
{ apply eq_pathover_constant_left_id_right, induction b,
refine !con.right_inv ⬝pv _, exact square_of_eq idp } end end }},
{ reflexivity }
end
definition smash_equiv_cofiber : smash A B ≃ cofiber (@prod_of_wedge A B) :=
begin
unfold [smash, cofiber, smash'], symmetry,
@ -133,7 +151,7 @@ namespace smash
/- commutativity -/
definition smash_flip (x : smash A B) : smash B A :=
definition smash_flip [unfold 3] (x : smash A B) : smash B A :=
begin
induction x,
{ exact smash.mk b a },
@ -143,7 +161,7 @@ namespace smash
{ exact gluel b }
end
definition smash_flip_smash_flip (x : smash A B) : smash_flip (smash_flip x) = x :=
definition smash_flip_smash_flip [unfold 3] (x : smash A B) : smash_flip (smash_flip x) = x :=
begin
induction x,
{ reflexivity },
@ -157,7 +175,7 @@ namespace smash
apply hrfl }
end
definition smash_comm : smash A B ≃* smash B A :=
definition smash_comm [constructor] : smash A B ≃* smash B A :=
begin
fapply pequiv_of_equiv,
{ apply equiv.MK, do 2 exact smash_flip_smash_flip },
@ -194,7 +212,7 @@ namespace smash
exact ap_is_constant gluer loop ⬝ !con.right_inv }
end
definition smash_pcircle_of_psusp_of_smash_pcircle_pt [unfold 3] (a : A) (x : S¹*) :
definition smash_pcircle_of_red_susp_of_smash_pcircle_pt [unfold 3] (a : A) (x : S¹*) :
smash_pcircle_of_red_susp (red_susp_of_smash_pcircle (smash.mk a x)) = smash.mk a x :=
begin
induction x,
@ -238,7 +256,7 @@ namespace smash
esimp, exact !idp_con ⬝ !elim_loop },
{ exact sorry } end end },
{ intro x, induction x,
{ exact smash_pcircle_of_psusp_of_smash_pcircle_pt a b },
{ exact smash_pcircle_of_red_susp_of_smash_pcircle_pt a b },
{ exact gluel pt },
{ exact gluer pt },
{ apply eq_pathover_id_right,
@ -255,18 +273,12 @@ namespace smash
{ exact whisker_right _ !con.right_inv },
{ apply eq_pathover_dep, refine !apd_con_fn ⬝pho _ ⬝hop !apd_con_fn⁻¹,
refine ap (λx, concat2o x _) !rec_loop ⬝pho _ ⬝hop (ap011 concat2o (apd_compose1 (λa b, ap smash_pcircle_of_red_susp b) (circle_elim_constant equator_pt) loop) !apd_constant')⁻¹,
}
exact sorry }
}}},
{ reflexivity }
end
print apd_constant
print apd_compose2
print apd_compose1
print apd_con
print eq_pathover_dep
--set_option pp.all true
print smash.elim_gluer
/- smash A S¹ = susp A -/
open susp
@ -301,17 +313,19 @@ print smash.elim_gluer
refine ap02 _ (elim_loop north (merid a ⬝ (merid pt)⁻¹)) ⬝ph _,
refine !ap_con ⬝ (!elim_merid ◾ (!ap_inv ⬝ !elim_merid⁻²)) ⬝ph _,
-- make everything below this a lemma defined by path induction?
refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, refine !con.assoc⁻¹ ⬝ph _,
apply whisker_bl, apply whisker_lb,
refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, apply hrfl
refine !con_idp⁻¹ ⬝pv _, apply whisker_tl,
refine !con.assoc⁻¹ ⬝ph _, apply whisker_bl, apply whisker_lb, apply hrfl
apply square_of_eq, rewrite [+con.assoc], apply whisker_left, apply whisker_left,
symmetry, apply con_eq_of_eq_inv_con, esimp, apply con_eq_of_eq_con_inv,
refine _⁻² ⬝ !con_inv, refine _ ⬝ !con.assoc,
refine _ ⬝ whisker_right _ !inv_con_cancel_right⁻¹, refine _ ⬝ !con.right_inv⁻¹,
refine !con.right_inv ◾ _, refine _ ◾ !con.right_inv,
refine !ap_mk_right ⬝ !con.right_inv end end }
exact sorry,
-- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, refine !con.assoc⁻¹ ⬝ph _,
-- apply whisker_bl, apply whisker_lb,
-- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl, apply hrfl
-- refine !con_idp⁻¹ ⬝pv _, apply whisker_tl,
-- refine !con.assoc⁻¹ ⬝ph _, apply whisker_bl, apply whisker_lb, apply hrfl
-- apply square_of_eq, rewrite [+con.assoc], apply whisker_left, apply whisker_left,
-- symmetry, apply con_eq_of_eq_inv_con, esimp, apply con_eq_of_eq_con_inv,
-- refine _⁻² ⬝ !con_inv, refine _ ⬝ !con.assoc,
-- refine _ ⬝ whisker_right _ !inv_con_cancel_right⁻¹, refine _ ⬝ !con.right_inv⁻¹,
-- refine !con.right_inv ◾ _, refine _ ◾ !con.right_inv,
-- refine !ap_mk_right ⬝ !con.right_inv
end end }
end
-- definition smash_pcircle_of_psusp_of_smash_pcircle_gluer_base (b : S¹*)
@ -366,4 +380,3 @@ exit
end
end smash
-- (X × A) → Y ≃ X → A → Y