import for_mathlib.derived.K_projective
import for_mathlib.derived.example

.

open category_theory

namespace homology

universes v u
variables {A : Type u} [category.{v} A] [abelian A]
  {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)

lemma desc_zero (w) :
  homology.desc' (0 : X ⟶ Y) g w (limits.kernel.ι _) (by simp) =
  homology.ι _ _ _ ≫ limits.cokernel.desc _ (𝟙 _) (by simp) :=
begin
  apply homology.hom_from_ext,
  simp,
end

lemma lift_desc'_of_eq_zero (hf : f = 0) :
  homology.lift f g w
    (limits.kernel.ι g ≫ limits.cokernel.π f) (by simp) ≫
    homology.desc' _ _ _ (limits.kernel.ι g) (by simp [hf]) =
  limits.kernel.ι _ :=
begin
  subst hf,
  rw desc_zero,
  simp,
end

end homology

namespace category_theory.ProjectiveResolution

open category_theory.limits

universes v u
variables {A : Type u} [category.{v} A] [abelian A]

variables {X : A} (P : ProjectiveResolution X)

noncomputable theory

def bhc : bounded_homotopy_category A :=
chain_complex.to_bounded_homotopy_category.obj P.complex

def bhc_π : P.bhc ⟶ (bounded_homotopy_category.single _ 0).obj X :=
chain_complex.to_bounded_homotopy_category.map P.π ≫
  ((homotopy_category.quotient _ _).map_iso
  ((chain_complex.single₀_comp_embed_iso_single).app X)).hom

instance [enough_projectives A] : homotopy_category.is_quasi_iso P.bhc_π :=
begin
  dsimp only [bhc_π],
  suffices : homotopy_category.is_quasi_iso
    (chain_complex.to_bounded_homotopy_category.map P.π),
  { resetI, apply_instance },
  exact P.is_projective_resolution.is_quasi_iso_embed,
end

instance [enough_projectives A] : homotopy_category.is_K_projective P.bhc.val :=
chain_complex.to_bounded_homotopy_category.is_K_projective _ X P.π
  P.is_projective_resolution

def Ext_iso [enough_projectives A] (Y : bounded_homotopy_category A) (i : ℤ) :
  ((bounded_homotopy_category.Ext i).obj
    (opposite.op ((bounded_homotopy_category.single _ 0).obj X))).obj Y ≅
  (preadditive_yoneda.obj (Y⟦i⟧)).obj (opposite.op P.bhc) :=
by apply bounded_homotopy_category.Ext_iso _ _ _ _ P.bhc_π

def Ext_iso_zero [enough_projectives A] (Y : bounded_homotopy_category A) :
  ((bounded_homotopy_category.Ext 0).obj
    (opposite.op ((bounded_homotopy_category.single _ 0).obj X))).obj Y ≅
  (preadditive_yoneda.obj Y).obj (opposite.op P.bhc) :=
P.Ext_iso Y 0 ≪≫ (preadditive_yoneda.map_iso (shift_zero _ _)).app _

def Ext_single_iso [enough_projectives A] (Y : A) :
  ((bounded_homotopy_category.Ext 0).obj
    (opposite.op ((bounded_homotopy_category.single _ 0).obj X))).obj
    ((bounded_homotopy_category.single _ 0).obj Y) ≅
    (((preadditive_yoneda.obj Y).map_homological_complex _).obj
      P.bhc.val.as.op).homology 0 :=
P.Ext_iso_zero _ ≪≫ P.bhc.hom_single_iso Y 0

lemma is_zero_hom_of_is_zero {X Y : A} (hX : is_zero X) :
  is_zero (AddCommGroup.of (X ⟶ Y)) :=
{ unique_to := λ Z,
  begin
    refine ⟨{to_inhabited := infer_instance, uniq := λ f, _}⟩,
    ext x,
    rw [hX.eq_to x, ← hX.eq_to (0 : X ⟶ Y), map_zero, map_zero]
  end,
  unique_from := λ Z,
  begin
    refine ⟨{to_inhabited := infer_instance, uniq := λ f, _}⟩,
    ext z,
    rw [hX.eq_to (f z), ← hX.eq_to _]
  end }

def homology_zero_iso [enough_projectives A] (Y : A) :
    (((preadditive_yoneda.obj Y).map_homological_complex _).obj
      P.bhc.val.as.op).homology 0 ≅
    kernel ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op) :=
homology_iso _ (1 : ℤ) 0 (-1) (by simp) (by simp) ≪≫
{ hom := kernel.lift _
    (homology.desc' _ _ _ (kernel.ι _) begin
      rw kernel.lift_ι,
      apply is_zero.eq_of_src,
      apply is_zero_hom_of_is_zero,
      exact is_zero_zero _,
    end) begin
      apply homology.hom_from_ext,
      simp only [homology.π'_desc'_assoc, comp_zero],
      erw kernel.condition,
    end,
  inv := homology.lift _ _ _
    (kernel.ι _ ≫ cokernel.π _)
    begin
      simp only [functor.map_homological_complex_obj_d,
        homological_complex.op_d, category.assoc, cokernel.π_desc],
      erw kernel.condition,
    end,
  hom_inv_id' := begin
    apply homology.hom_to_ext,
    apply homology.hom_from_ext,
    simp,
  end,
  inv_hom_id' := begin
    apply equalizer.hom_ext,
    simp only [category.assoc, kernel.lift_ι, equalizer_as_kernel, category.id_comp],
    apply homology.lift_desc'_of_eq_zero,
    apply is_zero.eq_of_src,
    apply is_zero_hom_of_is_zero,
    exact is_zero_zero _,
  end }

def Ext_single_iso_kernel [enough_projectives A] (Y : A) :
  ((bounded_homotopy_category.Ext 0).obj
    (opposite.op ((bounded_homotopy_category.single _ 0).obj X))).obj
    ((bounded_homotopy_category.single _ 0).obj Y) ≅
    kernel ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op) :=
P.Ext_single_iso Y ≪≫ P.homology_zero_iso _

def hom_to_kernel [enough_projectives A] (Y : A) :
  (preadditive_yoneda.obj Y).obj (opposite.op X) ⟶
  kernel ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op) :=
kernel.lift _ (category_theory.functor.map _ $ quiver.hom.op $ P.π.f _)
begin
  rw [← functor.map_comp, ← op_comp, ← P.π.comm, op_comp, functor.map_comp],
  convert zero_comp,
  apply is_zero.eq_of_tgt,
  dsimp,
  apply is_zero_hom_of_is_zero,
  exact is_zero_zero _,
end

instance mono_hom_to_kernel [enough_projectives A] (Y : A) :
  category_theory.mono (hom_to_kernel P Y) :=
begin
  dsimp only [hom_to_kernel],
  let e := (preadditive_yoneda.obj Y).map (P.π.f 0).op,
  suffices : mono e,
  { resetI,
    have he : e = kernel.lift ((preadditive_yoneda.obj Y).map
      (P.complex.d 1 0).op) ((preadditive_yoneda.obj Y).map (P.π.f 0).op) _ ≫ kernel.ι _, by simp,
    exact mono_of_mono_fac he.symm },
  rw AddCommGroup.mono_iff_injective,
  rw injective_iff_map_eq_zero,
  rintros (f : X ⟶ Y) (hf : _ ≫ f = 0),
  have : (0 : P.complex.X 0 ⟶ Y) = (P.π.f 0) ≫ 0, by simp,
  erw this at hf,
  haveI : category_theory.epi (P.π.f 0) := P.epi,
  erw cancel_epi at hf,
  exact hf
end

def cokernel_to : cokernel (P.complex.d 1 0) ⟶ X :=
cokernel.desc _ (P.π.f _)
begin
  rw ← P.π.comm,
  convert zero_comp,
  apply is_zero.eq_of_tgt,
  exact is_zero_zero _,
end

instance epi_cokernel_to : category_theory.epi P.cokernel_to :=
begin
  dsimp [cokernel_to],
  apply epi_of_epi_fac (cokernel.π_desc _ _ _),
  exact P.epi,
end

instance mono_cokernel_to : mono P.cokernel_to :=
begin
  dsimp [cokernel_to],
  apply abelian.pseudoelement.mono_of_zero_of_map_zero,
  intros a ha,
  obtain ⟨a,rfl⟩ := abelian.pseudoelement.pseudo_surjective_of_epi (cokernel.π _) a,
  rw [← abelian.pseudoelement.comp_apply, cokernel.π_desc] at ha,
  have e := abelian.pseudoelement.pseudo_exact_of_exact P.exact₀,
  obtain ⟨b,rfl⟩ := e.2 _ ha,
  rw [← abelian.pseudoelement.comp_apply, cokernel.condition,
    abelian.pseudoelement.zero_apply],
end

instance is_iso_cokernel_to : is_iso P.cokernel_to :=
is_iso_of_mono_of_epi _

instance epi_hom_to_kernel [enough_projectives A] (Y : A) :
  category_theory.epi (hom_to_kernel P Y) :=
begin
  dsimp only [hom_to_kernel],
  rw AddCommGroup.epi_iff_surjective,
  intros f,
  let g : P.complex.X 0 ⟶ Y :=
    kernel.ι ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op) f,
  have hg : P.complex.d 1 0 ≫ g = 0,
  { dsimp only [g],
    change (kernel.ι ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op) ≫
      ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op)) f = 0,
    rw kernel.condition, refl },
  change ∃ q : X ⟶ _, _ = _,
  let q' : cokernel (P.complex.d 1 0) ⟶ Y :=
    cokernel.desc _ g hg,
  use inv P.cokernel_to ≫ q',
  apply_fun (kernel.ι ((preadditive_yoneda.obj Y).map (P.complex.d 1 0).op)),
  swap,
  { rw ← AddCommGroup.mono_iff_injective, apply_instance },
  rw [← comp_apply, kernel.lift_ι],
  dsimp only [q'],
  change _ ≫ _ = _,
  rw ← category.assoc,
  let t := _, change t ≫ _ = _,
  have ht : t = cokernel.π _,
  { dsimp only [t], rw is_iso.comp_inv_eq, dsimp [cokernel_to], simp },
  rw ht, simp,
end

instance is_iso_hom_to_kernel [enough_projectives A] (Y : A) :
  is_iso (hom_to_kernel P Y) := is_iso_of_mono_of_epi _

def hom_to [enough_projectives A] (Y : A) :
  (preadditive_yoneda.obj Y).obj (opposite.op X) ⟶
  (preadditive_yoneda.obj ((bounded_homotopy_category.single _ 0).obj Y)).obj
    (opposite.op P.bhc) :=
{ to_fun := λ (f : X ⟶ Y), P.bhc_π ≫ (bounded_homotopy_category.single _ _).map f,
  map_zero' := begin
    convert comp_zero,
    dsimp [bounded_homotopy_category.single],
    simp,
  end,
  map_add' := begin
    -- Missing additive isntance for bounded_homotopy_category.single
    dsimp [bounded_homotopy_category.single],
    intros a b,
    rw ← preadditive.comp_add, congr' 1,
    rw ← functor.map_add,
    congr' 1,
    -- Missing additive instance....
    ext i,
    dsimp,
    split_ifs; simp,
  end }

instance is_iso_hom_to [enough_projectives A] (Y : A) :
  is_iso (P.hom_to Y) :=
begin
  -- rw AddCommGroup.is_iso_iff_bijective, <-- missing :(
  apply_with is_iso_of_mono_of_epi { instances := ff }, apply_instance,
  { rw AddCommGroup.mono_iff_injective,
    intros a b h,
    dsimp [hom_to] at h,
    erw ← (homotopy_category.quotient _ _).map_comp at h,
    erw ← (homotopy_category.quotient _ _).map_comp at h,
    replace h := homotopy_category.homotopy_of_eq _ _ h,
    have hh := h.comm 0, dsimp at hh,
    simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true, category.assoc,
      homological_complex.cochain_complex_d_next, homological_complex.cochain_complex_prev_d,
      homological_complex.single_obj_d, comp_zero, add_zero] at hh,
    dsimp [chain_complex.single₀_comp_embed_iso_single,
      chain_complex.single₀_comp_embed_iso_single_component] at hh,
    simp only [category.id_comp] at hh,
    rw [← d_next_eq_d_from_from_next, ← prev_d_eq_to_prev_d_to] at hh,
    dsimp [d_next, prev_d] at hh,
    have : h.hom ((complex_shape.up ℤ).next 0) 0 = 0,
    { apply is_zero.eq_of_src, rw cochain_complex.next, apply is_zero_zero, },
    simp only [comp_zero, add_zero, zero_add, this, cancel_epi (P.π.f 0)] at hh,
    exact hh },
  { rw AddCommGroup.epi_iff_surjective,
    rintros (a : P.bhc ⟶ _),
    change ∃ (b : X ⟶ Y), _ ≫ _ = _,
    let q := a.out,
    let q' : P.complex.X 0 ⟶ Y := q.f 0,
    let b : X ⟶ Y := inv P.cokernel_to ≫ cokernel.desc _ q' _,
    swap,
    { dsimp [q'], change P.bhc.val.as.d (-1) 0 ≫ _ = _, rw ← q.comm,
      convert zero_comp,
      apply is_zero.eq_of_tgt,
      exact is_zero_zero _ },
    use b,
    rw ← homotopy_category.quotient_map_out a,
    erw ← (homotopy_category.quotient _ _).map_comp,
    congr' 1, change _ = q, ext ((_|i)|i),
    { change _ = q',
      simp only [iso.app_hom, functor.map_comp, functor.map_inv, category.assoc,
        homological_complex.comp_f, homological_complex.single_map_f,
        int.of_nat_eq_coe, int.coe_nat_zero, eq_self_iff_true, eq_to_hom_refl,
        category.comp_id, category.id_comp, dite_eq_ite, if_true],
      change P.π.f 0 ≫ _ = _,
      simp_rw [← category.assoc],
      let t := _, change t ≫ _ = _,
      have ht : t = cokernel.π  _,
      { dsimp [t],
        rw [← functor.map_inv, ← as_iso_inv, ← functor.map_iso_inv],
        let w := (homological_complex.single A
          (complex_shape.up ℤ) 0).map_iso (as_iso P.cokernel_to),
        change (P.π.f 0 ≫ _) ≫
          ((homological_complex.eval _ _ 0).map_iso w).inv = _,
        rw iso.comp_inv_eq,
        dsimp [chain_complex.single₀_comp_embed_iso_single,
          chain_complex.single₀_comp_embed_iso_single_component],
        simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true],
        dsimp [cokernel_to],
        simp only [cokernel.π_desc],
        change _ ≫ (iso.refl _).hom = _,
        simp only [iso.refl_hom, category.comp_id] },
      rw ht, clear ht, clear t,
      rw cokernel.π_desc },
    { apply is_zero.eq_of_src, exact is_zero_zero _ },
    { apply is_zero.eq_of_tgt, exact is_zero_zero _ },
  },
end

def Ext_single_iso_hom [enough_projectives A] (Y : A) :
  (preadditive_yoneda.obj Y).obj (opposite.op X) ≅
  ((bounded_homotopy_category.Ext 0).obj
    (opposite.op ((bounded_homotopy_category.single _ 0).obj X))).obj
    ((bounded_homotopy_category.single _ 0).obj Y) :=
(as_iso $ P.hom_to _) ≪≫ (preadditive_yoneda.map_iso $ (shift_zero _ _).symm).app _ ≪≫
(P.Ext_iso ((bounded_homotopy_category.single _ 0).obj Y) 0).symm

end category_theory.ProjectiveResolution


import data.bool.subbool
import data.bool.misc

import algebra.theory
import algebra.theory.free
import .basic

/-
 * F2-vector space structure on `bool`
-/
attribute [instance,reducible]
definition bool_bxor : model binary_module bool :=
{
  act := λ n f, vect.foldl bxor ff,
  haxiom :=
    begin
      intros,
      cases r,
      case binary_module.rels.left_zero {
        dsimp [binary_module],
        repeat {
          csimp only [optree.elim_opnode,optree.elim_varleaf],
          try {dsimp [vect.map,vect.foldl]}
        },
        rw [ff_bxor_safe],
      },
      case binary_module.rels.right_zero {
        dsimp [binary_module],
        repeat {
          csimp only [optree.elim_opnode,optree.elim_varleaf],
          try {dsimp [vect.map,vect.foldl]}
        },
        rw [bxor_ff_safe, ff_bxor_safe]
      },
      case binary_module.rels.add_self {
        dsimp [binary_module],
        repeat {
          csimp only [optree.elim_opnode,optree.elim_varleaf],
          try {dsimp [vect.map,vect.foldl]}
        },
        rw [ff_bxor_safe],
        exact bxor_self_safe _
      },
      case binary_module.rels.add_comm {
        dsimp [binary_module],
        repeat {
          csimp only [optree.elim_opnode,optree.elim_varleaf],
          try {dsimp [vect.map,vect.foldl]}
        },
        rw [ff_bxor_safe,ff_bxor_safe],
        exact bxor_comm _ _
      },
      case binary_module.rels.add_assoc {
        dsimp [binary_module],
        repeat {
          csimp only [optree.elim_opnode,optree.elim_varleaf],
          try {dsimp [vect.map,vect.foldl]}
        },
        repeat {rw [ff_bxor_safe]},
        exact bxor_assoc _ _ _
      },
    end
}

#print axioms bool_bxor

namespace binary_module

definition generate {α : Type _} [model binary_module α] (a : α) : morphism binary_module bool α :=
{
  val := @bool.rec (λ_, α) (binary_module.zero α) a,
  property :=
    begin
      intros n f as,
      cases f,
      case binary_module.ops.zero {
        cases as,
        dsimp [premodel.act,vect.map,vect.foldl],
        dunfold binary_module.zero,
        refl
      },
      case binary_module.ops.add {
        cases as with _ x bs; cases bs with _ y cs; cases cs,
        dsimp [premodel.act],
        cases x,
        case bool.ff {
          cases y,
          case bool.ff {
            let h := binary_module.add_zero (binary_module.zero α),
            dunfold binary_module.add at h,
            have : (vect.foldl bxor ff (vect.cons ff (vect.cons ff vect.nil)))=ff,
              by refl,
            rw [this]; dsimp at *,
            dunfold vect.map,
            rw [h],
          },
          case bool.tt {
            let h := binary_module.zero_add a,
            dunfold binary_module.add at h,
            have : (vect.foldl bxor ff (vect.cons ff (vect.cons tt vect.nil)))=tt,
              by refl,
            rw [this]; dsimp at *,
            dunfold vect.map,
            rw [h]
          }
        },
        case bool.tt {
          cases y,
          case bool.ff {
            let h := binary_module.add_zero a,
            dunfold binary_module.add at h,
            have : (vect.foldl bxor ff (vect.cons tt (vect.cons ff vect.nil)))=tt,
              by refl,
            rw [this]; dsimp *,
            dunfold vect.map,
            rw [h]
          },
          case bool.tt {
            let h := binary_module.add_self a,
            dunfold binary_module.add at h,
            have : (vect.foldl bxor ff (vect.cons tt (vect.cons tt vect.nil)))=ff,
              by refl,
            rw [this]; dsimp *,
            dunfold vect.map,
            rw [h]
          }
        },
      }
    end
}

#print axioms binary_module.generate

theorem bool_free : is_free binary_module (function.const unit tt) :=
  begin
    dunfold is_free,
    intros γ hmc f,
    existsi @generate _ hmc (f ()),
    split; dsimp *,
    focus {
      intro a; cases a,
      unfold generate
    },
    focus {
      intros g hy,
      dunfold generate,
      dunfold function.const at hy,
      apply subtype.eq; dunfold subtype.val,
      apply funext,
      intros b,
      cases b,
      case bool.ff {
        let h := g.property binary_module.ops.zero vect.nil,
        unfold premodel.act at h,
        unfold vect.foldl at h,
        dsimp * at *,
        rw [h],
        refl
      },
      case bool.tt {
        dsimp *,
        rw [hy]
      },
    }
  end

#print axioms binary_module.bool_free

end binary_module

@[instance]
definition subbool_binmod (p : Prop) : model binary_module (subbool p) :=
{
  act := λ n f, vect.foldl subbool.xor (subbool.ff p),
  haxiom :=
    begin
      intros n r var,
      cases r,
      case binary_module.rels.left_zero {
        dsimp [binary_module],
        repeat { unfold optree.elim; try {unfold optree.elim_aux} },
        dunfold vect.foldl,
        exact subbool.ff_xor _
      },
      case binary_module.rels.right_zero {
        dsimp [binary_module],
        repeat { unfold optree.elim; try {unfold optree.elim_aux} },
        dunfold vect.foldl,
        rw [subbool.xor_ff,subbool.ff_xor],
      },
      case binary_module.rels.add_self {
        dsimp [binary_module],
        repeat { unfold optree.elim; try {unfold optree.elim_aux} },
        dunfold vect.foldl,
        rw [subbool.ff_xor, subbool.xor_self]
      },
      case binary_module.rels.add_comm {
        dsimp [binary_module],
        repeat { unfold optree.elim; try {unfold optree.elim_aux} },
        dunfold vect.foldl,
        csimp only [subbool.ff_xor, subbool.xor_comm]
      },
      case binary_module.rels.add_assoc {
        dsimp [binary_module],
        repeat { unfold optree.elim; try {unfold optree.elim_aux} },
        dunfold vect.foldl,
        csimp only [subbool.ff_xor, subbool.xor_assoc]
      },
    end
}

#print axioms subbool_binmod

namespace binary_module

@[reducible]
definition generate_p (p : Prop) {α : Type _} [model binary_module α] (a : p → α) : morphism binary_module (subbool p) α :=
{
  val := λ x, @subtype.rec_on _ _ (λ_, α) x (λ b, @bool.cases_on (λ b, p∨b=ff → α) b (λ_, binary_module.zero α) (λ h, a (or.elim h id (λ h, by injection h)))),
  property :=
    begin
      intros n f as,
      dsimp *,
      cases f,
      case binary_module.ops.zero {
        cases as,
        dsimp [premodel.act,vect.map,vect.foldl],
        unfold binary_module.zero,
      },
      case binary_module.ops.add {
        cases as with _ x bs; cases bs with _ y cs; cases cs,
        dsimp [premodel.act],
        cases x; cases x_val,
        case bool.ff {
          cases y; cases y_val,
          case bool.ff {
            let h := binary_module.add_zero (binary_module.zero α),
            unfold binary_module.add at h,
            have : vect.foldl subbool.xor (subbool.ff p) ⁅⟨ff, x_property⟩, ⟨ff, y_property⟩⁆ = subbool.ff p,
              by refl,
            rw [this],
            unfold vect.map,
            rw [h],
          },
          case bool.tt {
            have : p, from or.elim y_property id (λ h, by injection h),
            let h := binary_module.zero_add (a this),
            unfold binary_module.add at h,
            have : vect.foldl subbool.xor (subbool.ff p) ⁅⟨ff, x_property⟩, ⟨tt, y_property⟩⁆ = subbool.tt (y_property.elim id (λ x, by injection x)),
              by refl,
            rw [this],
            unfold vect.map,
            rw [h],
          }
        },
        case bool.tt {
          cases y; cases y_val,
          case bool.ff {
            have : p, from or.elim x_property id (λ h, by injection h),
            let h := binary_module.add_zero (a this),
            unfold binary_module.add at h,
            have : vect.foldl subbool.xor (subbool.ff p) ⁅⟨tt, x_property⟩, ⟨ff, y_property⟩⁆ = subbool.tt (x_property.elim id (λ x, by injection x)),
              by refl,
            rw [this],
            unfold vect.map,
            rw [h]
          },
          case bool.tt {
            have : p, from or.elim x_property id (λ h, by injection h),
            let h := binary_module.add_self (a this),
            unfold binary_module.add at h,
            have : vect.foldl subbool.xor (subbool.ff p) ⁅⟨tt, x_property⟩, ⟨tt, y_property⟩⁆ = subbool.ff p,
              by refl,
            rw [this],
            unfold vect.map,
            rw [h]
          }
        }
      }
    end
}

#print axioms generate_p

theorem subbool_free (p : Prop) : is_free binary_module (@subbool.tt p) :=
  begin
    intros γ mc f,
    existsi @generate_p _ _ mc f,
    split; dsimp *,
    focus {
      intro; refl
    },
    focus {
      intros g hg,
      unfold generate_p,
      simp *,
      apply subtype.eq; dunfold subtype.val,
      apply funext,
      intros x,
      cases x,
      cases x_val,
      case bool.ff {
        dsimp * at *,
        let h := g.property binary_module.ops.zero vect.nil,
        dsimp [premodel.act,vect.foldl] at h,
        rw [h],
        refl
      },
      case bool.tt {
        dsimp * at *,
        have : p,
          from x_property.elim id (λ h, by injection h),
        exact hg this
      },
    }
  end

#print axioms subbool_free

end binary_module


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Riccardo Brasca
-/
import analysis.normed.group.hom
import category_theory.limits.shapes.zero_morphisms
import category_theory.concrete_category.bundled_hom
import category_theory.elementwise

/-!
# The category of seminormed groups

We define `SemiNormedGroup`, the category of seminormed groups and normed group homs between them,
as well as `SemiNormedGroup₁`, the subcategory of norm non-increasing morphisms.
-/

noncomputable theory

universes u

open category_theory

/-- The category of seminormed abelian groups and bounded group homomorphisms. -/
def SemiNormedGroup : Type (u+1) := bundled semi_normed_group

namespace SemiNormedGroup

instance bundled_hom : bundled_hom @normed_group_hom :=
⟨@normed_group_hom.to_fun, @normed_group_hom.id, @normed_group_hom.comp, @normed_group_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] SemiNormedGroup

instance : has_coe_to_sort SemiNormedGroup (Type u) := bundled.has_coe_to_sort

/-- Construct a bundled `SemiNormedGroup` from the underlying type and typeclass. -/
def of (M : Type u) [semi_normed_group M] : SemiNormedGroup := bundled.of M

instance (M : SemiNormedGroup) : semi_normed_group M := M.str

@[simp] lemma coe_of (V : Type u) [semi_normed_group V] : (SemiNormedGroup.of V : Type u) = V := rfl
@[simp] lemma coe_id (V : SemiNormedGroup) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl

instance : inhabited SemiNormedGroup := ⟨of punit⟩

instance of_unique (V : Type u) [semi_normed_group V] [i : unique V] :
  unique (SemiNormedGroup.of V) := i

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup := {}

@[simp] lemma zero_apply {V W : SemiNormedGroup} (x : V) : (0 : V ⟶ W) x = 0 := rfl

lemma is_zero_of_subsingleton (V : SemiNormedGroup) [subsingleton V] :
  limits.is_zero V :=
begin
  refine ⟨λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩,
  { ext, have : x = 0 := subsingleton.elim _ _, simp only [this, normed_group_hom.map_zero], },
  { ext, apply subsingleton.elim }
end

instance has_zero_object : limits.has_zero_object SemiNormedGroup.{u} :=
⟨⟨of punit, is_zero_of_subsingleton _⟩⟩

lemma iso_isometry_of_norm_noninc {V W : SemiNormedGroup} (i : V ≅ W)
  (h1 : i.hom.norm_noninc) (h2 : i.inv.norm_noninc) :
  isometry i.hom :=
begin
  apply normed_group_hom.isometry_of_norm,
  intro v,
  apply le_antisymm (h1 v),
  calc ∥v∥ = ∥i.inv (i.hom v)∥ : by rw [iso.hom_inv_id_apply]
  ... ≤ ∥i.hom v∥ : h2 _,
end

end SemiNormedGroup

/--
`SemiNormedGroup₁` is a type synonym for `SemiNormedGroup`,
which we shall equip with the category structure consisting only of the norm non-increasing maps.
-/
def SemiNormedGroup₁ : Type (u+1) := bundled semi_normed_group

namespace SemiNormedGroup₁

instance : has_coe_to_sort SemiNormedGroup₁ (Type u) := bundled.has_coe_to_sort

instance : large_category.{u} SemiNormedGroup₁ :=
{ hom := λ X Y, { f : normed_group_hom X Y // f.norm_noninc },
  id := λ X, ⟨normed_group_hom.id X, normed_group_hom.norm_noninc.id⟩,
  comp := λ X Y Z f g, ⟨(g : normed_group_hom Y Z).comp (f : normed_group_hom X Y), g.2.comp f.2⟩, }

@[ext] lemma hom_ext {M N : SemiNormedGroup₁} (f g : M ⟶ N) (w : (f : M → N) = (g : M → N)) :
  f = g :=
subtype.eq (normed_group_hom.ext (congr_fun w))

instance : concrete_category.{u} SemiNormedGroup₁ :=
{ forget :=
  { obj := λ X, X,
    map := λ X Y f, f, },
  forget_faithful := {} }

/-- Construct a bundled `SemiNormedGroup₁` from the underlying type and typeclass. -/
def of (M : Type u) [semi_normed_group M] : SemiNormedGroup₁ := bundled.of M

instance (M : SemiNormedGroup₁) : semi_normed_group M := M.str

/-- Promote a morphism in `SemiNormedGroup` to a morphism in `SemiNormedGroup₁`. -/
def mk_hom {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) :
  SemiNormedGroup₁.of M ⟶ SemiNormedGroup₁.of N :=
⟨f, i⟩

@[simp] lemma mk_hom_apply {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) (x) :
  mk_hom f i x = f x := rfl

/-- Promote an isomorphism in `SemiNormedGroup` to an isomorphism in `SemiNormedGroup₁`. -/
@[simps]
def mk_iso {M N : SemiNormedGroup} (f : M ≅ N) (i : f.hom.norm_noninc) (i' : f.inv.norm_noninc) :
  SemiNormedGroup₁.of M ≅ SemiNormedGroup₁.of N :=
{ hom := mk_hom f.hom i,
  inv := mk_hom f.inv i',
  hom_inv_id' := by { apply subtype.eq, exact f.hom_inv_id, },
  inv_hom_id' := by { apply subtype.eq, exact f.inv_hom_id, }, }

instance : has_forget₂ SemiNormedGroup₁ SemiNormedGroup :=
{ forget₂ :=
  { obj := λ X, X,
    map := λ X Y f, f.1, }, }

@[simp] lemma coe_of (V : Type u) [semi_normed_group V] : (SemiNormedGroup₁.of V : Type u) = V :=
rfl
@[simp] lemma coe_id (V : SemiNormedGroup₁) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl
-- If `coe_fn_coe_base` fires before `coe_comp`, `coe_comp'` puts us back in normal form.
@[simp] lemma coe_comp' {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : normed_group_hom M K) = (↑g : normed_group_hom N K).comp ↑f := rfl

instance : inhabited SemiNormedGroup₁ := ⟨of punit⟩

instance of_unique (V : Type u) [semi_normed_group V] [i : unique V] :
  unique (SemiNormedGroup₁.of V) := i

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup₁ :=
{ has_zero := λ X Y, { zero := ⟨0, normed_group_hom.norm_noninc.zero⟩, },
  comp_zero' := λ X Y f Z, by { ext, refl, },
  zero_comp' := λ X Y Z f, by { ext, simp [coe_fn_coe_base'] } }

@[simp] lemma zero_apply {V W : SemiNormedGroup₁} (x : V) : (0 : V ⟶ W) x = 0 := rfl

lemma is_zero_of_subsingleton (V : SemiNormedGroup₁) [subsingleton V] :
  limits.is_zero V :=
begin
  refine ⟨λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩,
  { ext, have : x = 0 := subsingleton.elim _ _, simp only [this, normed_group_hom.map_zero],
    apply f.1.map_zero, },
  { ext, apply subsingleton.elim }
end

instance has_zero_object : limits.has_zero_object SemiNormedGroup₁.{u} :=
⟨⟨of punit, is_zero_of_subsingleton _⟩⟩

lemma iso_isometry {V W : SemiNormedGroup₁} (i : V ≅ W) :
  isometry i.hom :=
begin
  apply normed_group_hom.isometry_of_norm,
  intro v,
  apply le_antisymm (i.hom.2 v),
  calc ∥v∥ = ∥i.inv (i.hom v)∥ : by rw [iso.hom_inv_id_apply]
      ... ≤ ∥i.hom v∥ : i.inv.2 _,
end

end SemiNormedGroup₁


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import ring_theory.polynomial.basic
import algebra.algebra.subalgebra

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of subalgebras of an R-algebra generated
by a set of elements. A basic interface for `adjoin` is set up, and various
results about finitely-generated subalgebras and submodules are proved.

## Definitions

* `fg (S : subalgebra R A)` : A predicate saying that the subalgebra is finitely-generated
as an A-algebra

## Tags

adjoin, algebra, finitely-generated algebra

-/

universes u v w

open submodule

namespace algebra

variables {R : Type u} {A : Type v} {B : Type w}

section semiring
variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B] {s t : set A}
open subsemiring

theorem subset_adjoin : s ⊆ adjoin R s :=
algebra.gc.le_u_l s

theorem adjoin_le {S : subalgebra R A} (H : s ⊆ S) : adjoin R s ≤ S :=
algebra.gc.l_le H

theorem adjoin_le_iff {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ S:=
algebra.gc _ _

variables (R A)
@[simp] theorem adjoin_empty : adjoin R (∅ : set A) = ⊥ :=
show adjoin R ⊥ = ⊥, by { apply galois_connection.l_bot, exact algebra.gc }

variables (R) {A} (s)

theorem adjoin_eq_span : (adjoin R s).to_submodule = span R (submonoid.closure s) :=
begin
  apply le_antisymm,
  { intros r hr, rcases subsemiring.mem_closure_iff_exists_list.1 hr with ⟨L, HL, rfl⟩, clear hr,
    induction L with hd tl ih, { exact zero_mem _ },
    rw list.forall_mem_cons at HL,
    rw [list.map_cons, list.sum_cons],
    refine submodule.add_mem _ _ (ih HL.2),
    replace HL := HL.1, clear ih tl,
    suffices : ∃ z r (hr : r ∈ submonoid.closure s), has_scalar.smul z r = list.prod hd,
    { rcases this with ⟨z, r, hr, hzr⟩, rw ← hzr,
      exact smul_mem _ _ (subset_span hr) },
    induction hd with hd tl ih, { exact ⟨1, 1, (submonoid.closure s).one_mem', one_smul _ _⟩ },
    rw list.forall_mem_cons at HL,
    rcases (ih HL.2) with ⟨z, r, hr, hzr⟩, rw [list.prod_cons, ← hzr],
    rcases HL.1 with ⟨hd, rfl⟩ | hs,
    { refine ⟨hd * z, r, hr, _⟩,
      rw [algebra.smul_def, algebra.smul_def, (algebra_map _ _).map_mul, _root_.mul_assoc] },
    { exact ⟨z, hd * r, submonoid.mul_mem _ (submonoid.subset_closure hs) hr,
        (mul_smul_comm _ _ _).symm⟩ } },
  refine span_le.2 _,
  change submonoid.closure s ≤ (adjoin R s).to_subsemiring.to_submonoid,
  exact submonoid.closure_le.2 subset_adjoin
end

lemma adjoin_image (f : A →ₐ[R] B) (s : set A) :
  adjoin R (f '' s) = (adjoin R s).map f :=
le_antisymm (adjoin_le $ set.image_subset _ subset_adjoin) $
subalgebra.map_le.2 $ adjoin_le $ set.image_subset_iff.1 subset_adjoin

@[simp] lemma adjoin_insert_adjoin (x : A) :
  adjoin R (insert x ↑(adjoin R s)) = adjoin R (insert x s) :=
le_antisymm
  (adjoin_le (set.insert_subset.mpr
    ⟨subset_adjoin (set.mem_insert _ _), adjoin_mono (set.subset_insert _ _)⟩))
  (algebra.adjoin_mono (set.insert_subset_insert algebra.subset_adjoin))

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A]
variables [algebra R A] {s t : set A}
open subsemiring

variables (R s t)
theorem adjoin_union : adjoin R (s ∪ t) = (adjoin R s).under (adjoin (adjoin R s) t) :=
le_antisymm
  (closure_mono $ set.union_subset
    (set.range_subset_iff.2 $ λ r, or.inl ⟨algebra_map R (adjoin R s) r, rfl⟩)
    (set.union_subset_union_left _ $ λ x hxs, ⟨⟨_, subset_adjoin hxs⟩, rfl⟩))
  (closure_le.2 $ set.union_subset
    (set.range_subset_iff.2 $ λ x, adjoin_mono (set.subset_union_left _ _) x.2)
    (set.subset.trans (set.subset_union_right _ _) subset_adjoin))

theorem adjoin_eq_range :
  adjoin R s = (mv_polynomial.aeval (coe : s → A)).range :=
le_antisymm
  (adjoin_le $ λ x hx, ⟨mv_polynomial.X ⟨x, hx⟩, mv_polynomial.eval₂_X _ _ _⟩)
  (λ x ⟨p, (hp : mv_polynomial.aeval coe p = x)⟩, hp ▸ mv_polynomial.induction_on p
    (λ r, by { rw [mv_polynomial.aeval_def, mv_polynomial.eval₂_C],
               exact (adjoin R s).algebra_map_mem r })
    (λ p q hp hq, by rw alg_hom.map_add; exact subalgebra.add_mem _ hp hq)
    (λ p ⟨n, hn⟩ hp, by rw [alg_hom.map_mul, mv_polynomial.aeval_def _ (mv_polynomial.X _),
      mv_polynomial.eval₂_X]; exact subalgebra.mul_mem _ hp (subset_adjoin hn)))

theorem adjoin_singleton_eq_range (x : A) : adjoin R {x} = (polynomial.aeval x).range :=
le_antisymm
  (adjoin_le $ set.singleton_subset_iff.2 ⟨polynomial.X, polynomial.eval₂_X _ _⟩)
  (λ y ⟨p, (hp : polynomial.aeval x p = y)⟩, hp ▸ polynomial.induction_on p
    (λ r, by { rw [polynomial.aeval_def, polynomial.eval₂_C],
               exact (adjoin R _).algebra_map_mem r })
    (λ p q hp hq, by rw alg_hom.map_add; exact subalgebra.add_mem _ hp hq)
    (λ n r ih, by { rw [pow_succ', ← mul_assoc, alg_hom.map_mul,
      polynomial.aeval_def _ polynomial.X, polynomial.eval₂_X],
      exact subalgebra.mul_mem _ ih (subset_adjoin rfl) }))

lemma adjoin_singleton_one : adjoin R ({1} : set A) = ⊥ :=
eq_bot_iff.2 $ adjoin_le $ set.singleton_subset_iff.2 $ set_like.mem_coe.2 $ one_mem _

theorem adjoin_union_coe_submodule : (adjoin R (s ∪ t)).to_submodule =
  (adjoin R s).to_submodule * (adjoin R t).to_submodule :=
begin
  rw [adjoin_eq_span, adjoin_eq_span, adjoin_eq_span, span_mul_span],
  congr' 1 with z, simp [submonoid.closure_union, submonoid.mem_sup, set.mem_mul]
end

end comm_semiring

section ring
variables [comm_ring R] [ring A]
variables [algebra R A] {s t : set A}
variables {R s t}
open ring

theorem adjoin_int (s : set R) : adjoin ℤ s = subalgebra_of_is_subring (closure s) :=
le_antisymm (adjoin_le subset_closure) (closure_subset subset_adjoin : closure s ≤ adjoin ℤ s)

theorem mem_adjoin_iff {s : set A} {x : A} :
  x ∈ adjoin R s ↔ x ∈ closure (set.range (algebra_map R A) ∪ s) :=
⟨λ hx, subsemiring.closure_induction hx subset_closure is_add_submonoid.zero_mem
  is_submonoid.one_mem (λ _ _, is_add_submonoid.add_mem) (λ _ _, is_submonoid.mul_mem),
suffices closure (set.range ⇑(algebra_map R A) ∪ s) ⊆ adjoin R s, from @this x,
closure_subset subsemiring.subset_closure⟩

theorem adjoin_eq_ring_closure (s : set A) :
  (adjoin R s : set A) = closure (set.range (algebra_map R A) ∪ s) :=
set.ext $ λ x, mem_adjoin_iff

end ring

section comm_ring
variables [comm_ring R] [comm_ring A]
variables [algebra R A] {s t : set A}
variables {R s t}
open ring

theorem fg_trans (h1 : (adjoin R s).to_submodule.fg)
  (h2 : (adjoin (adjoin R s) t).to_submodule.fg) :
  (adjoin R (s ∪ t)).to_submodule.fg :=
begin
  rcases fg_def.1 h1 with ⟨p, hp, hp'⟩,
  rcases fg_def.1 h2 with ⟨q, hq, hq'⟩,
  refine fg_def.2 ⟨p * q, hp.mul hq, le_antisymm _ _⟩,
  { rw [span_le],
    rintros _ ⟨x, y, hx, hy, rfl⟩,
    change x * y ∈ _,
    refine is_submonoid.mul_mem _ _,
    { have : x ∈ (adjoin R s).to_submodule,
      { rw ← hp', exact subset_span hx },
      exact adjoin_mono (set.subset_union_left _ _) this },
    have : y ∈ (adjoin (adjoin R s) t).to_submodule,
    { rw ← hq', exact subset_span hy },
    change y ∈ adjoin R (s ∪ t), rwa adjoin_union },
  { intros r hr,
    change r ∈ adjoin R (s ∪ t) at hr,
    rw adjoin_union at hr,
    change r ∈ (adjoin (adjoin R s) t).to_submodule at hr,
    haveI := classical.dec_eq A,
    haveI := classical.dec_eq R,
    rw [← hq', ← set.image_id q, finsupp.mem_span_iff_total (adjoin R s)] at hr,
    rcases hr with ⟨l, hlq, rfl⟩,
    have := @finsupp.total_apply A A (adjoin R s),
    rw [this, finsupp.sum],
    refine sum_mem _ _,
    intros z hz, change (l z).1 * _ ∈ _,
    have : (l z).1 ∈ (adjoin R s).to_submodule := (l z).2,
    rw [← hp', ← set.image_id p, finsupp.mem_span_iff_total R] at this,
    rcases this with ⟨l2, hlp, hl⟩,
    have := @finsupp.total_apply A A R,
    rw this at hl,
    rw [←hl, finsupp.sum_mul],
    refine sum_mem _ _,
    intros t ht, change _ * _ ∈ _, rw smul_mul_assoc, refine smul_mem _ _ _,
    exact subset_span ⟨t, z, hlp ht, hlq hz, rfl⟩ }
end

end comm_ring

end algebra

namespace subalgebra

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- A subalgebra `S` is finitely generated if there exists `t : finset A` such that
`algebra.adjoin R t = S`. -/
def fg (S : subalgebra R A) : Prop :=
∃ t : finset A, algebra.adjoin R ↑t = S

lemma fg_adjoin_finset (s : finset A) : (algebra.adjoin R (↑s : set A)).fg :=
⟨s, rfl⟩

theorem fg_def {S : subalgebra R A} : S.fg ↔ ∃ t : set A, set.finite t ∧ algebra.adjoin R t = S :=
⟨λ ⟨t, ht⟩, ⟨↑t, set.finite_mem_finset t, ht⟩,
λ ⟨t, ht1, ht2⟩, ⟨ht1.to_finset, by rwa set.finite.coe_to_finset⟩⟩

theorem fg_bot : (⊥ : subalgebra R A).fg :=
⟨∅, algebra.adjoin_empty R A⟩

theorem fg_of_fg_to_submodule {S : subalgebra R A} : S.to_submodule.fg → S.fg :=
λ ⟨t, ht⟩, ⟨t, le_antisymm
  (algebra.adjoin_le (λ x hx, show x ∈ S.to_submodule, from ht ▸ subset_span hx)) $
  show S.to_submodule ≤ (algebra.adjoin R ↑t).to_submodule,
  from (λ x hx, span_le.mpr
    (λ x hx, algebra.subset_adjoin hx)
      (show x ∈ span R ↑t, by { rw ht, exact hx }))⟩

theorem fg_of_noetherian [is_noetherian R A] (S : subalgebra R A) : S.fg :=
fg_of_fg_to_submodule (is_noetherian.noetherian S.to_submodule)

lemma fg_of_submodule_fg (h : (⊤ : submodule R A).fg) : (⊤ : subalgebra R A).fg :=
let ⟨s, hs⟩ := h in ⟨s, to_submodule_injective $
by { rw [algebra.top_to_submodule, eq_top_iff, ← hs, span_le], exact algebra.subset_adjoin }⟩

section
open_locale classical
lemma fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hs : S.fg) : (S.map f).fg :=
let ⟨s, hs⟩ := hs in ⟨s.image f, by rw [finset.coe_image, algebra.adjoin_image, hs]⟩
end

lemma fg_of_fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hf : function.injective f)
  (hs : (S.map f).fg) : S.fg :=
let ⟨s, hs⟩ := hs in ⟨s.preimage f $ λ _ _ _ _ h, hf h, map_injective f hf $
by { rw [← algebra.adjoin_image, finset.coe_preimage, set.image_preimage_eq_of_subset, hs],
  rw [← alg_hom.coe_range, ← algebra.adjoin_le_iff, hs, ← algebra.map_top], exact map_mono le_top }⟩

lemma fg_top (S : subalgebra R A) : (⊤ : subalgebra R S).fg ↔ S.fg :=
⟨λ h, by { rw [← S.range_val, ← algebra.map_top], exact fg_map _ _ h },
λ h, fg_of_fg_map _ S.val subtype.val_injective $ by { rw [algebra.map_top, range_val], exact h }⟩

lemma induction_on_adjoin [is_noetherian R A] (P : subalgebra R A → Prop)
  (base : P ⊥) (ih : ∀ (S : subalgebra R A) (x : A), P S → P (algebra.adjoin R (insert x S)))
  (S : subalgebra R A) : P S :=
begin
  classical,
  obtain ⟨t, rfl⟩ := S.fg_of_noetherian,
  refine finset.induction_on t _ _,
  { simpa using base },
  intros x t hxt h,
  convert ih _ x h using 1,
  rw [finset.coe_insert, algebra.adjoin_insert_adjoin]
end

end subalgebra

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]

/-- The image of a Noetherian R-algebra under an R-algebra map is a Noetherian ring. -/
instance alg_hom.is_noetherian_ring_range (f : A →ₐ[R] B) [is_noetherian_ring A] :
  is_noetherian_ring f.range :=
is_noetherian_ring_range f.to_ring_hom

theorem is_noetherian_ring_of_fg {S : subalgebra R A} (HS : S.fg)
  [is_noetherian_ring R] : is_noetherian_ring S :=
let ⟨t, ht⟩ := HS in ht ▸ (algebra.adjoin_eq_range R (↑t : set A)).symm ▸
by haveI : is_noetherian_ring (mv_polynomial (↑t : set A) R) :=
mv_polynomial.is_noetherian_ring;
convert alg_hom.is_noetherian_ring_range _; apply_instance

theorem is_noetherian_ring_closure (s : set R) (hs : s.finite) :
  @@is_noetherian_ring (ring.closure s) subset.ring :=
show is_noetherian_ring (subalgebra_of_is_subring (ring.closure s)), from
algebra.adjoin_int s ▸ is_noetherian_ring_of_fg (subalgebra.fg_def.2 ⟨s, hs, rfl⟩)


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.has_limits
import category_theory.thin

/-!
# Wide pullbacks

We define the category `wide_pullback_shape`, (resp. `wide_pushout_shape`) which is the category
obtained from a discrete category of type `J` by adjoining a terminal (resp. initial) element.
Limits of this shape are wide pullbacks (pushouts).
The convenience method `wide_cospan` (`wide_span`) constructs a functor from this category, hitting
the given morphisms.

We use `wide_pullback_shape` to define ordinary pullbacks (pushouts) by using `J := walking_pair`,
which allows easy proofs of some related lemmas.
Furthermore, wide pullbacks are used to show the existence of limits in the slice category.
Namely, if `C` has wide pullbacks then `C/B` has limits for any object `B` in `C`.

Typeclasses `has_wide_pullbacks` and `has_finite_wide_pullbacks` assert the existence of wide
pullbacks and finite wide pullbacks.
-/

universes v u

open category_theory category_theory.limits opposite

namespace category_theory.limits

variable (J : Type v)

/-- A wide pullback shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pullback_shape := option J

/-- A wide pushout shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pushout_shape := option J

namespace wide_pullback_shape

variable {J}

/-- The type of arrows for the shape indexing a wide pullback. -/
@[derive decidable_eq]
inductive hom : wide_pullback_shape J → wide_pullback_shape J → Type v
| id : Π X, hom X X
| term : Π (j : J), hom (some j) none

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pullback_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.term _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pullback_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pullback_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pullback_shape J) := thin_category

@[simp] lemma hom_id (X : wide_pullback_shape J) : hom.id X = 𝟙 X := rfl

variables {C : Type u} [category.{v} C]

/--
Construct a functor out of the wide pullback shape given a J-indexed collection of arrows to a
fixed object.
-/
@[simps]
def wide_cospan (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B) :
  wide_pullback_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := λ _ _ _ f g,
  begin
    cases f,
    { simpa },
    cases g,
    simp
  end }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_cospan` -/
def diagram_iso_wide_cospan (F : wide_pullback_shape J ⥤ C) :
  F ≅ wide_cospan (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.term j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cone over a wide cospan. -/
@[simps]
def mk_cone {F : wide_pullback_shape J ⥤ C} {X : C}
  (f : X ⟶ F.obj none) (π : Π j, X ⟶ F.obj (some j))
  (w : ∀ j, π j ≫ F.map (hom.term j) = f) : cone F :=
{ X := X,
  π :=
  { app := λ j, match j with
    | none := f
    | (some j) := π j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pullback_shape

namespace wide_pushout_shape

variable {J}

/-- The type of arrows for the shape indexing a wide psuhout. -/
@[derive decidable_eq]
inductive hom : wide_pushout_shape J → wide_pushout_shape J → Type v
| id : Π X, hom X X
| init : Π (j : J), hom none (some j)

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pushout_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.init _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pushout_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pushout_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pushout_shape J) := thin_category

@[simp] lemma hom_id (X : wide_pushout_shape J) : hom.id X = 𝟙 X := rfl

variables {C : Type u} [category.{v} C]

/--
Construct a functor out of the wide pushout shape given a J-indexed collection of arrows from a
fixed object.
-/
@[simps]
def wide_span (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j) : wide_pushout_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_) (_|_); simpa <|> simp } }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_span` -/
def diagram_iso_wide_span (F : wide_pushout_shape J ⥤ C) :
  F ≅ wide_span (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.init j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cocone over a wide span. -/
@[simps]
def mk_cocone {F : wide_pushout_shape J ⥤ C} {X : C}
  (f : F.obj none ⟶ X) (ι : Π j, F.obj (some j) ⟶ X)
  (w : ∀ j, F.map (hom.init j) ≫ ι j = f) : cocone F :=
{ X := X,
  ι :=
  { app := λ j, match j with
    | none := f
    | (some j) := ι j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pushout_shape

variables (C : Type u) [category.{v} C]

/-- `has_wide_pullbacks` represents a choice of wide pullback for every collection of morphisms -/
abbreviation has_wide_pullbacks : Prop :=
Π (J : Type v), has_limits_of_shape (wide_pullback_shape J) C

/-- `has_wide_pushouts` represents a choice of wide pushout for every collection of morphisms -/
abbreviation has_wide_pushouts : Prop :=
Π (J : Type v), has_colimits_of_shape (wide_pushout_shape J) C

variables {C J}

/-- `has_wide_pullback B objs arrows` means that `wide_cospan B objs arrows` has a limit. -/
abbreviation has_wide_pullback (B : C) (objs : J → C)
  (arrows : Π (j : J), objs j ⟶ B) : Prop :=
has_limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- `has_wide_pushout B objs arrows` means that `wide_span B objs arrows` has a colimit. -/
abbreviation has_wide_pushout (B : C) (objs : J → C)
  (arrows : Π (j : J), B ⟶ objs j) : Prop :=
has_colimit (wide_pushout_shape.wide_span B objs arrows)

/-- A choice of wide pullback. -/
noncomputable
abbreviation wide_pullback (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B)
  [has_wide_pullback B objs arrows] : C :=
limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- A choice of wide pushout. -/
noncomputable
abbreviation wide_pushout (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j)
  [has_wide_pushout B objs arrows] : C :=
colimit (wide_pushout_shape.wide_span B objs arrows)

variable (C)

namespace wide_pullback

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), objs j ⟶ B)
variables [has_wide_pullback B objs arrows]

/-- The `j`-th projection from the pullback. -/
noncomputable
abbreviation π (j : J) : wide_pullback _ _ arrows ⟶ objs j :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) (option.some j)

/-- The unique map to the base from the pullback. -/
noncomputable
abbreviation base : wide_pullback _ _ arrows ⟶ B :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) option.none

@[simp, reassoc]

variables {arrows}

/-- Lift a collection of morphisms to a morphism to the pullback. -/
noncomputable
abbreviation lift {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f) : X ⟶ wide_pullback _ _ arrows :=
limit.lift (wide_pullback_shape.wide_cospan _ _ _)
  (wide_pullback_shape.mk_cone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f)

@[simp, reassoc]
lemma lift_π (j : J) : lift f fs w ≫ π arrows j = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma lift_base : lift f fs w ≫ base arrows = f :=
by { simp, refl }

lemma eq_lift_of_comp_eq (g : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g ≫ π arrows j = fs j) → g ≫ base arrows = f → g = lift f fs w :=
begin
  intros h1 h2,
  apply (limit.is_limit (wide_pullback_shape.wide_cospan B objs arrows)).uniq
    (wide_pullback_shape.mk_cone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_lift (g : X ⟶ wide_pullback _ _ arrows) :
  g = lift (g ≫ base arrows) (λ j, g ≫ π arrows j) (by tidy) :=
begin
  apply eq_lift_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g1 ≫ π arrows j = g2 ≫ π arrows j) →
  g1 ≫ base arrows = g2 ≫ base arrows → g1 = g2 :=
begin
  intros h1 h2,
  apply limit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pullback

namespace wide_pushout

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), B ⟶ objs j)
variables [has_wide_pushout B objs arrows]

/-- The `j`-th inclusion to the pushout. -/
noncomputable
abbreviation ι (j : J) : objs j ⟶ wide_pushout _ _ arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) (option.some j)

/-- The unique map from the head to the pushout. -/
noncomputable
abbreviation head : B ⟶ wide_pushout B objs arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) option.none

@[simp, reassoc]
lemma arrow_ι (j : J) : arrows j ≫ ι arrows j = head arrows :=
by apply colimit.w (wide_pushout_shape.wide_span _ _ _) (wide_pushout_shape.hom.init j)

variables {arrows}

/-- Descend a collection of morphisms to a morphism from the pushout. -/
noncomputable
abbreviation desc {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f) : wide_pushout _ _ arrows ⟶ X :=
colimit.desc (wide_pushout_shape.wide_span B objs arrows)
  (wide_pushout_shape.mk_cocone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f)

@[simp, reassoc]
lemma ι_desc (j : J) : ι arrows j ≫ desc f fs w = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma head_desc : head arrows ≫ desc f fs w = f :=
by { simp, refl }

lemma eq_desc_of_comp_eq (g : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g = fs j) → head arrows ≫ g = f → g = desc f fs w :=
begin
  intros h1 h2,
  apply (colimit.is_colimit (wide_pushout_shape.wide_span B objs arrows)).uniq
    (wide_pushout_shape.mk_cocone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_desc (g : wide_pushout _ _ arrows ⟶ X) :
  g = desc (head arrows ≫ g) (λ j, ι arrows j ≫ g) (λ j, by { rw ← category.assoc, simp }) :=
begin
  apply eq_desc_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g1 = ι arrows j ≫ g2) →
  head arrows ≫ g1 = head arrows ≫ g2 → g1 = g2 :=
begin
  intros h1 h2,
  apply colimit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pushout

variable (J)

/-- The action on morphisms of the obvious functor
  `wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ`-/
def wide_pullback_shape_op_map : Π (X Y : wide_pullback_shape J),
  (X ⟶ Y) → ((op X : (wide_pushout_shape J)ᵒᵖ) ⟶ (op Y : (wide_pushout_shape J)ᵒᵖ))
| _ _ (wide_pullback_shape.hom.id X) := quiver.hom.op (wide_pushout_shape.hom.id _)
| _ _ (wide_pullback_shape.hom.term j) := quiver.hom.op (wide_pushout_shape.hom.init _)

/-- The obvious functor `wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ` -/
@[simps]
def wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pullback_shape_op_map J, }

/-- The action on morphisms of the obvious functor
`wide_pushout_shape_op : `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
def wide_pushout_shape_op_map : Π (X Y : wide_pushout_shape J),
  (X ⟶ Y) → ((op X : (wide_pullback_shape J)ᵒᵖ) ⟶ (op Y : (wide_pullback_shape J)ᵒᵖ))
| _ _ (wide_pushout_shape.hom.id X) := quiver.hom.op (wide_pullback_shape.hom.id _)
| _ _ (wide_pushout_shape.hom.init j) := quiver.hom.op (wide_pullback_shape.hom.term _)

/-- The obvious functor `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
@[simps]
def wide_pushout_shape_op : wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pushout_shape_op_map J, }

/-- The obvious functor `(wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J`-/
@[simps]
def wide_pullback_shape_unop : (wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J :=
(wide_pullback_shape_op J).left_op

/-- The obvious functor `(wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_unop : (wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J :=
(wide_pushout_shape_op J).left_op

/-- The inverse of the unit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pushout_shape_op_unop : wide_pushout_shape_unop J ⋙ wide_pullback_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pushout_shape_unop_op : wide_pushout_shape_op J ⋙ wide_pullback_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The inverse of the unit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pullback_shape_op_unop : wide_pullback_shape_unop J ⋙ wide_pushout_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pullback_shape_unop_op : wide_pullback_shape_op J ⋙ wide_pushout_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The duality equivalence `(wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J :=
{ functor := wide_pushout_shape_unop J,
  inverse := wide_pullback_shape_op J,
  unit_iso := (wide_pushout_shape_op_unop J).symm,
  counit_iso := wide_pullback_shape_unop_op J, }

/-- The duality equivalence `(wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
@[simps]
def wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J :=
{ functor := wide_pullback_shape_unop J,
  inverse := wide_pushout_shape_op J,
  unit_iso := (wide_pullback_shape_op_unop J).symm,
  counit_iso := wide_pushout_shape_unop_op J, }

end category_theory.limits


import Cat.Fam.CatLemmas
import Cat.Fam.Categories.Setoid

/-! # Functors -/

namespace Cat

section laws

  variable
    {ℂ₁ ℂ₂ : Fam.Cat}
    (fObj : ℂ₁.Obj → ℂ₂.Obj)
    (fMap :
      {α β : ℂ₁.Obj}
      → ℂ₁.Hom α β ⇒ ℂ₂.Hom (fObj α) (fObj β)
    )

  /-- Functor composition law. -/
  @[simp]
  abbrev Fam.Cat.Func.law.comp
    {α β γ : ℂ₁.Obj}
    (f : β ↠ γ)
    (g : α ↠ β)
  : Prop :=
    fMap (f ⊚ g) ≈ (fMap f) ⊚ (fMap g)

  /-- Functor identity law. -/
  @[simp]
  protected abbrev Fam.Cat.Func.law.id
    {α : ℂ₁.Obj}
  : Prop :=
    @fMap α α ℂ₁.id ≈ ℂ₂.id

  /-- Functor identity law (explicit version). -/
  @[simp]
  protected abbrev Fam.Cat.Func.law.id'
    (α : ℂ₁.Obj)
  : Prop :=
    @law.id ℂ₁ ℂ₂ fObj fMap α

end laws

/-- A functor transforms objects/arrows and respects composition/identity laws.  -/
structure Fam.Cat.Func (ℂ₁ ℂ₂ : Cat) where
  /-- Maps `ℂ`-objects to `ℂ₂`-objects. -/
  fObj : ℂ₁.Obj → ℂ₂.Obj
  /-- Maps `ℂ₁`-arrows to `ℂ₂`-arrows. -/
  fMap :
    {α β : ℂ₁.Obj}
    → ℂ₁.Hom α β ⇒ ℂ₂.Hom (fObj α) (fObj β)
  /-- Functor composition law. -/
  comp_law
    {α β γ : ℂ₁.Obj}
    (f : β ↠ γ)
    (g : α ↠ β)
  : Func.law.comp fObj fMap f g
  /-- Functor identity law. -/
  id_law
    {α : ℂ₁.Obj}
  : @fMap α α ℂ₁.id ≈ ℂ₂.id

/-- Identity for the target of a source object. -/
@[simp]
abbrev Fam.Cat.Func.id
  {F : Func ℂ₁ ℂ₂}
  {α : outParam ℂ₁.Obj}
: F.fObj α ↠ F.fObj α :=
  ℂ₂.id

/-- Identity for the target of a source object, explicit version. -/
@[simp]
abbrev Fam.Cat.Func.id'
  {F : Func ℂ₁ ℂ₂}
  (α : outParam ℂ₁.Obj)
: F.fObj α ↠ F.fObj α :=
  ℂ₂.id

/-- Maps `ℂ₁`-arrows to `ℂ₂`-arrows (explicit version). -/
@[simp]
abbrev Fam.Cat.Func.fMap'
  {F : Func ℂ₁ ℂ₂}
  (α β : ℂ₁.Obj)
:=
  F.fMap (α := α) (β := β)

/-- Functor composition law (explicit version). -/
@[simp]
abbrev Fam.Cat.Func.comp_law'
  {F : Func ℂ₁ ℂ₂}
  (α β γ : ℂ₁.Obj)
:=
  @Func.comp_law ℂ₁ ℂ₂ F α β γ

/-- Functor identity law (explicit version). -/
@[simp]
abbrev Fam.Cat.Func.id_law'
  {F : Func ℂ₁ ℂ₂}
  (α : ℂ₁.Obj)
:=
  F.id_law (α := α)

/-- Applied version of `F.fMap`. -/
def Fam.Cat.Func.fmap
  (F : Func ℂ₁ ℂ₂)
  {α β : ℂ₁.Obj}
: (α ↠ β) → (F.fObj α ↠ F.fObj β) :=
  fun f =>
    F.fMap f

/-- Allows writing `F object` for `F.fObj object` -/
instance instCoeFunFunctorObj
  {ℂ₁ ℂ₂ : Fam.Cat}
: CoeFun
  (Fam.Cat.Func ℂ₁ ℂ₂)
  (𝕂 $ ℂ₁.Obj → ℂ₂.Obj)
where
  coe F :=
    F.fObj

example
  (F : Fam.Cat.Func ℂ₁ ℂ₂)
  (α : ℂ₁.Obj)
: ℂ₂.Obj :=
  F α

-- /-- Allows writing `F hom` for `F.fmap hom`. -/
-- instance instCoeFunFunctorHom
--   {ℂ₁ ℂ₂ : Fam.Cat}
--   {α β : ℂ₁.Obj}
-- : CoeFun
--   (Fam.Cat.Func ℂ₁ ℂ₂)
--   (fun F =>
--     (α ↠ β) → (F.fObj α ↠ F.fObj β)
--   )
-- where
--   coe F :=
--     F.fmap

-- example
--   (F : Fam.Cat.Func ℂ₁ ℂ₂)
--   (f : α ↠ β)
-- : F.fObj α ↠ F.fObj β :=
--   F f

/-- `fMap` is proper for `≈`. -/
theorem Fam.Cat.Func.fMap_proper
  (F : Func ℂ₁ ℂ₂)
  {α β : ℂ₁.Obj}
  {f₁ f₂ : α ↠ β}
: f₁ ≈ f₂ → F.fMap f₁ ≈ F.fMap f₂ :=
  F.fMap.proper
/-- `fMap` is proper for `≈`, explicit version. -/
theorem Fam.Cat.Func.fMap_proper'
  (F : Func ℂ₁ ℂ₂)
  {α β : ℂ₁.Obj}
  (f₁ f₂ : α ↠ β)
: f₁ ≈ f₂ → F.fMap f₁ ≈ F.fMap f₂ :=
  F.fMap.proper

/-- `fmap` is proper for `≈`. -/
theorem Fam.Cat.Func.fmap_proper
  (F : Func ℂ₁ ℂ₂)
  {α β : ℂ₁.Obj}
  {f₁ f₂ : α ↠ β}
: f₁ ≈ f₂ → F.fmap f₁ ≈ F.fmap f₂ :=
  F.fMap.proper
/-- `fmap` is proper for `≈`. -/
theorem Fam.Cat.Func.fmap_proper'
  (F : Func ℂ₁ ℂ₂)
  {α β : ℂ₁.Obj}
  (f₁ f₂ : α ↠ β)
: f₁ ≈ f₂ → F.fmap f₁ ≈ F.fmap f₂ :=
  F.fMap.proper

/-! ## Setoid of functors -/
section setoid
  variable
    {ℂ₁ ℂ₂ : Fam.Cat}
    (F G : Fam.Cat.Func ℂ₁ ℂ₂)

  /-- Functor equivalence is `fmap` equivalence. -/
  @[simp]
  abbrev Fam.Cat.Func.equiv
  : Prop :=
    ∀ {α β : ℂ₁.Obj} (f : α ↠ β), F.fmap f ≋ G.fmap f

  instance instFuncHasEquiv
  : HasEquiv (Fam.Cat.Func ℂ₁ ℂ₂) where
    Equiv F G :=
      Fam.Cat.Func.equiv F G

  /-- Functor equivalence is reflexive. -/
  theorem Fam.Cat.Func.Equiv.refl
  : F ≈ F :=
    fun f =>
      F.fmap f
      |> Hom.Equiv.refl

  /-- Functor equivalence is symmetric. -/
  theorem Fam.Cat.Func.Equiv.symm
    {F G : Func ℂ₁ ℂ₂}
  : F ≈ G → G ≈ F :=
    fun h_FG _α _β f =>
      h_FG f
      |> Hom.Equiv.symm (F.fmap f) (G.fmap f)

  /-- Functor equivalence is transitive. -/
  theorem Fam.Cat.Func.Equiv.trans
    {F G H : Func ℂ₁ ℂ₂}
  : F ≈ G → G ≈ H → F ≈ H :=
    fun h_FG h_GH _α _β f =>
      Hom.Equiv.trans
        (h_FG f)
        (h_GH f)

  instance instTransFuncEquiv
  : Trans
    (@Fam.Cat.Func.equiv ℂ₁ ℂ₂)
    (@Fam.Cat.Func.equiv ℂ₁ ℂ₂)
    (@Fam.Cat.Func.equiv ℂ₁ ℂ₂)
  where
    trans :=
      Fam.Cat.Func.Equiv.trans

  /-- Functor equivalence is an equivalence relation. -/
  def Fam.Cat.Func.Equiv.proof
  : Equivalence (@Fam.Cat.Func.equiv ℂ₁ ℂ₂) :=
    ⟨refl, symm, trans⟩

  /-- Functors are setoids in the Lean sense. -/
  instance instZetoidFunc
  : Zetoid (Fam.Cat.Func ℂ₁ ℂ₂) where
    r :=
      Fam.Cat.Func.equiv
    iseqv :=
      Fam.Cat.Func.Equiv.proof

  /-- Functors are setoids in this library's sense. -/
  def Fam.Cat.Func.mkSetoid
    (ℂ₁ ℂ₂ : Cat)
  : Setoid where
    Carrier :=
      Func ℂ₁ ℂ₂
    instZetoid :=
      instZetoidFunc

end setoid

/-! ## Family of Hom-functors

Functor `Hom(α,-) : ℂ → Set`. Basically, this functor
- maps `β : ℂ.Obj` to `ℂ.Hom α β`;
- maps `f : ℂ.Hom β γ` to `fun (g : ℂ.Hom α β) => f ∘ g`.

So `α` is a kind of pivot we see `ℂ` through: a `β` only matters as far as we can go from `α` to
`β`, and a `ℂ.Hom β γ` only matters as far as we can compose it with a `ℂ.Hom α β`.
-/
section hom_functors
  variable
    {ℂ : Fam.Cat}
    {α : ℂ.Obj}

  @[simp]
  abbrev Fam.Cat.Func.FunSET.HomFunc.obj
    (α β : ℂ.Obj)
  :=
    ℂ.Hom α β

  @[simp]
  abbrev Fam.Cat.Func.FunSET.HomFunc.hom
    (α : ℂ.Obj)
    {β γ : ℂ.Obj}
    (f : β ↠ γ)
    (g : α ↠ β)
  : α ↠ γ :=
    f ⊚ g

  /-- `HomFunc.hom α f` is a morphism. -/
  @[simp]
  def Fam.Cat.Func.FunSET.HomFunc.morph
    (α : ℂ.Obj)
    (f : β ↠ γ)
  : (ℂ.Hom α β) ⇒ (ℂ.Hom α γ) where
    map :=
      hom α f
    proper :=
      ℂ.congr.right f

  /-- `HomFunc.morph α` is also a morphism.

  `HomFunc.Morph` will be the arrow-map in the `FunSET` functor below.
  -/
  @[simp]
  def Fam.Cat.Func.FunSET.HomFunc.Morph
    (α : ℂ.Obj)
    {β γ : ℂ.Obj}
  : (ℂ.Hom β γ) ⇒ (Fam.Cat.SET.Hom (HomFunc.obj α β) (HomFunc.obj α γ)) where
    map f :=
      HomFunc.morph α f
    proper :=
      by
        intro f₁ f₂ h_f
        simp
        intro g
        apply ℂ.congr.left g h_f

  /-- `HomFunc.Morph` respects the composition law. -/
  theorem Fam.Cat.Func.FunSET.HomFunc.Morph.comp_law
    (α : ℂ.Obj)
    {β γ δ : ℂ.Obj}
    (g : γ ↠ δ)
    (h : β ↠ γ)
  : law.comp (ℂ₁ := ℂ) (ℂ₂ := SET) (obj α) (Morph α) g h :=
    by
      intro param
      simp [
        kompose, compose',
        SET, Comp.toCat, Morph.app2,
        Morph.compose.Comp, Morph.compose
      ]

  /-- `HomFunc.Morph` respects the identity law. -/
  theorem Fam.Cat.Func.FunSET.HomFunc.Morph.id_law
    (α β : ℂ.Obj)
  : law.id' (ℂ₁ := ℂ) (ℂ₂ := SET) (obj α) (Morph α) β :=
    by
      intro f
      simp [
        SET, Comp.toCat,
        Morph.id,
        kompose, compose',
        Morph.app2
      ]

  /-- Hom-functors are functors. -/
  def Fam.Cat.Func.FunSET
    {ℂ : Cat}
    (α : ℂ.Obj)
  : Func ℂ SET where
    fObj :=
      Fam.Cat.Func.FunSET.HomFunc.obj α
    fMap :=
      FunSET.HomFunc.Morph α
    comp_law :=
      FunSET.HomFunc.Morph.comp_law α
    id_law :=
      @FunSET.HomFunc.Morph.id_law _ α

end hom_functors

/-! ## Composition `⊙` (`\o.`) of two functors -/
section comp
  variable
    {ℂ₁ ℂ₂ ℂ₃ : Fam.Cat}
    (F₂₃ : Fam.Cat.Func ℂ₂ ℂ₃)
    (F₁₂ : Fam.Cat.Func ℂ₁ ℂ₂)

  @[simp]
  protected abbrev Fam.Cat.Func.comp.fObj
    (α : ℂ₁.Obj)
  :=
    F₁₂ α
    |> F₂₃

  @[simp]
  protected abbrev Fam.Cat.Func.comp.fmap
    {α β : ℂ₁.Obj}
    (f : α ↠ β)
  : F₂₃ (F₁₂ α) ↠ F₂₃ (F₁₂ β) :=
    F₁₂.fmap f
    |> F₂₃.fmap

  protected theorem Fam.Cat.Func.comp.fMap_proper
    {α β : ℂ₁.Obj}
    {f₁ f₂ : α ↠ β}
  : f₁ ≈ f₂ → Func.comp.fmap F₂₃ F₁₂ f₁ ≈ Func.comp.fmap F₂₃ F₁₂ f₂ :=
    fun h_f =>
      F₁₂.fMap.proper h_f
      |> F₂₃.fMap.proper

  /-- `Func.comp.fMap` defines a morphism. -/
  @[simp]
  protected def Fam.Cat.Func.comp.fMapMorph
    {α β : ℂ₁.Obj}
  : ℂ₁.Hom α β ⇒ ℂ₃.Hom (F₂₃ $ F₁₂ α) (F₂₃ $ F₁₂ β) where
    map :=
      Func.comp.fmap F₂₃ F₁₂
    proper :=
      Func.comp.fMap_proper F₂₃ F₁₂

  /-- Functor composition respects the functor composition law. -/
  protected def Fam.Cat.Func.comp.comp_law
    {α β γ : ℂ₁.Obj}
    (f : β ↠ γ)
    (g : α ↠ β)
  : Func.law.comp (Func.comp.fObj F₂₃ F₁₂) (Func.comp.fMapMorph F₂₃ F₁₂) f g :=
    by
      calc
        F₂₃.fMap
          (F₁₂.fMap (f ⊚ g))
        ≈ F₂₃.fMap
          ((F₁₂.fMap f) ⊚ (F₁₂.fMap g))
        :=
          F₁₂.comp_law f g
          |> F₂₃.fMap.proper

        _
        ≈ (F₂₃.fMap $ F₁₂.fMap f) ⊚ (F₂₃.fMap $ F₁₂.fMap g)
        :=
          by
            simp

  /-- Functor composition respects the functor identity law. -/
  protected def Fam.Cat.Func.comp.id_law
    {α : ℂ₁.Obj}
  : Func.law.id' (Func.comp.fObj F₂₃ F₁₂) (Func.comp.fMapMorph F₂₃ F₁₂) α :=
    by
      calc
        F₂₃.fMap.map (F₁₂.fMap.map ℂ₁.id)
        ≈ F₂₃.fMap.map ℂ₂.id
        :=
          F₂₃.fMap.proper (F₁₂.id_law)

        _
        ≈ ℂ₃.id
        :=
          F₂₃.id_law

  /-- Functor composition defines a functor (`⊙`, `\o.`). -/
  def Fam.Cat.Func.comp
    (F₂₃ : Func ℂ₂ ℂ₃)
    (F₁₂ : Func ℂ₁ ℂ₂)
  : Func ℂ₁ ℂ₃ where
    fObj :=
      Func.comp.fObj F₂₃ F₁₂
    fMap :=
      Func.comp.fMapMorph F₂₃ F₁₂
    comp_law :=
      Fam.Cat.Func.comp.comp_law F₂₃ F₁₂
    id_law :=
      Fam.Cat.Func.comp.id_law F₂₃ F₁₂

  infix:101 " ⊙ " =>
    Fam.Cat.Func.comp

  theorem Fam.Cat.Func.comp.congr_left
    {F₂₃ F₂₃' : Func ℂ₂ ℂ₃}
    (F₁₂ : Func ℂ₁ ℂ₂)
    (h₂₃ : F₂₃ ≈ F₂₃')
  : F₂₃ ⊙ F₁₂ ≈ F₂₃' ⊙ F₁₂ :=
    fun f =>
      h₂₃ (F₁₂.fmap f)

  protected theorem Fam.Cat.Func.comp.congr_right_aux
    (F₂₃ : Func ℂ₂ ℂ₃)
    (F₁₂ : Func ℂ₁ ℂ₂)
    {α' β' : ℂ₂.Obj}
    (f₁₂' : α' ↠ β')
    {α β : ℂ₁.Obj}
    (f : α ↠ β)
    (h : F₁₂.fmap f ≋ f₁₂')
  : F₂₃.fmap (F₁₂.fmap f) ≋ F₂₃.fmap f₁₂' :=
    by
      cases h with
      | proof f₁₂' eqv =>
        let eqv₂₃ :=
          F₂₃.fMap.proper eqv
        apply Hom.Equiv.proof _ eqv₂₃

  theorem Fam.Cat.Func.comp.congr_right
    (F₂₃ : Func ℂ₂ ℂ₃)
    {F₁₂ F₁₂' : Func ℂ₁ ℂ₂}
    (h₁₂ : F₁₂ ≈ F₁₂')
  : F₂₃ ⊙ F₁₂ ≈ F₂₃ ⊙ F₁₂' :=
    fun f =>
      let h :=
        h₁₂ f
      comp.congr_right_aux F₂₃ F₁₂ (fmap F₁₂' f) f h

  /-- `Func.comp` respects congruence laws. -/
  def Fam.Cat.Func.comp.Congr
  : Congr (Func ℂ₂ ℂ₃) (Func ℂ₁ ℂ₂) (Func ℂ₁ ℂ₃) Func.comp where
    left :=
      congr_left
    right :=
      congr_right

end comp


import category_theory.colimits
import category_theory.colimit_lemmas

import .category

/-

Construction of the basic finite colimits in Top.

-/

open category_theory
local notation f ` ∘ `:80 g:80 := g ≫ f

universe u

namespace homotopy_theory.topological_spaces
namespace Top

local notation `Top` := Top.{u}

section initial_object

protected def empty : Top := Top.mk_ob pempty
protected def empty_induced (Z : Top) : Top.empty ⟶ Z :=
Top.mk_hom (λ x, pempty.cases_on (λ _, Z) x) (by continuity)
protected def empty_is_initial_object : Is_initial_object.{u u+1} Top.empty :=
Is_initial_object.mk' Top.empty_induced (assume Z k k', by ext x; cases x)

instance : has_initial_object.{u} Top :=
⟨⟨Top.empty, Top.empty_is_initial_object⟩⟩

protected def is_initial_object_of_to_empty (A : Top) (h : A → pempty) :
  Is_initial_object.{u} A :=
have continuous h, begin
  intros u hu,
  have : u = ∅, from set.eq_empty_iff_forall_not_mem.mpr (pempty.rec _),
  rw [this, set.preimage_empty],
  exact is_open_empty
end,
have h' : A ⟶ Top.empty := Top.mk_hom h this,
Is_initial_object.mk'
  (λ Z, Top.empty_induced Z ∘ h')
  (assume Z k k', begin ext x, cases h x end)

end initial_object

section coproduct

section construction
parameters (X₀ X₁ : Top)

protected def coproduct_object : Top := Top.mk_ob (X₀ ⊕ X₁)
protected def coproduct_map₀ : X₀ ⟶ coproduct_object := Top.mk_hom sum.inl
protected def coproduct_map₁ : X₁ ⟶ coproduct_object := Top.mk_hom sum.inr

variables ⦃Z : Top⦄ (h₀ : X₀ ⟶ Z) (h₁ : X₁ ⟶ Z)
protected def coproduct_induced : coproduct_object ⟶ Z :=
Top.mk_hom (λ x, sum.cases_on x h₀ h₁) (by continuity!)

protected def coproduct_induced_commutes₀ : coproduct_induced h₀ h₁ ∘ coproduct_map₀ = h₀ :=
by ext; refl

protected def coproduct_induced_commutes₁ : coproduct_induced h₀ h₁ ∘ coproduct_map₁ = h₁ :=
by ext; refl

protected def coproduct_uniqueness {k k' : coproduct_object ⟶ Z}
  (e₀ : k ∘ coproduct_map₀ = k' ∘ coproduct_map₀)
  (e₁ : k ∘ coproduct_map₁ = k' ∘ coproduct_map₁) : k = k' :=
begin
  ext x,
  cases x,
  { exact @@Top.hom_congr e₀ x },
  { exact @@Top.hom_congr e₁ x }
end

protected def coproduct_is_coproduct : Is_coproduct coproduct_map₀ coproduct_map₁ :=
Is_coproduct.mk' coproduct_induced
  coproduct_induced_commutes₀ coproduct_induced_commutes₁
  coproduct_uniqueness

end construction

instance Top.has_coproducts : has_coproducts.{u} Top :=
⟨λ X₀ X₁,
  { ob := Top.coproduct_object X₀ X₁,
    map₀ := Top.coproduct_map₀ X₀ X₁,
    map₁ := Top.coproduct_map₁ X₀ X₁,
    is_coproduct := Top.coproduct_is_coproduct X₀ X₁ }⟩

end coproduct

section coequalizer

section construction
parameters {X Y : Top} (f₀ f₁ : X ⟶ Y)

protected def coeq_rel : Y → Y → Prop :=
λ y₀ y₁, ∃ x, y₀ = f₀ x ∧ y₁ = f₁ x

protected def coequalizer_object : Top :=
Top.mk_ob (quot coeq_rel)

protected def coequalizer_map : Y ⟶ Top.coequalizer_object f₀ f₁ :=
Top.mk_hom (quot.mk coeq_rel)

protected lemma coequalizer_commutes : coequalizer_map ∘ f₀ = coequalizer_map ∘ f₁ :=
by ext x; exact quot.sound ⟨x, rfl, rfl⟩

variable ⦃Z : Top⦄

protected def coequalizer_induced {k : Y ⟶ Z} (e : k ∘ f₀ = k ∘ f₁) :
  coequalizer_object ⟶ Z :=
Top.mk_hom
  (@quot.lift _ coeq_rel _ k
    (assume y₀ y₁ ⟨x, h₀, h₁⟩, by rw [h₀, h₁]; exact Top.hom_congr e x))
  (by continuity)

-- TODO: How can we avoid duplicating the proof on the last line here?
protected lemma coequalizer_induced_commutes {k : Y ⟶ Z} (e : k ∘ f₀ = k ∘ f₁) :
  coequalizer_induced e ∘ coequalizer_map = k :=
Top.hom_eq $ assume x,
  @quot.lift_beta _ coeq_rel _ k
    (assume y₀ y₁ ⟨x, h₀, h₁⟩, by rw [h₀, h₁]; exact Top.hom_congr e x) _

protected lemma coequalizer_uniqueness {k k' : coequalizer_object ⟶ Z}
  (e : k ∘ coequalizer_map = k' ∘ coequalizer_map) : k = k' :=
Top.hom_eq $ λ x, quot.ind (Top.hom_congr e) x

protected def coequalizer_is_coequalizer : Is_coequalizer f₀ f₁ coequalizer_map :=
Is_coequalizer.mk' coequalizer_commutes coequalizer_induced
  coequalizer_induced_commutes coequalizer_uniqueness

end construction

instance Top.has_coequalizers : has_coequalizers.{u} Top :=
⟨λ X Y f₀ f₁,
  { ob := Top.coequalizer_object f₀ f₁,
    map := Top.coequalizer_map f₀ f₁,
    is_coequalizer := Top.coequalizer_is_coequalizer _ _ }⟩

end coequalizer

section pushout

instance : has_pushouts.{u} Top :=
has_pushouts_of_has_coequalizers_and_coproducts

end pushout

end «Top»
end homotopy_theory.topological_spaces


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.pointwise
import Mathlib.group_theory.quotient_group
import Mathlib.topology.algebra.monoid
import Mathlib.topology.homeomorph
import Mathlib.PostPort

universes w u l u_1 x u_2

namespace Mathlib

/-!
# Theory of topological groups

This file defines the following typeclasses:

* `topological_group`, `topological_add_group`: multiplicative and additive topological groups,
  i.e., groups with continuous `(*)` and `(⁻¹)` / `(+)` and `(-)`;

* `has_continuous_sub G` means that `G` has a continuous subtraction operation.

There is an instance deducing `has_continuous_sub` from `topological_group` but we use a separate
typeclass because, e.g., `ℕ` and `ℝ≥0` have continuous subtraction but are not additive groups.

We also define `homeomorph` versions of several `equiv`s: `homeomorph.mul_left`,
`homeomorph.mul_right`, `homeomorph.inv`, and prove a few facts about neighbourhood filters in
groups.

## Tags

topological space, group, topological group
-/

/-!
### Groups with continuous multiplication

In this section we prove a few statements about groups with continuous `(*)`.
-/

/-- Multiplication from the left in a topological group as a homeomorphism. -/
protected def homeomorph.add_left {G : Type w} [topological_space G] [add_group G]
    [has_continuous_add G] (a : G) : G ≃ₜ G :=
  homeomorph.mk
    (equiv.mk (equiv.to_fun (equiv.add_left a)) (equiv.inv_fun (equiv.add_left a)) sorry sorry)

@[simp] theorem homeomorph.coe_mul_left {G : Type w} [topological_space G] [group G]
    [has_continuous_mul G] (a : G) : ⇑(homeomorph.mul_left a) = Mul.mul a :=
  rfl

theorem homeomorph.add_left_symm {G : Type w} [topological_space G] [add_group G]
    [has_continuous_add G] (a : G) :
    homeomorph.symm (homeomorph.add_left a) = homeomorph.add_left (-a) :=
  homeomorph.ext fun (x : G) => Eq.refl (coe_fn (homeomorph.symm (homeomorph.add_left a)) x)

theorem is_open_map_mul_left {G : Type w} [topological_space G] [group G] [has_continuous_mul G]
    (a : G) : is_open_map fun (x : G) => a * x :=
  homeomorph.is_open_map (homeomorph.mul_left a)

theorem is_closed_map_mul_left {G : Type w} [topological_space G] [group G] [has_continuous_mul G]
    (a : G) : is_closed_map fun (x : G) => a * x :=
  homeomorph.is_closed_map (homeomorph.mul_left a)

/-- Multiplication from the right in a topological group as a homeomorphism. -/
protected def homeomorph.mul_right {G : Type w} [topological_space G] [group G]
    [has_continuous_mul G] (a : G) : G ≃ₜ G :=
  homeomorph.mk
    (equiv.mk (equiv.to_fun (equiv.mul_right a)) (equiv.inv_fun (equiv.mul_right a)) sorry sorry)

theorem is_open_map_add_right {G : Type w} [topological_space G] [add_group G]
    [has_continuous_add G] (a : G) : is_open_map fun (x : G) => x + a :=
  homeomorph.is_open_map (homeomorph.add_right a)

theorem is_closed_map_mul_right {G : Type w} [topological_space G] [group G] [has_continuous_mul G]
    (a : G) : is_closed_map fun (x : G) => x * a :=
  homeomorph.is_closed_map (homeomorph.mul_right a)

theorem is_open_map_div_right {G : Type w} [topological_space G] [group G] [has_continuous_mul G]
    (a : G) : is_open_map fun (x : G) => x / a :=
  sorry

theorem is_closed_map_div_right {G : Type w} [topological_space G] [group G] [has_continuous_mul G]
    (a : G) : is_closed_map fun (x : G) => x / a :=
  sorry

/-!
### Topological groups

A topological group is a group in which the multiplication and inversion operations are
continuous. Topological additive groups are defined in the same way. Equivalently, we can require
that the division operation `λ x y, x * y⁻¹` (resp., subtraction) is continuous.
-/

/-- A topological (additive) group is a group in which the addition and negation operations are
continuous. -/
class topological_add_group (G : Type u) [topological_space G] [add_group G]
    extends has_continuous_add G where
  continuous_neg : continuous fun (a : G) => -a

/-- A topological group is a group in which the multiplication and inversion operations are
continuous. -/
class topological_group (G : Type u_1) [topological_space G] [group G] extends has_continuous_mul G
    where
  continuous_inv : continuous has_inv.inv

theorem continuous_on_neg {G : Type w} [topological_space G] [add_group G] [topological_add_group G]
    {s : set G} : continuous_on Neg.neg s :=
  continuous.continuous_on continuous_neg

theorem continuous_within_at_neg {G : Type w} [topological_space G] [add_group G]
    [topological_add_group G] {s : set G} {x : G} : continuous_within_at Neg.neg s x :=
  continuous.continuous_within_at continuous_neg

theorem continuous_at_inv {G : Type w} [topological_space G] [group G] [topological_group G]
    {x : G} : continuous_at has_inv.inv x :=
  continuous.continuous_at continuous_inv

theorem tendsto_neg {G : Type w} [topological_space G] [add_group G] [topological_add_group G]
    (a : G) : filter.tendsto Neg.neg (nhds a) (nhds (-a)) :=
  continuous_at_neg

/-- If a function converges to a value in a multiplicative topological group, then its inverse
converges to the inverse of this value. For the version in normed fields assuming additionally
that the limit is nonzero, use `tendsto.inv'`. -/
theorem filter.tendsto.inv {α : Type u} {G : Type w} [topological_space G] [group G]
    [topological_group G] {f : α → G} {l : filter α} {y : G} (h : filter.tendsto f l (nhds y)) :
    filter.tendsto (fun (x : α) => f x⁻¹) l (nhds (y⁻¹)) :=
  filter.tendsto.comp (continuous.tendsto continuous_inv y) h

theorem continuous.inv {α : Type u} {G : Type w} [topological_space G] [group G]
    [topological_group G] [topological_space α] {f : α → G} (hf : continuous f) :
    continuous fun (x : α) => f x⁻¹ :=
  continuous.comp continuous_inv hf

theorem continuous_on.inv {α : Type u} {G : Type w} [topological_space G] [group G]
    [topological_group G] [topological_space α] {f : α → G} {s : set α} (hf : continuous_on f s) :
    continuous_on (fun (x : α) => f x⁻¹) s :=
  continuous.comp_continuous_on continuous_inv hf

theorem continuous_within_at.inv {α : Type u} {G : Type w} [topological_space G] [group G]
    [topological_group G] [topological_space α] {f : α → G} {s : set α} {x : α}
    (hf : continuous_within_at f s x) : continuous_within_at (fun (x : α) => f x⁻¹) s x :=
  filter.tendsto.inv hf

protected instance prod.topological_add_group {G : Type w} {H : Type x} [topological_space G]
    [add_group G] [topological_add_group G] [topological_space H] [add_group H]
    [topological_add_group H] : topological_add_group (G × H) :=
  topological_add_group.mk (continuous.prod_map continuous_neg continuous_neg)

/-- Inversion in a topological group as a homeomorphism. -/
protected def homeomorph.neg (G : Type w) [topological_space G] [add_group G]
    [topological_add_group G] : G ≃ₜ G :=
  homeomorph.mk (equiv.mk (equiv.to_fun (equiv.neg G)) (equiv.inv_fun (equiv.neg G)) sorry sorry)

theorem nhds_zero_symm (G : Type w) [topological_space G] [add_group G] [topological_add_group G] :
    filter.comap Neg.neg (nhds 0) = nhds 0 :=
  Eq.trans (homeomorph.comap_nhds_eq (homeomorph.neg G) 0) (congr_arg nhds neg_zero)

/-- The map `(x, y) ↦ (x, xy)` as a homeomorphism. This is a shear mapping. -/
protected def homeomorph.shear_add_right (G : Type w) [topological_space G] [add_group G]
    [topological_add_group G] : G × G ≃ₜ G × G :=
  homeomorph.mk
    (equiv.mk (equiv.to_fun (equiv.prod_shear (equiv.refl G) equiv.add_left))
      (equiv.inv_fun (equiv.prod_shear (equiv.refl G) equiv.add_left)) sorry sorry)

@[simp] theorem homeomorph.shear_mul_right_coe (G : Type w) [topological_space G] [group G]
    [topological_group G] :
    ⇑(homeomorph.shear_mul_right G) = fun (z : G × G) => (prod.fst z, prod.fst z * prod.snd z) :=
  rfl

@[simp] theorem homeomorph.shear_mul_right_symm_coe (G : Type w) [topological_space G] [group G]
    [topological_group G] :
    ⇑(homeomorph.symm (homeomorph.shear_mul_right G)) =
        fun (z : G × G) => (prod.fst z, prod.fst z⁻¹ * prod.snd z) :=
  rfl

theorem inv_closure {G : Type w} [topological_space G] [group G] [topological_group G] (s : set G) :
    closure s⁻¹ = closure (s⁻¹) :=
  homeomorph.preimage_closure (homeomorph.inv G) s

theorem exists_nhds_half_neg {G : Type w} [topological_space G] [add_group G]
    [topological_add_group G] {s : set G} (hs : s ∈ nhds 0) :
    ∃ (V : set G), ∃ (H : V ∈ nhds 0), ∀ (v : G), v ∈ V → ∀ (w : G), w ∈ V → v - w ∈ s :=
  sorry

theorem nhds_translation_mul_inv {G : Type w} [topological_space G] [group G] [topological_group G]
    (x : G) : filter.comap (fun (y : G) => y * (x⁻¹)) (nhds 1) = nhds x :=
  sorry

@[simp] theorem map_mul_left_nhds {G : Type w} [topological_space G] [group G] [topological_group G]
    (x : G) (y : G) : filter.map (Mul.mul x) (nhds y) = nhds (x * y) :=
  homeomorph.map_nhds_eq (homeomorph.mul_left x) y

theorem map_mul_left_nhds_one {G : Type w} [topological_space G] [group G] [topological_group G]
    (x : G) : filter.map (Mul.mul x) (nhds 1) = nhds x :=
  sorry

theorem topological_group.ext {G : Type u_1} [group G] {t : topological_space G}
    {t' : topological_space G} (tg : topological_group G) (tg' : topological_group G)
    (h : nhds 1 = nhds 1) : t = t' :=
  sorry

theorem topological_group.of_nhds_aux {G : Type u_1} [group G] [topological_space G]
    (hinv : filter.tendsto (fun (x : G) => x⁻¹) (nhds 1) (nhds 1))
    (hleft : ∀ (x₀ : G), nhds x₀ = filter.map (fun (x : G) => x₀ * x) (nhds 1))
    (hconj : ∀ (x₀ : G), filter.map (fun (x : G) => x₀ * x * (x₀⁻¹)) (nhds 1) ≤ nhds 1) :
    continuous fun (x : G) => x⁻¹ :=
  sorry

theorem topological_add_group.of_nhds_zero' {G : Type (max u_1 u_2)} [add_group G]
    [topological_space G]
    (hmul : filter.tendsto (function.uncurry Add.add) (filter.prod (nhds 0) (nhds 0)) (nhds 0))
    (hinv : filter.tendsto (fun (x : G) => -x) (nhds 0) (nhds 0))
    (hleft : ∀ (x₀ : G), nhds x₀ = filter.map (fun (x : G) => x₀ + x) (nhds 0))
    (hright : ∀ (x₀ : G), nhds x₀ = filter.map (fun (x : G) => x + x₀) (nhds 0)) :
    topological_add_group G :=
  sorry

theorem topological_add_group.of_nhds_zero {G : Type (max u_1 u_2)} [add_group G]
    [topological_space G]
    (hmul : filter.tendsto (function.uncurry Add.add) (filter.prod (nhds 0) (nhds 0)) (nhds 0))
    (hinv : filter.tendsto (fun (x : G) => -x) (nhds 0) (nhds 0))
    (hleft : ∀ (x₀ : G), nhds x₀ = filter.map (fun (x : G) => x₀ + x) (nhds 0))
    (hconj : ∀ (x₀ : G), filter.tendsto (fun (x : G) => x₀ + x + -x₀) (nhds 0) (nhds 0)) :
    topological_add_group G :=
  topological_add_group.mk (topological_add_group.of_nhds_aux hinv hleft hconj)

theorem topological_add_group.of_comm_of_nhds_zero {G : Type (max u_1 u_2)} [add_comm_group G]
    [topological_space G]
    (hmul : filter.tendsto (function.uncurry Add.add) (filter.prod (nhds 0) (nhds 0)) (nhds 0))
    (hinv : filter.tendsto (fun (x : G) => -x) (nhds 0) (nhds 0))
    (hleft : ∀ (x₀ : G), nhds x₀ = filter.map (fun (x : G) => x₀ + x) (nhds 0)) :
    topological_add_group G :=
  sorry

protected instance quotient_group.quotient.topological_space {G : Type u_1} [group G]
    [topological_space G] (N : subgroup G) : topological_space (quotient_group.quotient N) :=
  quotient.topological_space

theorem quotient_group.is_open_map_coe {G : Type w} [topological_space G] [group G]
    [topological_group G] (N : subgroup G) : is_open_map coe :=
  sorry

protected instance topological_add_group_quotient {G : Type w} [topological_space G] [add_group G]
    [topological_add_group G] (N : add_subgroup G) [add_subgroup.normal N] :
    topological_add_group (quotient_add_group.quotient N) :=
  topological_add_group.mk
    (eq.mpr
      ((fun (f f_1 : quotient_add_group.quotient N → quotient_add_group.quotient N)
          (e_3 : f = f_1) => congr_arg continuous e_3)
        Neg.neg
        (quotient.lift (coe ∘ fun (a : G) => -a) (quotient_add_group.div_inv_monoid._proof_5 N))
        (Eq.refl Neg.neg))
      (continuous_quotient_lift (quotient_add_group.div_inv_monoid._proof_5 N)
        (continuous.comp continuous_quot_mk continuous_neg)))

/-- A typeclass saying that `λ p : G × G, p.1 - p.2` is a continuous function. This property
automatically holds for topological additive groups but it also holds, e.g., for `ℝ≥0`. -/
class has_continuous_sub (G : Type u_1) [topological_space G] [Sub G] where
  continuous_sub : continuous fun (p : G × G) => prod.fst p - prod.snd p

protected instance topological_add_group.to_has_continuous_sub {G : Type w} [topological_space G]
    [add_group G] [topological_add_group G] : has_continuous_sub G :=
  has_continuous_sub.mk
    (eq.mpr
      (id
        ((fun (f f_1 : G × G → G) (e_3 : f = f_1) => congr_arg continuous e_3)
          (fun (p : G × G) => prod.fst p - prod.snd p) (fun (p : G × G) => prod.fst p + -prod.snd p)
          (funext fun (p : G × G) => sub_eq_add_neg (prod.fst p) (prod.snd p))))
      (continuous.add continuous_fst (continuous.neg continuous_snd)))

theorem filter.tendsto.sub {α : Type u} {G : Type w} [topological_space G] [Sub G]
    [has_continuous_sub G] {f : α → G} {g : α → G} {l : filter α} {a : G} {b : G}
    (hf : filter.tendsto f l (nhds a)) (hg : filter.tendsto g l (nhds b)) :
    filter.tendsto (fun (x : α) => f x - g x) l (nhds (a - b)) :=
  filter.tendsto.comp (continuous.tendsto continuous_sub (a, b)) (filter.tendsto.prod_mk_nhds hf hg)

theorem continuous.sub {α : Type u} {G : Type w} [topological_space G] [Sub G]
    [has_continuous_sub G] [topological_space α] {f : α → G} {g : α → G} (hf : continuous f)
    (hg : continuous g) : continuous fun (x : α) => f x - g x :=
  continuous.comp continuous_sub (continuous.prod_mk hf hg)

theorem continuous_within_at.sub {α : Type u} {G : Type w} [topological_space G] [Sub G]
    [has_continuous_sub G] [topological_space α] {f : α → G} {g : α → G} {s : set α} {x : α}
    (hf : continuous_within_at f s x) (hg : continuous_within_at g s x) :
    continuous_within_at (fun (x : α) => f x - g x) s x :=
  filter.tendsto.sub hf hg

theorem continuous_on.sub {α : Type u} {G : Type w} [topological_space G] [Sub G]
    [has_continuous_sub G] [topological_space α] {f : α → G} {g : α → G} {s : set α}
    (hf : continuous_on f s) (hg : continuous_on g s) :
    continuous_on (fun (x : α) => f x - g x) s :=
  fun (x : α) (hx : x ∈ s) => continuous_within_at.sub (hf x hx) (hg x hx)

theorem nhds_translation {G : Type w} [topological_space G] [add_group G] [topological_add_group G]
    (x : G) : filter.comap (fun (y : G) => y - x) (nhds 0) = nhds x :=
  sorry

/-- additive group with a neighbourhood around 0.
Only used to construct a topology and uniform space.

This is currently only available for commutative groups, but it can be extended to
non-commutative groups too.
-/
class add_group_with_zero_nhd (G : Type u) extends add_comm_group G where
  Z : filter G
  zero_Z : pure 0 ≤ Z
  sub_Z : filter.tendsto (fun (p : G × G) => prod.fst p - prod.snd p) (filter.prod Z Z) Z

namespace add_group_with_zero_nhd

protected instance topological_space (G : Type w) [add_group_with_zero_nhd G] :
    topological_space G :=
  topological_space.mk_of_nhds fun (a : G) => filter.map (fun (x : G) => x + a) (Z G)

theorem neg_Z {G : Type w} [add_group_with_zero_nhd G] :
    filter.tendsto (fun (a : G) => -a) (Z G) (Z G) :=
  sorry

theorem add_Z {G : Type w} [add_group_with_zero_nhd G] :
    filter.tendsto (fun (p : G × G) => prod.fst p + prod.snd p) (filter.prod (Z G) (Z G)) (Z G) :=
  sorry

theorem exists_Z_half {G : Type w} [add_group_with_zero_nhd G] {s : set G} (hs : s ∈ Z G) :
    ∃ (V : set G), ∃ (H : V ∈ Z G), ∀ (v : G), v ∈ V → ∀ (w : G), w ∈ V → v + w ∈ s :=
  sorry

theorem nhds_eq {G : Type w} [add_group_with_zero_nhd G] (a : G) :
    nhds a = filter.map (fun (x : G) => x + a) (Z G) :=
  sorry

theorem nhds_zero_eq_Z {G : Type w} [add_group_with_zero_nhd G] : nhds 0 = Z G := sorry

protected instance has_continuous_add {G : Type w} [add_group_with_zero_nhd G] :
    has_continuous_add G :=
  has_continuous_add.mk (iff.mpr continuous_iff_continuous_at fun (_x : G × G) => sorry)

protected instance topological_add_group {G : Type w} [add_group_with_zero_nhd G] :
    topological_add_group G :=
  sorry

end add_group_with_zero_nhd

theorem is_open.add_left {G : Type w} [topological_space G] [add_group G] [topological_add_group G]
    {s : set G} {t : set G} : is_open t → is_open (s + t) :=
  fun (ht : is_open t) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_open (s + t))) (Eq.symm set.Union_add_left_image)))
      (is_open_Union
        fun (a : G) =>
          is_open_Union fun (ha : a ∈ s) => (fun (a : G) => is_open_map_add_left a t ht) a)

theorem is_open.add_right {G : Type w} [topological_space G] [add_group G] [topological_add_group G]
    {s : set G} {t : set G} : is_open s → is_open (s + t) :=
  fun (hs : is_open s) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_open (s + t))) (Eq.symm set.Union_add_right_image)))
      (is_open_Union
        fun (a : G) =>
          is_open_Union fun (ha : a ∈ t) => (fun (a : G) => is_open_map_add_right a s hs) a)

theorem topological_group.t1_space (G : Type w) [topological_space G] [group G]
    [topological_group G] (h : is_closed (singleton 1)) : t1_space G :=
  sorry

theorem topological_group.regular_space (G : Type w) [topological_space G] [group G]
    [topological_group G] [t1_space G] : regular_space G :=
  sorry

theorem topological_group.t2_space (G : Type w) [topological_space G] [group G]
    [topological_group G] [t1_space G] : t2_space G :=
  regular_space.t2_space G

/-! Some results about an open set containing the product of two sets in a topological group. -/

/-- Given a compact set `K` inside an open set `U`, there is a open neighborhood `V` of `1`
  such that `KV ⊆ U`. -/
theorem compact_open_separated_add {G : Type w} [topological_space G] [add_group G]
    [topological_add_group G] {K : set G} {U : set G} (hK : is_compact K) (hU : is_open U)
    (hKU : K ⊆ U) : ∃ (V : set G), is_open V ∧ 0 ∈ V ∧ K + V ⊆ U :=
  sorry

/-- A compact set is covered by finitely many left multiplicative translates of a set
  with non-empty interior. -/
theorem compact_covered_by_add_left_translates {G : Type w} [topological_space G] [add_group G]
    [topological_add_group G] {K : set G} {V : set G} (hK : is_compact K)
    (hV : set.nonempty (interior V)) :
    ∃ (t : finset G),
        K ⊆ set.Union fun (g : G) => set.Union fun (H : g ∈ t) => (fun (h : G) => g + h) ⁻¹' V :=
  sorry

/-- Every locally compact separable topological group is σ-compact.
  Note: this is not true if we drop the topological group hypothesis. -/
protected instance separable_locally_compact_group.sigma_compact_space {G : Type w}
    [topological_space G] [group G] [topological_group G] [topological_space.separable_space G]
    [locally_compact_space G] : sigma_compact_space G :=
  sorry

theorem nhds_add {G : Type w} [topological_space G] [add_comm_group G] [topological_add_group G]
    (x : G) (y : G) : nhds (x + y) = nhds x + nhds y :=
  sorry

theorem nhds_is_mul_hom {G : Type w} [topological_space G] [comm_group G] [topological_group G] :
    is_mul_hom fun (x : G) => nhds x :=
  is_mul_hom.mk fun (_x _x_1 : G) => nhds_mul _x _x_1

protected instance additive.topological_add_group {G : Type u_1} [h : topological_space G] [group G]
    [topological_group G] : topological_add_group (additive G) :=
  topological_add_group.mk continuous_inv

protected instance multiplicative.topological_group {G : Type u_1} [h : topological_space G]
    [add_group G] [topological_add_group G] : topological_group (multiplicative G) :=
  topological_group.mk continuous_neg

end Mathlib


import pseudo_normed_group.breen_deligne
import analysis.normed.group.SemiNormedGroup.kernels

/-!

# Constructions on the filtration on a profinitely filtered pseudo-normed group

## Main definitions

- `FiltrationPow r' c n`: the functor sending a profinitely filtered `M` to `M_c^n`.
- `φ.eval_FP r' c₁ c₂`: The map M_c₁^m → M_c₂^n induced by a (c₁, c₂)-suitable φ.

-/
open_locale classical nnreal big_operators kronecker
noncomputable theory
local attribute [instance] type_pow

universe variables u

@[simps]
def pseudo_normed_group.filtration_obj
  (M) [profinitely_filtered_pseudo_normed_group M] (c) : Profinite :=
Profinite.of (pseudo_normed_group.filtration M c)

open profinitely_filtered_pseudo_normed_group category_theory
  comphaus_filtered_pseudo_normed_group

namespace Filtration
variables (M : Type u) [profinitely_filtered_pseudo_normed_group M]
@[simps]
def cast_le (c₁ c₂ : ℝ≥0) [h : fact (c₁ ≤ c₂)] :
  pseudo_normed_group.filtration_obj.{u} M c₁ ⟶ pseudo_normed_group.filtration_obj.{u} M c₂ :=
{ to_fun := pseudo_normed_group.cast_le,
  continuous_to_fun := continuous_cast_le c₁ c₂ }

theorem cast_le_refl (c : ℝ≥0) : cast_le M c c = 𝟙 _ := by { ext, refl }

theorem cast_le_comp (c₁ c₂ c₃ : ℝ≥0) [h₁ : fact (c₁ ≤ c₂)] [h₂ : fact (c₂ ≤ c₃)] :
  cast_le M c₁ c₂ ≫ cast_le M c₂ c₃ = @cast_le M _ c₁ c₃ ⟨le_trans h₁.1 h₂.1⟩ :=
by { ext, refl }

end Filtration

@[simps obj_obj obj_map_apply map_app {fully_applied := ff}]
def Filtration (r' : ℝ≥0) : ℝ≥0 ⥤ ProFiltPseuNormGrpWithTinv.{u} r' ⥤ Profinite.{u} :=
{ obj := λ c,
  { obj := λ M, pseudo_normed_group.filtration_obj M c,
    map := λ M N f, ⟨f.level c, f.level_continuous c⟩,
    map_id' := by { intros, ext, refl },
    map_comp' := by { intros, ext, refl } },
  map := λ c₁ c₂ h,
  { app := λ M, @Filtration.cast_le _ _ c₁ c₂ ⟨le_of_hom h⟩ },
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }

open SemiNormedGroup opposite Profinite pseudo_normed_group category_theory breen_deligne
open profinitely_filtered_pseudo_normed_group
open profinitely_filtered_pseudo_normed_group_with_Tinv

/-- The functor that sends `A` to `A^n` -/
@[simps obj map]
def Pow (n : ℕ) : Profinite ⥤ Profinite :=
{ obj := λ A, of (A^n),
  map := λ A B f, {
    to_fun := λ x j, f (x j),
    continuous_to_fun := continuous_pi $ λ j, f.2.comp (continuous_apply j) } }

@[simps]
def Pow_Pow_X (N n : ℕ) (X) : (Pow N ⋙ Pow n).obj X ≅ (Pow (N * n)).obj X :=
Profinite.iso_of_homeo
{ to_equiv := (equiv.curry _ _ _).symm.trans (((equiv.prod_comm _ _).trans fin_prod_fin_equiv).arrow_congr (equiv.refl X)),
  continuous_to_fun :=
  begin
    apply continuous_pi,
    intro ij,
    let k := ((equiv.prod_comm _ _).trans fin_prod_fin_equiv).symm ij,
    convert (@continuous_apply _ (λ i, X) _ k.2).comp (@continuous_apply _ (λ i, (X^N)) _ k.1),
  end,
  continuous_inv_fun :=
  begin
    apply continuous_pi,
    intro i,
    refine continuous_pi _,
    intro j,
    exact continuous_apply _,
  end }
.

@[simps hom inv]
def Pow_mul (N n : ℕ) : Pow (N * n) ≅ Pow N ⋙ Pow n :=
nat_iso.of_components (λ X, (Pow_Pow_X N n X).symm)
begin
  intros X Y f,
  ext x i j,
  refl,
end

@[simps]
def profinitely_filtered_pseudo_normed_group_with_Tinv.Tinv₀_hom
  {r' : ℝ≥0} (M : Type*) [profinitely_filtered_pseudo_normed_group_with_Tinv r' M]
  (c c₂ : ℝ≥0) [fact (c ≤ r' * c₂)] : filtration_obj M c ⟶ filtration_obj M c₂ :=
by exact ⟨Tinv₀ c c₂, Tinv₀_continuous _ _⟩

open profinitely_filtered_pseudo_normed_group_with_Tinv

namespace Filtration

@[simps]
def res (r' c₁ c₂ : ℝ≥0) [h : fact (c₁ ≤ c₂)] :
  (Filtration r').obj c₁ ⟶ (Filtration r').obj c₂ :=
(Filtration r').map (hom_of_le h.1)

theorem res_refl (r' c : ℝ≥0) : res r' c c = 𝟙 _ := by { ext, refl }

theorem res_comp (r' c₁ c₂ c₃ : ℝ≥0) [h₁ : fact (c₁ ≤ c₂)] [h₂ : fact (c₂ ≤ c₃)] :
  res r' c₁ c₂ ≫ res r' c₂ c₃ = @res r' c₁ c₃ ⟨le_trans h₁.1 h₂.1⟩ :=
by { ext, refl }

@[simps] def Tinv₀ {r' : ℝ≥0} (c c₂ : ℝ≥0) [fact (c ≤ r' * c₂)] :
  (Filtration.{u} r').obj c ⟶ (Filtration r').obj c₂ :=
{ app := λ M, Tinv₀_hom M c c₂,
  naturality' := λ M₁ M₂ f, by { ext x, exact (f.map_Tinv _).symm } }

theorem Tinv₀_comp_res {r' : ℝ≥0} (c₁ c₂ c₃ c₄ : ℝ≥0)
  [fact (c₁ ≤ r' * c₂)] [fact (c₃ ≤ r' * c₄)] [fact (c₂ ≤ c₄)] [fact (c₁ ≤ c₃)] :
  Tinv₀ c₁ c₂ ≫ res r' c₂ c₄ = res r' c₁ c₃ ≫ Tinv₀ c₃ c₄ := rfl

def pi_iso (r' c : ℝ≥0) (M : ProFiltPseuNormGrpWithTinv r') (N : ℕ) :
  Profinite.of (filtration (M^N) c) ≅ Profinite.of ((filtration M c)^N) :=
Profinite.iso_of_homeo $ filtration_pi_homeo _ _

end Filtration

/-- `FiltrationPow r' c n` is the functor sending a profinitely filtered `M` to `M_c^n`. -/
@[simps obj map {fully_applied := ff}]
def FiltrationPow (r' : ℝ≥0) (c : ℝ≥0) (n : ℕ) :
  ProFiltPseuNormGrpWithTinv r' ⥤ Profinite :=
ProFiltPseuNormGrpWithTinv.Pow r' n ⋙ (Filtration r').obj c

namespace FiltrationPow

@[simps]
def cast_le (r' c₁ c₂ : ℝ≥0) [fact (c₁ ≤ c₂)] (n : ℕ) :
  FiltrationPow.{u} r' c₁ n ⟶ FiltrationPow r' c₂ n :=
{ app := λ M, (Filtration.cast_le _ c₁ c₂),
  naturality' := λ M N f, by { ext, refl } }

theorem cast_le_refl (r' c : ℝ≥0) (n : ℕ) : cast_le r' c c n = 𝟙 _ :=
by { ext, refl }

theorem cast_le_comp (r' c₁ c₂ c₃ : ℝ≥0) [h₁ : fact (c₁ ≤ c₂)] [h₂ : fact (c₂ ≤ c₃)] (n : ℕ) :
  cast_le r' c₁ c₂ n ≫ cast_le r' c₂ c₃ n =
  @cast_le r' c₁ c₃ ⟨le_trans h₁.1 h₂.1⟩ n :=
by { ext, refl }

@[simps]
def Tinv (r' : ℝ≥0) (c c₂) [fact (c ≤ r' * c₂)] (n) :
  FiltrationPow r' c n ⟶ FiltrationPow r' c₂ n :=
whisker_left _ (Filtration.Tinv₀ c c₂)

lemma Tinv_app (r' : ℝ≥0) (c c₂) [fact (c ≤ r' * c₂)] (n M) :
  (Tinv r' c c₂ n).app M = (Tinv₀_hom _ c c₂) := rfl

lemma cast_le_vcomp_Tinv (r' c₁ c₂ c₃ : ℝ≥0)
  [fact (c₁ ≤ c₂)] [fact (c₂ ≤ c₃)] [fact (c₁ ≤ r' * c₂)] [fact (c₂ ≤ r' * c₃)] (n : ℕ) :
  cast_le r' c₁ c₂ n ≫ Tinv r' c₂ c₃ n = Tinv r' c₁ c₂ n ≫ cast_le r' c₂ c₃ n :=
by { ext, refl }

@[simps hom inv]
def mul_iso (r' c : ℝ≥0) (M : ProFiltPseuNormGrpWithTinv r') (N n : ℕ) :
  (FiltrationPow r' c n).obj (ProFiltPseuNormGrpWithTinv.of r' (↥M ^ N)) ≅
  (FiltrationPow r' c (N * n)).obj M :=
((Filtration r').obj c).map_iso $ (ProFiltPseuNormGrpWithTinv.Pow_mul r' N n).symm.app _

end FiltrationPow

namespace breen_deligne
namespace basic_universal_map

variables (r' c c₁ c₂ c₃ c₄ : ℝ≥0) {l m n : ℕ} (ϕ : basic_universal_map m n)

open FiltrationPow comphaus_filtered_pseudo_normed_group_with_Tinv_hom

@[simps]
def eval_FP [ϕ.suitable c₁ c₂] : FiltrationPow.{u} r' c₁ m ⟶ FiltrationPow r' c₂ n :=
{ app := λ M,
  { to_fun := ϕ.eval_png₀ M c₁ c₂,
    continuous_to_fun := ϕ.eval_png₀_continuous M c₁ c₂ },
  naturality' := λ M₁ M₂ f, begin
    ext1 x,
    change ϕ.eval_png₀ M₂ c₁ c₂ ((FiltrationPow r' c₁ m).map f x) =
      (FiltrationPow r' c₂ n).map f (ϕ.eval_png₀ M₁ c₁ c₂ x),
    ext j,
    dsimp only [FiltrationPow_map, Filtration_obj_map_apply, basic_universal_map.eval_png₀_coe,
      comphaus_filtered_pseudo_normed_group_with_Tinv_hom.level_coe,
      comp_to_fun, coe_to_add_monoid_hom],
    simp only [basic_universal_map.eval_png_apply, pi_map_to_fun, f.map_sum, f.map_zsmul],
  end }

lemma eval_FP_comp (g : basic_universal_map m n) (f : basic_universal_map l m)
  [hg : g.suitable c₂ c₃] [hf : f.suitable c₁ c₂]
  [(basic_universal_map.comp g f).suitable c₁ c₃] :
  (basic_universal_map.comp g f).eval_FP r' c₁ c₃ = f.eval_FP r' c₁ c₂ ≫ g.eval_FP r' c₂ c₃ :=
by { ext, dsimp, rw eval_png_comp, refl }

lemma cast_le_comp_eval_FP
  [fact (c₁ ≤ c₂)] [ϕ.suitable c₂ c₄] [ϕ.suitable c₁ c₃] [fact (c₃ ≤ c₄)] :
  cast_le r' c₁ c₂ m ≫ ϕ.eval_FP r' c₂ c₄ = ϕ.eval_FP r' c₁ c₃ ≫ cast_le r' c₃ c₄ n :=
by { ext, refl }

open FiltrationPow

lemma Tinv_comp_eval_FP (r' c₁ c₂ c₃ c₄ : ℝ≥0)
  [fact (c₁ ≤ r' * c₂)] [fact (c₃ ≤ r' * c₄)] [ϕ.suitable c₁ c₃] [ϕ.suitable c₂ c₄] :
  Tinv r' c₁ c₂ m ≫ ϕ.eval_FP r' c₂ c₄ = ϕ.eval_FP r' c₁ c₃ ≫ Tinv r' c₃ c₄ n :=
begin
  ext M x : 3,
  change ϕ.eval_png₀ M c₂ c₄ ((Tinv r' c₁ c₂ m).app M x) =
    (Tinv r' c₃ c₄ n).app M (ϕ.eval_png₀ M c₁ c₃ x),
  ext j,
  dsimp,
  simp only [eval_png_apply, comphaus_filtered_pseudo_normed_group_hom.map_sum,
    comphaus_filtered_pseudo_normed_group_hom.map_zsmul, pi_Tinv_apply],
end
.

lemma mul_iso_eval_FP (N : ℕ) [ϕ.suitable c₂ c₁] (M) :
  (FiltrationPow.mul_iso.{u u} r' c₂ M N m).inv ≫
    (basic_universal_map.eval_FP r' c₂ c₁ ϕ).app (ProFiltPseuNormGrpWithTinv.of r' (M ^ N)) =
  (basic_universal_map.eval_FP r' c₂ c₁ ((basic_universal_map.mul N) ϕ)).app M ≫
    (FiltrationPow.mul_iso.{u u} r' c₁ M N n).inv :=
begin
  ext x i j,
  dsimp [mul],
  simp only [eval_png_apply, equiv.symm_apply_apply, matrix.submatrix_apply, matrix.kronecker],
  rw [← fin_prod_fin_equiv.sum_comp, ← finset.univ_product_univ, finset.sum_product,
      finset.sum_comm],
  simp only [equiv.symm_apply_apply, matrix.one_apply, boole_mul, ite_smul, zero_smul,
    finset.sum_ite_eq, finset.mem_univ, if_true, matrix.kronecker_map, matrix.kronecker_apply],
  convert finset.sum_apply j (finset.univ : finset (fin m)) _ using 1,
end

end basic_universal_map

end breen_deligne