Merge branch 'master' of https://github.com/cmu-phil/Spectral

algebra/group_constructions.hlean

@@ -220,7 +220,7 @@ namespace group
     is_contr (Σ(g : quotient_group N →g G'), g ∘g gq_map N = f) :=
   sorry
 
-  /- Binary products (direct sums) of Groups -/
+  /- Binary products (direct product) of Groups -/
   definition product_one [constructor] : G × G' := (one, one)
   definition product_inv [unfold 3] : G × G' → G × G' :=
   λv, (v.1⁻¹, v.2⁻¹)

homotopy/spectrum.hlean

@@ -6,14 +6,17 @@ Authors: Michael Shulman, Floris van Doorn
 -/
 
 import types.int types.pointed types.trunc homotopy.susp algebra.homotopy_group homotopy.chain_complex cubical .splice homotopy.LES_of_homotopy_groups
-open eq nat int susp pointed pmap sigma is_equiv equiv fiber algebra trunc trunc_index pi
+open eq nat int susp pointed pmap sigma is_equiv equiv fiber algebra trunc trunc_index pi group
 
 /-----------------------------------------
   Stuff that should go in other files
 -----------------------------------------/
 
-attribute equiv.symm equiv.trans is_equiv.is_equiv_ap fiber.equiv_postcompose fiber.equiv_precompose pequiv.to_pmap pequiv._trans_of_to_pmap [constructor]
+attribute equiv.symm equiv.trans is_equiv.is_equiv_ap fiber.equiv_postcompose fiber.equiv_precompose pequiv.to_pmap pequiv._trans_of_to_pmap ghomotopy_group_succ_in isomorphism_of_eq [constructor]
 attribute is_equiv.eq_of_fn_eq_fn' [unfold 3]
+attribute isomorphism._trans_of_to_hom [unfold 3]
+attribute homomorphism.struct [unfold 3]
+attribute pequiv.trans pequiv.symm [constructor]
 
 namespace sigma
 
@@ -26,6 +29,25 @@ open sigma
 namespace group
   open is_trunc
   definition pSet_of_Group (G : Group) : Set* := ptrunctype.mk G _ 1
+
+  definition pmap_of_isomorphism [constructor] {G₁ G₂ : Group} (φ : G₁ ≃g G₂) :
+    pType_of_Group G₁ →* pType_of_Group G₂ :=
+  pequiv_of_isomorphism φ
+
+  definition pequiv_of_isomorphism_of_eq {G₁ G₂ : Group} (p : G₁ = G₂) :
+    pequiv_of_isomorphism (isomorphism_of_eq p) = pequiv_of_eq (ap pType_of_Group p) :=
+  begin
+    induction p,
+    apply pequiv_eq,
+    fapply pmap_eq,
+    { intro g, reflexivity},
+    { apply is_prop.elim}
+  end
+
+  definition homomorphism_change_fun [constructor] {G₁ G₂ : Group} (φ : G₁ →g G₂) (f : G₁ → G₂)
+    (p : φ ~ f) : G₁ →g G₂ :=
+  homomorphism.mk f (λg h, (p (g * h))⁻¹ ⬝ to_respect_mul φ g h ⬝ ap011 mul (p g) (p h))
+
 end group open group
 
 namespace eq
@@ -170,6 +192,16 @@ namespace pointed
     pequiv_of_equiv (pi_equiv_pi_right g)
       begin esimp, apply eq_of_homotopy, intros a, esimp, exact (respect_pt (g a)) end
 
+  definition pcast_commute [constructor] {A : Type} {B C : A → Type*} (f : Πa, B a →* C a)
+    {a₁ a₂ : A} (p : a₁ = a₂) : pcast (ap C p) ∘* f a₁ ~* f a₂ ∘* pcast (ap B p) :=
+  phomotopy.mk
+    begin induction p, reflexivity end
+    begin induction p, esimp, refine !idp_con ⬝ !idp_con ⬝ !ap_id⁻¹ end
+
+  definition pequiv_of_eq_commute [constructor] {A : Type} {B C : A → Type*} (f : Πa, B a →* C a)
+    {a₁ a₂ : A} (p : a₁ = a₂) : pequiv_of_eq (ap C p) ∘* f a₁ ~* f a₂ ∘* pequiv_of_eq (ap B p) :=
+  pcast_commute f p
+
 end pointed
 open pointed
 
@@ -399,19 +431,42 @@ namespace spectrum
       intro n, exact sorry
     end
 
-   definition π_glue (X : spectrum) (n : ℤ) : π*[2] (X (2 - succ n)) ≃* π*[3] (X (2 - n)) :=
+  definition π_glue (X : spectrum) (n : ℤ) : π*[2] (X (2 - succ n)) ≃* π*[3] (X (2 - n)) :=
   begin
-    symmetry,
-    refine pequiv_of_eq (phomotopy_group_succ_in (X (2 - n)) 2) ⬝e* _,
-    assert H : 2 - n = succ (2 - succ n), exact (sub_add_cancel (2-n) 1)⁻¹ ⬝ ap succ !sub_sub,
-    refine phomotopy_group_pequiv 2 (loop_pequiv_loop (pequiv_of_eq (ap X H))) ⬝e* _,
-    exact phomotopy_group_pequiv 2 (equiv_glue X (2 - succ n))⁻¹ᵉ*
+    refine phomotopy_group_pequiv 2 (equiv_glue X (2 - succ n)) ⬝e* _,
+    assert H : succ (2 - succ n) = 2 - n, exact ap succ !sub_sub⁻¹ ⬝ sub_add_cancel (2-n) 1,
+    exact pequiv_of_eq (ap (λn, π*[2] (Ω (X n))) H),
+  end
+
+  definition πg_glue (X : spectrum) (n : ℤ) : πg[1+1] (X (2 - succ n)) ≃g πg[2+1] (X (2 - n)) :=
+  begin
+    refine homotopy_group_isomorphism_of_pequiv 1 (equiv_glue X (2 - succ n)) ⬝g _,
+    assert H : succ (2 - succ n) = 2 - n, exact ap succ !sub_sub⁻¹ ⬝ sub_add_cancel (2-n) 1,
+    exact isomorphism_of_eq (ap (λn, πg[1+1] (Ω (X n))) H),
+  end
+
+  definition πg_glue_homotopy_π_glue (X : spectrum) (n : ℤ) : πg_glue X n ~ π_glue X n :=
+  begin
+    intro x,
+    esimp [πg_glue, π_glue],
+    apply ap (λp, cast p _),
+    refine !ap_compose'⁻¹ ⬝ !ap_compose'
   end
 
-  /- TODO: fill in sorry -/
   definition π_glue_square {X Y : spectrum} (f : X →ₛ Y) (n : ℤ) :
     π_glue Y n ∘* π→*[2] (f (2 - succ n)) ~* π→*[3] (f (2 - n)) ∘* π_glue X n :=
-  sorry
+  begin
+    refine !passoc ⬝* _,
+    assert H1 : phomotopy_group_pequiv 2 (equiv_glue Y (2 - succ n)) ∘* π→*[2] (f (2 - succ n))
+     ~* π→*[2] (Ω→ (f (succ (2 - succ n)))) ∘* phomotopy_group_pequiv 2 (equiv_glue X (2 - succ n)),
+    { refine !phomotopy_group_functor_compose⁻¹* ⬝* _,
+      refine phomotopy_group_functor_phomotopy 2 !sglue_square ⬝* _,
+      apply phomotopy_group_functor_compose },
+    refine pwhisker_left _ H1 ⬝* _, clear H1,
+    refine !passoc⁻¹* ⬝* _ ⬝* !passoc,
+    apply pwhisker_right,
+    refine !pequiv_of_eq_commute ⬝* by reflexivity
+  end
 
   section
   open chain_complex prod fin group
@@ -441,8 +496,10 @@ namespace spectrum
   definition is_homomorphism_LES_of_shomotopy_groups :
     Π(v : +3ℤ), is_homomorphism (cc_to_fn LES_of_shomotopy_groups v)
   | (n, fin.mk 0 H) := proof homomorphism.struct (πₛ→[n] f) qed
-  | (n, fin.mk 1 H) := proof homomorphism.struct (πₛ→[n] (spoint f))  qed
-  | (n, fin.mk 2 H) := proof is_homomorphism_compose sorry sorry qed
+  | (n, fin.mk 1 H) := proof homomorphism.struct (πₛ→[n] (spoint f)) qed
+  | (n, fin.mk 2 H) := proof homomorphism.struct
+        (homomorphism_LES_of_homotopy_groups_fun (f (2 - n)) (1, 2) ∘g
+         homomorphism_change_fun (πg_glue Y n) _ (πg_glue_homotopy_π_glue Y n)) qed
   | (n, fin.mk (k+3) H) := begin exfalso, apply lt_le_antisymm H, apply le_add_left end
 
   -- In the comments below is a start on an explicit description of the LES for spectra

homotopy/spherical_fibrations.hlean

@@ -1,7 +1,7 @@
 import homotopy.join homotopy.smash
 
 open eq equiv trunc function bool join sphere sphere_index sphere.ops prod
-open pointed sigma smash
+open pointed sigma smash is_trunc
 
 namespace spherical_fibrations
 
@@ -18,7 +18,10 @@ namespace spherical_fibrations
   pt = pt :> BG n
 
   definition G_char (n : ℕ) : G n ≃ (S n..-1 ≃ S n..-1) :=
-  sorry
+  calc
+    G n ≃ Σ(p : S n..-1 = S n..-1), _ : sigma_eq_equiv
+    ... ≃ (S n..-1 = S n..-1) : sigma_equiv_of_is_contr_right
+    ... ≃ (S n..-1 ≃ S n..-1) : eq_equiv_equiv
 
   definition mirror (n : ℕ) : S n..-1 → G n :=
   begin
@@ -134,7 +137,7 @@ namespace spherical_fibrations
   - all bundles on S 3 are trivial, incl. tangent bundle
   - Adams' result on vector fields on spheres:
      there are maximally ρ(n)-1 indep.sections of the tangent bundle of S (n-1)
-     where ρ(n) is the n'th Radon-Hurwitz number.→ 
+     where ρ(n) is the n'th Radon-Hurwitz number.→
 -/
 
 -- tangent bundle on S 2:

homotopy/splice.hlean

@@ -63,31 +63,7 @@ begin
   { exact dif_pos p}
 end
 
---   definition splice_type {N M : succ_str} (G : N → chain_complex M) (k : ℕ) (m : M)
---     (x : stratified N k) : Set* :=
---   G x.1 (iterate S (val x.2) m)
-
--- --   definition splice_map {N M : succ_str} (G : N → chain_complex M) (k : ℕ) (m : M)
--- --     (x : stratified N k) : Set* :=
--- --   G x.1 (iterate S (val x.2) m)
-
---   definition splice (N M : succ_str) (G : N → chain_complex M) (k : ℕ) (m : M)
---     (e0 : Πn, G n m ≃* G (S n) (S (iterate S k m))) :
---     chain_complex (stratified N k) :=
---   chain_complex.mk (splice_type G k m)
---     begin
---       intro x, cases x with n l, cases l with l H,
---       refine if K : l = k then _ else _,
---       { intro p, induction p, exact sorry},
---       { exact sorry}
---       -- cases l with l,
---       -- { },
---       -- { }
---     end
---     begin
---       exact sorry
---     end
-
+  --move
   definition succ_str.add [reducible] {N : succ_str} (n : N) (k : ℕ) : N :=
   iterate S k n