continue working on higher groups

higher_groups.hlean

@@ -7,8 +7,9 @@ Formalization of the higher groups paper
 -/
 
 import .move_to_lib
-open eq is_conn pointed is_trunc trunc equiv is_equiv trunc_index susp nat algebra
+open eq is_conn pointed is_trunc trunc equiv is_equiv trunc_index susp nat algebra prod.ops sigma sigma.ops
 namespace higher_group
+set_option pp.binder_types true
 
   /- We require that the carrier has a point (preserved by the equivalence) -/
 
@@ -38,13 +39,39 @@ namespace higher_group
   open ωGrp (renaming B→oB e→oe)
 
   /- some basic properties -/
+  lemma is_trunc_B' (G : [n;k]Grp) : is_trunc (k+n) (B G) :=
+  begin
+    apply is_trunc_of_is_trunc_loopn,
+    exact is_trunc_equiv_closed _ (e G),
+    exact _
+  end
+
   lemma is_trunc_B (G : [n;k]Grp) : is_trunc (n+k) (B G) :=
-  sorry
+  transport (λm, is_trunc m (B G)) (add.comm k n) (is_trunc_B' G)
+
+  local attribute [instance] is_trunc_B
 
   /- some equivalences -/
   definition Grp_equiv (n k : ℕ) : [n;k]Grp ≃ (n+k)-Type*[k] :=
+  let f : Π(B : Type*[k]) (H : Σ(X : n-Type*), X ≃* Ω[k] B), (n+k)-Type*[k] :=
+    λB' H, ptruncconntype.mk B' (is_trunc_B (Grp.mk H.1 B' H.2)) pt _
+  in
+  calc
+    [n;k]Grp ≃ Σ(B : Type*[k]), Σ(X : n-Type*), X ≃* Ω[k] B : sorry
+         ... ≃ Σ(B : (n+k)-Type*[k]), Σ(X : n-Type*), X ≃* Ω[k] B :
+               @sigma_equiv_of_is_embedding_left _ _ _ sorry ptruncconntype.to_pconntype sorry
+                 (λB' H, fiber.mk (f B' H) sorry)
+         ... ≃ Σ(B : (n+k)-Type*[k]), Σ(X : n-Type*),
+                 X = ptrunctype_of_pType (Ω[k] B) !is_trunc_loopn_nat :> n-Type* :
+               sigma_equiv_sigma_right (λB, sigma_equiv_sigma_right (λX, sorry))
+         ... ≃ (n+k)-Type*[k] : sigma_equiv_of_is_contr_right
+
+  definition Grp_eq_equiv {n k : ℕ} (G H : [n;k]Grp) : (G = H) ≃ (B G ≃* B H) :=
   sorry
 
+  definition Grp_eq {n k : ℕ} {G H : [n;k]Grp} (e : B G ≃* B H) : G = H :=
+  (Grp_eq_equiv G H)⁻¹ᵉ e
+
   definition InfGrp_equiv (k : ℕ) : [∞;k]Grp ≃ Type*[k] :=
   sorry
 
@@ -52,57 +79,61 @@ namespace higher_group
 
   /- Constructions -/
   definition Decat (G : [n+1;k]Grp) : [n;k]Grp :=
-  Grp.mk (ptrunctype.mk (ptrunc n G) _ pt) (pconntype.mk (ptrunc (n +[ℕ₋₂] k) (B G)) _ pt)
+  Grp.mk (ptrunctype.mk (ptrunc n G) _ pt) (pconntype.mk (ptrunc (n + k) (B G)) _ pt)
     abstract begin
       refine ptrunc_pequiv_ptrunc n (e G) ⬝e* _,
-      symmetry, exact !loopn_ptrunc_pequiv
+      symmetry, exact sorry --!loopn_ptrunc_pequiv
     end end
 
   definition Disc (G : [n;k]Grp) : [n+1;k]Grp :=
   Grp.mk (ptrunctype.mk G (show is_trunc (n.+1) G, from _) pt) (B G) (e G)
 
-  definition Disc_adjoint_Decat (G : [n;k]Grp) (H : [n+1;k]Grp) :
+  definition Decat_adjoint_Disc (G : [n+1;k]Grp) (H : [n;k]Grp) :
-    ppmap (B (Disc G)) (B H) ≃* ppmap (B G) (B (Decat H)) :=
+    ppmap (B (Decat G)) (B H) ≃* ppmap (B G) (B (Disc H)) :=
+  pmap_ptrunc_pequiv (n + k) (B G) (B H)
+
+  definition Decat_adjoint_Disc_natural {G G' : [n+1;k]Grp} {H H' : [n;k]Grp}
+    (eG : B G' ≃* B G) (eH : B H ≃* B H') :
+    psquare (Decat_adjoint_Disc G H)
+            (Decat_adjoint_Disc G' H')
+            (ppcompose_left eH ∘* ppcompose_right (ptrunc_functor _ eG))
+            (ppcompose_left eH ∘* ppcompose_right eG) :=
   sorry
-  /- To do: naturality -/
 
   definition Decat_Disc (G : [n;k]Grp) : Decat (Disc G) = G :=
-  sorry
+  Grp_eq !ptrunc_pequiv
 
   definition InfDecat (n : ℕ) (G : [∞;k]Grp) : [n;k]Grp :=
-  Grp.mk (ptrunctype.mk (ptrunc n G) _ pt) (pconntype.mk (ptrunc (n +[ℕ₋₂] k) (iB G)) _ pt)
+  Grp.mk (ptrunctype.mk (ptrunc n G) _ pt) (pconntype.mk (ptrunc (n + k) (iB G)) _ pt)
     abstract begin
       refine ptrunc_pequiv_ptrunc n (ie G) ⬝e* _,
-      symmetry, exact !loopn_ptrunc_pequiv
+      symmetry, exact !loopn_ptrunc_pequiv_nat
     end end
 
   definition InfDisc (n : ℕ) (G : [n;k]Grp) : [∞;k]Grp :=
   InfGrp.mk G (B G) (e G)
 
-  definition InfDisc_adjoint_InfDecat (G : [n;k]Grp) (H : [∞;k]Grp) :
+  definition InfDecat_adjoint_InfDisc (G : [∞;k]Grp) (H : [n;k]Grp) :
-    ppmap (iB (InfDisc n G)) (iB H) ≃* ppmap (B G) (B (InfDecat n H)) :=
+    ppmap (B (InfDecat n G)) (B H) ≃* ppmap (iB G) (iB (InfDisc n H)) :=
-  sorry
+  pmap_ptrunc_pequiv (n + k) (iB G) (B H)
+
   /- To do: naturality -/
 
   definition InfDecat_InfDisc (G : [n;k]Grp) : InfDecat n (InfDisc n G) = G :=
   sorry
 
   definition Loop (G : [n+1;k]Grp) : [n;k+1]Grp :=
-  have is_trunc (n.+1) G, from !is_trunc_ptrunctype,
+  Grp.mk (ptrunctype.mk (Ω G) !is_trunc_loop_nat pt)
-  Grp.mk (ptrunctype.mk (Ω G) !is_trunc_loop pt)
+    (connconnect (k+1) (B G))
-    sorry
     abstract begin
-      exact sorry
+      exact loop_pequiv_loop (e G) ⬝e* (loopn_connect k (B G))⁻¹ᵉ* ⬝e* _
     end end
 
   definition Deloop (G : [n;k+1]Grp) : [n+1;k]Grp :=
-  have is_conn (k.+1) (B G), from !is_conn_pconntype,
   have is_trunc (n + (k + 1)) (B G), from is_trunc_B G,
-  have is_trunc (n +[ℕ] 1 +[ℕ₋₂] k) (pconntype.to_pType (B G)), from transport (λn, is_trunc n _)
+  have is_trunc ((n + 1) + k) (B G), from transport (λ(n : ℕ), is_trunc n _) (succ_add n k)⁻¹ this,
-    (ap trunc_index.of_nat (nat.succ_add n k)⁻¹ ⬝ !of_nat_add_of_nat⁻¹) this,
+  Grp.mk (ptrunctype.mk (Ω[k] (B G)) !is_trunc_loopn_nat pt)
-  have is_trunc (n + 1) (Ω[k] (B G)), from !is_trunc_loopn,
+    (pconntype.mk (B G) !is_conn_of_is_conn_succ_nat pt)
-  Grp.mk (ptrunctype.mk (Ω[k] (B G)) _ pt)
-    (pconntype.mk (B G) !is_conn_of_is_conn_succ pt)
     (pequiv_of_equiv erfl idp)
 
   /- to do: adjunction, and Loop ∘ Deloop = id -/

move_to_lib.hlean

@@ -568,98 +568,119 @@ end lift
 namespace trunc
   open trunc_index
 
+
 definition Prop_eq {P Q : Prop} (H : P ↔ Q) : P = Q :=
 tua (equiv_of_is_prop (iff.mp H) (iff.mpr H))
 
-  definition trunc_index_equiv_nat [constructor] : ℕ₋₂ ≃ ℕ :=
+definition trunc_index_equiv_nat [constructor] : ℕ₋₂ ≃ ℕ :=
-  equiv.MK add_two sub_two add_two_sub_two sub_two_add_two
+equiv.MK add_two sub_two add_two_sub_two sub_two_add_two
 
-  definition is_set_trunc_index [instance] : is_set ℕ₋₂ :=
+definition is_set_trunc_index [instance] : is_set ℕ₋₂ :=
-  is_trunc_equiv_closed_rev 0 trunc_index_equiv_nat
+is_trunc_equiv_closed_rev 0 trunc_index_equiv_nat
 
-  definition is_contr_ptrunc_minus_one (A : Type*) : is_contr (ptrunc -1 A) :=
+definition is_contr_ptrunc_minus_one (A : Type*) : is_contr (ptrunc -1 A) :=
-  is_contr_of_inhabited_prop pt
+is_contr_of_inhabited_prop pt
 
-  -- TODO: redefine loopn_ptrunc_pequiv
+-- TODO: redefine loopn_ptrunc_pequiv
-  definition apn_ptrunc_functor (n : ℕ₋₂) (k : ℕ) {A B : Type*} (f : A →* B) :
+definition apn_ptrunc_functor (n : ℕ₋₂) (k : ℕ) {A B : Type*} (f : A →* B) :
-    Ω→[k] (ptrunc_functor (n+k) f) ∘* (loopn_ptrunc_pequiv n k A)⁻¹ᵉ* ~*
+  Ω→[k] (ptrunc_functor (n+k) f) ∘* (loopn_ptrunc_pequiv n k A)⁻¹ᵉ* ~*
-    (loopn_ptrunc_pequiv n k B)⁻¹ᵉ* ∘* ptrunc_functor n (Ω→[k] f) :=
+  (loopn_ptrunc_pequiv n k B)⁻¹ᵉ* ∘* ptrunc_functor n (Ω→[k] f) :=
-  begin
+begin
-    revert n, induction k with k IH: intro n,
+  revert n, induction k with k IH: intro n,
-    { reflexivity },
+  { reflexivity },
-    { exact sorry }
+  { exact sorry }
-  end
+end
 
-  definition ptrunc_pequiv_natural [constructor] (n : ℕ₋₂) {A B : Type*} (f : A →* B) [is_trunc n A]
+definition ptrunc_pequiv_natural [constructor] (n : ℕ₋₂) {A B : Type*} (f : A →* B) [is_trunc n A]
-    [is_trunc n B] : f ∘* ptrunc_pequiv n A ~* ptrunc_pequiv n B ∘* ptrunc_functor n f :=
+  [is_trunc n B] : f ∘* ptrunc_pequiv n A ~* ptrunc_pequiv n B ∘* ptrunc_functor n f :=
-  begin
+begin
-    fapply phomotopy.mk,
+  fapply phomotopy.mk,
-    { intro a, induction a with a, reflexivity },
+  { intro a, induction a with a, reflexivity },
-    { refine !idp_con ⬝ _ ⬝ !idp_con⁻¹, refine !ap_compose'⁻¹ ⬝ _, apply ap_id }
+  { refine !idp_con ⬝ _ ⬝ !idp_con⁻¹, refine !ap_compose'⁻¹ ⬝ _, apply ap_id }
-  end
+end
 
-  definition ptr_natural [constructor] (n : ℕ₋₂) {A B : Type*} (f : A →* B) :
+definition ptr_natural [constructor] (n : ℕ₋₂) {A B : Type*} (f : A →* B) :
-    ptrunc_functor n f ∘* ptr n A ~* ptr n B ∘* f :=
+  ptrunc_functor n f ∘* ptr n A ~* ptr n B ∘* f :=
-  begin
+begin
-    fapply phomotopy.mk,
+  fapply phomotopy.mk,
-    { intro a, reflexivity },
+  { intro a, reflexivity },
-    { reflexivity }
+  { reflexivity }
-  end
+end
 
-  definition ptrunc_elim_pcompose (n : ℕ₋₂) {A B C : Type*} (g : B →* C) (f : A →* B) [is_trunc n B]
+definition ptrunc_elim_pcompose (n : ℕ₋₂) {A B C : Type*} (g : B →* C) (f : A →* B) [is_trunc n B]
-    [is_trunc n C] : ptrunc.elim n (g ∘* f) ~* g ∘* ptrunc.elim n f :=
+  [is_trunc n C] : ptrunc.elim n (g ∘* f) ~* g ∘* ptrunc.elim n f :=
-  begin
+begin
-    fapply phomotopy.mk,
+  fapply phomotopy.mk,
-    { intro a, induction a with a, reflexivity },
+  { intro a, induction a with a, reflexivity },
-    { apply idp_con }
+  { apply idp_con }
-  end
+end
 
-  definition ptrunc_elim_ptr_phomotopy_pid (n : ℕ₋₂) (A : Type*):
+definition ptrunc_elim_ptr_phomotopy_pid (n : ℕ₋₂) (A : Type*):
-    ptrunc.elim n (ptr n A) ~* pid (ptrunc n A) :=
+  ptrunc.elim n (ptr n A) ~* pid (ptrunc n A) :=
-  begin
+begin
-    fapply phomotopy.mk,
+  fapply phomotopy.mk,
-    { intro a, induction a with a, reflexivity },
+  { intro a, induction a with a, reflexivity },
-    { apply idp_con }
+  { apply idp_con }
-  end
+end
 
-  definition is_trunc_ptrunc_of_is_trunc [instance] [priority 500] (A : Type*)
+definition is_trunc_ptrunc_of_is_trunc [instance] [priority 500] (A : Type*)
-    (n m : ℕ₋₂) [H : is_trunc n A] : is_trunc n (ptrunc m A) :=
+  (n m : ℕ₋₂) [H : is_trunc n A] : is_trunc n (ptrunc m A) :=
-  is_trunc_trunc_of_is_trunc A n m
+is_trunc_trunc_of_is_trunc A n m
 
-  definition ptrunc_pequiv_ptrunc_of_is_trunc {n m k : ℕ₋₂} {A : Type*}
+definition ptrunc_pequiv_ptrunc_of_is_trunc {n m k : ℕ₋₂} {A : Type*}
-    (H1 : n ≤ m) (H2 : n ≤ k) (H : is_trunc n A) : ptrunc m A ≃* ptrunc k A :=
+  (H1 : n ≤ m) (H2 : n ≤ k) (H : is_trunc n A) : ptrunc m A ≃* ptrunc k A :=
-  have is_trunc m A, from is_trunc_of_le A H1,
+have is_trunc m A, from is_trunc_of_le A H1,
-  have is_trunc k A, from is_trunc_of_le A H2,
+have is_trunc k A, from is_trunc_of_le A H2,
-  pequiv.MK (ptrunc.elim _ (ptr k A)) (ptrunc.elim _ (ptr m A))
+pequiv.MK (ptrunc.elim _ (ptr k A)) (ptrunc.elim _ (ptr m A))
-    abstract begin
+  abstract begin
-      refine !ptrunc_elim_pcompose⁻¹* ⬝* _,
+    refine !ptrunc_elim_pcompose⁻¹* ⬝* _,
-      exact ptrunc_elim_phomotopy _ !ptrunc_elim_ptr ⬝* !ptrunc_elim_ptr_phomotopy_pid,
+    exact ptrunc_elim_phomotopy _ !ptrunc_elim_ptr ⬝* !ptrunc_elim_ptr_phomotopy_pid,
-    end end
+  end end
-    abstract begin
+  abstract begin
-      refine !ptrunc_elim_pcompose⁻¹* ⬝* _,
+    refine !ptrunc_elim_pcompose⁻¹* ⬝* _,
-      exact ptrunc_elim_phomotopy _ !ptrunc_elim_ptr ⬝* !ptrunc_elim_ptr_phomotopy_pid,
+    exact ptrunc_elim_phomotopy _ !ptrunc_elim_ptr ⬝* !ptrunc_elim_ptr_phomotopy_pid,
-    end end
+  end end
 
-  definition ptrunc_change_index {k l : ℕ₋₂} (p : k = l) (X : Type*)
+definition ptrunc_change_index {k l : ℕ₋₂} (p : k = l) (X : Type*)
-    : ptrunc k X ≃* ptrunc l X :=
+  : ptrunc k X ≃* ptrunc l X :=
-  pequiv_ap (λ n, ptrunc n X) p
+pequiv_ap (λ n, ptrunc n X) p
 
-  definition ptrunc_functor_le {k l : ℕ₋₂} (p : l ≤ k) (X : Type*)
+definition ptrunc_functor_le {k l : ℕ₋₂} (p : l ≤ k) (X : Type*)
-    : ptrunc k X →* ptrunc l X :=
+  : ptrunc k X →* ptrunc l X :=
-  have is_trunc k (ptrunc l X), from is_trunc_of_le _ p,
+have is_trunc k (ptrunc l X), from is_trunc_of_le _ p,
-  ptrunc.elim _ (ptr l X)
+ptrunc.elim _ (ptr l X)
 
-  definition trunc_index.pred [unfold 1] (n : ℕ₋₂) : ℕ₋₂ :=
+definition trunc_index.pred [unfold 1] (n : ℕ₋₂) : ℕ₋₂ :=
-  begin cases n with n, exact -2, exact n end
+begin cases n with n, exact -2, exact n end
 
-  /- A more general version of ptrunc_elim_phomotopy, where the proofs of truncatedness might be different -/
+/- A more general version of ptrunc_elim_phomotopy, where the proofs of truncatedness might be different -/
-  definition ptrunc_elim_phomotopy2 [constructor] (k : ℕ₋₂) {A B : Type*} {f g : A →* B} (H₁ : is_trunc k B)
+definition ptrunc_elim_phomotopy2 [constructor] (k : ℕ₋₂) {A B : Type*} {f g : A →* B} (H₁ : is_trunc k B)
-    (H₂ : is_trunc k B) (p : f ~* g) : @ptrunc.elim k A B H₁ f ~* @ptrunc.elim k A B H₂ g :=
+  (H₂ : is_trunc k B) (p : f ~* g) : @ptrunc.elim k A B H₁ f ~* @ptrunc.elim k A B H₂ g :=
-  begin
+begin
-    fapply phomotopy.mk,
+  fapply phomotopy.mk,
-    { intro x, induction x with a, exact p a },
+  { intro x, induction x with a, exact p a },
-    { exact to_homotopy_pt p }
+  { exact to_homotopy_pt p }
-  end
+end
+
+definition pmap_ptrunc_equiv [constructor] (n : ℕ₋₂) (A B : Type*) [H : is_trunc n B] :
+  (ptrunc n A →* B) ≃ (A →* B) :=
+begin
+  fapply equiv.MK,
+  { intro g, exact g ∘* ptr n A },
+  { exact ptrunc.elim n },
+  { intro f, apply eq_of_phomotopy, apply ptrunc_elim_ptr },
+  { intro g, apply eq_of_phomotopy,
+    exact ptrunc_elim_pcompose n g (ptr n A) ⬝* pwhisker_left g (ptrunc_elim_ptr_phomotopy_pid n A) ⬝*
+      pcompose_pid g }
+end
+
+definition pmap_ptrunc_pequiv [constructor] (n : ℕ₋₂) (A B : Type*) [H : is_trunc n B] :
+  ppmap (ptrunc n A) B ≃* ppmap A B :=
+pequiv_of_equiv (pmap_ptrunc_equiv n A B) (eq_of_phomotopy (pconst_pcompose (ptr n A)))
+
+definition loopn_ptrunc_pequiv_nat (n : ℕ) (k : ℕ) (A : Type*) :
+  Ω[k] (ptrunc (n+k) A) ≃* ptrunc n (Ω[k] A) :=
+loopn_pequiv_loopn k (ptrunc_change_index (of_nat_add_of_nat n k)⁻¹ A) ⬝e* loopn_ptrunc_pequiv n k A
 
 end trunc
 
@@ -667,6 +688,14 @@ namespace is_trunc
 
   open trunc_index is_conn
 
+  lemma is_trunc_loopn_nat (m n : ℕ) (A : Type*) [H : is_trunc (n + m) A] :
+    is_trunc n (Ω[m] A) :=
+  @is_trunc_loopn n m A (transport (λk, is_trunc k _) (of_nat_add_of_nat n m)⁻¹ H)
+
+  lemma is_trunc_loop_nat (n : ℕ) (A : Type*) [H : is_trunc (n + 1) A] :
+    is_trunc n (Ω A) :=
+  is_trunc_loop A n
+
   definition is_trunc_of_eq {n m : ℕ₋₂} (p : n = m) {A : Type} (H : is_trunc n A) : is_trunc m A :=
   transport (λk, is_trunc k A) p H
 
@@ -794,6 +823,20 @@ by induction q'; reflexivity
       sigma_functor_homotopy h k x ⬝
       (sigma_functor_compose g₁₂ g₀₁ x)⁻¹
 
+definition sigma_equiv_of_embedding_left_fun [constructor] {X Y : Type} {P : Y → Type} {f : X → Y}
+  (H : Πy, P y → fiber f y) (v : Σy, P y) : Σx, P (f x) :=
+⟨fiber.point (H v.1 v.2), transport P (point_eq (H v.1 v.2))⁻¹ v.2⟩
+
+definition sigma_equiv_of_is_embedding_left [constructor] {X Y : Type} {P : Y → Type} [HP : Πy, is_prop (P y)]
+  {f : X → Y} (Hf : is_embedding f) (H : Πy, P y → fiber f y) : (Σy, P y) ≃ Σx, P (f x) :=
+begin
+  apply equiv.MK (sigma_equiv_of_embedding_left_fun H) (sigma_functor f (λa, id)),
+  { intro v, induction v with x p, esimp [sigma_equiv_of_embedding_left_fun],
+    fapply sigma_eq, apply @is_injective_of_is_embedding _ _ f, exact point_eq (H (f x) p),
+    apply is_prop.elimo },
+  { intro v, induction v with y p, esimp, fapply sigma_eq, exact point_eq (H y p), apply is_prop.elimo },
+end
+
 end sigma open sigma
 
 namespace group
@@ -1022,6 +1065,22 @@ namespace is_conn
     (H : is_conn_fun n g) (K : is_conn_fun n f) : is_conn_fun n (g ∘ f) :=
   sorry
 
+/- the k-connectification of X, the fiber of the map X → ∥X∥ₖ. -/
+definition connect (k : ℕ) (X : Type*) : Type* :=
+pfiber (ptr k X)
+
+definition is_conn_connect (k : ℕ) (X : Type*) : is_conn k (connect k X) :=
+sorry
+
+definition connconnect [constructor] (k : ℕ) (X : Type*) : Type*[k]  :=
+pconntype.mk (connect k X) (is_conn_connect k X) pt
+
+definition loopn_connect (k : ℕ) (X : Type*) : Ω[k+1] (connect k X) ≃* Ω[k+1] X :=
+sorry
+
+definition is_conn_of_is_conn_succ_nat (n : ℕ) (A : Type) [is_conn (n+1) A] : is_conn n A :=
+is_conn_of_is_conn_succ n A
+
 end is_conn
 
 namespace misc