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

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

hott/homotopy/susp.hlean

@@ -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 ⬝

hott/init/pointed.hlean

@@ -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]
+  attribute pmap.to_fun ppi_gen.to_fun [coercion]
-  notation `Π*` binders `, ` r:(scoped P, ppi _ P) := r
+  -- 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) :=
+definition phomotopy {A B : Type*} (f g : A →* B) : Type :=
-  (homotopy : f ~ g)
+ppi_gen (λa, f a = g a) (respect_pt f ⬝ (respect_pt g)⁻¹)
-  (homotopy_pt : homotopy pt ⬝ respect_pt g = respect_pt f)
+
+-- 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
+  definition phomotopy.mk [reducible] [constructor] (h : f ~ g)
-  abbreviation to_homotopy [coercion] [unfold 5] (p : f ~* g) : Πa, f a = g a :=
+    (p : h pt ⬝ respect_pt g = respect_pt f) : f ~* g :=
-  phomotopy.homotopy p
+  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

hott/types/eq.hlean

@@ -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

hott/types/pointed.hlean

@@ -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,
+    { cases h with h p, exact phomotopy.mk 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) },
-    all_goals reflexivity
+    { 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 :=
+  definition phomotopy.eta_expand [constructor] {A B : Type*} {f g : A →* B} (p : f ~* g) :
-  phomotopy.mk p (phomotopy.homotopy_pt p)
+    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)) :

hott/types/sigma.hlean

@@ -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