3d0d0947d6
some of the changes are backported from the hott3 library pi_pathover and pi_pathover' are interchanged (same for variants and for sigma) various definitions received explicit arguments: pinverse and eq_equiv_homotopy and ***.sigma_char eq_of_fn_eq_fn is renamed to inj in definitions about higher loop spaces and homotopy groups, the natural number arguments are now consistently before the type arguments
171 lines
6.6 KiB
Text
171 lines
6.6 KiB
Text
/-
|
||
Copyright (c) 2016 Jakob von Raumer. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Jakob von Raumer, Floris van Doorn
|
||
|
||
The Smash Product of Types.
|
||
|
||
One definition is the cofiber of the map
|
||
wedge A B → A × B
|
||
However, we define it (equivalently) as the pushout of the maps A + B → 2 and A + B → A × B.
|
||
-/
|
||
|
||
import homotopy.circle homotopy.join types.pointed homotopy.cofiber homotopy.wedge
|
||
|
||
open bool pointed eq equiv is_equiv sum bool prod unit circle cofiber prod.ops wedge
|
||
|
||
namespace smash
|
||
|
||
variables {A B : Type*}
|
||
|
||
section
|
||
open pushout
|
||
|
||
definition prod_of_sum [unfold 3] (u : A + B) : A × B :=
|
||
by induction u with a b; exact (a, pt); exact (pt, b)
|
||
|
||
definition bool_of_sum [unfold 3] (u : A + B) : bool :=
|
||
by induction u; exact ff; exact tt
|
||
|
||
definition smash' (A B : Type*) : Type := pushout (@prod_of_sum A B) (@bool_of_sum A B)
|
||
protected definition mk' (a : A) (b : B) : smash' A B := inl (a, b)
|
||
|
||
definition pointed_smash' [instance] [constructor] (A B : Type*) : pointed (smash' A B) :=
|
||
pointed.mk (smash.mk' pt pt)
|
||
definition smash [constructor] (A B : Type*) : Type* :=
|
||
pointed.mk' (smash' A B)
|
||
|
||
infixr ` ∧ ` := smash
|
||
|
||
protected definition mk (a : A) (b : B) : A ∧ B := inl (a, b)
|
||
definition auxl : smash A B := inr ff
|
||
definition auxr : smash A B := inr tt
|
||
definition gluel (a : A) : smash.mk a pt = auxl :> smash A B := glue (inl a)
|
||
definition gluer (b : B) : smash.mk pt b = auxr :> smash A B := glue (inr b)
|
||
|
||
end
|
||
|
||
definition gluel' (a a' : A) : smash.mk a pt = smash.mk a' pt :> smash A B :=
|
||
gluel a ⬝ (gluel a')⁻¹
|
||
definition gluer' (b b' : B) : smash.mk pt b = smash.mk pt b' :> smash A B :=
|
||
gluer b ⬝ (gluer b')⁻¹
|
||
definition glue (a : A) (b : B) : smash.mk a pt = smash.mk pt b :=
|
||
gluel' a pt ⬝ gluer' pt b
|
||
|
||
definition glue_pt_left (b : B) : glue (Point A) b = gluer' pt b :=
|
||
whisker_right _ !con.right_inv ⬝ !idp_con
|
||
|
||
definition glue_pt_right (a : A) : glue a (Point B) = gluel' a pt :=
|
||
proof whisker_left _ !con.right_inv qed
|
||
|
||
definition ap_mk_left {a a' : A} (p : a = a') : ap (λa, smash.mk a (Point B)) p = gluel' a a' :=
|
||
!ap_is_constant
|
||
|
||
definition ap_mk_right {b b' : B} (p : b = b') : ap (smash.mk (Point A)) p = gluer' b b' :=
|
||
!ap_is_constant
|
||
|
||
protected definition rec {P : smash A B → Type} (Pmk : Πa b, P (smash.mk a b))
|
||
(Pl : P auxl) (Pr : P auxr) (Pgl : Πa, Pmk a pt =[gluel a] Pl)
|
||
(Pgr : Πb, Pmk pt b =[gluer b] Pr) (x : smash' A B) : P x :=
|
||
begin
|
||
induction x with x b u,
|
||
{ induction x with a b, exact Pmk a b },
|
||
{ induction b, exact Pl, exact Pr },
|
||
{ induction u: esimp,
|
||
{ apply Pgl },
|
||
{ apply Pgr }}
|
||
end
|
||
|
||
theorem rec_gluel {P : smash A B → Type} {Pmk : Πa b, P (smash.mk a b)}
|
||
{Pl : P auxl} {Pr : P auxr} (Pgl : Πa, Pmk a pt =[gluel a] Pl)
|
||
(Pgr : Πb, Pmk pt b =[gluer b] Pr) (a : A) :
|
||
apd (smash.rec Pmk Pl Pr Pgl Pgr) (gluel a) = Pgl a :=
|
||
!pushout.rec_glue
|
||
|
||
theorem rec_gluer {P : smash A B → Type} {Pmk : Πa b, P (smash.mk a b)}
|
||
{Pl : P auxl} {Pr : P auxr} (Pgl : Πa, Pmk a pt =[gluel a] Pl)
|
||
(Pgr : Πb, Pmk pt b =[gluer b] Pr) (b : B) :
|
||
apd (smash.rec Pmk Pl Pr Pgl Pgr) (gluer b) = Pgr b :=
|
||
!pushout.rec_glue
|
||
|
||
theorem rec_glue {P : smash A B → Type} {Pmk : Πa b, P (smash.mk a b)}
|
||
{Pl : P auxl} {Pr : P auxr} (Pgl : Πa, Pmk a pt =[gluel a] Pl)
|
||
(Pgr : Πb, Pmk pt b =[gluer b] Pr) (a : A) (b : B) :
|
||
apd (smash.rec Pmk Pl Pr Pgl Pgr) (glue a b) =
|
||
(Pgl a ⬝o (Pgl pt)⁻¹ᵒ) ⬝o (Pgr pt ⬝o (Pgr b)⁻¹ᵒ) :=
|
||
by rewrite [↑glue, ↑gluel', ↑gluer', +apd_con, +apd_inv, +rec_gluel, +rec_gluer]
|
||
|
||
protected definition elim {P : Type} (Pmk : Πa b, P) (Pl Pr : P)
|
||
(Pgl : Πa : A, Pmk a pt = Pl) (Pgr : Πb : B, Pmk pt b = Pr) (x : smash' A B) : P :=
|
||
smash.rec Pmk Pl Pr (λa, pathover_of_eq _ (Pgl a)) (λb, pathover_of_eq _ (Pgr b)) x
|
||
|
||
-- an elim where you are forced to make (Pgl pt) and (Pgl pt) to be reflexivity
|
||
protected definition elim' [reducible] {P : Type} (Pmk : Πa b, P)
|
||
(Pgl : Πa : A, Pmk a pt = Pmk pt pt) (Pgr : Πb : B, Pmk pt b = Pmk pt pt)
|
||
(ql : Pgl pt = idp) (qr : Pgr pt = idp) (x : smash' A B) : P :=
|
||
smash.elim Pmk (Pmk pt pt) (Pmk pt pt) Pgl Pgr x
|
||
|
||
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) :
|
||
ap (smash.elim Pmk Pl Pr Pgl Pgr) (gluel a) = Pgl a :=
|
||
begin
|
||
apply inj_inv !(pathover_constant (@gluel A B a)),
|
||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑smash.elim,rec_gluel],
|
||
end
|
||
|
||
theorem elim_gluer {P : Type} {Pmk : Πa b, P} {Pl Pr : P}
|
||
(Pgl : Πa : A, Pmk a pt = Pl) (Pgr : Πb : B, Pmk pt b = Pr) (b : B) :
|
||
ap (smash.elim Pmk Pl Pr Pgl Pgr) (gluer b) = Pgr b :=
|
||
begin
|
||
apply inj_inv !(pathover_constant (@gluer A B b)),
|
||
rewrite [▸*,-apd_eq_pathover_of_eq_ap,↑smash.elim,rec_gluer],
|
||
end
|
||
|
||
theorem elim_glue {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) (b : B) :
|
||
ap (smash.elim Pmk Pl Pr Pgl Pgr) (glue a b) = (Pgl a ⬝ (Pgl pt)⁻¹) ⬝ (Pgr pt ⬝ (Pgr b)⁻¹) :=
|
||
by rewrite [↑glue, ↑gluel', ↑gluer', +ap_con, +ap_inv, +elim_gluel, +elim_gluer]
|
||
|
||
end smash
|
||
open smash
|
||
attribute smash.mk smash.mk' auxl auxr [constructor]
|
||
attribute smash.elim' smash.rec smash.elim [unfold 9] [recursor 9]
|
||
|
||
namespace smash
|
||
|
||
variables {A B : Type*}
|
||
|
||
definition of_smash_pbool [unfold 2] (x : smash A pbool) : A :=
|
||
begin
|
||
induction x,
|
||
{ induction b, exact pt, exact a },
|
||
{ exact pt },
|
||
{ exact pt },
|
||
{ reflexivity },
|
||
{ induction b: reflexivity }
|
||
end
|
||
|
||
definition smash_pbool_pequiv [constructor] (A : Type*) : smash A pbool ≃* A :=
|
||
begin
|
||
fapply pequiv_of_equiv,
|
||
{ fapply equiv.MK,
|
||
{ exact of_smash_pbool },
|
||
{ intro a, exact smash.mk a tt },
|
||
{ intro a, reflexivity },
|
||
{ exact abstract begin intro x, induction x,
|
||
{ induction b, exact gluer' tt pt ⬝ gluel' pt a, reflexivity },
|
||
{ exact gluer' tt ff ⬝ gluel pt, },
|
||
{ exact gluer tt, },
|
||
{ apply eq_pathover_id_right,
|
||
refine ap_compose (λa, smash.mk a tt) _ _ ⬝ ap02 _ !elim_gluel ⬝ph _,
|
||
apply square_of_eq_top, refine !con.assoc⁻¹ ⬝ whisker_right _ !idp_con⁻¹ },
|
||
{ apply eq_pathover_id_right,
|
||
refine ap_compose (λa, smash.mk a tt) _ _ ⬝ ap02 _ !elim_gluer ⬝ph _,
|
||
induction b: esimp,
|
||
{ apply square_of_eq_top,
|
||
refine whisker_left _ !con.right_inv ⬝ !con_idp ⬝ whisker_right _ !idp_con⁻¹ },
|
||
{ apply square_of_eq idp }} end end }},
|
||
{ reflexivity }
|
||
end
|
||
|
||
end smash
|