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₁


import Days
import Days.Common

namespace Days.Day02
open Days
open Common

inductive RockPaperScissors where
  | Rock
  | Paper
  | Scissors
  deriving Repr, DecidableEq

def RockPaperScissors.value : RockPaperScissors → Nat
  | .Rock => 1
  | .Paper => 2
  | .Scissors => 3

instance : LT RockPaperScissors where
  lt
  | .Rock, .Paper => true
  | .Paper, .Scissors => true
  | .Scissors, .Rock => true
  | _, _ => false

instance : Ord RockPaperScissors where
  compare
  | .Rock, .Paper
  | .Paper, .Scissors
  | .Scissors, .Rock => .lt
  | m₁, m₂ => if m₁ = m₂ then .eq else .gt

/--
Provide a default value (required for panic! to work...)
-/
instance : Inhabited RockPaperScissors where default := .Rock

def parseOpponentsMove : (i: Input × Input) → RockPaperScissors
  | (⟨"A"⟩, _)  => .Rock
  | (⟨"B"⟩, _) => .Paper
  | (⟨"C"⟩, _) => .Scissors
  | _ => panic! "Invalid opponent move"

def parseMyMove : (i: Input × Input) → RockPaperScissors
  | (_, ⟨"X"⟩)  => .Rock
  | (_, ⟨"Y"⟩) => .Paper
  | (_, ⟨"Z"⟩) => .Scissors
  | (move, _) => panic! s!"Invalid move: {move}"

def scoreRound : RockPaperScissors × RockPaperScissors → Nat
  | (opp, me) => me.value + (
    match Ord.compare opp me with
    | .lt => 6
    | .eq => 3
    | _ => 0
  )

/--
The Elves begin to set up camp on the beach. To decide whose tent gets to be closest to the snack storage, a giant Rock Paper Scissors tournament is already in progress.

Rock Paper Scissors is a game between two players. Each game contains many rounds; in each round, the players each simultaneously choose one of Rock, Paper, or Scissors using a hand shape. Then, a winner for that round is selected: Rock defeats Scissors, Scissors defeats Paper, and Paper defeats Rock. If both players choose the same shape, the round instead ends in a draw.

Appreciative of your help yesterday, one Elf gives you an encrypted strategy guide (your puzzle input) that they say will be sure to help you win. "The first column is what your opponent is going to play: A for Rock, B for Paper, and C for Scissors. The second column--" Suddenly, the Elf is called away to help with someone's tent.

The second column, you reason, must be what you should play in response: X for Rock, Y for Paper, and Z for Scissors. Winning every time would be suspicious, so the responses must have been carefully chosen.

The winner of the whole tournament is the player with the highest score. Your total score is the sum of your scores for each round. The score for a single round is the score for the shape you selected (1 for Rock, 2 for Paper, and 3 for Scissors) plus the score for the outcome of the round (0 if you lost, 3 if the round was a draw, and 6 if you won).

Since you can't be sure if the Elf is trying to help you or trick you, you should calculate the score you would get if you were to follow the strategy guide.

For example, suppose you were given the following strategy guide:

A Y
B X
C Z
This strategy guide predicts and recommends the following:

In the first round, your opponent will choose Rock (A), and you should choose Paper (Y). This ends in a win for you with a score of 8 (2 because you chose Paper + 6 because you won).
In the second round, your opponent will choose Paper (B), and you should choose Rock (X). This ends in a loss for you with a score of 1 (1 + 0).
The third round is a draw with both players choosing Scissors, giving you a score of 3 + 3 = 6.
In this example, if you were to follow the strategy guide, you would get a total score of 15 (8 + 1 + 6).

What would your total score be if everything goes exactly according to your strategy guide?
-/
def part₁ (input: Input) : Nat :=
  scoreForPerfectPlay
  where
    parseStratLine (line: Input) :=
      match line.splitOn " " with
      | [fst, snd] =>
        let pair := (fst, snd)
        let opp := parseOpponentsMove pair
        let me := parseMyMove pair
        (opp, me)
      | _ => panic! "Error parsing"

    parseStrategy (i: Input) : List $ RockPaperScissors × RockPaperScissors :=
      i.lines |> .map parseStratLine

    scoreForPerfectPlay :=
      parseStrategy input
      |> .map scoreRound
      |> sum

inductive Outcome where
  | Lose
  | Draw
  | Win
  deriving Repr, DecidableEq

/--
Again, needed for panic!...
-/
instance : Inhabited Outcome where default := .Draw

def parseOutcome : (i: Input × Input) → Outcome
  | (_, ⟨"X"⟩)  => .Lose
  | (_, ⟨"Y"⟩) => .Draw
  | (_, ⟨"Z"⟩) => .Win
  | (_, move) => panic! s!"Invalid outcome: {move}"

/--
Picks the move we should make to force the desired outcome
-/
def RockPaperScissors.forceOutcome : RockPaperScissors → Outcome → RockPaperScissors
  | m, .Draw => m
  | .Rock, .Win => .Paper
  | .Rock, .Lose => .Scissors
  | .Paper, .Win => .Scissors
  | .Paper, .Lose => .Rock
  | .Scissors, .Win => .Rock
  | .Scissors, .Lose => .Paper

/--
The Elf finishes helping with the tent and sneaks back over to you. "Anyway, the second column says how the round needs to end: X means you need to lose, Y means you need to end the round in a draw, and Z means you need to win. Good luck!"

The total score is still calculated in the same way, but now you need to figure out what shape to choose so the round ends as indicated. The example above now goes like this:

In the first round, your opponent will choose Rock (A), and you need the round to end in a draw (Y), so you also choose Rock. This gives you a score of 1 + 3 = 4.
In the second round, your opponent will choose Paper (B), and you choose Rock so you lose (X) with a score of 1 + 0 = 1.
In the third round, you will defeat your opponent's Scissors with Rock for a score of 1 + 6 = 7.
Now that you're correctly decrypting the ultra top secret strategy guide, you would get a total score of 12.

Following the Elf's instructions for the second column, what would your total score be if everything goes exactly according to your strategy guide?
-/
def part₂ (input: Input) : Nat :=
  scorePlannedPlay
  where
    parseOutcomeLine (line: Input) :=
      match line.splitOn " " with
      | [fst, snd] =>
        let pair := (fst, snd)
        let opp := parseOpponentsMove pair
        let me := parseOutcome pair
        (opp, me)
      | _ => panic! "Error parsing"

    decideStrategy (i: Input) : List $ RockPaperScissors × RockPaperScissors :=
      i.lines
      |> .map parseOutcomeLine
      |> .map (fun
      | ⟨opponentsMove, outcome⟩ => ⟨opponentsMove, opponentsMove.forceOutcome outcome⟩
      )

    scorePlannedPlay :=
      decideStrategy input
      |> .map scoreRound
      |> sum

def solution : Problem Nat := ⟨ 2, part₁, part₂ ⟩

def sample := "A Y
B X
C Z"

#eval testPart₁ solution sample (expect:=15)
#eval testPart₂ solution sample (expect:=12)


/-
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