compute fiber of postnikov_smap

2017-07-05 20:40:15 +01:00 · 2017-07-05 20:40:15 +01:00 · e24865d48b
commit e24865d48b
parent 9d39f7771f
5 changed files with 205 additions and 57 deletions
--- a/homotopy/serre.hlean
+++ b/homotopy/serre.hlean
@ -8,7 +8,7 @@ set_option pp.binder_types true

 namespace pointed
 definition postnikov_map [constructor] (A : Type*) (n : ℕ₋₂) : ptrunc (n.+1) A →* ptrunc n A :=
-ptrunc.elim (n.+1) !ptr
+ptrunc.elim (n.+1) (ptr n A)

 definition ptrunc_functor_postnikov_map {A B : Type*} (n : ℕ₋₂) (f : A →* B) :
  ptrunc_functor n f ∘* postnikov_map A n ~* ptrunc.elim (n.+1) (!ptr ∘* f) :=
@ -68,39 +68,95 @@ this⁻¹ᵛ*
 end pointed open pointed

 namespace spectrum
-
+/- begin move -/
 definition is_strunc_strunc_pred (X : spectrum) (k : ℤ) : is_strunc k (strunc (k - 1) X) :=
 λn, @(is_trunc_of_le _ (maxm2_monotone (add_le_add_right (sub_one_le k) n))) !is_strunc_strunc

+definition ptrunc_maxm2_pred {n m : ℤ} (A : Type*) (p : n - 1 = m) :
+  ptrunc (maxm2 m) A ≃* ptrunc (trunc_index.pred (maxm2 n)) A :=
+begin
+  cases n with n, cases n with n, apply pequiv_of_is_contr,
+        induction p, apply is_trunc_trunc,
+      apply is_contr_ptrunc_minus_one,
+    exact ptrunc_change_index (ap maxm2 (p⁻¹ ⬝ !add_sub_cancel)) A,
+  exact ptrunc_change_index (ap maxm2 p⁻¹) A
+end
+
+definition ptrunc_maxm2_pred_nat {n : ℕ} {m l : ℤ} (A : Type*)
+  (p : nat.succ n = l) (q : pred l = m) (r : maxm2 m = trunc_index.pred (maxm2 (nat.succ n))) :
+  @ptrunc_maxm2_pred (nat.succ n) m A (ap pred p ⬝ q) ~* ptrunc_change_index r A :=
+begin
+  have ap maxm2 ((ap pred p ⬝ q)⁻¹ ⬝ add_sub_cancel n 1) = r, from !is_set.elim,
+  induction this, reflexivity
+end
+
+definition EM_type_pequiv_EM (A : spectrum) (n k : ℤ) (l : ℕ) (p : n + k = l) :
+  EM_type (A k) l ≃* EM (πₛ[n] A) l :=
+begin
+  symmetry,
+  cases l with l,
+  { exact shomotopy_group_pequiv_homotopy_group A p },
+  { cases l with l,
+    { apply EM1_pequiv_EM1, exact shomotopy_group_isomorphism_homotopy_group A p },
+    { apply EMadd1_pequiv_EMadd1 (l+1), exact shomotopy_group_isomorphism_homotopy_group A p }}
+end
+/- end move -/
+
 definition postnikov_smap [constructor] (X : spectrum) (k : ℤ) :
  strunc k X →ₛ strunc (k - 1) X :=
 strunc_elim (str (k - 1) X) (is_strunc_strunc_pred X k)

-/-
-  we could try to prove that postnikov_smap is homotopic to postnikov_map, although the types
-  are different enough, that even stating it will be quite annoying
-/
+definition postnikov_map_pred (A : Type*) (n : ℕ₋₂) :
+  ptrunc n A →* ptrunc (trunc_index.pred n) A :=
+begin cases n with n, exact !pid, exact postnikov_map A n end
+
+definition pfiber_postnikov_map_pred (A : Type*) (n : ℕ) :
+  pfiber (postnikov_map_pred A n) ≃* EM_type A n :=
+begin
+  cases n with n,
+    apply pfiber_pequiv_of_is_contr, apply is_contr_ptrunc_minus_one,
+  exact pfiber_postnikov_map A n
+end
+
+definition pfiber_postnikov_map_pred' (A : spectrum) (n k l : ℤ) (p : n + k = l) :
+  pfiber (postnikov_map_pred (A k) (maxm2 l)) ≃* EM_spectrum (πₛ[n] A) l :=
+begin
+  cases l with l l,
+  { refine pfiber_postnikov_map_pred (A k) l ⬝e* _,
+    exact EM_type_pequiv_EM A n k l p },
+  { apply pequiv_of_is_contr, apply is_contr_pfiber_pid,
+    apply is_contr_EM_spectrum_neg }
+end
+
+definition psquare_postnikov_map_ptrunc_elim (A : Type*) {n k l : ℕ₋₂} (H : is_trunc n (ptrunc k A))
+  (p : n = l.+1) (q : k = l) :
+  psquare (ptrunc.elim n (ptr k A)) (postnikov_map A l)
+          (ptrunc_change_index p A) (ptrunc_change_index q A) :=
+begin
+  induction q, cases p,
+  refine _ ⬝pv* pvrfl,
+  apply ptrunc_elim_phomotopy2,
+  reflexivity
+end
+
+definition postnikov_smap_postnikov_map (A : spectrum) (n k l : ℤ) (p : n + k = l) :
+  psquare (postnikov_smap A n k) (postnikov_map_pred (A k) (maxm2 l))
+    (ptrunc_maxm2_change_int p (A k)) (ptrunc_maxm2_pred (A k) (ap pred p⁻¹ ⬝ add.right_comm n k (- 1))) :=
+begin
+  cases l with l,
+  { cases l with l, apply phomotopy_of_is_contr_cod, apply is_contr_ptrunc_minus_one,
+    refine psquare_postnikov_map_ptrunc_elim (A k) _ _ _ ⬝hp* _,
+    exact ap maxm2 (add.right_comm n (- 1) k ⬝ ap pred p ⬝ !pred_succ),
+    apply ptrunc_maxm2_pred_nat },
+  { apply phomotopy_of_is_contr_cod, apply is_trunc_trunc }
+end

 definition pfiber_postnikov_smap (A : spectrum) (n : ℤ) (k : ℤ) :
-  sfiber (postnikov_smap A n) k ≃* EM_spectrum (πₛ[n] A) k :=
-begin
-  exact sorry
-/-  symmetry, apply spectrum_pequiv_of_nat_succ_succ, clear k, intro k,
-  apply EMadd1_pequiv k,
-  { exact sorry
-    -- refine _ ⬝g shomotopy_group_strunc n A,
-    -- exact chain_complex.LES_isomorphism_of_trivial_cod _ _
-    --   (trivial_homotopy_group_of_is_trunc _ (self_lt_succ n))
-    --   (trivial_homotopy_group_of_is_trunc _ (le_succ _))
-},
-  { exact sorry --apply is_conn_fun_trunc_elim,  apply is_conn_fun_tr
-    },
-  { -- have is_trunc (n+1) (ptrunc n.+1 A), from !is_trunc_trunc,
-    -- have is_trunc ((n+1).+1) (ptrunc n A), by do 2 apply is_trunc_succ, apply is_trunc_trunc,
-    -- apply is_trunc_pfiber
-    exact sorry
-    }-/
-end
+  sfiber (postnikov_smap A n) k ≃* EM_spectrum (πₛ[n] A) (n + k) :=
+proof
+pfiber_pequiv_of_square _ _ (postnikov_smap_postnikov_map A n k (n + k) idp) ⬝e*
+pfiber_postnikov_map_pred' A n k _ idp
+qed

 section atiyah_hirzebruch
  parameters {X : Type*} (Y : X → spectrum) (s₀ : ℤ) (H : Πx, is_strunc s₀ (Y x))
@ -141,10 +197,18 @@ section atiyah_hirzebruch
    (λn s, πₛ[n] (sfiber (postnikov_smap (spi X Y) s))) ⟹ᵍ (λn, πₛ[n] (strunc s₀ (spi X Y))) :=
  converges_to_sequence _ s₀ (λn, n - 1) atiyah_hirzebruch_lb atiyah_hirzebruch_ub

-  lemma spi_EM_spectrum (k n : ℤ) :
-    EM_spectrum (πₛ[n] (spi X Y)) k ≃* spi X (λx, EM_spectrum (πₛ[n] (Y x))) k :=
-  sorry
+  lemma spi_EM_spectrum (n : ℤ) : Π(k : ℤ),
+    EM_spectrum (πₛ[n] (spi X Y)) (n + k) ≃* spi X (λx, EM_spectrum (πₛ[n] (Y x))) k :=
+  begin
+    exact sorry
+    -- apply spectrum_pequiv_of_nat_add 2, intro k,
+    -- fapply EMadd1_pequiv (k+1),
+    -- { exact sorry },
+    -- { exact sorry },
+    -- { apply is_trunc_ppi, rotate 1, intro x,  },
+  end

+set_option formatter.hide_full_terms false
  definition atiyah_hirzebruch_convergence :
    (λn s, opH^-n[(x : X), πₛ[s] (Y x)]) ⟹ᵍ (λn, pH^-n[(x : X), Y x]) :=
  converges_to_g_isomorphism atiyah_hirzebruch_convergence'
--- a/homotopy/spectrum.hlean
+++ b/homotopy/spectrum.hlean
@ -59,6 +59,30 @@ namespace spectrum
    exact add.assoc n 1 1
  end

+  definition gluen {N : succ_str} (X : gen_prespectrum N) (n : N) (k : ℕ)
+    : X n →* Ω[k] (X (n +' k)) :=
+  by induction k with k f; reflexivity; exact !loopn_succ_in⁻¹ᵉ* ∘* Ω→[k] (glue X (n +' k)) ∘* f
+
+  -- note: the forward map is (currently) not definitionally equal to gluen. Is that a problem?
+  definition equiv_gluen {N : succ_str} (X : gen_spectrum N) (n : N) (k : ℕ)
+    : X n ≃* Ω[k] (X (n +' k)) :=
+  by induction k with k f; reflexivity; exact f ⬝e* (loopn_pequiv_loopn k (equiv_glue X (n +' k))
+                                                ⬝e* !loopn_succ_in⁻¹ᵉ*)
+
+  definition equiv_gluen_inv_succ {N : succ_str} (X : gen_spectrum N) (n : N) (k : ℕ) :
+    (equiv_gluen X n (k+1))⁻¹ᵉ* ~*
+    (equiv_gluen X n k)⁻¹ᵉ* ∘* Ω→[k] (equiv_glue X (n +' k))⁻¹ᵉ* ∘* !loopn_succ_in :=
+  begin
+    refine !trans_pinv ⬝* pwhisker_left _ _, refine !trans_pinv ⬝* _, refine pwhisker_left _ !pinv_pinv
+  end
+
+  definition succ_str_add_eq_int_add (n : ℤ) (m : ℕ) : @succ_str.add sint n m = n + m :=
+  begin
+    induction m with m IH,
+    { symmetry, exact add_zero n },
+    { exact ap int.succ IH ⬝ add.assoc n m 1 }
+  end
+
  -- a square when we compose glue with transporting over a path in N
  definition glue_ptransport {N : succ_str} (X : gen_prespectrum N) {n n' : N} (p : n = n') :
    glue X n' ∘* ptransport X p ~* Ω→ (ptransport X (ap S p)) ∘* glue X n :=
@ -267,14 +291,16 @@ namespace spectrum
    { exact spectrum_pequiv_of_pequiv_succ -[1+succ n] IH }
  end

-  -- definition spectrum_pequiv_of_nat_add {E F : spectrum} (m : ℕ)
-  --   (e : Π(n : ℕ), E (n + m) ≃* F (n + m)) : Π(n : ℤ), E n ≃* F n :=
-  -- begin
-  --   apply spectrum_pequiv_of_nat,
-  --   refine nat.rec_down _ m e _,
-  --   intro n f m, cases m with m,
-
-  -- end
+  definition spectrum_pequiv_of_nat_add {E F : spectrum} (m : ℕ)
+    (e : Π(n : ℕ), E (n + m) ≃* F (n + m)) : Π(n : ℤ), E n ≃* F n :=
+  begin
+    apply spectrum_pequiv_of_nat,
+    refine nat.rec_down _ m e _,
+    intro n f k, cases k with k,
+    exact spectrum_pequiv_of_pequiv_succ _ (f 0),
+    exact pequiv_ap E (ap of_nat (succ_add k n)) ⬝e* f k ⬝e*
+          pequiv_ap F (ap of_nat (succ_add k n))⁻¹
+  end

  definition is_contr_spectrum_of_nat {E : spectrum} (e : Π(n : ℕ), is_contr (E n)) (n : ℤ) :
    is_contr (E n)  :=
@ -496,6 +522,56 @@ namespace spectrum
    refine !sglue_square ⬝v* ap1_psquare !pequiv_of_eq_commute
  end

+  definition homotopy_group_spectrum_irrel_one {n m : ℤ} {k : ℕ} (E : spectrum) (p : n + 1 = m + k)
+    [Hk : is_succ k] : πg[k] (E n) ≃g π₁ (E m) :=
+  begin
+    induction Hk with k,
+    change π₁ (Ω[k] (E n)) ≃g π₁ (E m),
+    apply homotopy_group_isomorphism_of_pequiv 0,
+    symmetry,
+    have m + k = n, from (pred_succ (m + k))⁻¹ ⬝ ap pred (add.assoc m k 1 ⬝ p⁻¹) ⬝ pred_succ n,
+    induction (succ_str_add_eq_int_add m k ⬝ this),
+    exact equiv_gluen E m k
+  end
+
+  definition homotopy_group_spectrum_irrel {n m : ℤ} {l k : ℕ} (E : spectrum) (p : n + l = m + k)
+    [Hk : is_succ k] [Hl : is_succ l] : πg[k] (E n) ≃g πg[l] (E m) :=
+  have Πa b c : ℤ, a + (b + c) = c + (b + a), from λa b c,
+  !add.assoc⁻¹ ⬝ add.comm (a + b) c ⬝ ap (λx, c + x) (add.comm a b),
+  have n + 1 = m + 1 - l + k, from
+  ap succ (add_sub_cancel n l)⁻¹ ⬝ !add.assoc ⬝ ap (λx, x + (-l + 1)) p ⬝ !add.assoc ⬝
+  ap (λx, m + x) (this k (-l) 1) ⬝ !add.assoc⁻¹ ⬝ !add.assoc⁻¹,
+  homotopy_group_spectrum_irrel_one E this ⬝g
+  (homotopy_group_spectrum_irrel_one E (sub_add_cancel (m+1) l)⁻¹)⁻¹ᵍ
+
+  definition shomotopy_group_isomorphism_homotopy_group {n m : ℤ} {l : ℕ} (E : spectrum) (p : n + m = l)
+    [H : is_succ l] : πₛ[n] E ≃g πg[l] (E m) :=
+  have 2 - n + l = m + 2, from
+  ap (λx, 2 - n + x) p⁻¹ ⬝ !add.assoc⁻¹ ⬝ ap (λx, x + m) (sub_add_cancel 2 n) ⬝ add.comm 2 m,
+  homotopy_group_spectrum_irrel E this
+
+  definition shomotopy_group_pequiv_homotopy_group_ab {n m : ℤ} {l : ℕ} (E : spectrum) (p : n + m = l)
+    [H : is_at_least_two l] : πₛ[n] E ≃g πag[l] (E m) :=
+  begin
+    induction H with l,
+    exact shomotopy_group_isomorphism_homotopy_group E p
+  end
+
+  definition shomotopy_group_pequiv_homotopy_group {n m : ℤ} {l : ℕ} (E : spectrum) (p : n + m = l) :
+    πₛ[n] E ≃* π[l] (E m) :=
+  begin
+    cases l with l,
+    { apply ptrunc_pequiv_ptrunc, symmetry,
+      change E m ≃* Ω (Ω (E (2 - n))),
+      refine !equiv_glue ⬝e* loop_pequiv_loop _,
+      refine !equiv_glue ⬝e* loop_pequiv_loop _,
+      apply pequiv_ap E,
+      have -n = m, from neg_eq_of_add_eq_zero p,
+      induction this,
+      rexact add.assoc (-n) 1 1 ⬝ add.comm (-n) 2 },
+    { exact pequiv_of_isomorphism (shomotopy_group_isomorphism_homotopy_group E p) }
+  end
+
  section
  open chain_complex prod fin group

@ -690,23 +766,6 @@ namespace spectrum
  definition spectrify [constructor] {N : succ_str} (X : gen_prespectrum N) : gen_spectrum N :=
  spectrum.MK (spectrify_type X) (spectrify_pequiv X)

-  definition gluen {N : succ_str} (X : gen_prespectrum N) (n : N) (k : ℕ)
-    : X n →* Ω[k] (X (n +' k)) :=
-  by induction k with k f; reflexivity; exact !loopn_succ_in⁻¹ᵉ* ∘* Ω→[k] (glue X (n +' k)) ∘* f
-
-  -- note: the forward map is (currently) not definitionally equal to gluen. Is that a problem?
-  definition equiv_gluen {N : succ_str} (X : gen_spectrum N) (n : N) (k : ℕ)
-    : X n ≃* Ω[k] (X (n +' k)) :=
-  by induction k with k f; reflexivity; exact f ⬝e* (loopn_pequiv_loopn k (equiv_glue X (n +' k))
-                                                ⬝e* !loopn_succ_in⁻¹ᵉ*)
-
-  definition equiv_gluen_inv_succ {N : succ_str} (X : gen_spectrum N) (n : N) (k : ℕ) :
-    (equiv_gluen X n (k+1))⁻¹ᵉ* ~*
-    (equiv_gluen X n k)⁻¹ᵉ* ∘* Ω→[k] (equiv_glue X (n +' k))⁻¹ᵉ* ∘* !loopn_succ_in :=
-  begin
-    refine !trans_pinv ⬝* pwhisker_left _ _, refine !trans_pinv ⬝* _, refine pwhisker_left _ !pinv_pinv
-  end
-
  definition spectrify_map {N : succ_str} {X : gen_prespectrum N} : X →ₛ spectrify X :=
  begin
    fapply smap.mk,
@ -836,6 +895,13 @@ spectrify_fun (smash_prespectrum_fun f g)
    (is_contr_spectrum_of_nat (λk, is_contr_EM k !is_trunc_lift) n)
    !is_trunc_lift

+  definition is_contr_EM_spectrum_neg (G : AbGroup) (n : ℕ) : is_contr (EM_spectrum G (-[1+n])) :=
+  begin
+    induction n with n IH,
+    { apply is_contr_loop, exact is_trunc_EM G 0 },
+    { apply is_contr_loop_of_is_contr, exact IH }
+  end
+
  /- Wedge of prespectra -/

 open fwedge
--- a/homotopy/strunc.hlean
+++ b/homotopy/strunc.hlean
@ -40,7 +40,7 @@ namespace spectrum

 definition ptrunc_maxm2_change_int {k l : ℤ} (p : k = l) (X : Type*)
  : ptrunc (maxm2 k) X ≃* ptrunc (maxm2 l) X :=
-pequiv_ap (λ n, ptrunc (maxm2 n) X) p
+ptrunc_change_index (ap maxm2 p) X

 definition is_trunc_maxm2_change_int {k l : ℤ} (X : pType) (p : k = l)
  : is_trunc (maxm2 k) X → is_trunc (maxm2 l) X :=
--- a/move_to_lib.hlean
+++ b/move_to_lib.hlean
@ -232,7 +232,7 @@ namespace int
  definition le_add_one (n : ℤ) : n ≤ n + 1:=
  le_add_nat n 1

-end int
+end int open int

 namespace pmap

@ -250,6 +250,15 @@ namespace lift
 end lift

 namespace trunc
+  open trunc_index
+  definition trunc_index_equiv_nat [constructor] : ℕ₋₂ ≃ ℕ :=
+  equiv.MK add_two sub_two add_two_sub_two sub_two_add_two
+
+  definition is_set_trunc_index [instance] : is_set ℕ₋₂ :=
+  is_trunc_equiv_closed_rev 0 trunc_index_equiv_nat
+
+  definition is_contr_ptrunc_minus_one (A : Type*) : is_contr (ptrunc -1 A) :=
+  is_contr_of_inhabited_prop pt

  -- TODO: redefine loopn_ptrunc_pequiv
  definition apn_ptrunc_functor (n : ℕ₋₂) (k : ℕ) {A B : Type*} (f : A →* B) :
@ -320,6 +329,9 @@ namespace trunc
  have is_trunc k (ptrunc l X), from is_trunc_of_le _ p,
  ptrunc.elim _ (ptr l X)

+  definition trunc_index.pred [unfold 1] (n : ℕ₋₂) : ℕ₋₂ :=
+  begin cases n with n, exact -2, exact n end
+
 end trunc

 namespace is_trunc
@ -419,6 +431,13 @@ namespace group

 end group open group

+namespace fiber
+
+  definition is_contr_pfiber_pid (A : Type*) : is_contr (pfiber (pid A)) :=
+  is_contr.mk pt begin intro x, induction x with a p, esimp at p, cases p, reflexivity end
+
+end fiber
+
 namespace function
  variables {A B : Type} {f f' : A → B}
  open is_conn sigma.ops
--- a/pointed.hlean
+++ b/pointed.hlean
@ -2,7 +2,7 @@

 -- Author: Floris van Doorn

-import types.pointed2
+import types.pointed2 .move_to_lib

 open pointed eq equiv function is_equiv unit is_trunc trunc nat algebra sigma group

@ -220,5 +220,4 @@ namespace pointed
    begin rewrite [▸*, is_prop_elim_self, +ap_idp, idp_con, con_idp, inv_con_cancel_right] end


-
 end pointed