some additions to the smash product and direct sums

2016-11-14 14:44:29 -05:00 · 2016-11-14 14:44:29 -05:00 · 9df0b25ae5
commit 9df0b25ae5
parent e87c235e24
7 changed files with 164 additions and 47 deletions
--- a/algebra/direct_sum.hlean
+++ b/algebra/direct_sum.hlean
@ -8,7 +8,7 @@ Constructions with groups

 import .quotient_group .free_commutative_group

-open eq algebra is_trunc set_quotient relation sigma prod sum list trunc function equiv
+open eq algebra is_trunc set_quotient relation sigma prod sum list trunc function equiv sigma.ops

 namespace group

@ -20,13 +20,42 @@ namespace group
  section

    parameters {I : Set} (Y : I → CommGroup)
+    variables {A' : CommGroup}

    definition dirsum_carrier : CommGroup := free_comm_group (trunctype.mk (Σi, Y i) _)
    local abbreviation ι := @free_comm_group_inclusion
    inductive dirsum_rel : dirsum_carrier → Type :=
    | rmk : Πi y₁ y₂, dirsum_rel (ι ⟨i, y₁⟩ * ι ⟨i, y₂⟩ * (ι ⟨i, y₁ * y₂⟩)⁻¹)

-    definition direct_sum : CommGroup := quotient_comm_group_gen dirsum_carrier (λg, ∥dirsum_rel g∥)
+    definition dirsum : CommGroup := quotient_comm_group_gen dirsum_carrier (λg, ∥dirsum_rel g∥)
+
+    -- definition dirsum_carrier_incl [constructor] (i : I) : Y i →g dirsum_carrier :=
+
+    definition dirsum_incl [constructor] (i : I) : Y i →g dirsum :=
+    homomorphism.mk (λy, class_of (ι ⟨i, y⟩))
+      begin intro g h, symmetry, apply gqg_eq_of_rel, apply tr, apply dirsum_rel.rmk end
+
+    definition dirsum_elim [constructor] (f : Πi, Y i →g A') : dirsum →g A' :=
+    begin
+      refine homomorphism.mk (gqg_elim _ (free_comm_group_elim (λv, f v.1 v.2)) _) _,
+      { intro g r, induction r with r, induction r,
+        rewrite [to_respect_mul, to_respect_inv], apply mul_inv_eq_of_eq_mul,
+        rewrite [one_mul], apply ap (free_comm_group_elim (λ v, group_fun (f v.1) v.2)),
+        exact sorry
+        },
+      { exact sorry }
+    end
+
+    definition dirsum_elim_compute (f : Πi, Y i →g A') (i : I) :
+      dirsum_elim f ∘g dirsum_incl i ~ f i :=
+    begin
+      intro g, exact sorry
+    end
+
+    definition dirsum_elim_unique (f : Πi, Y i →g A') (k : dirsum →g A')
+      (H : Πi, k ∘g dirsum_incl i ~ f i) : k ~ dirsum_elim f :=
+    sorry
+

  end

--- a/algebra/free_commutative_group.hlean
+++ b/algebra/free_commutative_group.hlean
@ -160,7 +160,7 @@ namespace group
    { exact !IH₁ ⬝ !IH₂}
  end

-  definition free_comm_group_hom [constructor] (f : X → A) : free_comm_group X →g A :=
+  definition free_comm_group_elim [constructor] (f : X → A) : free_comm_group X →g A :=
  begin
    fapply homomorphism.mk,
    { intro g, refine set_quotient.elim _ _ g,
@ -171,15 +171,15 @@ namespace group
      esimp, refine !foldl_append ⬝ _, esimp, apply fgh_helper_mul}
  end

-  definition fn_of_free_comm_group_hom [unfold_full] (φ : free_comm_group X →g A) : X → A :=
+  definition fn_of_free_comm_group_elim [unfold_full] (φ : free_comm_group X →g A) : X → A :=
  φ ∘ free_comm_group_inclusion

  variables (X A)
-  definition free_comm_group_hom_equiv_fn : (free_comm_group X →g A) ≃ (X → A) :=
+  definition free_comm_group_elim_equiv_fn : (free_comm_group X →g A) ≃ (X → A) :=
  begin
    fapply equiv.MK,
-    { exact fn_of_free_comm_group_hom},
-    { exact free_comm_group_hom},
+    { exact fn_of_free_comm_group_elim},
+    { exact free_comm_group_elim},
    { intro f, apply eq_of_homotopy, intro x, esimp, unfold [foldl], apply one_mul},
    { intro φ, apply homomorphism_eq, refine set_quotient.rec_prop _, intro l, esimp,
      induction l with s l IH,
--- a/algebra/quotient_group.hlean
+++ b/algebra/quotient_group.hlean
@ -13,7 +13,7 @@ open eq algebra is_trunc set_quotient relation sigma sigma.ops prod trunc functi
 namespace group

  variables {G G' : Group} (H : subgroup_rel G) (N : normal_subgroup_rel G) {g g' h h' k : G}
-            {A B : CommGroup}
+  variables {A B : CommGroup}

  /- Quotient Group -/

@ -139,7 +139,7 @@ namespace group
    : CommGroup :=
  CommGroup.mk _ (comm_group_qg (normal_subgroup_rel_comm N))

-  definition gq_map : G →g quotient_group N :=
+  definition qg_map [constructor] : G →g quotient_group N :=
  homomorphism.mk class_of (λ g h, idp)

  definition comm_gq_map {G : CommGroup} (N : subgroup_rel G) : G →g quotient_comm_group N :=
@ -150,13 +150,13 @@ namespace group
  end

  namespace quotient
-    notation `⟦`:max a `⟧`:0 := gq_map a _
+    notation `⟦`:max a `⟧`:0 := qg_map a _
  end quotient

  open quotient
  variable {N}

-  definition gq_map_eq_one (g : G) (H : N g) : gq_map N g = 1 :=
+  definition qg_map_eq_one (g : G) (H : N g) : qg_map N g = 1 :=
  begin
    apply eq_of_rel,
      have e : (g * 1⁻¹ = g),
@ -166,18 +166,18 @@ namespace group
    unfold quotient_rel, rewrite e, exact H
  end

-  definition comm_gq_map_eq_one {K : subgroup_rel A} (a :A) (H : K a) : comm_gq_map K a = 1 :=
+  definition comm_gq_map_eq_one {K : subgroup_rel A} (g :A) (H : K g) : comm_gq_map K g = 1 :=
  begin
    apply eq_of_rel,
      have e : (g * 1⁻¹ = g),
      from calc
      g * 1⁻¹ = g * 1 : one_inv
        ...   = g : mul_one,
-    unfold quotient_rel, rewrite e, exact H
+    unfold quotient_rel, xrewrite e, exact H
  end

   --- there should be a smarter way to do this!! Please have a look, Floris.
-  definition rel_of_gq_map_eq_one (g : G) (H : gq_map N g = 1) : N g :=
+  definition rel_of_qg_map_eq_one (g : G) (H : qg_map N g = 1) : N g :=
  begin
    have e : (g * 1⁻¹ = g),
    from calc
@ -202,31 +202,31 @@ namespace group
      apply H, exact K},
    { intro g h, induction g using set_quotient.rec_prop with g,
      induction h using set_quotient.rec_prop with h,
-      krewrite (inverse (to_respect_mul (gq_map N) g h)),
-      unfold gq_map, esimp, exact to_respect_mul f g h }
+      krewrite (inverse (to_respect_mul (qg_map N) g h)),
+      unfold qg_map, esimp, exact to_respect_mul f g h }
  end

-  definition quotient_group_compute (f : G →g G') (H : Π⦃g⦄, N g → f g = 1) : quotient_group_elim f H ∘g gq_map N ~ f :=
+  definition quotient_group_compute (f : G →g G') (H : Π⦃g⦄, N g → f g = 1) : quotient_group_elim f H ∘g qg_map N ~ f :=
  begin
    intro g, reflexivity
  end

  definition gelim_unique (f : G →g G') (H : Π⦃g⦄, N g → f g = 1) (k : quotient_group N →g G')
-    : ( k ∘g gq_map N ~ f ) → k ~ quotient_group_elim f H :=
+    : ( k ∘g qg_map N ~ f ) → k ~ quotient_group_elim f H :=
  begin
    intro K cg, induction cg using set_quotient.rec_prop with g,
    krewrite (quotient_group_compute f),
    exact K g
  end

-  definition gq_universal_property (f : G →g G') (H : Π⦃g⦄, N g → f g = 1)  :
-    is_contr (Σ(g : quotient_group N →g G'), g ∘g gq_map N = f) :=
+  definition qg_universal_property (f : G →g G') (H : Π⦃g⦄, N g → f g = 1)  :
+    is_contr (Σ(g : quotient_group N →g G'), g ∘g qg_map N = f) :=
  begin
    fapply is_contr.mk,
      -- give center of contraction
    { fapply sigma.mk, exact quotient_group_elim f H, apply homomorphism_eq, exact quotient_group_compute f H },
      -- give contraction
-    { intro pair, induction pair with g p, fapply sigma_eq, 
+    { intro pair, induction pair with g p, fapply sigma_eq,
      {esimp, apply homomorphism_eq, symmetry, exact gelim_unique f H g (homotopy_of_homomorphism_eq p)},
      {fapply is_prop.elimo} }
  end
@ -252,38 +252,68 @@ definition comm_group_first_iso_thm (A B : CommGroup) (f : A →g B) : quotient_
    exact k,
    exact sorry,
    -- show that the above map is injective and surjective.
-  end  
+  end

    /- set generating normal subgroup -/

  section

-    parameters {GG : CommGroup} (S : GG → Prop)
+    parameters {A₁ : CommGroup} (S : A₁ → Prop)
+    variable {A₂ : CommGroup}

-    inductive generating_relation' : GG → Type :=
+    inductive generating_relation' : A₁ → Type :=
    | rincl : Π{g}, S g → generating_relation' g
    | rmul  : Π{g h}, generating_relation' g → generating_relation' h → generating_relation' (g * h)
    | rinv  : Π{g}, generating_relation' g → generating_relation' g⁻¹
    | rone  : generating_relation' 1
    open generating_relation'
-    definition generating_relation (g : GG) : Prop := ∥ generating_relation' g ∥
+    definition generating_relation (g : A₁) : Prop := ∥ generating_relation' g ∥
    local abbreviation R := generating_relation
    definition gr_one : R 1 := tr (rone S)
-    definition gr_inv (g : GG) : R g → R g⁻¹ :=
+    definition gr_inv (g : A₁) : R g → R g⁻¹ :=
    trunc_functor -1 rinv
-    definition gr_mul (g h : GG) : R g → R h → R (g * h) :=
+    definition gr_mul (g h : A₁) : R g → R h → R (g * h) :=
    trunc_functor2 rmul

-    definition normal_generating_relation : subgroup_rel GG :=
+    definition normal_generating_relation : subgroup_rel A₁ :=
    ⦃ subgroup_rel,
-      R := generating_relation,
+      R := R,
      Rone := gr_one,
      Rinv := gr_inv,
      Rmul := gr_mul⦄

-    parameter (GG)
+    parameter (A₁)
    definition quotient_comm_group_gen : CommGroup := quotient_comm_group normal_generating_relation

+    definition gqg_map [constructor] : A₁ →g quotient_comm_group_gen :=
+    qg_map _
+
+    parameter {A₁}
+    definition gqg_eq_of_rel {g h : A₁} (H : S (g * h⁻¹)) : gqg_map g = gqg_map h :=
+    eq_of_rel (tr (rincl H))
+
+    definition gqg_elim (f : A₁ →g A₂) (H : Π⦃g⦄, S g → f g = 1)
+      : quotient_comm_group_gen →g A₂ :=
+    begin
+      apply quotient_group_elim f,
+      intro g r, induction r with r,
+      induction r with g s g h r r' IH1 IH2 g r IH,
+      { exact H s },
+      { exact !respect_mul ⬝ ap011 mul IH1 IH2 ⬝ !one_mul },
+      { exact !respect_inv ⬝ ap inv IH ⬝ !one_inv },
+      { apply respect_one }
+    end
+
+    definition gqg_elim_compute (f : A₁ →g A₂) (H : Π⦃g⦄, S g → f g = 1)
+      : gqg_elim f H ∘g gqg_map ~ f :=
+    begin
+      intro g, reflexivity
+    end
+
+    definition gqg_elim_unique (f : A₁ →g A₂) (H : Π⦃g⦄, S g → f g = 1)
+      (k : quotient_comm_group_gen →g A₂) : ( k ∘g gqg_map ~ f ) → k ~ gqg_elim f H :=
+    !gelim_unique
+
  end

  end group
--- a/algebra/subgroup.hlean
+++ b/algebra/subgroup.hlean
@ -135,7 +135,8 @@ namespace group
  theorem is_normal_subgroup' (h : G) (r : N g) : N (h⁻¹ * g * h) :=
  inv_inv h ▸ is_normal_subgroup N h⁻¹ r

-  definition normal_subgroup_rel_comm.{u} (R : subgroup_rel.{_ u} A) : normal_subgroup_rel.{_ u} A :=
+  definition normal_subgroup_rel_comm.{u} [constructor] (R : subgroup_rel.{_ u} A)
+    : normal_subgroup_rel.{_ u} A :=
  ⦃normal_subgroup_rel, R,
    is_normal_subgroup := abstract begin
      intros g h r, xrewrite [mul.comm h g, mul_inv_cancel_right], exact r
@ -243,14 +244,14 @@ namespace group
    intro g h, reflexivity
  end

-  definition subgroup_rel_of_subgroup {G : Group} (H1 H2 : subgroup_rel G) (hyp : Π (g : G), subgroup_rel.R H1 g → subgroup_rel.R H2 g) : subgroup_rel (subgroup H2) := 
-  subgroup_rel.mk 
+  definition subgroup_rel_of_subgroup {G : Group} (H1 H2 : subgroup_rel G) (hyp : Π (g : G), subgroup_rel.R H1 g → subgroup_rel.R H2 g) : subgroup_rel (subgroup H2) :=
+  subgroup_rel.mk
      -- definition of the subset
-    (λ h, H1 (incl_of_subgroup H2 h)) 
+    (λ h, H1 (incl_of_subgroup H2 h))
      -- contains 1
-    (subgroup_has_one H1) 
+    (subgroup_has_one H1)
      -- closed under multiplication
-    (λ g h p q, subgroup_respect_mul H1 p q) 
+    (λ g h p q, subgroup_respect_mul H1 p q)
      -- closed under inverses
    (λ h p, subgroup_respect_inv H1 p)

--- a/homotopy/EM.hlean
+++ b/homotopy/EM.hlean
@ -35,7 +35,7 @@ namespace EM
    exact φ
  end

-  definition EM_functor {G H : CommGroup} (φ : G →g H) (n : ℕ) :
+  definition EM_functor [unfold 4] {G H : CommGroup} (φ : G →g H) (n : ℕ) :
    K G n →* K H n :=
  begin
    cases n with n,
@ -43,6 +43,8 @@ namespace EM
    { exact EMadd1_functor φ n }
  end

+  -- TODO: (K G n →* K H n) ≃ (G →g H)
+
  /- Equivalence of Groups and pointed connected 1-truncated types -/

  definition pEM1_pequiv_ptruncconntype (X : 1-Type*[0]) : pEM1 (π₁ X) ≃* X :=
@ -159,10 +161,10 @@ namespace EM
    apply homotopy_of_inv_homotopy_pre (loopn_EMadd1 G n),
    intro g, esimp at *,
    revert X e r H1 H2, induction n with n IH: intro X e r H1 H2,
-    { refine !idp_con ⬝ _, refine !ap_compose'⁻¹ ⬝ _, esimp, apply elim_pth},
+    { refine !idp_con ⬝ _, refine !ap_compose'⁻¹ ⬝ _, apply elim_pth},
    { replace (succ (succ n)) with ((succ n) + 1), rewrite [apn_succ],
      exact sorry}
-    --exact !idp_con ⬝ !elim_pth
+    -- exact !idp_con ⬝ !elim_pth
  end

  -- definition is_conn_of_le (n : ℕ₋₂) (A : Type) [is_conn (n.+1) A] :
--- a/homotopy/smash.hlean
+++ b/homotopy/smash.hlean
@ -8,7 +8,7 @@

 import homotopy.circle homotopy.join types.pointed homotopy.cofiber ..move_to_lib

-open bool pointed eq equiv is_equiv sum bool prod unit circle cofiber
+open bool pointed eq equiv is_equiv sum bool prod unit circle cofiber prod.ops wedge

 namespace smash

@ -183,7 +183,7 @@ namespace smash

  /- smash A B ≃ pcofiber (pprod_of_pwedge A B) -/

-  definition prod_of_pwedge [unfold 3] (v : pwedge A B) : A × B :=
+  definition prod_of_pwedge [unfold 3] (v : pwedge' A B) : A × B :=
  begin
    induction v with a b ,
    { exact (a, pt) },
@ -191,7 +191,7 @@ namespace smash
    { reflexivity }
  end

-  definition pprod_of_pwedge [constructor] : pwedge A B →* A ×* B :=
+  definition pprod_of_pwedge [constructor] : pwedge' A B →* A ×* B :=
  begin
    fconstructor,
    { intro v, induction v with a b ,
@ -202,16 +202,35 @@ namespace smash
  end

  attribute pcofiber [constructor]
-  definition pcofiber_of_smash (x : smash A B) : pcofiber (@pprod_of_pwedge A B) :=
+  definition pcofiber_of_smash (x : smash A B) : pcofiber' (@pprod_of_pwedge A B) :=
  begin
    induction x,
    { exact pushout.inr (a, b) },
    { exact pushout.inl ⋆ },
    { exact pushout.inl ⋆ },
-    { symmetry, },
-    { }
+    { symmetry, exact pushout.glue (pushout.inl a) },
+    { symmetry, exact pushout.glue (pushout.inr b) }
  end

+  definition ap_eq_ap011 {A B C X : Type} (f : A → B → C) (g : X → A) (h : X → B) {x x' : X}
+    (p : x = x') : ap (λx, f (g x) (h x)) p = ap011 f (ap g p) (ap h p) :=
+  by induction p; reflexivity
+
+  definition smash_of_pcofiber (x : pcofiber' (@pprod_of_pwedge A B)) : smash A B :=
+  begin
+    induction x with x x,
+    { exact smash.mk pt pt },
+    { exact smash.mk x.1 x.2 },
+    { induction x with a b: esimp,
+      { apply gluel' },
+      { apply gluer' },
+      { apply eq_pathover_constant_left, refine _ ⬝hp (ap_eq_ap011 smash.mk _ _ _)⁻¹,
+        unfold [wedge.elim],
+        rewrite [ap_compose' prod.pr1, ap_compose' prod.pr2],
+        -- TODO: define elim_glue for wedges and remove krewrite
+        krewrite [pushout.elim_glue], esimp, apply vdeg_square,
+        exact !con.right_inv ⬝ !con.right_inv⁻¹ }}
+  end

  /- smash A S¹ = susp A -/
  open susp
--- a/move_to_lib.hlean
+++ b/move_to_lib.hlean
@ -1,6 +1,6 @@
 -- definitions, theorems and attributes which should be moved to files in the HoTT library

-import homotopy.sphere2
+import homotopy.sphere2 homotopy.cofiber homotopy.wedge

 open eq nat int susp pointed pmap sigma is_equiv equiv fiber algebra trunc trunc_index pi group
     is_trunc function sphere
@ -86,7 +86,7 @@ namespace pi -- move to types.arrow
  begin
    cases f with f p, esimp [pmap_eq],
    refine apd011 (apd011 pmap.mk) !eq_of_homotopy_idp _,
-    exact sorry
+    induction Y with Y y0, esimp at *, induction p, esimp, exact sorry
  end

  definition pfunext [constructor] (X Y : Type*) : ppmap X (Ω Y) ≃* Ω (ppmap X Y) :=
@ -761,3 +761,39 @@ namespace sphere
  -- end

 end sphere
+
+namespace cofiber
+
+  -- replace with the definition of pcofiber (and remove primes in homotopy.smash)
+  definition pcofiber' [constructor] {A B : Type*} (f : A →* B) : Type* :=
+  pointed.MK (cofiber f) !cofiber.base
+  attribute pcofiber [constructor]
+  -- move ppushout attribute out namespace
+
+  protected definition elim {A : Type} {B : Type} {f : A → B} {P : Type}
+    (Pinl : P) (Pinr : B → P) (Pglue : Π (x : A), Pinl = Pinr (f x)) (y : cofiber f) : P :=
+  begin
+    induction y using pushout.elim with x x x, induction x, exact Pinl, exact Pinr x, exact Pglue x,
+  end
+
+end cofiber
+attribute cofiber.rec cofiber.elim [recursor 8] [unfold 8]
+
+namespace wedge
+  open pushout unit
+  definition wedge (A B : Type*) : Type := ppushout (pconst punit A) (pconst punit B)
+  local attribute wedge [reducible]
+  definition pwedge' (A B : Type*) : Type* := pointed.mk' (wedge A B)
+
+  protected definition rec {A B : Type*} {P : wedge A B → Type} (Pinl : Π(x : A), P (inl x))
+    (Pinr : Π(x : B), P (inr x)) (Pglue : pathover P (Pinl pt) (glue ⋆) (Pinr pt))
+    (y : wedge A B) : P y :=
+  by induction y; apply Pinl; apply Pinr; induction x; exact Pglue
+
+  protected definition elim {A B : Type*} {P : Type} (Pinl : A → P)
+    (Pinr : B → P) (Pglue : Pinl pt = Pinr pt) (y : wedge A B) : P :=
+  by induction y with a b x; exact Pinl a; exact Pinr b; induction x; exact Pglue
+
+end wedge
+
+attribute wedge.rec wedge.elim [recursor 7] [unfold 7]