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

feat(pointed): define phomotopy as a dependent pointed function

Browse source 
this also requires dependent pointed functions to be generalized to the case where the type family only has a point over the basepoint of the basetype
This commit is contained in:
Floris van Doorn 2017-06-17 17:20:04 -04:00
parent a1126cfcf2
commit 39a8c7fef4
5 changed files with 68 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
hott/homotopy/susp.hlean
View file

@ -275,7 +275,7 @@ namespace susp
: loop_psusp_unit Y ∘* f ~* Ω→ (psusp_functor f) ∘* loop_psusp_unit X :=
begin
induction X with X x, induction Y with Y y, induction f with f pf, esimp at *, induction pf,
fconstructor,
fapply phomotopy.mk,
{ intro x', symmetry,
exact
!ap1_gen_idp_left ⬝

44
hott/init/pointed.hlean
View file

@ -84,9 +84,12 @@ namespace pointed
end pointed
/- pointed maps -/
structure ppi (A : Type*) (P : A → Type*) :=
structure ppi_gen {A : Type*} (P : A → Type) (x₀ : P pt) :=
(to_fun : Π a : A, P a)
(resp_pt : to_fun (Point A) = Point (P (Point A)))
(resp_pt : to_fun (Point A) = x₀)
definition ppi {A : Type*} (P : A → Type*) : Type :=
ppi_gen P pt
-- We could try to define pmap as a special case of ppi
-- definition pmap (A B : Type*) := @ppi A (λa, B)
@ -95,11 +98,23 @@ structure pmap (A B : Type*) :=
(resp_pt : to_fun (Point A) = Point B)
namespace pointed
definition ppi.mk [constructor] [reducible] {A : Type*} {P : A → Type*} (f : Πa, P a)
(p : f pt = pt) : ppi P :=
ppi_gen.mk f p
definition ppi.to_fun [unfold 3] [coercion] [reducible] {A : Type*} {P : A → Type*} (f : ppi P)
(a : A) : P a :=
ppi_gen.to_fun f a
definition ppi.resp_pt [unfold 3] [reducible] {A : Type*} {P : A → Type*} (f : ppi P) :
f pt = pt :=
ppi_gen.resp_pt f
abbreviation respect_pt [unfold 3] := @pmap.resp_pt
notation `map₊` := pmap
infix ` →* `:30 := pmap
attribute pmap.to_fun ppi.to_fun [coercion]
notation `Π*` binders `, ` r:(scoped P, ppi _ P) := r
attribute pmap.to_fun ppi_gen.to_fun [coercion]
-- notation `Π*` binders `, ` r:(scoped P, ppi _ P) := r
-- definition pmap.mk [constructor] {A B : Type*} (f : A → B) (p : f pt = pt) : A →* B :=
-- ppi.mk f p
-- definition pmap.to_fun [coercion] [unfold 3] {A B : Type*} (f : A →* B) : A → B := f
@ -107,16 +122,25 @@ namespace pointed
end pointed open pointed
/- pointed homotopies -/
structure phomotopy {A B : Type*} (f g : A →* B) :=
(homotopy : f ~ g)
(homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f)
definition phomotopy {A B : Type*} (f g : A →* B) : Type :=
ppi_gen (λa, f a = g a) (respect_pt f ⬝ (respect_pt g)⁻¹)
-- structure phomotopy {A B : Type*} (f g : A →* B) : Type :=
-- (homotopy : f ~ g)
-- (homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f)
namespace pointed
variables {A B : Type*} {f g : A →* B}
infix ` ~* `:50 := phomotopy
abbreviation to_homotopy_pt [unfold 5] := @phomotopy.homotopy_pt
abbreviation to_homotopy [coercion] [unfold 5] (p : f ~* g) : Πa, f a = g a :=
phomotopy.homotopy p
definition phomotopy.mk [reducible] [constructor] (h : f ~ g)
(p : h pt ⬝ respect_pt g = respect_pt f) : f ~* g :=
ppi_gen.mk h (eq_con_inv_of_con_eq p)
definition to_homotopy [coercion] [unfold 5] [reducible] (p : f ~* g) : Πa, f a = g a := p
definition to_homotopy_pt [unfold 5] [reducible] (p : f ~* g) :
p pt ⬝ respect_pt g = respect_pt f :=
con_eq_of_eq_con_inv (ppi_gen.resp_pt p)
end pointed

19
hott/types/eq.hlean
View file

@ -126,19 +126,19 @@ namespace eq
definition eq_transport_l (p : a₁ = a₂) (q : a₁ = a₃)
: transport (λx, x = a₃) p q = p⁻¹ ⬝ q :=
by induction p; induction q; reflexivity
by induction p; exact !idp_con⁻¹
definition eq_transport_r (p : a₂ = a₃) (q : a₁ = a₂)
: transport (λx, a₁ = x) p q = q ⬝ p :=
by induction p; induction q; reflexivity
by induction p; reflexivity
definition eq_transport_lr (p : a₁ = a₂) (q : a₁ = a₁)
: transport (λx, x = x) p q = p⁻¹ ⬝ q ⬝ p :=
by induction p; rewrite [▸*,idp_con]
by induction p; exact !idp_con⁻¹
definition eq_transport_Fl (p : a₁ = a₂) (q : f a₁ = b)
definition eq_transport_Fl [unfold 7] (p : a₁ = a₂) (q : f a₁ = b)
: transport (λx, f x = b) p q = (ap f p)⁻¹ ⬝ q :=
by induction p; induction q; reflexivity
by induction p; exact !idp_con⁻¹
definition eq_transport_Fr (p : a₁ = a₂) (q : b = f a₁)
: transport (λx, b = f x) p q = q ⬝ (ap f p) :=
@ -146,27 +146,26 @@ namespace eq
definition eq_transport_FlFr (p : a₁ = a₂) (q : f a₁ = g a₁)
: transport (λx, f x = g x) p q = (ap f p)⁻¹ ⬝ q ⬝ (ap g p) :=
by induction p; rewrite [▸*,idp_con]
by induction p; exact !idp_con⁻¹
definition eq_transport_FlFr_D {B : A → Type} {f g : Πa, B a}
(p : a₁ = a₂) (q : f a₁ = g a₁)
: transport (λx, f x = g x) p q = (apdt f p)⁻¹ ⬝ ap (transport B p) q ⬝ (apdt g p) :=
by induction p; rewrite [▸*,idp_con,ap_id]
by induction p; exact !ap_id⁻¹ ⬝ !idp_con⁻¹
definition eq_transport_FFlr (p : a₁ = a₂) (q : h (f a₁) = a₁)
: transport (λx, h (f x) = x) p q = (ap h (ap f p))⁻¹ ⬝ q ⬝ p :=
by induction p; rewrite [▸*,idp_con]
by induction p; exact !idp_con⁻¹
definition eq_transport_lFFr (p : a₁ = a₂) (q : a₁ = h (f a₁))
: transport (λx, x = h (f x)) p q = p⁻¹ ⬝ q ⬝ (ap h (ap f p)) :=
by induction p; rewrite [▸*,idp_con]
by induction p; exact !idp_con⁻¹
/- Pathovers -/
-- In the comment we give the fibration of the pathover
-- we should probably try to do everything just with pathover_eq (defined in cubical.square),
-- the following definitions may be removed in future.
definition eq_pathover_l (p : a₁ = a₂) (q : a₁ = a₃) : q =[p] p⁻¹ ⬝ q := /-(λx, x = a₃)-/
by induction p; induction q; exact idpo

28
hott/types/pointed.hlean
View file

@ -138,14 +138,14 @@ namespace pointed
definition pid_pcompose [constructor] (f : A →* B) : pid B ∘* f ~* f :=
begin
fconstructor,
fapply phomotopy.mk,
{ intro a, reflexivity},
{ reflexivity}
end
definition pcompose_pid [constructor] (f : A →* B) : f ∘* pid A ~* f :=
begin
fconstructor,
fapply phomotopy.mk,
{ intro a, reflexivity},
{ reflexivity}
end
@ -310,7 +310,7 @@ namespace pointed
protected definition phomotopy.refl [constructor] [refl] (f : A →* B) : f ~* f :=
begin
fconstructor,
fapply phomotopy.mk,
{ intro a, exact idp},
{ apply idp_con}
end
@ -330,18 +330,29 @@ namespace pointed
/- equalities and equivalences relating pointed homotopies -/
definition phomotopy.rec' [recursor] (P : f ~* g → Type)
(H : Π(h : f ~ g) (p : h pt ⬝ respect_pt g = respect_pt f), P (phomotopy.mk h p))
(h : f ~* g) : P h :=
begin
induction h with h p,
refine transport (λp, P (ppi_gen.mk h p)) _ (H h (con_eq_of_eq_con_inv p)),
apply to_left_inv !eq_con_inv_equiv_con_eq p
end
definition phomotopy.sigma_char [constructor] {A B : Type*} (f g : A →* B)
: (f ~* g) ≃ Σ(p : f ~ g), p pt ⬝ respect_pt g = respect_pt f :=
begin
fapply equiv.MK : intros h,
{ exact ⟨h , to_homotopy_pt h⟩ },
all_goals cases h with h p,
{ exact phomotopy.mk h p },
all_goals reflexivity
{ cases h with h p, exact phomotopy.mk h p },
{ cases h with h p, exact ap (dpair h) (to_right_inv !eq_con_inv_equiv_con_eq p) },
{ induction h using phomotopy.rec' with h p, esimp,
exact ap (phomotopy.mk h) (to_right_inv !eq_con_inv_equiv_con_eq p) },
end
definition phomotopy.eta_expand [constructor] {A B : Type*} {f g : A →* B} (p : f ~* g) : f ~* g :=
phomotopy.mk p (phomotopy.homotopy_pt p)
definition phomotopy.eta_expand [constructor] {A B : Type*} {f g : A →* B} (p : f ~* g) :
f ~* g :=
phomotopy.mk p (to_homotopy_pt p)
definition is_trunc_pmap [instance] (n : ℕ₋₂) (A B : Type*) [is_trunc n B] :
is_trunc n (A →* B) :=
@ -458,6 +469,7 @@ namespace pointed
induction p using phomotopy_rec_on_eq,
induction q, exact H
end
attribute phomotopy.rec' [recursor]
definition phomotopy_rec_on_eq_phomotopy_of_eq {A B : Type*} {f g: A →* B}
{Q : (f ~* g) → Type} (p : f = g) (H : Π(q : f = g), Q (phomotopy_of_eq q)) :

5
hott/types/sigma.hlean
View file

@ -32,9 +32,12 @@ namespace sigma
definition dpair_eq_dpair [unfold 8] (p : a = a') (q : b =[p] b') : ⟨a, b⟩ = ⟨a', b'⟩ :=
apd011 sigma.mk p q
definition sigma_eq [unfold 3 4] (p : u.1 = v.1) (q : u.2 =[p] v.2) : u = v :=
definition sigma_eq [unfold 5 6] (p : u.1 = v.1) (q : u.2 =[p] v.2) : u = v :=
by induction u; induction v; exact (dpair_eq_dpair p q)
definition sigma_eq_right [unfold 6] (q : b₁ = b₂) : ⟨a, b₁⟩ = ⟨a, b₂⟩ :=
ap (dpair a) q
definition eq_pr1 [unfold 5] (p : u = v) : u.1 = v.1 :=
ap pr1 p