move naturality of loop-susp-adjunction to standard library

hott/algebra/inf_group.hlean

@@ -594,17 +594,15 @@ definition inf_group_of_add_inf_group (A : Type) [G : add_inf_group A] : inf_gro
   inv             := has_neg.neg,
   mul_left_inv    := add.left_inv ⦄
 
-namespace norm_num
+theorem add.comm4 [s : add_comm_inf_semigroup A] :
+  Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
+comm4 add.comm add.assoc
 
 definition add1 [s : has_add A] [s' : has_one A] (a : A) : A := add a one
 
 theorem add_comm_three [s : add_comm_inf_semigroup A] (a b c : A) : a + b + c = c + b + a :=
   by rewrite [{a + _}add.comm, {_ + c}add.comm, -*add.assoc]
 
-theorem add.comm4 [s : add_comm_inf_semigroup A] :
-  Π (n m k l : A), n + m + (k + l) = n + k + (m + l) :=
-comm4 add.comm add.assoc
-
 theorem add_comm_four [s : add_comm_inf_semigroup A] (a b : A) :
   a + a + (b + b) = (a + b) + (a + b) :=
 !add.comm4
@@ -706,20 +704,5 @@ theorem subst_into_sum [s : has_add A] (l r tl tr t : A) (prl : l = tl) (prr : r
 theorem neg_zero_helper [s : add_inf_group A] (a : A) (H : a = 0) : - a = 0 :=
   by rewrite [H, neg_zero]
 
-end norm_num
 
 end algebra
-open algebra
-
-attribute [simp]
-  zero_add add_zero one_mul mul_one
-  at simplifier.unit
-
-attribute [simp]
-  neg_neg sub_eq_add_neg
-  at simplifier.neg
-
-attribute [simp]
-  add.assoc add.comm add.left_comm
-  mul.left_comm mul.comm mul.assoc
-  at simplifier.ac

hott/homotopy/join.hlean

@@ -511,20 +511,26 @@ end join
 namespace join
 
   open sphere sphere.ops
+
+  definition join_susp (A B : Type) : join (susp A) B ≃ susp (join A B) :=
+  calc join (susp A) B
+           ≃ join (join bool A) B
+           : join_equiv_join (join_bool A)⁻¹ᵉ erfl
+       ... ≃ join bool (join A B)
+           : join_assoc
+       ... ≃ susp (join A B)
+           : join_bool (join A B)
+
   definition join_sphere (n m : ℕ) : join (S n) (S m) ≃ S (n+m+1) :=
   begin
     refine join_symm (S n) (S m) ⬝e _,
     induction m with m IH,
     { exact join_bool (S n) },
     { calc join (S (m+1)) (S n)
-           ≃ join (join bool (S m)) (S n)
+           ≃ susp (join (S m) (S n))
-           : join_equiv_join (join_bool (S m))⁻¹ᵉ erfl
+           : join_susp (S m) (S n)
-       ... ≃ join bool (join (S m) (S n))
-           : join_assoc
-       ... ≃ join bool (S (n+m+1))
-           : join_equiv_join erfl IH
        ... ≃ sphere (n+m+2)
-           : join_bool (S (n+m+1)) }
+           : susp.equiv IH }
   end
 
 end join

hott/homotopy/susp.hlean

@@ -8,7 +8,7 @@ Declaration of suspension
 
 import hit.pushout types.pointed2 cubical.square .connectedness
 
-open pushout unit eq equiv pointed
+open pushout unit eq equiv pointed is_equiv
 
 definition susp' (A : Type) : Type := pushout (λ(a : A), star) (λ(a : A), star)
 
@@ -204,7 +204,7 @@ end susp
 
 namespace susp
   open pointed is_trunc
-  variables {X Y Z : Type*}
+  variables {X X' Y Y' Z : Type*}
 
   definition susp_functor [constructor] (f : X →* Y) : susp X →* susp Y :=
   begin
@@ -394,24 +394,68 @@ namespace susp
     { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
   end
 
-  definition susp_adjoint_loop_pconst (X Y : Type*) :
+  definition susp_functor_pconst_homotopy [unfold 3] {X Y : Type*} (x : susp X) :
-    susp_adjoint_loop_unpointed X Y (pconst (susp X) Y) ~* pconst X (Ω Y) :=
+    susp_functor (pconst X Y) x = pt :=
   begin
-    refine pwhisker_right _ !ap1_pconst ⬝* _,
+    induction x,
-    apply pconst_pcompose
+    { reflexivity },
+    { exact (merid pt)⁻¹ },
+    { apply eq_pathover, refine !elim_merid ⬝ph _ ⬝hp !ap_constant⁻¹, exact square_of_eq !con.right_inv⁻¹ }
+  end
+
+  definition susp_functor_pconst [constructor] (X Y : Type*) : susp_functor (pconst X Y) ~* pconst (susp X) (susp Y) :=
+  begin
+    fapply phomotopy.mk,
+    { exact susp_functor_pconst_homotopy },
+    { reflexivity }
+  end
+
+  definition susp_pfunctor [constructor] (X Y : Type*) : ppmap X Y →* ppmap (susp X) (susp Y) :=
+  pmap.mk susp_functor (eq_of_phomotopy !susp_functor_pconst)
+
+  definition susp_pelim [constructor] (X Y : Type*) : ppmap X (Ω Y) →* ppmap (susp X) Y :=
+  ppcompose_left (loop_susp_counit Y) ∘* susp_pfunctor X (Ω Y)
+
+  definition loop_susp_pintro [constructor] (X Y : Type*) : ppmap (susp X) Y →* ppmap X (Ω Y) :=
+  ppcompose_right (loop_susp_unit X) ∘* pap1 (susp X) Y
+
+  definition loop_susp_pintro_natural_left (f : X' →* X) :
+    psquare (loop_susp_pintro X Y) (loop_susp_pintro X' Y)
+            (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
+  !pap1_natural_left ⬝h* ppcompose_right_psquare (loop_susp_unit_natural f)⁻¹*
+
+  definition loop_susp_pintro_natural_right (f : Y →* Y') :
+    psquare (loop_susp_pintro X Y) (loop_susp_pintro X Y')
+            (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
+  !pap1_natural_right ⬝h* !ppcompose_left_ppcompose_right⁻¹*
+
+  definition is_equiv_loop_susp_pintro [constructor] (X Y : Type*) :
+    is_equiv (loop_susp_pintro X Y) :=
+  begin
+    fapply adjointify,
+    { exact susp_pelim X Y },
+    { intro g, apply eq_of_phomotopy, exact susp_adjoint_loop_right_inv g },
+    { intro f, apply eq_of_phomotopy, exact susp_adjoint_loop_left_inv f }
   end
 
   definition susp_adjoint_loop [constructor] (X Y : Type*) : ppmap (susp X) Y ≃* ppmap X (Ω Y) :=
-  begin
+  pequiv_of_pmap (loop_susp_pintro X Y) (is_equiv_loop_susp_pintro X Y)
-    apply pequiv_of_equiv (susp_adjoint_loop_unpointed X Y),
+
-    apply eq_of_phomotopy,
+  definition susp_adjoint_loop_natural_right (f : Y →* Y') :
-    apply susp_adjoint_loop_pconst
+    psquare (susp_adjoint_loop X Y) (susp_adjoint_loop X Y')
-  end
+            (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
+  loop_susp_pintro_natural_right f
+
+  definition susp_adjoint_loop_natural_left (f : X' →* X) :
+    psquare (susp_adjoint_loop X Y) (susp_adjoint_loop X' Y)
+            (ppcompose_right (susp_functor f)) (ppcompose_right f) :=
+  loop_susp_pintro_natural_left f
 
   definition ap1_susp_elim {A : Type*} {X : Type*} (p : A →* Ω X) :
     Ω→(susp_elim p) ∘* loop_susp_unit A ~* p :=
   susp_adjoint_loop_right_inv p
 
+  /- the underlying homotopies of susp_adjoint_loop_natural_* -/
   definition susp_adjoint_loop_nat_right (f : susp X →* Y) (g : Y →* Z)
     : susp_adjoint_loop X Z (g ∘* f) ~* ap1 g ∘* susp_adjoint_loop X Y f :=
   begin